diff --git a/SVN_EXTERNAL_DIRECTORIES b/SVN_EXTERNAL_DIRECTORIES new file mode 100644 index 0000000000..e64ea2aceb --- /dev/null +++ b/SVN_EXTERNAL_DIRECTORIES @@ -0,0 +1,4 @@ +chem_proc https://svn-ccsm-models.cgd.ucar.edu/tools/proc_atm/chem_proc/release_tags/chem_proc5_0_03_rel +src/physics/carma/base https://svn-ccsm-models.cgd.ucar.edu/carma/release_tags/carma3_49_rel +src/physics/clubb https://svn-ccsm-models.cgd.ucar.edu/clubb_core/release_tags/clubb_r8099_n02_rel +src/physics/cosp2/src https://github.com/CFMIP/COSPv2.0/tags/v2.0.3cesm/src diff --git a/bld/Makefile.in b/bld/Makefile.in index 9f16f305b8..474719200c 100644 --- a/bld/Makefile.in +++ b/bld/Makefile.in @@ -110,19 +110,11 @@ CURDIR := $(shell pwd) # Generate Make dependencies. $(CURDIR)/Depends: $(CURDIR)/Srcfiles $(CURDIR)/Filepath - if [ -d "${ROOTDIR}/components/cam" ]; then \ - $(ROOTDIR)/components/cam/bld/mkDepends Filepath Srcfiles > $@; \ - else \ - $(ROOTDIR)/bld/mkDepends Filepath Srcfiles > $@; \ - fi + $(ROOTDIR)/components/cam/bld/mkDepends Filepath Srcfiles > $@ # Generate list of source files. $(CURDIR)/Srcfiles: $(CURDIR)/Filepath - if [ -d "${ROOTDIR}/components/cam" ]; then \ - $(ROOTDIR)/components/cam/bld/mkSrcfiles -e $(EXCLUDE_SOURCES) > $@; \ - else \ - $(ROOTDIR)/bld/mkSrcfiles -e $(EXCLUDE_SOURCES) > $@; \ - fi + $(ROOTDIR)/components/cam/bld/mkSrcfiles -e $(EXCLUDE_SOURCES) > $@ OBJS := $(addsuffix .o, $(basename $(SOURCES))) diff --git a/bld/build-namelist b/bld/build-namelist index 8cffb24c6f..bba86bd15b 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -477,6 +477,7 @@ add_default($nl, 'ninst_driver', 'val'=>'1'); # namelist group: seq_cplflds_inparm # ###################################### add_default($nl, 'flds_co2_dmsa', 'val'=>'.false.'); +add_default($nl, 'flds_co2_dmsb', 'val'=>'.false.'); add_default($nl, 'flds_co2a', 'val'=>'.true.'); add_default($nl, 'flds_co2b', 'val'=>'.false.'); add_default($nl, 'flds_co2c', 'val'=>'.false.'); @@ -694,6 +695,11 @@ if ($cfg->get('debug')) { my $prescribe_aerosols = $TRUE; if ($simple_phys) {$prescribe_aerosols = $FALSE;} +if( $chem =~ /_oslo/){ +$prescribe_aerosols = $FALSE; +print " ==> Using Oslo aerosols: PRESCRIBED AERO = FALSE (not yet implemented) \n" +} + # Chemistry deposition lists if ( ($chem ne 'none') or ( $prog_species ) ){ my $chem_proc_src = $cfg->get('chem_proc_src'); @@ -1055,7 +1061,12 @@ else { my $aer_model = 'bam'; if ($prescribed_aero_model eq 'modal' or $chem =~ /_mam/) {$aer_model = 'mam';} -if ($aer_model eq 'mam' ) { +if ($chem =~ /_mam_oslo/) {$aer_model = 'oslo';} + +if ($aer_model eq 'oslo') { + #do nothing here +} +elsif ($aer_model eq 'mam' ) { my $aero_modes = '3mode'; if ($chem =~ /_mam7/) {$aero_modes = '7mode';} @@ -1646,7 +1657,8 @@ elsif ($carma eq 'tholin') { # turn on stratospheric aerosol forcings in CAM6 configurations my $chem_has_ocs = chem_has_species($cfg, 'OCS'); -if ($phys =~ /cam6/) { +# djlo +if ($phys =~ /cam6/ and $chem ne 'trop_mam_oslo') { # turn on volc forcings in cam6 -- prognostic or prescribed if ( $chem_has_ocs ) { # turn on prognostic stratospheric aerosols @@ -2220,6 +2232,93 @@ if ($chem eq 'trop_mam3') { } } +if ($chem eq 'trop_mam_oslo' ) { + + my %species; + + # Surface emission datasets: + %species = (); + %species = (%species, + 'DMS -> ' => 'dms_oslo_emis_file', + 'SO2 -> ' => 'so2_oslo_emis_file', + 'BC_AX -> ' => 'bc_ax_oslo_emis_file', + 'BC_N -> ' =>'bc_n_oslo_emis_file', + 'BC_NI -> ' =>'bc_ni_oslo_emis_file', + 'SO4_PR -> ' =>'so4_pr_oslo_emis_file', + 'OM_NI -> ' =>'om_ni_oslo_emis_file', + 'monoterp -> ' => 'monoterp_oslo_emis_file', + 'isoprene -> ' => 'isoprene_oslo_emis_file', + ); + + my $first = 1; + my $pre = ""; + my $val = ""; + foreach my $id (sort keys %species) { + my $rel_filepath = get_default_value($species{$id} ); + my $abs_filepath = set_abs_filepath($rel_filepath, $inputdata_rootdir); + $val .= $pre . quote_string($id . $abs_filepath); + if ($first) { + $pre = ","; + $first = 0; + } + } + add_default($nl, 'srf_emis_specifier', 'val'=>$val); + unless (defined $nl->get_value('srf_emis_type')) { + add_default($nl, 'srf_emis_type', 'val'=>'CYCLICAL'); + add_default($nl, 'srf_emis_cycle_yr', 'val'=>'2000'); + } + + # Vertical emission datasets: + %species = (); + %species = ('SO2 -> ' => 'so2_oslo_ext_file', + 'BC_AX -> ' => 'bc_ax_oslo_ext_file', + 'BC_N -> ' => 'bc_n_oslo_ext_file', + 'BC_NI -> ' => 'bc_ni_oslo_ext_file', + 'OM_NI -> ' => 'om_ni_oslo_ext_file', + 'SO4_PR -> ' => 'so4_pr_oslo_ext_file'); + + $first = 1; + $pre = ""; + $val = ""; + foreach my $id (sort keys %species) { + my $rel_filepath = get_default_value($species{$id} ); + my $abs_filepath = set_abs_filepath($rel_filepath, $inputdata_rootdir); + $val .= $pre . quote_string($id . $abs_filepath); + if ($first) { + $pre = ","; + $first = 0; + } + } + add_default($nl, 'ext_frc_specifier', 'val'=>$val); + unless (defined $nl->get_value('ext_frc_type')) { + add_default($nl, 'ext_frc_type', 'val'=>"'CYCLICAL'"); + add_default($nl, 'ext_frc_cycle_yr', 'val'=>'2000'); + } + + # Prescribed species + add_default($nl, 'tracer_cnst_specifier', 'val'=>"'O3','OH','NO3','HO2'"); + unless (defined $nl->get_value('tracer_cnst_type')) { + add_default($nl, 'tracer_cnst_type', 'ver'=>'fixed_ox'); + add_default($nl, 'tracer_cnst_cycle_yr','ver'=>'fixed_ox'); + } + + my @files = ('tracer_cnst_datapath', 'tracer_cnst_file', 'tracer_cnst_filelist'); + foreach my $file (@files) { + add_default($nl, $file, 'ver'=>'fixed_ox'); + } + + add_default($nl, 'fstrat_list', 'val'=>"' '"); + add_default($nl, 'flbc_list', 'val'=>"' '"); + add_default($nl, 'xactive_prates', 'val'=>'.false.'); + + # Datasets + my @files = ('soil_erod_file', + 'xs_long_file', 'rsf_file', 'exo_coldens_file' ); + foreach my $file (@files) { + add_default($nl, $file); + } +} + # CMIP6 emissions if ($chem =~ /_mam4/ and $phys =~ /cam6/) { my %species; @@ -2778,6 +2877,36 @@ $nl->set_variable_value('phys_ctl_nl', 'use_simple_phys', $use_simple_phys); # WACCM-X runtime options add_default($nl, 'waccmx_opt'); +#Cam-Oslo options +#++djlo++ +add_default($nl, 'volc_fraction_coarse'); +add_default($nl, 'aerotab_table_dir'); +add_default($nl, 'ocean_filepath'); +add_default($nl, 'dms_source'); +add_default($nl, 'opom_source'); +#add_default($nl, 'dms_source_type'); +#add_default($nl, 'dms_cycle_year'); +#add_default($nl, 'ocean_filename'); +#add_default($nl, 'ocean_filepath'); +#add_default($nl, 'opom_source'); +unless (defined $nl->get_value('ocean_filename')) { + add_default($nl, 'ocean_filename'); +} +unless (defined $nl->get_value('opom_source_type')) { + add_default($nl, 'opom_source_type'); + add_default($nl, 'opom_cycle_year'); +} +unless (defined $nl->get_value('dms_source_type')) { + add_default($nl, 'dms_source_type'); + add_default($nl, 'dms_cycle_year'); +} +#add_default($nl, 'opom_source_type'); + +#add_default($nl, 'opom_cycle_year'); +#--djlo-- + +if ($chem =~ /_mam_oslo/) {$nl->set_variable_value('phys_ctl_nl','use_hetfrz_classnuc','.true.');} + if ($waccmx) { my $wmx_opt = $nl->get_value('waccmx_opt'); my $ionos = $cfg->get('ionosphere'); @@ -2892,6 +3021,7 @@ add_default($nl, 'srf_flux_avg', 'val'=>0); add_default($nl, 'use_subcol_microp'); add_default($nl, 'microp_scheme'); + if ($cfg->get('microphys') =~ /^mg/) { add_default($nl, 'micro_mg_version'); add_default($nl, 'micro_mg_sub_version'); diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index 656f62f152..8a7d59519d 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -11,10 +11,7 @@ CAM build directory; contains .o and .mod files. Directory where CAM executable will be created. -Root directory of CAM source distribution - - -Root directory of CAM model source.. +Root directory of CAM source distribution. User source directories to prepend to the filepath. Multiple directories @@ -91,8 +88,8 @@ meteor_smoke (Meteor Smoke), mixed_sulfate (Meteor Smoke and Sulfate), pmc (Pola sulfate (Sulfate Aerosols), tholin (early earth haze), test_detrain (Detrainment), test_growth (Particle Growth), test_passive (Passive Dust), test_radiative (Radiatively Active Dust), test_swelling (Sea Salt), test_tracers (Asian Monsoon), test_tracers2 (Guam). - -Chemistry package: trop_mam3 trop_mam4 trop_mam7 trop_mozart trop_strat_mam4_vbs trop_strat_mam4_vbsext waccm_ma waccm_mad waccm_mad_mam4 waccm_ma_mam4 waccm_ma_sulfur waccm_sc waccm_sc_mam4 waccm_tsmlt_mam4 terminator none + +Chemistry package: trop_mam3 trop_mam4 trop_mam7 trop_mozart trop_strat_mam4_vbs trop_strat_mam4_vbsext waccm_ma waccm_mad waccm_mad_mam4 waccm_ma_mam4 waccm_ma_sulfur waccm_sc waccm_sc_mam4 waccm_tsmlt_mam4 terminator trop_mam_oslo none Prognostic mozart species packages: list of any subset of the following: DST,SSLT,SO4,GHG,OC,BC,CARBON16 @@ -115,7 +112,7 @@ Chemistry source directory generated by the chemistry preprocessor; contains F90 Chemistry source directory; contains F90 files. - + Use data ocean model (docn or dom), stub ocean (socn), or aqua planet ocean (aquaplanet) in cam build. When built from the CESM scripts the value of ocn may be set to pop. This doesn't impact how CAM is built, only how diff --git a/bld/configure b/bld/configure index e00e6ae57a..cdea30d292 100755 --- a/bld/configure +++ b/bld/configure @@ -124,7 +124,7 @@ OPTIONS [ trop_mam3 | trop_mam4 | trop_mam7 | trop_mozart | trop_strat_mam4_vbs | trop_strat_mam4_vbsext | waccm_ma | waccm_mad | waccm_mad_mam4 | waccm_ma_mam4 | waccm_ma_sulfur | waccm_sc | waccm_sc_mam4 | waccm_tsmlt_mam4 | - terminator | none ]. + terminator | trop_mam_oslo | none ]. Default: trop_mam4 for cam6 and trop_mam3 for cam5. -[no]clubb_sgs Switch on [off] CLUBB_SGS. Default: on for cam6, otherwise off. -clubb_opts Comma separated list of CLUBB options to turn on/off. By default they are all off. @@ -450,30 +450,17 @@ if (($ccsm_seq)) { #----------------------------------------------------------------------------------------------- # CAM root directory. -# Check for standalone or CESM checkout -my $cam_root = absolute_path("$cfgdir/.."); -my $cam_dir = $cam_root; -if (! -d "$cam_root/cime") { - $cam_root = absolute_path("$cfgdir/../../.."); -} +my $cam_root = absolute_path("$cfgdir/../../.."); + if (-d "$cam_root/components/cam/src") { $cfg_ref->set('cam_root', $cam_root); - $cam_dir = "$cam_root/components/cam"; - $cfg_ref->set('cam_dir', $cam_dir); -} -elsif (-d "$cam_root/src") { - $cfg_ref->set('cam_root', $cam_root); - $cfg_ref->set('cam_dir', $cam_dir); } else { die <<"EOF"; ** Invalid CAM root directory: $cam_root ** -** The CAM root directory must contain the subdirectory components/cam/src/ -** (CESM checkout) or the subdirectory src (standalone checkout). -** For CESM checkouts, it is derived from "config_dir/../../..". -** For CAM standalone checkouts, it is derived from"config_dir/..", -** where config_dir is the directory in the CAM distribution that -** contains the configuration scripts. +** The CAM root directory must contain the subdirectory components/cam/src/. +** It is derived from "config_dir/../../.." where config_dir is the +** directory in the CAM distribution that contains the configuration ** scripts. EOF } @@ -1386,7 +1373,7 @@ my $chem_cppdefs = ''; my $chem_src_dir = ''; if (!$prog_species) { - $chem_src_dir = "$cam_dir/src/chemistry/pp_$chem_pkg"; + $chem_src_dir = "$cam_root/components/cam/src/chemistry/pp_$chem_pkg"; $cfg_ref->set('chem_src_dir', $chem_src_dir); } @@ -1428,6 +1415,10 @@ if ($chem_pkg =~ '_mam3') { $chem_cppdefs = ' -DMODAL_AERO -DMODAL_AERO_7MODE '; } +if ($chem_pkg =~ '_oslo') { + $chem_cppdefs = ' -DOSLO_AERO -DDIRIND' +} + # CARMA sectional microphysics # # New CARMA models need to define the number of advected constituents. @@ -2742,7 +2733,7 @@ sub write_filepath my $inic_val = $cfg_ref->get('analytic_ic'); # Root directory - my $camsrcdir = $cfg_ref->get('cam_dir'); + my $camsrcdir = "$cam_root/components"; # Start writing paths to the file. *** Order is important *** The # sequence of paths will be used to set the GNU Makefile's VPATH macro @@ -2762,21 +2753,31 @@ sub write_filepath print $fh "$CASEROOT/SourceMods/src.cam\n"; } - # offline unit driver (defaults to stub) - print $fh "$camsrcdir/src/unit_drivers\n"; - print $fh "$camsrcdir/src/unit_drivers/${offline_drv}\n"; + #NorESM-specific: + #Any files in "NorESM"-folder go before the original CAM-files + #These files MUST give back standard CAM5.3 if a standard CAM5.3 compset is chosen + #Un-commenting this line will give back standard CAM 5.3 (unmodified). + #This is used for testing. + #++djlo (should be switched off when pure NCAR version is desired) + print $fh "$camsrcdir/cam/src/NorESM\n"; + print $fh "$camsrcdir/cam/src/NorESM/$dyn\n"; + #--djlo + + # offline unit driver (defaults to stub) + print $fh "$camsrcdir/cam/src/unit_drivers\n"; + print $fh "$camsrcdir/cam/src/unit_drivers/${offline_drv}\n"; if ($simple_phys) { - print $fh "$camsrcdir/src/physics/simple\n"; + print $fh "$camsrcdir/cam/src/physics/simple\n"; } if ($carma ne 'none') { # This directory needs to precede physics/cam/ to replace # the CARMA stub package with CARMA. Putting it first allows # any CAM file to be overridden by a particular CARMA model. - print $fh "$camsrcdir/src/physics/carma/models/$carma\n"; - print $fh "$camsrcdir/src/physics/carma/cam\n"; - print $fh "$camsrcdir/src/physics/carma/base\n"; + print $fh "$camsrcdir/cam/src/physics/carma/models/$carma\n"; + print $fh "$camsrcdir/cam/src/physics/carma/cam\n"; + print $fh "$camsrcdir/cam/src/physics/carma/base\n"; } # CAM chemistry, dynamics, physics, control and shared utilities. @@ -2786,59 +2787,65 @@ sub write_filepath if ($chem_src_dir) { print $fh "$chem_src_dir\n"; } - if ($chem =~ /_mam/) { - print $fh "$camsrcdir/src/chemistry/modal_aero\n"; - } else { - print $fh "$camsrcdir/src/chemistry/bulk_aero\n"; + if ($chem =~/_oslo/) { + print $fh "$camsrcdir/cam/src/chemistry/oslo_aero\n"; + print $fh "$camsrcdir/cam/src/physics/cam_oslo\n"; + } + else{ + if ($chem =~ /_mam/) { + print $fh "$camsrcdir/cam/src/chemistry/modal_aero\n"; + } else { + print $fh "$camsrcdir/cam/src/chemistry/bulk_aero\n"; + } } - print $fh "$camsrcdir/src/chemistry/aerosol\n"; + print $fh "$camsrcdir/cam/src/chemistry/aerosol\n"; if ($waccmx) { - print $fh "$camsrcdir/src/physics/waccmx\n"; + print $fh "$camsrcdir/cam/src/physics/waccmx\n"; if ($ionos =~ /wxi/) { - print $fh "$camsrcdir/src/ionosphere/waccmx\n"; + print $fh "$camsrcdir/cam/src/ionosphere/waccmx\n"; } } if ($waccm_phys) { - print $fh "$camsrcdir/src/physics/waccm\n"; + print $fh "$camsrcdir/cam/src/physics/waccm\n"; } - print $fh "$camsrcdir/src/ionosphere\n"; + print $fh "$camsrcdir/cam/src/ionosphere\n"; - print $fh "$camsrcdir/src/chemistry/mozart\n"; - print $fh "$camsrcdir/src/chemistry/utils\n"; + print $fh "$camsrcdir/cam/src/chemistry/mozart\n"; + print $fh "$camsrcdir/cam/src/chemistry/utils\n"; if ($rad eq 'rrtmg') { - print $fh "$camsrcdir/src/physics/rrtmg\n"; - print $fh "$camsrcdir/src/physics/rrtmg/aer_src\n"; + print $fh "$camsrcdir/cam/src/physics/rrtmg\n"; + print $fh "$camsrcdir/cam/src/physics/rrtmg/aer_src\n"; } elsif ($rad eq 'camrt') { - print $fh "$camsrcdir/src/physics/camrt\n"; + print $fh "$camsrcdir/cam/src/physics/camrt\n"; } if ($clubb_sgs eq '1') { - print $fh "$camsrcdir/src/physics/clubb\n"; + print $fh "$camsrcdir/cam/src/physics/clubb\n"; } # Superparameterization if ($phys_pkg eq 'spcam_m2005' or $phys_pkg eq 'spcam_sam1mom') { - print $fh "$camsrcdir/src/physics/spcam\n"; - print $fh "$camsrcdir/src/physics/spcam/crm\n"; + print $fh "$camsrcdir/cam/src/physics/spcam\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm\n"; # add additional directories for sam6.10.4 - print $fh "$camsrcdir/src/physics/spcam/crm/ADV_MPDATA\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm/ADV_MPDATA\n"; if ($phys_pkg eq 'spcam_sam1mom') { - print $fh "$camsrcdir/src/physics/spcam/crm/MICRO_SAM1MOM\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm/MICRO_SAM1MOM\n"; } if ($phys_pkg eq 'spcam_m2005') { - print $fh "$camsrcdir/src/physics/spcam/crm/MICRO_M2005\n"; - print $fh "$camsrcdir/src/physics/spcam/ecpp\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm/MICRO_M2005\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/ecpp\n"; } if ( $spcam_clubb_sgs == 1 ) { - print $fh "$camsrcdir/src/physics/spcam/crm/CLUBB\n"; - print $fh "$camsrcdir/src/physics/spcam/crm/SGS_CLUBBkvhkvm\n" + print $fh "$camsrcdir/cam/src/physics/spcam/crm/CLUBB\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm/SGS_CLUBBkvhkvm\n" } else { - print $fh "$camsrcdir/src/physics/spcam/crm/SGS_TKE\n"; + print $fh "$camsrcdir/cam/src/physics/spcam/crm/SGS_TKE\n"; } } @@ -2846,31 +2853,31 @@ sub write_filepath # as well as the cam specific interface modules that may need to # be overridden by modules from directories that occur earlier # in the list of filepaths. - print $fh "$camsrcdir/src/physics/cam\n"; + print $fh "$camsrcdir/cam/src/physics/cam\n"; # Dynamics package and test utilities - print $fh "$camsrcdir/src/dynamics/$dyn\n"; + print $fh "$camsrcdir/cam/src/dynamics/$dyn\n"; if($dyn eq 'se') { - print $fh "$camsrcdir/src/dynamics/se/dycore\n"; + print $fh "$camsrcdir/cam/src/dynamics/se/dycore\n"; } - print $fh "$camsrcdir/src/dynamics/tests\n"; + print $fh "$camsrcdir/cam/src/dynamics/tests\n"; if($inic_val) { - print $fh "$camsrcdir/src/dynamics/tests/initial_conditions\n"; + print $fh "$camsrcdir/cam/src/dynamics/tests/initial_conditions\n"; } # Parallelization utilies if ($dyn eq 'fv' or $cppdefs =~ /MODCM_DP_TRANSPOSE/) { - print $fh "$camsrcdir/src/utils/pilgrim\n"; + print $fh "$camsrcdir/cam/src/utils/pilgrim\n"; } # Advective transport if ($dyn eq 'eul') { - print $fh "$camsrcdir/src/advection/slt\n"; + print $fh "$camsrcdir/cam/src/advection/slt\n"; } - print $fh "$camsrcdir/src/cpl\n"; - print $fh "$camsrcdir/src/control\n"; - print $fh "$camsrcdir/src/utils\n"; + print $fh "$camsrcdir/cam/src/cpl\n"; + print $fh "$camsrcdir/cam/src/control\n"; + print $fh "$camsrcdir/cam/src/utils\n"; if ($cam_build) { @@ -2890,15 +2897,15 @@ sub write_filepath # Ocean package. if ($ocn eq 'dom') { - print $fh "$camsrcdir/src/utils/cam_dom\n"; + print $fh "$camsrcdir/cam/src/utils/cam_dom\n"; } elsif ($ocn eq 'docn' or $ocn eq 'som') { print $fh "$cam_root/cime/src/components/data_comps/docn\n"; print $fh "$cam_root/cime/src/components/data_comps/docn/mct\n"; } elsif ($ocn eq 'aquaplanet') { - print $fh "$camsrcdir/src/utils/cam_aqua\n"; - print $fh "$camsrcdir/src/utils/cam_aqua/cpl\n"; + print $fh "$camsrcdir/cam/src/utils/cam_aqua\n"; + print $fh "$camsrcdir/cam/src/utils/cam_aqua/cpl\n"; } elsif ($ocn eq 'socn') { print $fh "$cam_root/cime/src/components/stub_comps/socn/cpl\n"; @@ -3074,14 +3081,14 @@ sub write_cosp_makefile print $fh_out <<"EOF"; CAM_BLD := $cam_bld -COSP_PATH := $cam_dir/src/physics/cosp2 -ISCCP_PATH := $cam_dir/src/physics/cosp2/src/simulator/icarus -RS_PATH := $cam_dir/src/physics/cosp2/src/simulator/quickbeam -RT_PATH := $cam_dir/src/physics/cosp2/src/simulator/rttov -CS_PATH := $cam_dir/src/physics/cosp2/src/simulator/actsim -MISR_PATH := $cam_dir/src/physics/cosp2/src/simulator/MISR_simulator -MODIS_PATH := $cam_dir/src/physics/cosp2/src/simulator/MODIS_simulator -PARASOL_PATH := $cam_dir/src/physics/cosp2/src/simulator/parasol +COSP_PATH := $cam_root/components/cam/src/physics/cosp2 +ISCCP_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/icarus +RS_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/quickbeam +RT_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/rttov +CS_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/actsim +MISR_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/MISR_simulator +MODIS_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/MODIS_simulator +PARASOL_PATH := $cam_root/components/cam/src/physics/cosp2/src/simulator/parasol EOF diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 17ebec5ca6..3d4b25f34b 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -356,7 +356,13 @@ CYCLICAL 2000 aero_1.9x2.5_L26_list_c070514.txt - + +atm/cam/chem/trop_mam/aero +mam3_1.9x2.5_L30_2000clim_c130319.nc +none +CYCLICAL +2000 +aero_1.9x2.5_L26_list_c070514.txt atm/cam/chem/trop_mozart_aero/aero aerosoldep_monthly_1849-2006_1.9x2.5_c090803.nc @@ -366,6 +372,11 @@ mam3_1.9x2.5_L30_2000clim_c130319.nc CYCLICAL 2000 + +atm/cam/chem/trop_mam/aero +mam3_1.9x2.5_L30_2000clim_c130319.nc +CYCLICAL +2000 atm/cam/rad/VolcanicMass_1870-1999_64x1_L18_c040115.nc @@ -629,6 +640,25 @@ atm/cam/chem/trop_mozart_aero/emis/aerocom_SO2_vertical_2000.c080807.nc atm/cam/chem/trop_mozart_aero/emis/aerocom_SO4_vertical_2000.c080807.nc + +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/aerocom_mam3_dms_surf_1849-2006_c090804.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_so2_surf_1850-2005_c090804.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_BCFFX_surf_1850-2005_c090804.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_BCFFN_surf_1850-2005_c090804.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/BCBB_ZERO_dummy_surf.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_so4_pr_surf_1850-2005_c090804.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_pom_surf_oslo_scaled_1850-2010_c20140421_v12.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/soanucl/bvocgcmFV19_monoterp_2000.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/soanucl/bvocgcmFV19_isopr_2000.nc + +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_so2_elev_1850-2005_c090804.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/BCFFX_ZERO_dummy_elev.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/BCFFN_ZERO_dummy_elev.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_bc_elev_1850-2005_c090804.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_pom_elev_oslo_scaled_1850-2010_c20140421_v12.nc +noresm-only/atm/cam/chem/trop_mozart_aero/emis/ipcc_ar5/ar5_mam3_so4_pr_elev_1850-2005_c090804.nc + + atm/cam/chem/trop_mozart_aero/emis/emis_NH3_2000_c111014.nc atm/cam/chem/trop_mozart_aero/emis/aerocom_mam3_dms_surf_2000_c120315.nc @@ -1194,6 +1224,9 @@ 1.0D0 1.0D0 + + + 1 3 @@ -1297,6 +1330,13 @@ 0.24D0 0.9D0 + + + + + + + 1.35D0 @@ -1898,7 +1938,19 @@ share/domains/domain.ocn.ne60np4_gx1v6.121113.nc share/domains/domain.ocn.ne120np4_gx1v6.121113.nc share/domains/domain.ocn.ne240np4_gx1v6.111226.nc - atm/cam/ocnfrac/domain.aqua.fv1.9x2.5.nc + +.true. +0.0 +noresm-only/atm/cam/camoslo/AeroTab_8jun17 +lana +CYCLICAL +2000 +odowd +CYCLICAL +2000 +Lana_ocean_1849_2006.nc +noresm-only/atm/cam/camoslo + diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 8d8acbafa4..8998be4684 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -563,6 +563,18 @@ Chooses level of velocity diffusion. Default: 3.0e5 + +Flag to extend standard 4th-order PPM scheme to model top. +Default: .false. + + + +Flag to turn on corrections in FV geometry and/or pressure terms. +Default: .false. + + Flag to turn on corrections that improve angular momentum conservation. @@ -944,6 +956,13 @@ Relaxation time (hours) applied to specified meteorology. Default: 0.0 + +if true, nudge only u, v and ps. If false, nudge other fields as well +(T, Q, TS, SHOWH, TAUX, TAUY, SHFLX, QFLX) +Default: true + + switch to turn on/off mass fixer for offline driver @@ -3906,7 +3925,7 @@ Default: set by build-namelist + terminator,trop_mam_oslo,none" > Name of the CAM chemistry package. N.B. this variable may not be set by the user. It is set by build-namelist via information in the configure cache file to be consistent with how CAM was built. @@ -4000,6 +4019,15 @@ Full pathname of AMIE inputs for southern hemisphere. Default: NONE. + + + +Switch to use appropriate energy adjustment in dry-mass adjustment at the +end of tphysac. +Default: .false. + + + + +Switch to use appropriate energy adjustment in dry-mass adjustment at the +end of tphysac. +Default: .false. + + - Full pathname of the directory that contains the files specified in @@ -7037,6 +7072,10 @@ Default: FALSE group="seq_cplflds_inparm" valid_values="" > Default: FALSE + +Default: FALSE + Default: @@ -7681,4 +7720,65 @@ List of filepaths for dataset for offline unit driver. Default: none + + + +Fraction of volcanic aerosols which will end up in coarse mode +Default: 0.0 + + +Directory where we will expect to find the CAM-Oslo tables +created from AeroTab + + + +Type of DMS data source +Default: emission_file + + + +Type of DMS data source type +Default: CYCLICAL + + + +DMS cycle year +Default: 2000 + + + +Type of ocean POM data source +Default: no_file + + + +Type of ocean POM data source type +Default: CYCLICAL + + + +Ocean POM cycle year +Default: 2000 + + + +Filename for ocean concentration of DMS, chlorophyll and poc +Default: name + + + +Path to ocean file +Default: path + + diff --git a/bld/namelist_files/use_cases/1850_cam54_ptaero.xml b/bld/namelist_files/use_cases/1850_cam54_ptaero.xml new file mode 100644 index 0000000000..0ea3a13972 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam54_ptaero.xml @@ -0,0 +1,43 @@ + + + + + +atm/cam/solar/SOLAR_SPECTRAL_Lean_1610-2008_annual_c090324.nc +18500101 +FIXED + + +284.7e-6 +791.6e-9 +275.68e-9 +12.48e-12 +0.0 + + +atm/cam/ozone +ozone_1.9x2.5_L26_1850clim_c090420.nc +O3 +CYCLICAL +1850 + +1850 +1850 + + + +CYCLICAL +1850 +oxid_1.9x2.5_L26_1850clim_c091123.nc + + +'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 + + diff --git a/bld/namelist_files/use_cases/1850_cam5_ptaero.xml b/bld/namelist_files/use_cases/1850_cam5_ptaero.xml new file mode 100644 index 0000000000..3713d50ea4 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam5_ptaero.xml @@ -0,0 +1,68 @@ + + + + + +atm/cam/solar/SOLAR_SPECTRAL_Lean_1610-2008_annual_c090324.nc +18500101 +FIXED + + +284.7e-6 +791.6e-9 +275.68e-9 +12.48e-12 +0.0 + + +atm/cam/ozone +ozone_1.9x2.5_L26_1850clim_c090420.nc +O3 +CYCLICAL +1850 + + +CYCLICAL +atm/cam/chem/trop_mozart_aero/emis/aerocom_mam3_dms_surf_2000_c090129.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so2_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_soag_1.5_surf_1850_c100217.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_bc_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_oc_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a1_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a2_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a1_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a2_surf_1850_c090726.nc + + +CYCLICAL +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a1_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a1_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_oc_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_bc_elev_1850_c090726.nc + +1850 +1850 + + + +CYCLICAL +1850 +oxid_1.9x2.5_L26_1850clim_c091123.nc + + +5 + + +'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 + + diff --git a/bld/namelist_files/use_cases/1850_cam6_noresm.xml b/bld/namelist_files/use_cases/1850_cam6_noresm.xml new file mode 100644 index 0000000000..5a337518ad --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_aer2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_aer2014.xml new file mode 100644 index 0000000000..71274136dc --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_aer2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxid2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxid2014.xml new file mode 100644 index 0000000000..f0ea07927f --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxid2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'noresm-only/atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxidonly.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxidonly.xml new file mode 100644 index 0000000000..a909cf7a60 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_aeroxidonly.xml @@ -0,0 +1,159 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_date_0000_5000_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_date_0000_5000_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_anthro2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_anthro2014.xml new file mode 100644 index 0000000000..a5fecfac5d --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_anthro2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 397.55e-6 + 1831.47e-9 + 326.99e-9 + 809.19e-12 + 520.58e-12 + + + 1850 + 'noresm-only/atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2014_date1850_CMIP6ensAvg_c180923.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'noresm-only/atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_bc2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_bc2014.xml new file mode 100644 index 0000000000..cfc7a258ce --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_bc2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ch42014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ch42014.xml new file mode 100644 index 0000000000..5575f7fb96 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ch42014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 1831.47e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ch4noh2o2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ch4noh2o2014.xml new file mode 100644 index 0000000000..4c9b6329f5 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ch4noh2o2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 1831.47e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..7c058095d6 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_frc2.xml @@ -0,0 +1,142 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1850_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1850_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1850_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1850_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_1.9x2.5_version20190808.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ghg2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ghg2014.xml new file mode 100644 index 0000000000..db7bf880ab --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ghg2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 397.55e-6 + 1831.47e-9 + 326.99e-9 + 809.19e-12 + 520.58e-12 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ghgnoh2o2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgnoh2o2014.xml new file mode 100644 index 0000000000..e6d6b6c95b --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgnoh2o2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 397.55e-6 + 1831.47e-9 + 326.99e-9 + 809.19e-12 + 520.58e-12 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ghgonly.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgonly.xml new file mode 100644 index 0000000000..28d58c2726 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgonly.xml @@ -0,0 +1,163 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ghgozone2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgozone2014.xml new file mode 100644 index 0000000000..804872caf1 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ghgozone2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 397.55e-6 + 1831.47e-9 + 326.99e-9 + 809.19e-12 + 520.58e-12 + + + 1850 + 'noresm-only/atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2014_date1850_CMIP6ensAvg_c180923.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_h2o2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_h2o2014.xml new file mode 100644 index 0000000000..e9f144c51b --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_h2o2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/noresm-only/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_n2o2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_n2o2014.xml new file mode 100644 index 0000000000..a0d118798f --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_n2o2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 326.99e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_natonly.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_natonly.xml new file mode 100644 index 0000000000..0d72b3bf47 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_natonly.xml @@ -0,0 +1,159 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +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/bld/namelist_files/use_cases/1850_cam6_noresm_ntcf2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ntcf2014.xml new file mode 100644 index 0000000000..4ae5b4d53e --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ntcf2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'noresm-only/atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2014_date1850_CMIP6ensAvg_c180923.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'noresm-only/atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_oc2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_oc2014.xml new file mode 100644 index 0000000000..9572242cf6 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_oc2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_oxid2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_oxid2014.xml new file mode 100644 index 0000000000..05b651cffc --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_oxid2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'noresm-only/atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ozone2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ozone2014.xml new file mode 100644 index 0000000000..0edc300da1 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ozone2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'noresm-only/atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2014_date1850_CMIP6ensAvg_c180923.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_ozoneonly.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_ozoneonly.xml new file mode 100644 index 0000000000..69692cb06c --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_ozoneonly.xml @@ -0,0 +1,161 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_so22014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_so22014.xml new file mode 100644 index 0000000000..de381cb15e --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_so22014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_noresm_so2oxid2014.xml b/bld/namelist_files/use_cases/1850_cam6_noresm_so2oxid2014.xml new file mode 100644 index 0000000000..573abe0db2 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_noresm_so2oxid2014.xml @@ -0,0 +1,162 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'noresm-only/atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014_date1850_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_2014_date_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2014_date_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2014_date_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_2014_date_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_2014_date_1850_1.9x2.5_version20180512.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/1850_cam6_oslo.xml b/bld/namelist_files/use_cases/1850_cam6_oslo.xml new file mode 100644 index 0000000000..726fcd32f6 --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam6_oslo.xml @@ -0,0 +1,155 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_1.9x2.5_version20180512.nc' + + + + + + + + + + + + + + + + + + + + .false. + .true. + .true. + .true. + .true. + .true. + + + .true. + + + .true. + + + 0.0300D0 + 0.0300D0 + + 8.0E-6 + 8.0E-6 + + +'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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/2000_cam6_noclb.xml b/bld/namelist_files/use_cases/2000_cam6_noclb.xml new file mode 100644 index 0000000000..fc971aa057 --- /dev/null +++ b/bld/namelist_files/use_cases/2000_cam6_noclb.xml @@ -0,0 +1,44 @@ + + + + + .true. + .false. + .true. + + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + + 'O3','OH','NO3','HO2' + 'CYCLICAL' + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + 'O3' + 'CYCLICAL' + + .false. + .true. + + 1 + + 2000 + + + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/ccmi_1950_2100_rcp6/IPCC_emissions_DMS_surface_1850-2100_1.9x2.5_c130814.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/ccmi_1950_2100_rcp6/IPCC_emissions_SO2_surface_1850-2100_1.9x2.5_c130814.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_soag_1.5_surf_1850-2005_c130424.nc', + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_bc_surf_1850-2005_c090804.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam4_num_a1_surf_1850-2005_c150205.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a2_surf_1850-2005_c090804.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam4_num_a4_surf_1850-2005_c150205.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_pom_surf_1850-2005_c130424.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a1_surf_1850-2005_c090804.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a2_surf_1850-2005_c090804.nc' + + + + diff --git a/bld/namelist_files/use_cases/2000_cam6_noclb_oslo.xml b/bld/namelist_files/use_cases/2000_cam6_noclb_oslo.xml new file mode 100644 index 0000000000..21901195ad --- /dev/null +++ b/bld/namelist_files/use_cases/2000_cam6_noclb_oslo.xml @@ -0,0 +1,44 @@ + + + + + .true. + .false. + .true. + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + + 'O3','OH','NO3','HO2' + 'CYCLICAL' + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + 'O3' + 'CYCLICAL' + + + .false. + .true. + + 1 + + 2000 + +'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 + + +' ' +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/2000_cam6_noclb_oslonudge.xml b/bld/namelist_files/use_cases/2000_cam6_noclb_oslonudge.xml new file mode 100644 index 0000000000..5c5a7c4467 --- /dev/null +++ b/bld/namelist_files/use_cases/2000_cam6_noclb_oslonudge.xml @@ -0,0 +1,49 @@ + + + + + .true. + .false. + .true. + atm/cam/topo/fv_0.9x1.25_nc3000_Nsw042_Nrs008_Co060_Fi001_ZR_160505.nc + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + + 'O3','OH','NO3','HO2' + 'CYCLICAL' + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + 'O3' + 'CYCLICAL' + + + .false. + .true. + + 1 + + 2000 + +'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 + + +'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 + +/work/shared/noresm/inputdata/noresm-only/inputForNudging/ERA_f09f09_32L_days/2010-01-01.nc +/work/shared/noresm/inputdata/noresm-only/inputForNudging/ERA_f09f09_32L_days/fileList2001-2015.txt + +'xactive_atm' + + diff --git a/bld/namelist_files/use_cases/2000_cam6_oslo.xml b/bld/namelist_files/use_cases/2000_cam6_oslo.xml new file mode 100644 index 0000000000..10d2d9ba10 --- /dev/null +++ b/bld/namelist_files/use_cases/2000_cam6_oslo.xml @@ -0,0 +1,138 @@ + + + + + + + + + + 2000 + atm/cam/ozone + tracer_cnst_CAM6chem_2000climo_3D_monthly_c171004.nc + '' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + + 2000 + atm/cam/ozone + ozone_strataero_CAM6chem_2000climo_zm_5day_c171004.nc + 'O3' + 'CYCLICAL' + + 'atm/cam/solar/SolarForcing1995-2005avg_c160929.nc' + 20000101 + FIXED + + + CYCLICAL + 2000 + + + CYCLICAL + 2000 + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_2000climo_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3Dmonthly_L70_2000climo_c180511.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2000climo_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2000climo_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2000climo_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2000climo_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3Dmonthly_L70_2000climo_c180511.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_2000climo_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_2000climo_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_2000climo_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_2000climo_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_2000climo_1.9x2.5_version20180512.nc' + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_2000climo_1.9x2.5_version20180512.nc' + + + + + + + + + + + + .false. + .true. + .true. + .true. + .true. + .true. + + + .true. + + + .true. + + + 0.0300D0 + 0.0300D0 + + 8.0E-6 + 8.0E-6 + + +'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 + + + +atm/cam/volc +CMIP_CAM6_radiation_v3_reformatted_1995-2005_clim.nc +2000 +CYCLICAL +'A:Q:H2O','N:O2:O2','N:CO2:CO2','N:ozone:O3','N:N2O:N2O','N:CH4:CH4','N:CFC11:CFC11','N:CFC12:CFC12' + 'atm/waccm/lb/LBC_2000climo_CMIP6_0p5degLat_c180227.nc' + 'CO2','CH4','N2O','CFC11eq','CFC12' + 'CYCLICAL' + 2000 + + diff --git a/bld/namelist_files/use_cases/2000_cam6_oslonudge.xml b/bld/namelist_files/use_cases/2000_cam6_oslonudge.xml new file mode 100644 index 0000000000..28480657e0 --- /dev/null +++ b/bld/namelist_files/use_cases/2000_cam6_oslonudge.xml @@ -0,0 +1,46 @@ + + + + + .true. + .false. + .true. + atm/cam/topo/fv_0.9x1.25_nc3000_Nsw042_Nrs008_Co060_Fi001_ZR_160505.nc + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + + 'O3','OH','NO3','HO2' + 'CYCLICAL' + + 2000 + atm/cam/ozone + oxid_ozone_WACCM_CCMI_REFC1_2000_cycle_3D_monthly.nc + 'O3' + 'CYCLICAL' + + .true. + + .false. + .true. + + 1 + + 2000 + + 0.29 + + +'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 + +/work/shared/noresm/inputdata/noresm-only/inputForNudging/ERA_f09f09_32L_days/2010-01-01.nc +/work/shared/noresm/inputdata/noresm-only/inputForNudging/ERA_f09f09_32L_days/fileList2001-2015.txt + +'xactive_atm' + + diff --git a/bld/namelist_files/use_cases/cam54_ptaero_up1.xml b/bld/namelist_files/use_cases/cam54_ptaero_up1.xml new file mode 100644 index 0000000000..aad0f0ac98 --- /dev/null +++ b/bld/namelist_files/use_cases/cam54_ptaero_up1.xml @@ -0,0 +1,12 @@ + + + + + +'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 + + diff --git a/bld/namelist_files/use_cases/cam5_nudge_ptaero_up1.xml b/bld/namelist_files/use_cases/cam5_nudge_ptaero_up1.xml new file mode 100644 index 0000000000..5a886bdfc9 --- /dev/null +++ b/bld/namelist_files/use_cases/cam5_nudge_ptaero_up1.xml @@ -0,0 +1,19 @@ + + + + + +/work/shared/noresm/inputdata/noresm-only/inputForNudging/FAMIPC5NudgeOut/atm/hist/FAMIPC5NudgeOut.cam.h1.1979-01-01-00000.nc +/work/shared/noresm/inputdata/noresm-only/inputForNudging/FAMIPC5NudgeOut/atm/hist/fileList.txt + + +5 + + +'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 + + diff --git a/bld/namelist_files/use_cases/cam5_ptaero_up1.xml b/bld/namelist_files/use_cases/cam5_ptaero_up1.xml new file mode 100644 index 0000000000..b4378ac98b --- /dev/null +++ b/bld/namelist_files/use_cases/cam5_ptaero_up1.xml @@ -0,0 +1,15 @@ + + + + + +5 + + +'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 + + diff --git a/bld/namelist_files/use_cases/hist_cam6_noresm.xml b/bld/namelist_files/use_cases/hist_cam6_noresm.xml new file mode 100644 index 0000000000..55bef46c0f --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_noresm.xml @@ -0,0 +1,160 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/hist_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/hist_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..386e014c7a --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_noresm_frc2.xml @@ -0,0 +1,140 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1849-2015_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1849-2015_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1849-2015_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1849-2015_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1849-2015_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1849-2015_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1849-2015_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1849-2015_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1849-2015_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1849-2015_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1849-2015_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1849-2015_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1849-2015_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1849-2015_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1849-2015_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1849-2015_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1849-2015_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1849-2015_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1849-2015_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1849-2015_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1849-2015_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1849-2015_1.9x2.5_version20190808.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/hist_cam6_noresm_piaer.xml b/bld/namelist_files/use_cases/hist_cam6_noresm_piaer.xml new file mode 100644 index 0000000000..79ca5139be --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_noresm_piaer.xml @@ -0,0 +1,161 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + CYCLICAL + 1850 + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/hist_cam6_noresm_piaeroxid.xml b/bld/namelist_files/use_cases/hist_cam6_noresm_piaeroxid.xml new file mode 100644 index 0000000000..25ea10020e --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_noresm_piaeroxid.xml @@ -0,0 +1,162 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/hist_cam6_noresm_pintcf.xml b/bld/namelist_files/use_cases/hist_cam6_noresm_pintcf.xml new file mode 100644 index 0000000000..f087902eae --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_noresm_pintcf.xml @@ -0,0 +1,163 @@ + + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfAGRTRADOMSOLWSTSHP_surface_1850_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1850_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofENEIND_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbAGRIBORFDEFOPEATSAVATEMF_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcCONTEXPL_vertical_1850_date_0000_5000_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO2_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1850_date_0000_5000_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/hist_cam6_oslo.xml b/bld/namelist_files/use_cases/hist_cam6_oslo.xml new file mode 100644 index 0000000000..99179428cd --- /dev/null +++ b/bld/namelist_files/use_cases/hist_cam6_oslo.xml @@ -0,0 +1,143 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + + + + .false. + .true. + .true. + .true. + .true. + .true. + + + .true. + + + .true. + + + 0.0300D0 + 0.0300D0 + + 8.0E-6 + 8.0E-6 + + +'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 + + + +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/bld/namelist_files/use_cases/sd_hist_cam6_noresm.xml b/bld/namelist_files/use_cases/sd_hist_cam6_noresm.xml new file mode 100644 index 0000000000..d25e05bde8 --- /dev/null +++ b/bld/namelist_files/use_cases/sd_hist_cam6_noresm.xml @@ -0,0 +1,168 @@ + + + + + +/work/olivie/topography-era/ERA_bnd_topo_noresm2_20191023.nc +6 +.true. +$INPUTDATA_ROOT/noresm-only/inputForNudging/ERA_f09f09_32L_days/2001-01-01.nc +noresm-only/inputForNudging/ERA_f09f09_32L_days/fileList2001-2015.txt +'xactive_atm' + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_1750-2015_CMIP6_GlobAnnAvg_c180926.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-20150103_CMIP6ensAvg_c180923.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_0.9x1.25_version20180512.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthrosurfALL_surface_1849-2015_1.9x2.5_version20180512.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_0.9x1.25_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_0.9x1.25_version20180512.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2015_CMIP6ensAvg_c180927.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_AX_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_N_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_BC_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_OM_NI_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO2_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_airALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_anthroprofALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_bbALL_vertical_1849-2015_1.9x2.5_version20180512.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/emissions_cmip6_noresm2_SO4_PR_volcALL_vertical_1849-2015_1.9x2.5_version20180512.nc' + + + + + + + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + +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 + + + +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/bld/namelist_files/use_cases/ssp126_cam6.xml b/bld/namelist_files/use_cases/ssp126_cam6.xml new file mode 100644 index 0000000000..fbb281f3fd --- /dev/null +++ b/bld/namelist_files/use_cases/ssp126_cam6.xml @@ -0,0 +1,94 @@ + + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP1-2.6_c190307.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a1_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a2_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_SO2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190225.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a1_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc' + + + + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_DMS_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-SSP_DMS_other_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_num_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_anthro-ag-ship-res_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_anthro-ene_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SOAGx1.5_anthro_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp126/emissions-cmip6-ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SOAGx1.5_bb_surface_mol_175001-210101_0.9x1.25_c20190225.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp/emissions-cmip6-SOAGx1.5_biogenic_surface_mol_175001-210101_0.9x1.25_c20190329.nc' + + + + atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc + + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014-2101_CMIP6-SSP1-2.6_c190307.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP126_c190221.nc' + 'O3' + 'SERIAL' + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + + 'SERIAL' + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP126_c190221.nc' + .true. + + + + + + .true. + atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-IMAGE-ssp126_201401-210112_fv_0.9x1.25_c20190207.nc + atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-IMAGE-ssp126_201401-210112_fv_1.9x2.5_c20190207.nc + + .true. + SERIAL + atm/cam/ggas + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_ssp126_201401-210112_fv_0.9x1.25_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-IMAGE-ssp126_201401-210112_fv_0.9x1.25_c20190207.nc + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_ssp126_201401-210112_fv_1.9x2.5_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-IMAGE-ssp126_201401-210112_fv_1.9x2.5_c20190207.nc + + + + 'CHEM_LBC_FILE' + atm/waccm/lb/LBC_2014-2500_CMIP6_SSP126_0p5degLat_GlobAnnAvg_c190301.nc + 'SERIAL' + 'CO2','CH4','N2O','CFC11eq','CFC12' + + + 1850-2100 + + + diff --git a/bld/namelist_files/use_cases/ssp126_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/ssp126_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..e17ba4cfc4 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp126_cam6_noresm_frc2.xml @@ -0,0 +1,126 @@ + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_2014-2500_CMIP6_SSP126_0p5degLat_GlobAnnAvg_c190301.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP126_c190221_nc3.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014-2101_CMIP6-SSP1-2.6_c190307.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_AX_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_N_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_OM_NI_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO4_PR_all_surface_2014-2301_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_AX_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_N_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_OM_NI_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO4_PR_all_surface_2014-2301_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP1-2.6_c190307.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_AX_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_N_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_OM_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO4_PR_all_vertical_2014-2301_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP1-2.6_c190307.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_AX_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_N_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_BC_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_OM_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO2_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-IMAGE-ssp126-1-1_SO4_PR_all_vertical_2014-2301_1.9x2.5_version20190808.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/bld/namelist_files/use_cases/ssp245_cam6.xml b/bld/namelist_files/use_cases/ssp245_cam6.xml new file mode 100644 index 0000000000..93d19b279b --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6.xml @@ -0,0 +1,91 @@ + + + + + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP2-4.5_c190403.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a1_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a2_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_SO2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a1_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc' + + + + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_DMS_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-SSP_DMS_other_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_num_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthro-ag-ship-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_anthro-ene_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc' + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SOAGx1.5_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp245/emissions-cmip6-ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SOAGx1.5_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp/emissions-cmip6-SOAGx1.5_biogenic_surface_mol_175001-210101_0.9x1.25_c20190329.nc' + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + + + atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2101_CMIP6ensAvg_SSP2-4.5_c190403.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP245_c190403.nc' + 'O3' + 'SERIAL' + + 'SERIAL' + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP245_c190403.nc' + .true. + + +.true. +atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245_201401-210112_fv_0.9x1.25_c20190207.nc +atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245_201401-210112_fv_1.9x2.5_c20190207.nc +.true. + + SERIAL + atm/cam/ggas + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_GLOBIOM-ssp245_201401-210112_fv_0.9x1.25_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245_201401-210112_fv_0.9x1.25_c20190207.nc + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_GLOBIOM-ssp245_201401-210112_fv_1.9x2.5_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245_201401-210112_fv_1.9x2.5_c20190207.nc + + + + + 'CHEM_LBC_FILE' + atm/waccm/lb/LBC_2014-2500_CMIP6_SSP245_0p5degLat_GlobAnnAvg_c190301.nc + 'SERIAL' + 'CO2','CH4','N2O','CFC11eq','CFC12' + + + 1850-2100 + + diff --git a/bld/namelist_files/use_cases/ssp245_cam6_noresm_aeroxidonly_frc2.xml b/bld/namelist_files/use_cases/ssp245_cam6_noresm_aeroxidonly_frc2.xml new file mode 100644 index 0000000000..fb3dedec35 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6_noresm_aeroxidonly_frc2.xml @@ -0,0 +1,134 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + '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_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_surface_2014-2301_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_surface_2014-2301_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_date_0000_5000_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_vertical_2014-2301_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20180512/perturbations/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_date_0000_5000_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_vertical_2014-2301_1.9x2.5_version20190808.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/ssp245_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/ssp245_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..f11c1f9025 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6_noresm_frc2.xml @@ -0,0 +1,126 @@ + + + + + + '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_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_surface_2014-2301_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_surface_2014-2301_1.9x2.5_version20190808.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_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_vertical_2014-2301_0.9x1.25_version20190808.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_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_AX_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_N_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_BC_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_OM_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO2_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-MESSAGE-GLOBIOM-ssp245-1-1_SO4_PR_all_vertical_2014-2301_1.9x2.5_version20190808.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/bld/namelist_files/use_cases/ssp245_cam6_noresm_ghgonly_frc2.xml b/bld/namelist_files/use_cases/ssp245_cam6_noresm_ghgonly_frc2.xml new file mode 100644 index 0000000000..1ca7d147ca --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6_noresm_ghgonly_frc2.xml @@ -0,0 +1,136 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6piControl_c160921.nc' + 18500101 + FIXED + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_2014-2500_CMIP6_SSP245_0p5degLat_GlobAnnAvg_c190301.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_1.9x2.5_version20190808.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_version20190808/perturbations/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_BC_N_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_SO2_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_date_0000_5000_0.9x1.25_version20190808.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_version20190808/perturbations/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_BC_N_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_SO2_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/perturbations/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_date_0000_5000_1.9x2.5_version20190808.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 + + + +atm/cam/volc +CMIP_CAM6_radiation_average_v3_reformatted.nc +1850 +CYCLICAL +'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/bld/namelist_files/use_cases/ssp245_cam6_noresm_natonly_frc2.xml b/bld/namelist_files/use_cases/ssp245_cam6_noresm_natonly_frc2.xml new file mode 100644 index 0000000000..10640234f6 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp245_cam6_noresm_natonly_frc2.xml @@ -0,0 +1,134 @@ + + + + + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 284.32e-6 + 808.25e-9 + 273.02e-9 + 32.11e-12 + 0.0 + + + 1850 + 'atm/cam/ozone_strataero' + 'ozone_strataero_cyclical_WACCM6_L70_CMIP6-piControl.001_y21-50avg_zm_5day_c180802.nc' + 'O3' + 'CYCLICAL' + + + 1850 + 'atm/cam/tracer_cnst' + 'tracer_cnst_WACCM6_halons_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc' + 'O3','OH','NO3','HO2' + 'CYCLICAL' + '' + + + CYCLICAL + 1850 + + + CYCLICAL + 1850 + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_surface_1850_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_surface_1850_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_surface_1850_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_surface_1850_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1850_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1850_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2O_emission_CH4_oxidationx2_elev_3DmonthlyL70_1850climoCMIP6piControl001_y21-50avg_c180802.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_AX_all_vertical_1850_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_N_all_vertical_1850_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_BC_NI_all_vertical_1850_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_OM_NI_all_vertical_1850_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO2_all_vertical_1850_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_SO4_PR_all_vertical_1850_1.9x2.5_version20190808.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/bld/namelist_files/use_cases/ssp370_cam6.xml b/bld/namelist_files/use_cases/ssp370_cam6.xml new file mode 100644 index 0000000000..e3d6720a91 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp370_cam6.xml @@ -0,0 +1,90 @@ + + + + + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP3-7.0_c190403.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a1_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a2_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_SO2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a1_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc' + + + + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_DMS_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-SSP_DMS_other_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_num_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_anthro-ag-ship-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_anthro-ene_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190222.nc' + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_SOAGx1.5_anthro_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp370/emissions-cmip6-ScenarioMIP_IAMC-AIM-ssp370-1-1_SOAGx1.5_bb_surface_mol_175001-210101_0.9x1.25_c20190222.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp/emissions-cmip6-SOAGx1.5_biogenic_surface_mol_175001-210101_0.9x1.25_c20190329.nc' + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + + + atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2101_CMIP6ensAvg_SSP3-7.0_c190403.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP370_c190403.nc' + 'O3' + 'SERIAL' + + 'SERIAL' + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP370_c190403.nc' + .true. + + + .true. + atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-AIM-ssp370_201401-210112_fv_0.9x1.25_c20190207.nc + atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-AIM-ssp370_201401-210112_fv_1.9x2.5_c20190207.nc + .true. + + SERIAL + atm/cam/ggas + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_ssp370_201401-210112_fv_0.9x1.25_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-AIM-ssp370_201401-210112_fv_0.9x1.25_c20190207.nc + ac_CO2 -> emissions-cmip6_CO2_anthro_ac_ssp370_201401-210112_fv_1.9x2.5_c20190207.txt + atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-AIM-ssp370_201401-210112_fv_1.9x2.5_c20190207.nc + + + + 'CHEM_LBC_FILE' + atm/waccm/lb/LBC_2014-2500_CMIP6_SSP370_0p5degLat_GlobAnnAvg_c190301.nc + 'SERIAL' + 'CO2','CH4','N2O','CFC11eq','CFC12' + + + 1850-2100 + + diff --git a/bld/namelist_files/use_cases/ssp370_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/ssp370_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..4e0fc8d31a --- /dev/null +++ b/bld/namelist_files/use_cases/ssp370_cam6_noresm_frc2.xml @@ -0,0 +1,126 @@ + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_2014-2500_CMIP6_SSP370_0p5degLat_GlobAnnAvg_c190301.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_18500101-21010201_CMIP6histEnsAvg_SSP370_c190403.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_1849-2101_CMIP6ensAvg_SSP3-7.0_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_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_AX_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_N_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_OM_NI_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO4_PR_all_surface_2014-2301_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_AX_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_N_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_OM_NI_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO4_PR_all_surface_2014-2301_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP3-7.0_c190403.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_AX_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_N_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_OM_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO4_PR_all_vertical_2014-2301_0.9x1.25_version20190808.nc' + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_1849-2101_CMIP6ensAvg_SSP3-7.0_c190403.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_AX_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_N_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_BC_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_OM_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO2_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-AIM-ssp370-1-1_SO4_PR_all_vertical_2014-2301_1.9x2.5_version20190808.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/bld/namelist_files/use_cases/ssp585_cam6.xml b/bld/namelist_files/use_cases/ssp585_cam6.xml new file mode 100644 index 0000000000..451a93671a --- /dev/null +++ b/bld/namelist_files/use_cases/ssp585_cam6.xml @@ -0,0 +1,96 @@ + + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP5-8.5_c190307.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a1_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_num_a2_so4_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_SO2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_so4_a1_anthro-ene_vertical_mol_175001-210101_0.9x1.25_c20190224.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a1_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/CMIP6_emissions_1750_2015/emissions-cmip6_so4_a2_contvolcano_vertical_850-5000_0.9x1.25_c20170724.nc' + + + + + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'bc_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_DMS_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'DMS -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-SSP_DMS_other_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_bc_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_bc_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'num_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_num_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_pom_a4_anthro_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'pom_a4 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_pom_a4_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_anthro-ag-ship-res_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_anthro-ene_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_so4_a1_anthro-ag-ship_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'so4_a1 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_so4_a1_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'so4_a2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_so4_a2_anthro-res_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SOAGx1.5_anthro_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SOAGx1.5_bb_surface_mol_175001-210101_0.9x1.25_c20190224.nc', + 'SOAG -> $INPUTDATA_ROOT/atm/cam/chem/emis/emissions_ssp585/emissions-cmip6-ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SOAGx1.5_biogenic_surface_mol_175001-210101_0.9x1.25_c20190226.nc' + + + + + atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014-2101_CMIP6-SSP5-8.5_c190307.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP585_c190529.nc' + 'O3' + 'SERIAL' + + + INTERP_MISSING_MONTHS + INTERP_MISSING_MONTHS + + + 'SERIAL' + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP585_c190529.nc' + .true. + + +.true. +atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.nc + +atm/cam/ggas/emissions-cmip6_CO2_anthro_surface_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.nc + + +.true. +SERIAL +atm/cam/ggas +ac_CO2 -> emissions-cmip6_CO2_anthro_ac_MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.txt +atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.nc + + +ac_CO2 -> emissions-cmip6_CO2_anthro_ac_MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.txt +atm/cam/ggas/emissions-cmip6_CO2_anthro_ac_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585_201401-210112_fv_0.9x1.25_c20190207.nc + + 'CHEM_LBC_FILE' + atm/waccm/lb/LBC_2014-2500_CMIP6_SSP585_0p5degLat_GlobAnnAvg_c190301.nc + 'SERIAL' + 'CO2','CH4','N2O','CFC11eq','CFC12' + + + + 1850-2100 + + + diff --git a/bld/namelist_files/use_cases/ssp585_cam6_noresm_frc2.xml b/bld/namelist_files/use_cases/ssp585_cam6_noresm_frc2.xml new file mode 100644 index 0000000000..68b680c437 --- /dev/null +++ b/bld/namelist_files/use_cases/ssp585_cam6_noresm_frc2.xml @@ -0,0 +1,126 @@ + + + + + + 'atm/cam/solar/SolarForcingCMIP6_18491230-22991231_c171031.nc' + + + 'CHEM_LBC_FILE' + +atm/waccm/lb/LBC_2014-2500_CMIP6_SSP585_0p5degLat_GlobAnnAvg_c190301.nc +'SERIAL' +'CO2','CH4','N2O','CFC11eq','CFC12' + + + 'atm/cam/ozone_strataero' + 'ozone_strataero_WACCM_L70_zm5day_2015-2100_SSP585_c190529.nc' + 'O3' + 'SERIAL' + + + 'atm/cam/tracer_cnst' + 'tracer_cnst_halons_3D_L70_2014-2101_CMIP6-SSP5-8.5_c190307.nc' + 'O3','OH','NO3','HO2' + 'INTERP_MISSING_MONTHS' + '' + + + INTERP_MISSING_MONTHS + + + INTERP_MISSING_MONTHS + + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_AX_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_N_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_OM_NI_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_all_surface_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO4_PR_all_surface_2014-2301_0.9x1.25_version20190808.nc' + + + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_AX_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_N_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_OM_NI_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_all_surface_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO4_PR_all_surface_2014-2301_1.9x2.5_version20190808.nc' + + + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP5-8.5_c190307.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_AX_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_N_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_OM_NI_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO4_PR_all_vertical_2014-2301_0.9x1.25_version20190808.nc', + + + 'H2O -> $INPUTDATA_ROOT/atm/cam/chem/emis/elev/H2OemissionCH4oxidationx2_3D_L70_2014-2101_CMIP6-SSP5-8.5_c190307.nc', + 'BC_AX -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_AX_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_N -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_N_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'BC_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_BC_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'OM_NI -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_OM_NI_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO2 -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO2_all_vertical_2014-2301_1.9x2.5_version20190808.nc', + 'SO4_PR -> $INPUTDATA_ROOT/atm/cam/chem/emis/cmip6_emissions_version20190808/emissions_cmip6_noresm2_ScenarioMIP_IAMC-REMIND-MAGPIE-ssp585-1-1_SO4_PR_all_vertical_2014-2301_1.9x2.5_version20190808.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/chem_proc/README b/chem_proc/README new file mode 100644 index 0000000000..2b0e6b6938 --- /dev/null +++ b/chem_proc/README @@ -0,0 +1,34 @@ + +This is the MOZART chemical preprocessor, which has been modified for the +CAM framework. + +This tool creates CAM chemistry source code files (fortran) for a given +chemical mechanism file (*.inp file). + +Here $PROC_DIR is the top level directory of the chemical preprocessor. + +To build: +> cd $PROC_DIR/src +> gmake +This will biuld $PROC_DIR/bin/campp executable. + +Edit or create a chemical mechanism file in the $PROC_DIR/inputs +directory. Example mechanisms files can be found in $PROC_DIR/inputs. +More information the chemical mechanism inputs can be found at +http://gctm.acd.ucar.edu/mozart/documents/mozart2_preprocessor.pdf + +To run: +> cd $PROC_DIR/inputs +> $PROC_DIR/bin/campp mechanism.inp +> cd $PROC_DIR/output +> cp cam.subs.tar $CAM_USRSRC +> cd $CAM_USRSRC +> tar -xvf cam.subs.tar + +Include the fortran source files extacted from cam.subs.tar in the +source path of the CAM build by one of the follow methods. + 1) configure CAM with the -usr_src $CAM_USRSRC option +or + 2) copy the new *.F90 files to the trop_mozart directory + +Configure and build the new CAM executable. diff --git a/chem_proc/bkend/cam.mod.files.PP b/chem_proc/bkend/cam.mod.files.PP new file mode 100644 index 0000000000..05ee37296b --- /dev/null +++ b/chem_proc/bkend/cam.mod.files.PP @@ -0,0 +1,9 @@ +# include +# include +# include +# include +# include +#if defined(MOZART) +MODSPATH/mo_grid.mod +#endif +MODSPATH/mo_chem.mod diff --git a/chem_proc/bkend/cam.src.files.PP b/chem_proc/bkend/cam.src.files.PP new file mode 100644 index 0000000000..a6c6847467 --- /dev/null +++ b/chem_proc/bkend/cam.src.files.PP @@ -0,0 +1,11 @@ +# include +# include +# include +# include +# if defined(RXTNLOOKUP) && TDEPCNT != 0 +rxttab.F +# endif +SETRXTFILE +ADJRXTFILE +PHTADJFILE +SETDATFILE diff --git a/chem_proc/bkend/mozart.mat.files.PP b/chem_proc/bkend/mozart.mat.files.PP new file mode 100644 index 0000000000..f00a5dc794 --- /dev/null +++ b/chem_proc/bkend/mozart.mat.files.PP @@ -0,0 +1,9 @@ +# include +# include +# include +prd_loss.F +indprd.F +linmat.F +nlnmat.F +lu_fac.F +lu_slv.F diff --git a/chem_proc/bkend/mozart.mod.files.PP b/chem_proc/bkend/mozart.mod.files.PP new file mode 100644 index 0000000000..0deac5ad98 --- /dev/null +++ b/chem_proc/bkend/mozart.mod.files.PP @@ -0,0 +1,7 @@ +# include +# include +# include +# include +# include +MODSPATH/mo_grid.mod +MODSPATH/mo_chem.mod diff --git a/chem_proc/bkend/mozart.src.files.PP b/chem_proc/bkend/mozart.src.files.PP new file mode 100644 index 0000000000..9b77ce4601 --- /dev/null +++ b/chem_proc/bkend/mozart.src.files.PP @@ -0,0 +1,12 @@ +# include +# include +# include +# include +# if defined(RXTNLOOKUP) && TDEPCNT != 0 +rxttab.F +# endif +SETRXTFILE +ADJRXTFILE +PHTADJFILE +RXTMODFILE +GRPVMRFILE diff --git a/chem_proc/bkend/wrf.mod.files.PP b/chem_proc/bkend/wrf.mod.files.PP new file mode 100644 index 0000000000..05ee37296b --- /dev/null +++ b/chem_proc/bkend/wrf.mod.files.PP @@ -0,0 +1,9 @@ +# include +# include +# include +# include +# include +#if defined(MOZART) +MODSPATH/mo_grid.mod +#endif +MODSPATH/mo_chem.mod diff --git a/chem_proc/inputs/cam_TP1.inp b/chem_proc/inputs/cam_TP1.inp new file mode 100644 index 0000000000..d173facf4b --- /dev/null +++ b/chem_proc/inputs/cam_TP1.inp @@ -0,0 +1,118 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + CO + COEA -> CO + COSA -> CO + COEU -> CO + CONA -> CO + COAVOC -> CO + COBVOC -> CO + COCH4 -> CO + CAVOC -> C + CBVOC -> C + PRO1 -> C3H8 + BUT1 -> C4H10 + ETH1 -> C2H6 + PRO2 -> C3H8 + BUT2 -> C4H10 + ETH2 -> C2H6 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + End Col-int + + End SPECIES + + Solution Classes + Explicit + CO + COEA + COSA + COEU + CONA + COAVOC + COBVOC + COCH4 + CAVOC + CBVOC + PRO1 + BUT1 + ETH1 + PRO2 + BUT2 + ETH2 + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + CO -> ; 4.62963e-07 + COEA -> ; 4.62963e-07 + COSA -> ; 4.62963e-07 + COEU -> ; 4.62963e-07 + CONA -> ; 4.62963e-07 + COAVOC -> ; 4.62963e-07 + COBVOC -> ; 4.62963e-07 + COCH4 -> ; 4.62963e-07 + CAVOC -> 0.7*COAVOC ; 1.65344e-06 + CBVOC -> 0.4*COBVOC ; 1.15741e-05 + CH4 -> 0.86*COCH4 ; 3.83142e-07 + PRO1 -> ; 0.86e-7 + BUT1 -> ; 2.05e-7 + ETH1 -> ; 0.18e-7 + PRO2 -> ; 1.72e-7 + BUT2 -> ; 4.10e-7 + ETH2 -> ; 0.36e-7 + End Reactions + + Heterogeneous + End Heterogeneous + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_TP1.v2.inp b/chem_proc/inputs/cam_TP1.v2.inp new file mode 100644 index 0000000000..0ace862cf3 --- /dev/null +++ b/chem_proc/inputs/cam_TP1.v2.inp @@ -0,0 +1,147 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + CO + COEA -> CO + COSA -> CO + COEU -> CO + CONA -> CO + SCO -> CO + SCOEA -> CO + SCOSA -> CO + SCOEU -> CO + SCONA -> CO + COAVOC -> CO + COBVOC -> CO + COCH4 -> CO + CAVOC -> C + CBVOC -> C + PRO1 -> C3H8 + BUT1 -> C4H10 + ETH1 -> C2H6 + PRO2 -> C3H8 + BUT2 -> C4H10 + ETH2 -> C2H6 + LVOC -> C + MVOC -> C + SVOC -> C + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + End Col-int + + End SPECIES + + Solution Classes + Explicit + CO + COEA + COSA + COEU + CONA + SCO + SCOEA + SCOSA + SCOEU + SCONA + COAVOC + COBVOC + COCH4 + CAVOC + CBVOC + PRO1 + BUT1 + ETH1 + PRO2 + BUT2 + ETH2 + LVOC + MVOC + SVOC + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + CO -> ; 2.3148e-07 + COEA -> ; 2.3148e-07 + COSA -> ; 2.3148e-07 + COEU -> ; 2.3148e-07 + CONA -> ; 2.3148e-07 + + SCO -> ; 2.3148e-07 + SCOEA -> ; 2.3148e-07 + SCOSA -> ; 2.3148e-07 + SCOEU -> ; 2.3148e-07 + SCONA -> ; 2.3148e-07 + + COAVOC -> ; 2.3148e-07 + COBVOC -> ; 2.3148e-07 + COCH4 -> ; 2.3148e-07 + + CAVOC -> 0.7*COAVOC ; 1.65344e-06 + CBVOC -> 0.4*COBVOC ; 1.15741e-05 + CH4 -> 0.86*COCH4 ; 3.73e-09 + PRO1 -> ; 0.86e-07 + BUT1 -> ; 2.05e-07 + ETH1 -> ; 0.18e-07 + PRO2 -> ; 1.72e-07 + BUT2 -> ; 4.10e-07 + ETH2 -> ; 0.36e-07 + + LVOC -> ; 1.80845E-07 + MVOC -> ; 8.90313E-07 + SVOC -> ; 2.0668E-06 + + End Reactions + + Heterogeneous + End Heterogeneous + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_arctas_gfs.inp b/chem_proc/inputs/cam_arctas_gfs.inp new file mode 100644 index 0000000000..1e4f42aa03 --- /dev/null +++ b/chem_proc/inputs/cam_arctas_gfs.inp @@ -0,0 +1,353 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_arctas_gfs.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = arctas_gfst42.dat + +Comments + "This is a cam-chem simulation with :" + "(1) NCEP/GFS meteorology inputs" + "(2) no SYNOZ" + "(3) CO tags for ARCTAS forecasts" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, DMS -> CH3SCH3, SO4, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + O3S -> O3, O3INERT -> O3 + COnama -> CO, COnamb -> CO, COeura -> CO, COeurb -> CO + COnasa -> CO, COnasb -> CO, COsasa -> CO, COsasb -> CO + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, H2, O3INERT, O3S + COnama, COnamb, COeura, COeurb, COnasa, COnasb, COsasa, COsasb + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + SO2, DMS, SO4, NH3, NH4, NH4NO3, SOA + CB1, CB2, OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH +* [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 4.4e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 +* ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 1.52e-11, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 +*30-day lifetime + COnama -> CO2 ; 3.8e-7 + COnamb -> CO2 ; 3.8e-7 + COeura -> CO2 ; 3.8e-7 + COeurb -> CO2 ; 3.8e-7 + COnasa -> CO2 ; 3.8e-7 + COnasb -> CO2 ; 3.8e-7 + COsasa -> CO2 ; 3.8e-7 + COsasb -> CO2 ; 3.8e-7 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, SO4, SOA, NH3, NH4, NH4NO3, CB2, OC2, SSLT01, SSLT02, SSLT03, SSLT04 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_bc.inp b/chem_proc/inputs/cam_bc.inp new file mode 100644 index 0000000000..be0fc12c10 --- /dev/null +++ b/chem_proc/inputs/cam_bc.inp @@ -0,0 +1,78 @@ +BEGSIM +output_unit_number = 7 +output_file = bc.doc +sim_dat_filename = sim.dat +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ + +Comments + "This is a mozart2 simulation with :" + "(1) The new Lin and Rood advection routine" +End Comments + + SPECIES + + Solution + CB1 -> C, CB2 -> C + End Solution + + Fixed + M, N2, O2 + End Fixed + + Col-int + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + CB1,CB2 + End Implicit + End Solution Classes + + CHEMISTRY + + Reactions + CB1 -> CB2 ; 7.1e-6 + End Reactions + + Ext Forcing + End Ext Forcing + + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = Intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM + + + + + + + + + + + + + diff --git a/chem_proc/inputs/cam_co_prescribed.inp b/chem_proc/inputs/cam_co_prescribed.inp new file mode 100644 index 0000000000..d943e742d7 --- /dev/null +++ b/chem_proc/inputs/cam_co_prescribed.inp @@ -0,0 +1,79 @@ +BEGSIM +output_unit_number = 7 +output_file = co2.doc +sim_dat_filename = sim.dat +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ + +Comments + "This is a mozart2 simulation with :" + "(1) The new Lin and Rood advection routine" +End Comments + + SPECIES + + Solution + CO + End Solution + + Fixed + M, N2, O2, H2O, OH + End Fixed + + Col-int + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CO + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + + Reactions +[usr8] CO + OH -> CO2 + HO2 + End Reactions + + Ext Forcing + CO<-dataset + End Ext Forcing + + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = Intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM + + + + + + + + + + + + + diff --git a/chem_proc/inputs/cam_fixed_aerosols.inp b/chem_proc/inputs/cam_fixed_aerosols.inp new file mode 100644 index 0000000000..5143d3b1b4 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_aerosols.inp @@ -0,0 +1,70 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + End Solution + + Fixed + M, N2, O2, H2O, SO4, CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + End Reactions + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_aerosols_ozone.inp b/chem_proc/inputs/cam_fixed_aerosols_ozone.inp new file mode 100644 index 0000000000..653d868595 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_aerosols_ozone.inp @@ -0,0 +1,71 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + End Solution + + Fixed + M, N2, O2, H2O, SO4, CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + O3 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + End Reactions + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_aerosols_run6.inp b/chem_proc/inputs/cam_fixed_aerosols_run6.inp new file mode 100644 index 0000000000..d924cc0a42 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_aerosols_run6.inp @@ -0,0 +1,71 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + End Solution + + Fixed + M, N2, O2, H2O, SO4, CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, + SOA -> C12, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + End Reactions + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_ch4_2.inp b/chem_proc/inputs/cam_fixed_ch4_2.inp new file mode 100644 index 0000000000..150304a916 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_ch4_2.inp @@ -0,0 +1,354 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4, CH4CHML->CH4 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD, CH4CHML + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 +* CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 +* CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + OH -> CH3O2 + H2O + CH4CHML ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 + CH4CHML ; 1.5e-10 + CH4CHML -> ; 7.1 e-6 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH +* [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 +* + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Numerical Control + Implicit Iterations = 11 + End Numerical Control + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_oxidants.inp b/chem_proc/inputs/cam_fixed_oxidants.inp new file mode 100644 index 0000000000..b7ce5b6b3f --- /dev/null +++ b/chem_proc/inputs/cam_fixed_oxidants.inp @@ -0,0 +1,70 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + H2O2, SO2, SO4, DMS -> CH3SCH3 + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, SO2, SO4, DMS + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + End Reactions + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_oxidants_aerosols.inp b/chem_proc/inputs/cam_fixed_oxidants_aerosols.inp new file mode 100644 index 0000000000..391fc794fb --- /dev/null +++ b/chem_proc/inputs/cam_fixed_oxidants_aerosols.inp @@ -0,0 +1,85 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + H2O2, SO2, SO4, DMS -> CH3SCH3 + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + Fixed + M, N2, O2, H2O + O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, SO2, SO4, DMS + CB1, CB2, OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04 + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + CB1 -> CB2 ; 1.006e-05 + OC1 -> OC2 ; 1.006e-05 + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + SO4 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_3modes_0707.inp b/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_3modes_0707.inp new file mode 100644 index 0000000000..9bdef974e3 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_3modes_0707.inp @@ -0,0 +1,101 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants_modal_aero_cw_3modes_0707.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants_modal_aero_cw_3modes_0707.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + H2O2, H2SO4, SO2, DMS -> CH3SCH3, SOAG -> C + so4_a1 -> NH4HSO4 + pom_a1 -> C, soa_a1 -> C, bc_a1 -> C + dst_a1 -> AlSiO5, ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> NH4HSO4 + soa_a2 -> C, ncl_a2 -> NaCl + num_a2 -> H + dst_a3 -> AlSiO5, ncl_a3 -> NaCl + so4_a3 -> NH4HSO4 + num_a3 -> H + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, H2SO4, SO2, DMS, SOAG + so4_a1, pom_a1 + soa_a1, bc_a1, dst_a1, ncl_a1 + num_a1 + so4_a2, soa_a2, ncl_a2, num_a2 + dst_a3, ncl_a3, so4_a3, num_a3 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + [usr23] SO2 + OH -> H2SO4 + DMS + OH -> SO2 ; 9.6e-12, -234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_7modes_noaerwater.inp b/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_7modes_noaerwater.inp new file mode 100644 index 0000000000..679319cfe2 --- /dev/null +++ b/chem_proc/inputs/cam_fixed_oxidants_modal_aero_cw_7modes_noaerwater.inp @@ -0,0 +1,112 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants_modal_aero_cw_7modes_noaerwater.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_fixed_oxidants_modal_aero_cw_7modes_noaerwater.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + H2O2, H2SO4, SO2, DMS -> CH3SCH3, NH3, SOAG -> C + so4_a1 -> SO4, nh4_a1 -> NH4 + pom_a1 -> C, soa_a1 -> C, bc_a1 -> C, ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> SO4, nh4_a2 -> NH4 + soa_a2 -> C, ncl_a2 -> NaCl + num_a2 -> H + pom_a3 -> C, bc_a3 -> C + num_a3 -> H + ncl_a4 -> NaCl, so4_a4 -> SO4 + nh4_a4 -> NH4, num_a4 -> H + dst_a5 -> AlSiO5, so4_a5 -> SO4 + nh4_a5 -> NH4, num_a5 -> H + ncl_a6 -> NaCl, so4_a6 -> SO4 + nh4_a6 -> NH4, num_a6 -> H + dst_a7 -> AlSiO5, so4_a7 -> SO4 + nh4_a7 -> NH4, num_a7 -> H + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, H2SO4, SO2, DMS, NH3, SOAG + so4_a1, nh4_a1, pom_a1 + soa_a1, bc_a1, ncl_a1, num_a1 + so4_a2, nh4_a2, soa_a2, ncl_a2 + num_a2 + pom_a3, bc_a3, num_a3 + ncl_a4, so4_a4, nh4_a4, num_a4 + dst_a5, so4_a5, nh4_a5, num_a5 + ncl_a6, so4_a6, nh4_a6, num_a6 + dst_a7, so4_a7, nh4_a7, num_a7 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + [usr23] SO2 + OH -> H2SO4 + DMS + OH -> SO2 ; 9.6e-12, -234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf.inp b/chem_proc/inputs/cam_full_mech_newsulf.inp new file mode 100644 index 0000000000..e9677797c5 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf.inp @@ -0,0 +1,347 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_newsulf.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_newsulf.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_fixed_ch4.inp b/chem_proc/inputs/cam_full_mech_newsulf_fixed_ch4.inp new file mode 100644 index 0000000000..299e6ad002 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_fixed_ch4.inp @@ -0,0 +1,352 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_newsulf.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_newsulf.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4CHML->CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4CHML, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 +* CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 +* CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + OH -> CH3O2 + H2O + CH4CHML ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 + CH4CHML ; 1.5e-10 + CH4CHML -> ; 7.1 e-6 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 +* [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 +* + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_nosynoz.inp b/chem_proc/inputs/cam_full_mech_newsulf_nosynoz.inp new file mode 100644 index 0000000000..0a90014256 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_nosynoz.inp @@ -0,0 +1,347 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_newsulf.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_newsulf.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) No SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_table.in b/chem_proc/inputs/cam_full_mech_newsulf_table.in new file mode 100644 index 0000000000..d6090ba2a2 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_table.in @@ -0,0 +1,328 @@ + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2->,jo2_b] O2 + hv -> 2*O + [jo1d->,jo3_a] O3 + hv -> O1D + O2 + [jo3p->,jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5->,jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3_b] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2_b] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmacr_b] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr_O_O2] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [tag_NO2_NO3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr_N2O5_M] N2O5 + M -> NO2 + NO3 + M + [tag_NO2_OH] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr_HNO3_OH] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [tag_NO2_HO2] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr_HO2NO2_M] HO2NO2 + M -> HO2 + NO2 + M + [usr_N2O5_aer] N2O5 -> 2 * HNO3 + [usr_NO3_aer] NO3 -> HNO3 + [usr_NO2_aer] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr_CO_OH_a] CO + OH -> CO2 + HO2 + [tag_C2H4_OH] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [tag_C3H6_OH] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [tag_CH3CO3_NO2] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr_PAN_M] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr_CH3COCH3_OH] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr_MCO3_NO2] MCO3 + NO2 + M -> MPAN + M + [usr_MPAN_M] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr_XOOH_OH] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr_SO2_OH] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr_DMS_OH] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr_HO2_aer] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/cam_full_mech_newsulf_tagged.inp b/chem_proc/inputs/cam_full_mech_newsulf_tagged.inp new file mode 100644 index 0000000000..57cb6bde8d --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_tagged.inp @@ -0,0 +1,368 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_newsulf.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_newsulf.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH +* [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3->,1.1236*jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH +* [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH +* [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 +* [jmpan] MPAN + hv -> MCO3 + NO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 +* [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH +* [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 +* [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 +* [jxooh] XOOH + hv -> OH + [jxooh->,jch3ooh] XOOH + hv -> OH +* [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O +* [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 +* [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O +* [jmek] MEK + hv -> CH3CO3 + C2H5O2 +* [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO +* [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 +* [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH +* [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO +* [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD +* [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_tagged.nontransport.inp b/chem_proc/inputs/cam_full_mech_newsulf_tagged.nontransport.inp new file mode 100644 index 0000000000..67cae7baee --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_tagged.nontransport.inp @@ -0,0 +1,372 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_newsulf.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_newsulf.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + Not-Transported + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Not-Transported + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH +* [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3->,1.1236*jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH +* [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH +* [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 +* [jmpan] MPAN + hv -> MCO3 + NO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 +* [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH +* [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 +* [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 +* [jxooh] XOOH + hv -> OH + [jxooh->,jch3ooh] XOOH + hv -> OH +* [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O +* [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 +* [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O +* [jmek] MEK + hv -> CH3CO3 + C2H5O2 +* [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO +* [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 +* [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH +* [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO +* [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD +* [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_xnox.inp b/chem_proc/inputs/cam_full_mech_newsulf_xnox.inp new file mode 100644 index 0000000000..81208ad13d --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_xnox.inp @@ -0,0 +1,454 @@ +BEGSIM +output_unit_number = 7 +output_file = newsulf_xnox.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = newsulf_xnox.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" + "(8) XNOx for surface emissions" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + XNO -> NO, XNO2 -> NO2, XNO3 -> NO3, XHNO3 -> HNO3 + XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5 + XPAN -> CH3CO3NO2, XONIT -> CH3COCH2ONO2, XMPAN -> CH2CCH3CO3NO2 + XISOPNO3 -> CH2CHCCH3OOCH2ONO2, XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR, XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15a] XMPAN + M -> XNO2 + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_xnox_fixed_ch4.inp b/chem_proc/inputs/cam_full_mech_newsulf_xnox_fixed_ch4.inp new file mode 100644 index 0000000000..7014ed64a8 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_xnox_fixed_ch4.inp @@ -0,0 +1,460 @@ +BEGSIM +output_unit_number = 7 +output_file = newsulf_xnox.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = newsulf_xnox.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" + "(8) XNOx for surface emissions" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4CHML->CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb, O3S -> O3, O3INERT -> O3, SYNOZ -> O3, O3RAD -> O3 + XNO -> NO, XNO2 -> NO2, XNO3 -> NO3, XHNO3 -> HNO3 + XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5 + XPAN -> CH3CO3NO2, XONIT -> CH3COCH2ONO2, XMPAN -> CH2CCH3CO3NO2 + XISOPNO3 -> CH2CHCCH3OOCH2ONO2, XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4CHML, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR, XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 +* CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 +* CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + OH -> CH3O2 + H2O + CH4CHML ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 + CH4CHML ; 1.5e-10 +* CH4 + O1DA -> CH4 ; 1.5e-10 + CH4 + O1DA -> ; 1.5e-10 + CH4CHML -> ; 7.1 e-6 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 +* [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 +* + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15a] XMPAN + M -> XNO2 + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz.inp b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz.inp new file mode 100644 index 0000000000..c68e640772 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz.inp @@ -0,0 +1,454 @@ +BEGSIM +output_unit_number = 7 +output_file = newsulf_xnox_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = newsulf_xnox_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) NO SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" + "(8) XNOx for surface emissions" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + XNO -> NO, XNO2 -> NO2, XNO3 -> NO3, XHNO3 -> HNO3 + XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5 + XPAN -> CH3CO3NO2, XONIT -> CH3COCH2ONO2, XMPAN -> CH2CCH3CO3NO2 + XISOPNO3 -> CH2CHCCH3OOCH2ONO2, XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2 + SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR, XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15a] XMPAN + M -> XNO2 + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom.inp b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom.inp new file mode 100644 index 0000000000..28f3b0d1a9 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom.inp @@ -0,0 +1,465 @@ +BEGSIM +output_unit_number = 7 +output_file = newsulf_xnox_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = newsulf_xnox_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) NO SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" + "(8) XNOx for surface emissions" + "(6) updated hydrophob->hydrophil conversion rate to 1.15 days + "(7) added SOA classes with MW for pinonaldehyde, methyl-erythritol and TOLO2/BENO2/XYLO2 +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + BENZENE -> C6H6, BENO2 -> C6H7O3, BENNO3 -> C6H7ONO3, BENOOH -> C6H8O3 + XYLENE -> C8H10, XYLO2 -> C8H11O3, XYLNO3 -> C8H11ONO3, XYLOOH -> C8H12O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOAM -> C10H16O4 + SOAI -> CH3C4H9O4, SOAT -> C7H9O3, SOAB -> C6H7O3, SOAX -> C8H11O3 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + XNO -> NO, XNO2 -> NO2, XNO3 -> NO3, XHNO3 -> HNO3 + XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5 + XPAN -> CH3CO3NO2, XONIT -> CH3COCH2ONO2, XMPAN -> CH2CCH3CO3NO2 + XISOPNO3 -> CH2CHCCH3OOCH2ONO2, XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + BENZENE, BENO2, BENNO3, BENOOH, XYLENE, XYLO2, XYLNO3, XYLOOH + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOAM, SOAI, SOAT, SOAB, SOAX + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR, XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.8e-12, 338 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + [soa6] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 2.6e-12, 350 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 2.6e-12, 350 + [soa5] TOLO2 + HO2 -> TOLOOH ; 1.4e-12, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + BENZENE + OH -> BENO2 ; 2.3e-12, -193 + [soa7] BENO2 + NO -> BENNO3 ; 2.6e-12, 350 + [soa8] BENO2 + HO2 -> BENOOH ; 1.4e-12, 700 + XYLENE + OH -> XYLO2 ; 2.3e-11 + [soa9] XYLO2 + NO -> XYLNO3 ; 2.6e-12, 350 + [soa10] XYLO2 + HO2 -> XYLOOH ; 1.4e-12, 700 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + [soa4] ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15a] XMPAN + M -> XNO2 + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 1.0e-5 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 1.0e-5 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, BENOOH, XYLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom_sog.inp b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom_sog.inp new file mode 100644 index 0000000000..491ab93a74 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_newsulf_xnox_nosynoz_soa_arom_sog.inp @@ -0,0 +1,469 @@ +BEGSIM +output_unit_number = 7 +output_file = newsulf_xnox_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = newsulf_xnox_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP/GFS inputs (T42, 42 levels)" + "(5) NO SYNOZ" + "(6) no N atom" + "(7) new treatment of: SO4, NH4, NH4NO3" + "(8) XNOx for surface emissions" + "(6) updated hydrophob->hydrophil conversion rate to 1.15 days + "(7) added SOA classes with MW for pinonaldehyde, methyl-erythritol and TOLO2/BENO2/XYLO2 + "(8) added SOG +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + BENZENE -> C6H6, BENO2 -> C6H7O3, BENNO3 -> C6H7ONO3, BENOOH -> C6H8O3 + XYLENE -> C8H10, XYLO2 -> C8H11O3, XYLNO3 -> C8H11ONO3, XYLOOH -> C8H12O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SOAM -> C10H16O4, SOAI -> CH3C4H9O4, SOAT -> C7H9O3, SOAB -> C6H7O3, SOAX -> C8H11O3 + SOGM -> C10H16O4, SOGI -> CH3C4H9O4, SOGT -> C7H9O3, SOGB -> C6H7O3, SOGX -> C8H11O3 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + XNO -> NO, XNO2 -> NO2, XNO3 -> NO3, XHNO3 -> HNO3 + XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5 + XPAN -> CH3CO3NO2, XONIT -> CH3COCH2ONO2, XMPAN -> CH2CCH3CO3NO2 + XISOPNO3 -> CH2CHCCH3OOCH2ONO2, XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + BENZENE, BENO2, BENNO3, BENOOH, XYLENE, XYLO2, XYLNO3, XYLOOH + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04 + SOAM, SOAI, SOAT, SOAB, SOAX + SOGM, SOGI, SOGT, SOGB, SOGX + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR, XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.8e-12, 338 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + [soa6] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 2.6e-12, 350 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 2.6e-12, 350 + [soa5] TOLO2 + HO2 -> TOLOOH ; 1.4e-12, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + BENZENE + OH -> BENO2 ; 2.3e-12, -193 + [soa7] BENO2 + NO -> BENNO3 ; 2.6e-12, 350 + [soa8] BENO2 + HO2 -> BENOOH ; 1.4e-12, 700 + XYLENE + OH -> XYLO2 ; 2.3e-11 + [soa9] XYLO2 + NO -> XYLNO3 ; 2.6e-12, 350 + [soa10] XYLO2 + HO2 -> XYLOOH ; 1.4e-12, 700 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + [soa4] ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15a] XMPAN + M -> XNO2 + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 1.0e-5 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 1.0e-5 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, BENOOH, XYLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3, SOGM, SOGI, SOGT, SOGB, SOGX + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_nosynoz.inp b/chem_proc/inputs/cam_full_mech_nosynoz.inp new file mode 100644 index 0000000000..283221e6f7 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_nosynoz.inp @@ -0,0 +1,343 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH, SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_nosynoz_xfrc.inp b/chem_proc/inputs/cam_full_mech_nosynoz_xfrc.inp new file mode 100644 index 0000000000..52487a2809 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_nosynoz_xfrc.inp @@ -0,0 +1,361 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_nosynoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_nosynoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2 + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH, SO2, NH3 + End Heterogeneous + + Ext Forcing + NO <- dataset + CO <- dataset + BIGALK <- dataset + BIGENE <- dataset + C2H4 <- dataset + C2H5OH <- dataset + C2H6 <- dataset + C3H6 <- dataset + C3H8 <- dataset + CB1 <- dataset + CH2O <- dataset + CH3CHO <- dataset + CH3COCH3 <- dataset + CH3OH <- dataset + MEK <- dataset + NH3 <- dataset + OC1 <- dataset + SO2 <- dataset + TOLUENE <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz.inp b/chem_proc/inputs/cam_full_mech_synoz.inp new file mode 100644 index 0000000000..b7bd2a58cd --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz.inp @@ -0,0 +1,343 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_synoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_synoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH, SO2, NH3 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4.inp new file mode 100644 index 0000000000..ddc1ee57bc --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4.inp @@ -0,0 +1,345 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom.inp new file mode 100644 index 0000000000..ddea932b04 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom.inp @@ -0,0 +1,357 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" + "(6) updated hydrophob->hydrophil conversion rate to 1.15 days + "(7) added SOA classes with MW for pinonaldehyde, methyl-erythritol and TOLO2/BENO2/XYLO2 +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + BENZENE -> C6H6, BENO2 -> C6H7O3, BENNO3 -> C6H7ONO3, BENOOH -> C6H8O3 + XYLENE -> C8H10, XYLO2 -> C8H11O3, XYLNO3 -> C8H11ONO3, XYLOOH -> C8H12O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOAM -> C10H16O4 + SOAI -> CH3C4H9O4, SOAT -> C7H9O3, SOAB -> C6H7O3, SOAX -> C8H11O3 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + BENZENE, BENO2, BENNO3, BENOOH, XYLENE, XYLO2, XYLNO3, XYLOOH + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOAM, SOAI, SOAT, SOAB, SOAX + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.8e-12, 338 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [soa6] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 2.6e-12, 350 + + .9*NO2 + .9*HO2 + [soa5] TOLO2 + HO2 -> TOLOOH ; 1.4e-12, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + BENZENE + OH -> BENO2 ; 2.3e-12, -193 + [soa7] BENO2 + NO -> BENNO3 ; 2.6e-12, 350 + [soa8] BENO2 + HO2 -> BENOOH ; 1.4e-12, 700 + XYLENE + OH -> XYLO2 ; 2.3e-11 + [soa9] XYLO2 + NO -> XYLNO3 ; 2.6e-12, 350 + [soa10] XYLO2 + HO2 -> XYLOOH ; 1.4e-12, 700 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + [soa4] ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 1.0e-5 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 1.0e-5 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, BENOOH, XYLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom_sog.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom_sog.inp new file mode 100644 index 0000000000..220f39dc16 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_soa_arom_sog.inp @@ -0,0 +1,360 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" + "(6) updated hydrophob->hydrophil conversion rate to 1.15 days + "(7) added SOA classes with MW for pinonaldehyde, methyl-erythritol and TOLO2/BENO2/XYLO2 + "(8) added SOG +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + BENZENE -> C6H6, BENO2 -> C6H7O3, BENNO3 -> C6H7ONO3, BENOOH -> C6H8O3 + XYLENE -> C8H10, XYLO2 -> C8H11O3, XYLNO3 -> C8H11ONO3, XYLOOH -> C8H12O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SOAM -> C10H16O4, SOAI -> CH3C4H9O4, SOAT -> C7H9O3, SOAB -> C6H7O3, SOAX -> C8H11O3 + SOGM -> C10H16O4, SOGI -> CH3C4H9O4, SOGT -> C7H9O3, SOGB -> C6H7O3, SOGX -> C8H11O3 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + BENZENE, BENO2, BENNO3, BENOOH, XYLENE, XYLO2, XYLNO3, XYLOOH + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOAM, SOAI, SOAT, SOAB, SOAX + SOGM, SOGI, SOGT, SOGB, SOGX + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.8e-12, 338 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [soa6] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 2.6e-12, 350 + + .9*NO2 + .9*HO2 + [soa5] TOLO2 + HO2 -> TOLOOH ; 1.4e-12, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + BENZENE + OH -> BENO2 ; 2.3e-12, -193 + [soa7] BENO2 + NO -> BENNO3 ; 2.6e-12, 350 + [soa8] BENO2 + HO2 -> BENOOH ; 1.4e-12, 700 + XYLENE + OH -> XYLO2 ; 2.3e-11 + [soa9] XYLO2 + NO -> XYLNO3 ; 2.6e-12, 350 + [soa10] XYLO2 + HO2 -> XYLOOH ; 1.4e-12, 700 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + [soa4] ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 1.0e-5 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 1.0e-5 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, BENOOH, XYLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4, SOGM, SOGI, SOGT, SOGB, SOGX + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_stacy.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_stacy.inp new file mode 100644 index 0000000000..bc747cabd7 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_stacy.inp @@ -0,0 +1,347 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3->,1.1236*jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged.inp new file mode 100644 index 0000000000..e7ce0b9bc9 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged.inp @@ -0,0 +1,353 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2->,jo2_b] O2 + hv -> 2*O + [jo1d->,jo3_a] O3 + hv -> O1D + O2 + [jo3p->,jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5->,jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3->,1.1236*jno3_a] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 +* [jno3->,1.1236*jno3_b] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2->,jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 +* [jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 +* [jho2no2_b] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 +* [jmacr->,0.5*jmacr_a+0.5*jmacr_b] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmacr->,jmacr_a] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH +* [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged2.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged2.inp new file mode 100644 index 0000000000..9c8eb7a859 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_tagged2.inp @@ -0,0 +1,354 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2->,jo2_b] O2 + hv -> 2*O + [jo1d->,jo3_a] O3 + hv -> O1D + O2 + [jo3p->,jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5->,jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH +* [jno3->,1.1236*jno3_a] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3_a] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3_b] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 +* [jho2no2->,jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2_b] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 +* [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmacr_b] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH +* [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox.inp new file mode 100644 index 0000000000..858ec14abe --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox.inp @@ -0,0 +1,458 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + XNO -> NO,XNO2 -> NO2,XNO3 -> NO3,XHNO3 -> HNO3,XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5, + XPAN -> CH3CO3NO2,XONIT -> CH3COCH2ONO2,XMPAN -> CH2CCH3CO3NO2,XISOPNO3 -> CH2CHCCH3OOCH2ONO2 + XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR + XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo1da] O3A + hv ->O1DA + [jo3p] O3 + hv -> O + O2 + [jo3pa] O3A + hv -> OA + [jn2o] N2O + hv -> O1D + N2 + [jno2a] XNO2 + hv -> XNO + OA + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jhno3a] XHNO3 + hv -> XNO2 + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmpana] XMPAN + hv -> XNO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitra] XONITR + hv -> XNO2 + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O + O3A -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + O1DA + O2 -> OA + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab]XNO2 -> 0.5*XNO + 0.5*XHNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O ; 1.5e-10 + + .4*HO2 + .05*H2 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH ; 3.8e-12, 200 + + .3 * CH2O + H2O + [nacd1] CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [nacd1a] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O ; 1.e-28,.8, 8.8e-12,0., .6 + + .25*HO2 + M + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + C2H4 + O3A -> C2H4 ; 1.2e-14, -2630 + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO ; 2.e-13 + + HO2 + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 ; 6.8e-14 + + .4 * C2H5OH + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO ; 3.8e-12, 200 + + .5 * OH + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + [nacd2] CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [nacd2a] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH ; 4.3e-13, 1040 + + .25*O3 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 ; 2.0e-12,500 + + .9*CO2 + .1*CH3COOH + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O ; 1e-12 + + .5*CO2 + H2O + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15] MPAN + M -> MCO3 + NO2 + M + [usr15a] XMPAN + M -> XNO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + [nacd3] CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + [nacd3a] CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + [nacd4] DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + [nacd4a] DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + End Heterogeneous + + Ext Forcing + NO, CO, XNO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox_fixed_ch4.inp b/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox_fixed_ch4.inp new file mode 100644 index 0000000000..11395785b1 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_h2so4_xnox_fixed_ch4.inp @@ -0,0 +1,465 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4CHML->CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + XNO -> NO,XNO2 -> NO2,XNO3 -> NO3,XHNO3 -> HNO3,XHO2NO2 -> HO2NO2, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5, + XPAN -> CH3CO3NO2,XONIT -> CH3COCH2ONO2,XMPAN -> CH2CCH3CO3NO2,XISOPNO3 -> CH2CHCCH3OOCH2ONO2 + XONITR -> CH2CCH3CHONO2CH2OH + XNH4NO3 -> NH4NO3, OA -> O, O1DA -> O, O3A -> O3 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4CHML, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + XNO, XNO2, XNO3, XHNO3, XHO2NO2, XNO2NO3, NO2XNO3 + XPAN, XONIT, XMPAN, XISOPNO3, XONITR + XNH4NO3, O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo1da] O3A + hv ->O1DA + [jo3p] O3 + hv -> O + O2 + [jo3pa] O3A + hv -> OA + [jn2o] N2O + hv -> O1D + N2 + [jno2a] XNO2 + hv -> XNO + OA + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jhno3a] XHNO3 + hv -> XNO2 + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmpana] XMPAN + hv -> XNO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jonitra] XONITR + hv -> XNO2 + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O + O3A -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + O1DA + N2 -> OA + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + O1DA + O2 -> OA + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + H2O -> H2O ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + OA + OH -> OH ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + HO2 + OA -> HO2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab]XNO2 -> 0.5*XNO + 0.5*XHNO3 +* CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + OH -> CH3O2 + H2O + CH4CHML ; 2.45e-12, -1775 +* CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O ; 1.5e-10 +* + .4*HO2 + .05*H2 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O ; 1.5e-10 + + .4*HO2 + .05*H2 + CH4CHML +* CH4 + O1DA -> CH4 ; 1.5e-10 + CH4 + O1DA -> ; 1.5e-10 + CH4CHML -> ; 7.1 e-6 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH ; 3.8e-12, 200 + + .3 * CH2O + H2O + [nacd1] CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [nacd1a] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O ; 1.e-28,.8, 8.8e-12,0., .6 + + .25*HO2 + M + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + C2H4 + O3A -> C2H4 ; 1.2e-14, -2630 + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO ; 2.e-13 + + HO2 + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 ; 6.8e-14 + + .4 * C2H5OH + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO ; 3.8e-12, 200 + + .5 * OH + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 +* [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 +* + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + [nacd2] CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [nacd2a] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH ; 4.3e-13, 1040 + + .25*O3 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 ; 2.0e-12,500 + + .9*CO2 + .1*CH3COOH + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O ; 1e-12 + + .5*CO2 + H2O + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15] MPAN + M -> MCO3 + NO2 + M + [usr15a] XMPAN + M -> XNO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + [nacd3] CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + [nacd3a] CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + [nacd4] DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + [nacd4a] DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + End Heterogeneous + + Ext Forcing + NO, CO, XNO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_synoz_xfrc.inp b/chem_proc/inputs/cam_full_mech_synoz_xfrc.inp new file mode 100644 index 0000000000..fe0793c8e6 --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_synoz_xfrc.inp @@ -0,0 +1,362 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_synoz.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_synoz.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH, SO2, NH3 + End Heterogeneous + + Ext Forcing + NO <- dataset + CO <- dataset + BIGALK <- dataset + BIGENE <- dataset + C2H4 <- dataset + C2H5OH <- dataset + C2H6 <- dataset + C3H6 <- dataset + C3H8 <- dataset + CB1 <- dataset + CH2O <- dataset + CH3CHO <- dataset + CH3COCH3 <- dataset + CH3OH <- dataset + MEK <- dataset + NH3 <- dataset + OC1 <- dataset + SO2 <- dataset + TOLUENE <- dataset + SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_full_mech_xnox.inp b/chem_proc/inputs/cam_full_mech_xnox.inp new file mode 100644 index 0000000000..7fa083650c --- /dev/null +++ b/chem_proc/inputs/cam_full_mech_xnox.inp @@ -0,0 +1,460 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_xnox.doc +sim_dat_filename = cam_xnox.dat +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) NOx tags fire" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, N, NO, XNO -> NO, NO2, XNO2 -> NO2, NO3 + XNO3 -> NO3, HNO3, XHNO3 -> HNO3 + HO2NO2, XHO2NO2 -> HO2NO2, N2O5, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5, CH4, CH3O2 + CH3OOH, CH2O, CO, OH, HO2, H2O2, C3H6, ISOP -> C5H8, PO2 -> C3H6OHO2, CH3CHO + POOH -> C3H6OHOOH, CH3CO3, CH3COOOH, PAN -> CH3CO3NO2, XPAN -> CH3CO3NO2 + ONIT -> CH3COCH2ONO2, XONIT -> CH3COCH2ONO2, C2H6, C2H4 + MPAN -> CH2CCH3CO3NO2, XMPAN -> CH2CCH3CO3NO2 + ISOPO2 -> HOCH2COOCH3CHCH2, MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH -> CH3COCH2OOH + CH3OH, C2H5OH, GLYALD -> HOCH2CHO, HYAC -> CH3COCH2OH, EO2 -> HOCH2CH2O2 + EO -> HOCH2CH2O, HYDRALD -> HOCH2CCH3CHCHO + RO2 -> CH3COCH2O2, CH3COCHO, Rn, Pb + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, XISOPNO3 -> CH2CHCCH3OOCH2ONO2 + ONITR -> CH2CCH3CHONO2CH2OH, XONITR -> CH2CCH3CHONO2CH2OH + XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH, ISOPOOH -> HOCH2COOHCH3CHCH2 + BIGALK -> C5H12, BIGENE -> C4H8 + ENEO2 -> C4H9O3, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2, MEK -> C4H8O + MEKO2 -> C4H7O3, MEKOOH -> C4H8O3, TOLUENE -> C7H8, CRESOL -> C7H8O + TOLO2 -> C7H9O3, TOLOOH -> C7H10O3, XOH -> C7H10O4, TERPO2 -> C10H17O3 + TERPOOH -> C10H18O3, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2, CH3COOH + H2, O3S -> O3, O3INERT -> O3, OA -> O, O1DA -> O, O3A -> O3 + CB1 -> C, CB2 -> C, SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3, NH4 + OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + SOA -> C12, H2SO4 + O3RAD -> O3, SYNOZ -> O3 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, H2SO4, O3S, O3INERT, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, N, NO, XNO, NO2, XNO2, NO3, + XNO3, HNO3, XHNO3, HO2NO2, XHO2NO2 + N2O5, XNO2NO3, NO2XNO3, CH3O2 + CH3OOH, CH2O, OH, HO2, H2O2, C3H6, ISOP, PO2, CH3CHO + POOH, CH3CO3, CH3COOOH, XPAN, PAN, ONIT, XONIT, C2H6 + C2H4, BIGALK, MPAN, XMPAN + ISOPO2, MVK, MACR, MACRO2, MACROOH + MCO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH + CH3OH, C2H5OH, GLYALD, HYAC, EO2 + EO, HYDRALD, RO2, CH3COCHO, ISOPNO3, XISOPNO3, ONITR, XONITR + XO2, XOOH, ISOPOOH + BIGENE, ENEO2, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH, TOLUENE + CRESOL, TOLO2, TOLOOH, XOH, TERPO2, TERPOOH, BIGALD, GLYOXAL, CH3COOH + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4 + OC1, OC2 + SOA + O3A, O1DA, OA + DST01, DST02, DST03, DST04 + SSLT01, SSLT02, SSLT03, SSLT04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno] NO + hv -> N + O + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 +* [jho2no2] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 +* [jh2o] H2O + hv -> OH + HO2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO +* [jmacr_a] MACR -> 1.34 * HO2 + .66 * MCO3 + 1.34 * CH2O + 1.34 * CH3CO3 +* [jmacr_b] MACR -> .66 * OH + 1.34 * CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A+ O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 1.8e-11, 110 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 +[ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M +* N2O5 + H2O -> 2*HNO3 ; 0. + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75 * CH3O2 + .75 * OH + .25 * CH2O + .4 * HO2 + .05 * H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + OH + C2H6 -> C2H5O2 + H2O ; 8.7e-12, -1070 + OH + BIGENE -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + OH + ALKOOH -> ALKO2 ; 3.8e-12, 200 + OH + MEK -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + OH + MEKOOH -> MEKO2 ; 3.8e-12, 200 +* [soa4] OH+ TOLUENE -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 5.5e-12 + [soa4] OH + TOLUENE -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + OH + CRESOL -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + OH + TOLOOH -> TOLO2 ; 3.8e-12, 200 + OH + GLYOXAL -> HO2 + CO + CO2 ; 1.1e-11 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + OH + TERPOOH -> TERPO2 ; 3.8e-12, 200 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr13] OH + C2H4 + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + [ox_l6] O3 + C2H4 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47 * HO2 + .25 * CH2O + .25 * CH3COCHO ; 2.4e-12 + + .22 * CO + .53 * GLYALD + .22 * HYAC + .53 * CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73 * HO2 + .88 * CH2O + .11 * CO + .24 * CH3COCHO ; 5.e-13,400 + + .26 * GLYALD + .26 * CH3CO3 + .25 * CH3OH + .23 * HYAC + MACRO2 + CH3CO3 -> .25 * CH3COCHO + CH3O2 + .22 * CO + .47 * HO2 ; 1.4e-11 + + .53 * GLYALD + .22 * HYAC + .25 * CH2O + .53 * CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15] MPAN + M -> MCO3 + NO2 + M + [usr15a] XMPAN + M -> XNO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + N + O2 -> NO + O ; 1.5e-11, -3600 + N + NO -> N2 + O ; 2.1e-11, 100 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + OH + CH3OH -> HO2 + CH2O ; 7.3e-12,-620 + OH + C2H5OH -> HO2 + CH3CHO ; 6.9e-12,-230 + OH + MPAN -> .5 * HYAC + .5 * NO3 + .5 * CH2O + .5 * HO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + OH + PAN -> CH2O + NO3 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + OH + HYAC -> CH3COCHO + HO2 ; 3.e-12 + OH + GLYALD -> HO2 + .2*GLYOXAL + .8*CH2O ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + [usr25] NH3 -> NH4 + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, NH3, NH4, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, XNO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + machine = scalar + model = cam + architecture = hybrid +* vec_ftns = on + namemod = on + End Version Options + + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_noaa_xnox.inp b/chem_proc/inputs/cam_noaa_xnox.inp new file mode 100644 index 0000000000..54fa075df2 --- /dev/null +++ b/chem_proc/inputs/cam_noaa_xnox.inp @@ -0,0 +1,511 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_xnox.doc +sim_dat_filename = cam_xnox.dat +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) NOx tags fire" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, N2O, N, NO, XNO -> NO, NO2, XNO2 -> NO2, NO3 + XNO3 -> NO3, HNO3, XHNO3 -> HNO3 + HO2NO2, XHO2NO2 -> HO2NO2, N2O5, XNO2NO3 -> N2O5, NO2XNO3 -> N2O5, CH4, CH3O2 + CH3OOH, CH2O, CO, OH, HO2, H2O2, C3H6, ISOP -> C5H8, PO2 -> C3H6OHO2, CH3CHO + POOH -> C3H6OHOOH, CH3CO3, CH3COOOH, PAN -> CH3CO3NO2, XPAN -> CH3CO3NO2 + ONIT -> CH3COCH2ONO2, XONIT -> CH3COCH2ONO2, C2H6, C2H4 + MPAN -> CH2CCH3CO3NO2, XMPAN -> CH2CCH3CO3NO2 + ISOPO2 -> HOCH2COOCH3CHCH2, MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH -> CH3COCH2OOH + CH3OH, C2H5OH, GLYALD -> HOCH2CHO, HYAC -> CH3COCH2OH, EO2 -> HOCH2CH2O2 + EO -> HOCH2CH2O, HYDRALD -> HOCH2CCH3CHCHO + RO2 -> CH3COCH2O2, CH3COCHO, Rn, Pb + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, XISOPNO3 -> CH2CHCCH3OOCH2ONO2 + ONITR -> CH2CCH3CHONO2CH2OH, XONITR -> CH2CCH3CHONO2CH2OH + XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH, ISOPOOH -> HOCH2COOHCH3CHCH2 + BIGALK -> C5H12, BIGENE -> C4H8 + ENEO2 -> C4H9O3, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2, MEK -> C4H8O + MEKO2 -> C4H7O3, MEKOOH -> C4H8O3, TOLUENE -> C7H8, CRESOL -> C7H8O + TOLO2 -> C7H9O3, TOLOOH -> C7H10O3, XOH -> C7H10O4, TERPO2 -> C10H17O3 + TERPOOH -> C10H18O3, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2, CH3COOH + H2, O3S -> O3, O3INERT -> O3, OA -> O, O1DA -> O, O3A -> O3 + CB1 -> C, CB2 -> C, SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3, NH4 + OC1 -> C, OC2 -> C, SA1 -> NaCl, SA2 -> NaCl, SA3 -> NaCl, SA4 -> NaCl + SOA -> C12, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, H2SO4, O3S, O3INERT + End Explicit + Implicit + O3, O1D, O, N, NO, XNO, NO2, XNO2, NO3, + XNO3, HNO3, XHNO3, HO2NO2, XHO2NO2 + N2O5, XNO2NO3, NO2XNO3, CH3O2 + CH3OOH, CH2O, OH, HO2, H2O2, C3H6, ISOP, PO2, CH3CHO + POOH, CH3CO3, CH3COOOH, XPAN, PAN, ONIT, XONIT, C2H6 + C2H4, BIGALK, MPAN, XMPAN + ISOPO2, MVK, MACR, MACRO2, MACROOH + MCO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH + CH3OH, C2H5OH, GLYALD, HYAC, EO2 + EO, HYDRALD, RO2, CH3COCHO, ISOPNO3, XISOPNO3, ONITR, XONITR + XO2, XOOH, ISOPOOH + BIGENE, ENEO2, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH, TOLUENE + CRESOL, TOLO2, TOLOOH, XOH, TERPO2, TERPOOH, BIGALD, GLYOXAL, CH3COOH + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4 + OC1, OC2, SA1, SA2, SA3, SA4 + SOA + O3A, O1DA, OA + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno] NO + hv -> N + O + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 +* [jho2no2] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 +* [jh2o] H2O + hv -> OH + HO2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO +* [jmacr_a] MACR -> 1.34 * HO2 + .66 * MCO3 + 1.34 * CH2O + 1.34 * CH3CO3 +* [jmacr_b] MACR -> .66 * OH + 1.34 * CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + [jo1da] O3A + hv ->O1DA + [jo3pa] O3A + hv -> OA + [jno2a] XNO2 + hv -> XNO + OA + [jn2o5a] XNO2NO3 + hv -> XNO2 + [jn2o5b] NO2XNO3 + hv -> XNO3 + [jhno3a] XHNO3 + hv -> XNO2 + [jno3a] XNO3 + hv -> .89*XNO2 + .11*XNO +.89*O3A + [jpana] XPAN + hv -> .6*XNO2 + .4*XNO3 + [jmpana] XMPAN + hv -> XNO2 + [jho2no2a] XHO2NO2 + hv -> .33*XNO3 + .66*XNO2 + [jonitra] XONITR + hv -> XNO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + [usr1a] OA + O2 + M -> O3A + M + O + O3 -> 2*O2 ; 8e-12, -2060 + OA + O3 -> O3 ; 8e-12, -2060 + O3A + O -> O ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1DA + N2 -> OA + N2 ; 1.8e-11, 110 + O1DA + O2 -> OA + O2 ; 3.2e-11 , 70 + O1DA + H2O -> H2O ; 2.2e-10 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + N2O + O1DA -> N2O ; 6.7e-11 + N2O + O1DA -> N2O ; 4.9e-11 +[ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + XNO + HO2 -> XNO2 + HO2 ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + XNO + O3 -> XNO2 + O3 ; 3e-12, -1500 + NO + O3A -> NO ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + OA -> NO2 ; 5.6e-12, 180 + XNO2 + O -> XNO + O ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + XNO2 + O3 -> XNO3 + O3 ; 1.2e-13, -2450 + NO2 + O3A -> NO2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + XNO3 + HO2 -> HO2 + XNO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2a] XNO2 + NO3 + M -> XNO2NO3 + NO3 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr2b] NO2 + XNO3 + M -> NO2XNO3 + NO2 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr3a] XNO2NO3 + M -> XNO2 + M + [usr3b] NO2XNO3 + M -> XNO3 + M +* N2O5 + H2O -> 2*HNO3 ; 0. + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4a] XNO2 + OH + M -> XHNO3 + OH + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + [usr5a] XHNO3 + OH -> XNO3 + OH + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + XNO3 + NO -> XNO2 + NO ; 1.5e-11, 170 + NO3 + XNO -> XNO2 + NO3 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + [usr6a] XNO2 + HO2 + M -> XHO2NO2 + HO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + XHO2NO2 + OH -> XNO2 + OH ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr7a] XHO2NO2 + M -> XNO2 + M + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75 * CH3O2 + .75 * OH + .25 * CH2O + .4 * HO2 + .05 * H2 ; 1.5e-10 + CH4 + O1DA -> CH4 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + XNO -> CH3O2 + XNO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + [new3] CH2O + XNO3 -> CH2O + XHNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + O1DA -> H2 ; 1.1e-10 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + O3A -> OH ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + HO2 + O3A -> HO2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + O3A -> C3H6 ; 6.5e-15, -1900 + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [new2] C3H6 + XNO3 -> XONIT +C3H6 ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + XNO -> PO2 + XNO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [new4] CH3CHO + XNO3 -> CH3CHO + XHNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + CH3CO3 + XNO -> CH3CO3 + XNO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + [usr11a] CH3CO3 + XNO2 + M -> XPAN + CH3CO3 + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + [usr12a] XPAN + M -> XNO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + O3A -> ISOP + .1 * O3A ; 1.05e-14, -2000 + OH + C2H6 -> C2H5O2 + H2O ; 8.7e-12, -1070 + OH + BIGENE -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + ENEO2 + XNO -> ENEO2 + XNO2 ; 4.2e-12, 180 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + XNO -> ALKO2 + .9*XNO2 + .1*XONIT ; 4.2e-12, 180 + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + OH + ALKOOH -> ALKO2 ; 3.8e-12, 200 + OH + MEK -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + XNO -> MEKO2 + XNO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + OH + MEKOOH -> MEKO2 ; 3.8e-12, 200 +* [soa4] OH+ TOLUENE -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 5.5e-12 + [soa4] OH + TOLUENE -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + OH + CRESOL -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + [new1] XOH + XNO2 -> XOH + .7*XNO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + XNO -> TOLO2 + .9*XNO2 ; 4.2e-12, 180 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + OH + TOLOOH -> TOLO2 ; 3.8e-12, 200 + OH + GLYOXAL -> HO2 + CO + CO2 ; 1.1e-11 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + XNO -> TERPO2 + XNO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + OH + TERPOOH -> TERPO2 ; 3.8e-12, 200 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + XNO -> C2H5O2 + XNO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr13] OH + C2H4 + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO2 + XNO -> EO2 + XNO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + [ox_l6] O3 + C2H4 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + O3A + C2H4 -> C2H4 ; 1.2e-14, -2630 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + XNO -> ISOPO2 + .92 * XNO2 +.08 * XONITR ; 2.2e-12, 180 + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + XNO3 -> ISOPO2 + XNO2 ; 2.4e-12 + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MVK + O3A -> MVK + .2 * O3A ; 7.52e-16,-1521 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + MACR + O3A -> MACR + .2 * O3A ; 4.4e-15, -2500 + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + XNO -> XNO2 + MACRO2 ; 2.7e-12, 360 + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + XNO -> 0.8*XONITR + MACRO2 ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47 * HO2 + .25 * CH2O + .25 * CH3COCHO ; 2.4e-12 + + .22 * CO + .53 * GLYALD + .22 * HYAC + .53 * CH3CO3 + MACRO2 + XNO3 -> XNO2 + MACRO2 ; 2.4e-12 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73 * HO2 + .88 * CH2O + .11 * CO + .24 * CH3COCHO ; 5.e-13,400 + + .26 * GLYALD + .26 * CH3CO3 + .25 * CH3OH + .23 * HYAC + MACRO2 + CH3CO3 -> .25 * CH3COCHO + CH3O2 + .22 * CO + .47 * HO2 ; 1.4e-11 + + .53 * GLYALD + .22 * HYAC + .25 * CH2O + .53 * CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 ; 5.3e-12, 360 + MCO3 + XNO -> XNO2 + MCO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 ; 5.e-12 + MCO3 + XNO3 -> XNO2 + MCO3 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr14a] MCO3 + XNO2 + M -> XMPAN + M + MCO3 + [usr15] MPAN + M -> MCO3 + NO2 + M + [usr15a] XMPAN + M -> XNO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + C10H16 + O3A -> C10H16 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + C10H16 + XNO3 -> C10H16 + XNO2 ; 1.2e-12, 490 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + [usr16] N2O5 -> 2 * HNO3 + [usr16a] XNO2NO3 -> XHNO3 + [usr16b] NO2XNO3 -> XHNO3 + [usr17] NO3 -> HNO3 + [usr17b] XNO3 -> XHNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + [usr17ab] XNO2 -> 0.5*XNO + 0.5*XHNO3 + N + O2 -> NO + O ; 1.5e-11, -3600 + N + NO -> N2 + O ; 2.1e-11, 100 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + XNO -> C3H7O2 + XNO2 ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + XNO -> RO2 + XNO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + XONIT + OH -> XNO2 + OH ; 6.8e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + [new5] ISOP + XNO3 -> XISOPNO3 + ISOP ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + XISOPNO3 + NO -> .794 * XONITR + .206 * XNO2 + NO ; 2.7e-12, 360 + ISOPNO3 + XNO -> 1.00 * XNO2 + ISOPNO3 ; 2.7e-12, 360 + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + XISOPNO3 + NO3 -> .794 * XONITR + .206 * XNO2 + NO3 ; 2.4e-12 + ISOPNO3 + XNO3 -> 1.00 * XNO2 + ISOPNO3 ; 2.4e-12 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + XISOPNO3 + HO2 -> .206 * XNO2 + .794 * XONITR + HO2 ; 8.e-13, 700 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + CH3COCHO + XNO3 -> XHNO3 + CH3COCHO ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + XONITR + OH -> OH + .4 *XNO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + XONITR + NO3 -> .5 * XNO2 + NO3 ; 1.4e-12, -1860 + ONITR + XNO3 -> .5 * XNO2 + ONITR ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + XNO -> XNO2 + XO2 ; 2.7e-12, 360 + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + XNO3 -> XNO2 + XO2 ; 2.4e-12 + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + OH + CH3OH -> HO2 + CH2O ; 7.3e-12,-620 + OH + C2H5OH -> HO2 + CH3CHO ; 6.9e-12,-230 + OH + MPAN -> .5 * HYAC + .5 * NO3 + .5 * CH2O + .5 * HO2 ; 8.e-27,3.5,3.e-11,0.,.5 + OH + XMPAN -> .5 * XNO3 + OH ; 8.e-27,3.5,3.e-11,0.,.5 + OH + PAN -> CH2O + NO3 ; 4.e-14 + OH + XPAN -> XNO3 + OH ; 4.e-14 + OH + HYAC -> CH3COCHO + HO2 ; 3.e-12 + OH + GLYALD -> HO2 + .2*GLYOXAL + .8*CH2O ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + DMS + XNO3 -> DMS + XHNO3 ; 1.9e-13, 520. + [usr25] NH3 -> NH4 + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + [usr27] CH2O -> + [usr28] O3 -> + [usr28a] O3A -> + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + XHNO3, XHO2NO2, XONIT, XONITR, XISOPNO3 + SO2, SO4, CB2, NH3, NH4NO3, NH4, OC2, SA1, SA2, SA3, SA4, SOA, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Spatial Dimensions + Longitude points = 128 + Latitude points = 64 + Vertical points = 28 + End Spatial Dimensions + + Numerical Control + Implicit Iterations = 11 + End Numerical Control + + Version Options + machine = scalar + model = cam + architecture = hybrid +* vec_ftns = on + namemod = on + End Version Options + +* Bndy Conds +* Fixed Lower BC +* CH4, N2O, H2 +* End Fixed Lower BC +* End Bndy Conds +* + + Surface Flux + NO, N2O, CH4, CH2O, CO, C2H6, C2H4, C3H8, C3H6, BIGALK, BIGENE + ISOP, C10H16, TOLUENE, CH3OH, C2H5OH, CH3COCH3, CH3CHO, MEK, H2 + CB1, CB2, OC1, OC2, SO2, DMS, NH3 + End Surface Flux + + Surface Deposition + O3, NO2, HNO3, CH3OOH, CH2O, CO, H2O2, POOH + CH3COOOH, PAN, MPAN, C2H5OOH, ONIT + C3H7OOH, ROOH, CH3COCHO, CH3COCH3, Pb, O3S, O3INERT + ONITR, MACROOH, XOOH, ISOPOOH + CH3CHO, NO, HO2NO2 + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + CB1, CB2, SO2, SO4, NH3, NH4NO3, NH4, OC1, OC2, SA1, SA2, SA3, SA4, SOA + H2SO4, XNO, XNO2, XHNO3, XONIT, XONITR, XPAN, XMPAN, XHO2NO2, O3A + End Surface Deposition + + Outputs + File + Transported Species = avrg + End Transported Species + Surface Flux = avrg + End Surface Flux + Deposition velocity = avrg + End Deposition velocity + Photorates = inst + End Photorates + Production = avrg + End Production + Loss = avrg + End Loss + Massdiags = avrg + End Massdiags + End File + End Outputs + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/cam_reduced_mech.inp b/chem_proc/inputs/cam_reduced_mech.inp new file mode 100644 index 0000000000..d08863fa2b --- /dev/null +++ b/chem_proc/inputs/cam_reduced_mech.inp @@ -0,0 +1,200 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_reduced_mech.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_reduced_mech.dat + +Comments + "Houweling et al. NMHC chemistry added to CO-CH4 chemistry" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O + N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, OH, HO2, H2O2 + CH3CHO, C2O3, PAN -> CH3CO3NO2, PAR -> C, ROR -> CH3O + OLE -> C2, C2H4, CH3COCHO, ISOP -> C5H8, ROOH -> CH3COCH2OOH + ONIT -> CH3COCH2ONO2, XO2 -> H, XO2N -> H, RXPAR -> H + CB1 -> C, CB2 -> C, SO2, SO4, DMS -> CH3SCH3, NH3, NH4, H2SO4, NH4NO3 + OC1 -> C, OC2 -> C, SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, H2 + End Explicit + Implicit + O3, O, O1D + NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, HO2, H2O2 + CH3CHO, C2O3, PAN, PAR, ROR + OLE, C2H4, CH3COCHO, ISOP, ROOH + ONIT, XO2, XO2N, RXPAR + SO2, SO4, DMS, NH3, NH4, H2SO4, NH4NO3 + CB1, CB2, OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH2O + XO2 + CO + 2*HO2 + [jpan] PAN + hv -> C2O3 + NO2 + [jmgly] CH3COCHO + hv -> C2O3 + HO2 + CO + [jrooh] ROOH + hv -> OH + [jonitr] ONIT + hv -> NO2 + HO2 + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75 * CH3O2 + .75 * OH + .25 * CH2O + .4 * HO2 + .05 * H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 +* +* NMHC reactions +* +* changed reaction to increase PAN production +* +* CH3CHO + OH -> HO2 ; 7.0e-12, 250 + CH3CHO + OH -> 0.5 * HO2 + 0.5 * C2O3 ; 7.0e-12, 250 + CH3CHO + NO3 -> C2O3 + HNO3 ; 2.5e-15 + [ox_p3] C2O3 + NO -> CH2O + XO2 + HO2 + NO2 ; 3.5e-11, -180 + [nmhc01] C2O3 + NO2 -> PAN + PAN -> C2O3 + NO2 ; 2e16, -13500 + C2O3 + C2O3 -> 2*CH2O + 2*XO2 + 2*HO2 ; 2.e-12 + C2O3 + HO2 -> CH2O + XO2 + HO2 + 0.79*OH + 0.21*ROOH ; 6.5e-12 + PAR + OH -> 0.87*XO2 + 0.76*ROR + 0.13*XO2N + 0.11*HO2 ; 8.1e-13 + + 0.11*CH3CHO + 0.11*RXPAR + ROR -> 1.1*CH3CHO + 0.96 * XO2 + 0.94*HO2 + 2.1*RXPAR ; 1.1e15, -8000 + ROR -> HO2 ; 1.6e3 + OLE + OH -> CH2O + CH3CHO + XO2 + HO2 + RXPAR ; 5.2e-12, 504 + [ox_l7] OLE + O3 -> 0.44*CH3CHO + 0.64*CH2O + 0.37*CO + 0.25*HO2 + 0.29*XO2 ; 4.33e-15, -1800 + + 0.4*OH + 0.9*RXPAR + OLE + NO3 -> 0.91*XO2 + CH2O + CH3CHO + 0.09*XO2N + NO2 + RXPAR ; 7.7e-15 + [nmhc02] C2H4 + OH -> XO2 + HO2 + 1.56*CH2O + 0.22*CH3CHO + [ox_l6] C2H4 + O3 -> CH2O + 0.43*CO + 0.26*HO2 + 0.12*OH ; 9.1e-15, -2580 + CH3COCHO + OH -> XO2 + C2O3 ; 1.7e-11 + ISOP + OH -> 0.85*XO2 + 0.61*CH2O + 0.85*HO2 + 0.03*CH3COCHO + 0.58*OLE ; 2.54e-11, 410 + + 0.15*XO2N + 0.63*PAR + [ox_l5] ISOP + O3 -> 0.9*CH2O + 0.55*OLE + 0.18*XO2 + 0.36*CO + 0.15*C2O3 ; 12.3e-15, -2013 + + 0.03*CH3COCHO + 0.63*PAR + 0.3*HO2 + 0.28*OH + ISOP + NO3 -> 0.9*HO2 + 0.9*ONIT + 0.03*CH2O + 0.45*OLE + 0.12*CH3CHO ; 7.8e-13 + + 0.1*NO2 + 0.08*CH3COCHO + ROOH + OH -> 0.7*XO2 + 0.3*OH ; 3.2e-12 + ONIT + OH -> NO2 + XO2 ; 1.78e-12 + [r63] XO2 + NO -> NO2 ; 4.2e-12, 180 + XO2 + XO2 -> ; 1.7e-14, 1300 + [r65] XO2N + NO -> ONIT ; 6.8e-13 + [r66] XO2 + HO2 -> ROOH ; 3.5e-13, 1000 + [nmhc03] XO2N + HO2 -> ROOH + RXPAR + PAR -> ; 8e-11 +* +* aerosols +* + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, ONIT + ROOH, CH3COCHO, CH3CHO + SO2, NH3, NH4, H2SO4 + End Heterogeneous +* aer_wetdep_list = 'CB2', 'OC2', 'SOA', 'SO4', 'NH4NO3' + + Ext Forcing + NO<-dataset, CO<-dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/ghg_fixed_aerosols.inp b/chem_proc/inputs/ghg_fixed_aerosols.inp new file mode 100644 index 0000000000..f159bb45e5 --- /dev/null +++ b/chem_proc/inputs/ghg_fixed_aerosols.inp @@ -0,0 +1,80 @@ +BEGSIM +output_unit_number = 7 +output_file = ghg_fxd_aero.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = ghg_fxd_aero.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom; no NH4, no H2SO4" +End Comments + + SPECIES + + Solution + CH4, N2O, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + End Solution + + Fixed + M, N2, O2, H2O, SO4, CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + O3 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + CH4, N2O, CFC11, CFC12 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + [ch4_loss] CH4 -> + [n2o_loss] N2O -> + [cfc11_loss] CFC11 -> + [cfc12_loss] CFC12 -> + End Reactions + + Heterogeneous + End Heterogeneous + + Ext Forcing + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/halogen.inp b/chem_proc/inputs/halogen.inp new file mode 100644 index 0000000000..20cecaa53e --- /dev/null +++ b/chem_proc/inputs/halogen.inp @@ -0,0 +1,811 @@ +BEGSIM +output_unit_number = 7 +output_file = halogen.doc +procout_path = ../output/ +src_path = /home/fvitt/chem_proc_stacy/bkend/ +procfiles_path = /home/fvitt/chem_proc_stacy/procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = halogen.dat + +Comments + "This is a mozart3 simulation with :" + "(1) Detailed tropospheric, stratospheric and mesopheric chemistry" + "(2) New "merged" code version" + "(3) JPL-02 Kinetic and Photochemical Data" + "(4) New hydrocarbon chemistry (Tyndall and Orlando)" + "(5) Extended bromine (organic and inorganic) chemistry, photolysis, and wet and dry depos. from JPL06 + "(6) New iodine (organic and inorganic) chemistry photolysis, and wet and dry depos. from JPL06 and others + "(7) Heterogeneous halogen recycle on sea-salt aerosol + "(8) Simplified sulphur chemistry scheme +End Comments + + + SPECIES + + Solution + O3, O, O1D -> O + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + H, OH, HO2, H2O2, H2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, CLNO2 -> ClNO2 + BR2 -> Br2, BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2, BRNO2 -> BrNO2, BRCL -> BrCl + CH2BR2 -> CH2Br2, CH2BRCL -> CH2BrCl, CHBR2CL -> CHBr2Cl, CHBRCL2 -> CHBrCl2, CHBR3 -> CHBr3 + I -> I, I2 -> I2, IO -> IO, OIO -> OIO, INO -> INO, INO2 -> INO2, IONO2 -> IONO2, HI -> HI + HOI -> HOI, I2O2 -> I2O2, I2O3 -> I2O3, I2O4 -> I2O4, I2O5 -> I2O5, IBR -> IBr, ICL -> ICl + CH3I -> CH3I, CH2I2 -> CH2I2, CH2IBR -> CH2IBr, CH2ICL -> CH2ICl, CF3I -> CF3I + C2H5I -> C2H5I, CH3CHI2 -> CH2CHI2, C3H7I -> C3H7I, C4H9I -> C4H9I, CF2I2 -> CF2I2 + C2F5I -> C2F5I, C3F7I -> C3F7I, C2F4BRI -> CF2BrCF2I + CH4, CH3O2, CH3OOH, CH3OH, CH2O, CO + C2H4, C2H6, C2H5O2, C2H5OOH, CH3CO3, CH3COOH, CH3CHO, C2H5OH, GLYALD -> HOCH2CHO + GLYOXAL -> C2H2O2, CH3COOOH, EO2 -> HOCH2CH2O2, EO -> HOCH2CH2O, PAN -> CH3CO3NO2 + C3H6, C3H8, C3H7O2, C3H7OOH, CH3COCH3, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH, HYAC -> CH3COCH2OH + RO2 -> CH3COCH2O2, CH3COCHO, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, BIGALK -> C5H12, MEK -> C4H8O, ENEO2 -> C4H9O3, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + MCO3 -> CH2CCH3CO3, MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH, MPAN -> CH2CCH3CO3NO2, ONIT -> CH3COCHO2CH2OHNO + ISOP -> C5H8, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2, BIGALD -> C5H6O2, HYDRALD -> HOCH2CCH3CHCHO + ISOPO2 -> HOCH2COOCH3CHCH2, ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH, ISOPOOH -> HOCH2COOHCH3CHCH2 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3, XOH -> C7H10O4 + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, H2O + DMS -> CH3SCH3, DMSO -> CH3SOCH3 + SOA -> C12, CB1 -> C, CB2 -> C, SO2, SO4, NH3, NH4, NH4NO3 + OC1 -> C, OC2 -> C + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + End Solution + + + Fixed + M, N2, N2D, O2 + End Fixed + + + Col-int + O3 = 0. + O2 = 0. + End Col-int + End SPECIES + + + Solution Classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CF3I, CF2I2 + C2F5I, C3F7I, C2F4BRI + End Explicit + Implicit + O3, O, O1D, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + H, OH, HO2, H2O2, H2O, CH3O2, CH3OOH, CH2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, CLNO2, BRCL + BR2, BR, BRO, HBR, HOBR, BRONO2, BRNO2, CH2BR2, CH2BRCL, CHBR2CL, CHBRCL2, CHBR3 + I, I2, IO, OIO, INO, INO2, IONO2, HI, HOI, I2O2, I2O3, I2O4, I2O5 + IBR, ICL, CH3I, CH2I2, CH2IBR, CH2ICL, C2H5I, CH3CHI2, C3H7I, C4H9I + C3H6, ISOP, PO2, CH3CHO, CH3COOH + POOH, CH3CO3, CH3COOOH, PAN, ONIT, C2H6, C2H4, BIGALK, MPAN + BIGENE, ENEO2, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH, TOLUENE + CRESOL, TOLO2, TOLOOH, XOH, TERPO2, TERPOOH, BIGALD, GLYOXAL + ISOPO2, MVK, MACR, MACRO2, MACROOH + MCO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH + CH3OH, C2H5OH, GLYALD, HYAC, EO2 + EO, HYDRALD, RO2, CH3COCHO, ISOPNO3, ONITR + XO2, XOOH, ISOPOOH + DMS, DMSO, SO2, SO4, NH3, NH4, NH4NO3 + CB1, CB2, OC1, OC2, SOA + SSLT01, SSLT02, SSLT03, SSLT04 + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + +CHEMISTRY + Photolysis + [jo2_a] O2 + hv -> O + O1D + [jo2_b] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2 + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno] NO + hv -> N + O + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + *[jclno2] CLNO2 + hv -> CL + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jbr2] BR2 + hv -> 2*BR + [jbrno2] BRNO2 + hv -> BR + NO2 + [jclo] CLO + hv -> CL + O +*[jclno2] CLNO2 + hv -> CL + NO2 +* +* ,userdefined +* + [jchbr3] CHBR3 + hv -> 3*BR + [jch2br2] CH2BR2 + hv -> 2 * BR + [jch2brcl] CH2BRCL + hv -> BR + CL + [jchbr2cl] CHBR2CL + hv -> 2 * BR + CL + [jchbrcl2] CHBRCL2 + hv -> BR + 2 * CL + [ji2] I2 + hv -> 2*I + [jio] IO + hv -> I + O + [joio] OIO + hv -> I + O2 + [jino] INO + hv -> I + NO + [jino2_a->,userdefined] INO2 + hv -> I + NO2 + [jino2_b->,userdefined] INO2 + hv -> IO + NO + [jiono2] IONO2 + hv -> I + NO3 + [jhoi] HOI + hv -> I + OH + [ji2o2_a->,jiono2] I2O2 + hv -> 2*IO + [ji2o2_b->,jiono2] I2O2 + hv -> OIO + I + [ji2o3->,jiono2] I2O3 + hv -> OIO + IO + [ji2o4->,jiono2] I2O4 + hv -> OIO + OIO + [ji2o5->,jiono2] I2O5 + hv -> OIO + IO + O2 + [jibr] IBR + hv -> I + BR + [jicl] ICL + hv -> I + CL + [jch3i] CH3I + hv -> I + CH3 + [jch2i2] CH2I2 + hv -> 2*I + CH2 + [jch2ibr] CH2IBR + hv -> I + CH2BR +* +*[jcf3i->,userdefined] CF3I + hv -> I +*[jcf2i2->,userdefined] CF2I2 + hv -> 2*I +*[jc2f5i->,userdefined] C2F5I + hv -> I +*[jc3f7i->,userdefined] C3F7I + hv -> I +*[jcf2brcf2i->,userdefined] C2F4BRI + hv -> I +* + [jch2icl] CH2ICL + hv -> I + CH2CL + [jc2h5i] C2H5I + hv -> I + C2H5 + [jch3chi2] CH3CHI2 + hv -> 2*I + [jc3h7i] C3H7I + hv -> I + [jc4h9i] C4H9I + hv -> I +* + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .44*H2 + .38*CO + .05*H2O + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> 1.34 * HO2 + .66 * MCO3 + 1.34 * CH2O + 1.34 * CH3CO3 + [jmacr_b] MACR -> .66 * OH + 1.34 * CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL +.56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions +*========================================== +* Ox Reactions +*========================================== + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 +[usr_o_o] O + O + M -> O2 + M +[o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 +[o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 +[ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> 2*O2 ; 1.20e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + +*========================================== +* HOx Reactions +*========================================== + H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + H + O3 -> OH + O2 ; 1.40e-10, -470.0 +*JPL02 +*Change QY from 0.87 to 0.89; total QY now equals 1.0 +* H + HO2 -> 2*OH ; 7.05e-11 + H + HO2 -> 2*OH ; 7.21e-11 + H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + OH + O -> H + O2 ; 2.2e-11, 120 +*JPL02 +*[ox_l2] OH + O3 -> HO2 + O2 ; 1.5e-12, -880 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 +*JPL02 +* OH + OH + M -> H2O2 + M ; 6.2e-31,1.0, 2.6e-11, 0., .6 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + HO2 + O -> OH + O2 ; 3e-11, 200 +*JPL02 +*[ox_l3] HO2 + O3 -> OH + 2*O2 ; 2e-14, -680 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.0e-14, -490. + [usr9] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +*========================================== +* NOx Reactions +*========================================== + N2D + O2 -> NO + O ; 5.e-12 + N2D + O -> N + O ; 4.5e-13 + N + O2 -> NO + O ; 1.5e-11, -3600 + N + NO -> N2 + O ; 2.1e-11, 100 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 +*JPL02 +* NO2 + O + M -> NO3 + M ; 9.0e-32, 2., 2.2e-11, 0., .6 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, .6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.0e-30,4.4,1.4e-12,.7,.6 + [usr3] N2O5 + M -> NO2 + NO3 + M + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 +*JPL02 +*[usr6] NO2 + OH + M -> HNO3 + M ; 2.4e-30,3.1, 1.7e-11,2.1, 0.6 + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0.0, 0.6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + +*========================================== +* ClOx Reactions +*========================================== + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.40e-12, +270.0 +*JPL02 +* CLO + OH -> HCL + O2 ; 3.2e-13, 320 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 +*JPL02 +* CLO + HO2 -> O2 + HOCL ; 4.80e-13, +700.0 + CLO + HO2 -> O2 + HOCL ; 2.7e-12, +220.0 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11, 1.9, 0.6 + CL + NO2 + M -> CLNO2 + M ; 1.8e-31,2, 1.0e-10, 1.0, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 +*JPL02; Bloss et al. in new jpl02; sander was jpl00 +*[usr10] CLO + CLO + M -> CL2O2 + M ; 2.2e-32,3.1, 3.5e-12, 1.0, 0.6 +[clo_clo] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12, 2.4, 0.6 + [cl2o2] CL2O2 + M -> 2*CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. +*JPL02 +* CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -333. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + CLNO2 + OH -> HOCL + NO2 ; 2.40e-12, -1250. + CL2 + OH -> HOCL + CL ; 1.4e-12,-900. + +*========================================== +* BrOx Reactions +*========================================== + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BR + CH3CHO -> CH3CO3 + HBR ; 1.30e-11,-360. + BR + NO3 -> BRO + NO2 ; 1.6e-11 + BR + OH -> HOBR ; 4.2e-11 + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BR + NO2 + M -> BRNO2 + M ; 4.2e-31,2.4, 2.7e-11,0.0, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + CH3O2 -> BR + CH2O + HO2 ; 1.6e-12 + BRO + CH3O2 -> HOBR + CH2O ; 4.10e-12 + BRO + CH3CO3 -> BR + CH3O2 ; 1.7e-12 + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 5.5e-12, 200. + HBR + O -> OH + BR ; 5.8e-12, -1500. + HBR + O1D -> 0.2 * O + 0.2 * HBR + 0.8 * OH + 0.8 * Br ; 1.5e-10 + BR2 + OH -> HOBR + BR ; 2.1e-11, 240. + BRONO2 + O -> BRO + NO3 ; 1.91e-11,215. + BRONO2 + BR -> BR2 + NO3 ; 1.78e-11,365. + BRONO2 + CL -> BRCL + NO3 ; 6.28e-11,215. + BRO + DMS -> DMSO + BR ; 1.4e-14, 950. + +*========================================== +* IOx Reactions, JPL06 +* oiofactor = 0.2 +*========================================== + I2 + O3 -> IO + I + O2 ; 3.80e-18 + I2 + O3 -> OIO + IO ; 3.80e-18 + I + O3 -> IO + O2 ; 2.3e-11, -870. + I + HO2 -> HI + O2 ; 1.5e-11, -1090. + IO + NO -> I + NO2 ; 9.1e-12, 240. + IO + HO2 -> HOI + O2 ; 8.4e-11 + IO + IO -> OIO + I ; 1.8e-11 + IO + IO -> I2O2 ; 7.2e-11 + IO + OIO -> I2O3 ; 1.5e-10 + OIO + OIO -> I2O4 ; 1.0e-10 +*========================================================================================================= +* Thermal decomposition @ 265 K, calculated using RRKM theory +*========================================================================================================= + I2O2 -> OIO + I ; 0.21 + I2O2 -> IO + IO ; 1.3e-4 + I2O4 -> 2*OIO ; 4.4e-4 + BRONO2 -> BRO + NO2 ; 2.8e13, -12360. +*========================================================================================================= + I2O3 + O3 -> I2O4 + O2 ; 1.0e-12 + I2O4 + O3 -> I2O5 + O2 ; 1.0e-12 + I2 + OH -> HOI + I ; 1.8e-10 + I2 + NO3 -> IO + INO2 ; 1.5e-12 + I + NO3 -> IO + NO2 ; 4.5e-10 + OH + HI -> I + H2O ; 3.5e-11 + HOI + OH -> IO + H2O ; 2.0e-13 + IO + DMS -> DMSO + I ; 1.2e-14 + I + NO2 + M -> INO2 + M ; 3.0e-31,1.0, 6.0e-11,0.0, .6 + INO2 -> I + NO2 ; 993.6e15, -11859. + IO + NO2 + M -> IONO2 + M ; 6.5e-31,3.5, 7.6e-12,1.5, .6 + I + NO + M -> INO + M ; 1.8e-32, 1.0, 1.7e-11, 0.0, .6 + INO + INO -> I2 + 2*NO ; 8.4e-11, -2620. + INO2 + INO2 -> I2 + 2*NO2 ; 2.9e-11, -2600. + IO + BRO + M -> BR + I + O2 ; 0.45e-11, 510. +* IO + BRO + M -> BR + OIO + I + BRO -> IO + BR ; 1.2e-11 + IO + CLO -> I + OCLO ; 5.1e-12, 280. +* What happens to CH2I ??????? + OH + CH3I -> CH2I + H2O ; 2.9e-12, -1100. + OH + CF3I -> HOI + CF3 ; 2.5e-11, -2070. +* +* aerosols +* + CB1 -> CB2 ; 7.1e-6 + [usr23] SO2 + OH -> SO4 + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 7.1e-6 + [usr26] HO2 -> 0.5*H2O2 + +*========================================== +* DMS Reactions +*========================================== + DMS + OH -> SO2 ; 1.1e-11,-240. +[usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.0e-12, 500. + +*========================================== +* Halogens Reactions with Cl, OH +*========================================== + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250.0 +*JPL02 +* CH3CL + OH -> CL + H2O + HO2 ; 4.00e-12, -1400.0 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250.0 +*JPL02 +* CH3CCL3 + OH -> H2O + 3*CL ; 1.80e-12, -1550.0 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520.0 +*JPL02 +* HCFC22 + OH -> CL + H2O + CF2O ; 1.00e-12, -1600.0 + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600.0 +*JPL02 +* CH3BR + OH -> BR + H2O + HO2 ; 4.00e-12, -1470.0 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300.0 +*=============================================== +* additional reactions +*=============================================== + OH + C2H5I -> CH3CHO + IO + H2O ; 7.0e-13 + OH + C3H7I -> CH3COCH3 + IO + H2O ; 1.4e-12 + OH + C4H9I -> MEK + IO + H2O ; 3.0e-13 + + CL + C2H5I -> HCL + C2H4 + I ; 2.4e-11, -428. + CL + C2H5I -> HCL + IO + CH3CHO ; 4.1e-11, -428. + CL + C3H7I -> HCL + C3H6 + I ; 2.5e-11 + CL + C3H7I -> HCL + IO + CH3COCH3 ; 2.0e-11 + CL + C4H9I -> HCL + I ; 7.0e-11 + +*================================================ +* Heterogeneous bromo reactions +*================================================ +* [het1] BRONO2 -> HOBR + HNO3 +* [het2] HOBR -> BRCL +* [het3] HOBR -> 0.5 * BR2 + +*========================================== +* C-1 Degradation +*========================================== + [usr8] CO + OH -> CO2 + H + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3OH + OH -> HO2 + CH2O ; 6.7e-12,-600 +*JPL02 +*[ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 3.e-12, 280 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 +*JPL02 +* CH3O2 + HO2 -> CH3OOH + O2 ; 3.8e-13, 800 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 +*JPL02 +* CH2O + OH -> CO + H2O + H ; 1e-11 + CH2O + OH -> CO + H2O + H ; 9.0e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + +*========================================== +* C-2 Degradation +* +* EO2 = HOCH2CH2O2 +* EO = HOCH2CH2O +* PAN = CH3CO3NO2 +* GLYALD = HOCH2CHO +* +*========================================== + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .32 * CH3COOH + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 +*JPL02 +* CH3CO3 + HO2 -> .7 * CH3COOOH + .3 * CH3COOH + .3 * O3 ; 4.3e-13, 1040 + CH3CO3 + HO2 -> .75 * CH3COOOH + .25 * CH3COOH + .25 * O3 ; 4.3e-13, 1040 +*JPL02 +* CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 1.3e-12, 640 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12, 500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.2e-12, 180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + [usr12] PAN + M -> CH3CO3 + NO2 + M + PAN + OH -> CH2O + NO3 ; 4.e-14 + +*========================================== +* C-3 Degradation +* +* PO2 = C3H6OHO2 +* POOH = C3H6OHOOH +* RO2 = CH3COCH2O2 +* ROOH = CH3COCH2OOH +* HYAC = CH3COCH2OH +* +*========================================== + C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O +*JPL02 +*[ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 4.2e-12, 180 + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 +*JPL02 +* RO2 + HO2 -> ROOH + O2 ; 7.5e-13, 700 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 +*JPL02 (not in previous mechanism) + RO2 + CH3O2 -> .3*CH3CO3 + .8* CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + +*========================================== +* C-4 Degradation +* +* ENEO2 = C4H9O3 +* MEK = C4H8O +* MEKO2 = C4H7O3 +* MEKOOH = C4H8O3 +* MVK = CH2CHCOCH3 +* MACR = CH2CCH3CHO +* MACRO2 = CH3COCHO2CH2OH +* MACROOH = CH3COCHOOHCH2OH +* MCO3 = CH2CCH3CO3 +* MPAN = CH2CCH3CO3NO2 +* ONIT = CH3COCHO2CH2OHNO +* +*========================================== + BIGENE + OH -> ENEO2 ; 5.4e-11 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47 * HO2 + .25 * CH2O + .25 * CH3COCHO ; 2.4e-12 + + .22 * CO + .53 * GLYALD + .22 * HYAC + .53 * CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73 * HO2 + .88 * CH2O + .11 * CO + .24 * CH3COCHO ; 5.e-13,400 + + .26 * GLYALD + .26 * CH3CO3 + .25 * CH3OH + .23 * HYAC + MACRO2 + CH3CO3 -> .25 * CH3COCHO + CH3O2 + .22 * CO + .47 * HO2 ; 1.4e-11 + + .53 * GLYALD + .22 * HYAC + .25 * CH2O + .53 * CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 ; 5.e-12 +*JPL02 +* MCO3 + HO2 -> .3 * O3 + .3 * CH3COOH + .7 * CH3COOOH + .7 * O2 ; 4.30e-13, 1040 + MCO3 + HO2 -> .25 * O3 + .25 * CH3COOH + .75 * CH3COOOH + .75 * O2 ; 4.30e-13, 1040 +*JPL02 +* MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 1.3e-12,640 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + MPAN + OH -> .5 * HYAC + .5 * NO3 + .5 * CH2O + .5 * HO2 ; 8.e-27,3.5,3.e-11,0.,.5 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + +*========================================== +* C-5 Degradation +* +* ALKO2 = C5H11O2 +* ALKOOH = C5H12O2 +* ISOPO2 = HOCH2COOCH3CHCH2 +* ISOPNO3 = CH2CHCCH3OOCH2ONO2 +* ISOPOOH = HOCH2COOHCH3CHCH2 +* ONITR = CH2CCH3CHONO2CH2OH +* XO2 = HOCH2COOCH3CHCHOH +* XOOH = HOCH2COOHCH3CHCHOH +* +*========================================== + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .51 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> XOOH + .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 +*JPL02 (Different products) +* ONITR + OH -> .5*CO + .5*CH2O ; 1.5e-11 +* + HYDRALD + NO2 + HO2 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HO2 + NO2 + HYDRALD ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 +*JPL02 +* C2H5OH + OH-> HO2 + CH3CHO ; 7.e-12,-235 + C2H5OH + OH-> HO2 + CH3CHO ; 6.9e-12,-230 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O ; 1.e-11 + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .8*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + +*========================================== +* C-7 degradation +* +* CRESOL = C7H8O +* TOLUENE = C7H8 +* TOLO2 = C7H9O3 +* TOLOOH = C7H10O3 +* XOH = C7H10O4 +* +*========================================== + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 5.5e-12 + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + +*========================================== +* C-10 degradation (3) +*========================================== + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + +*============================================================ +* NOTE: does the halogen recycle happen on these aerosols???? +* sea-salt aerosols to be included +*============================================================= + +*========================================== +* Sulfate aerosol reactions +*========================================== + [het0] NO3 -> HNO3 + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O + +*========================================== +* Nitric acid Di-hydrate reactions +*========================================== + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 + +*========================================== +* Water-Ice aerosol reactions +*========================================== + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O + +*=========================================================== +* NOTE: the 75/25 % is taken as a compromise between +* reaction probability, halide content and halide depletion with time +*===================================================================== +*========================================== +* Additional Sulfate aerosol reactions +*========================================== +*[het_add_0] CLNO2 -> .75*CL2 + .25*BRCL +*[het_add_1] BRNO2 -> .75*BR2 + .25*BRCL +*[het_add_2] IONO2 -> .5*IBR + .5*ICL +*[het_add_3] INO2 -> .5*IBR + .5*ICL +*[het_add_4] HOI + HBR -> .5*IBR + .5*ICL + +*========================================== +* Sea-salt aerosol reactions +*========================================== +[het_ss_0] BRONO2 -> .75*BR2 + .25*BRCL +[het_ss_1] BRNO2 -> .75*BR2 + .25*BRCL +[het_ss_2] HOBR -> .75*BR2 + .25*BRCL +[het_ss_3] CLONO2 -> .75*CL2 + .25*BRCL +[het_ss_4] CLNO2 -> .75*CL2 + .25*BRCL +[het_ss_5] HOCL -> .75*CL2 + .25*BRCL +[het_ss_6] IONO2 -> .5*IBR + .5*ICL +[het_ss_7] INO2 -> .5*IBR + .5*ICL +[het_ss_8] HOI -> .5*IBR + .5*ICL + + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR, C2H5OOH + C3H7OOH, ROOH, CH3COCHO, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3, ALKOOH, MEKOOH, TOLOOH, TERPOOH + CLONO2, CLNO2, BRONO2, BRNO2, INO2, IONO2, HI, HOI, HCL, HOCL, HOBR, HBR, CH3COOH + CH3I, CH2I2, CH2IBR, CF3I, CF2I2, C2F5I, C3F7I, C2F4BRI, CH2ICL, C2H5I, CH3CHI2, C3H7I, C4H9I + DMS, DMSO, SO2 + End Heterogeneous + + + Ext Forcing + NO, CO, CH4 + End Ext Forcing + +END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM + diff --git a/chem_proc/inputs/kmg_CAM3_input_deck_T6_v4.inp b/chem_proc/inputs/kmg_CAM3_input_deck_T6_v4.inp new file mode 100644 index 0000000000..0daebdba14 --- /dev/null +++ b/chem_proc/inputs/kmg_CAM3_input_deck_T6_v4.inp @@ -0,0 +1,156 @@ +BEGSIM +output_unit_number = 7 +output_file = T6_LLNL_v4.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = T6_LLNL_v4.dat + +COMMENTS + "!=======================================================================" + "!" + "! $Id: kmg_CAM3_input_deck.inp $" + "!" + "! CODE DEVELOPER" + "! Name and affiliation" + "! connell2@llnl.gov" + "!" + "! FILE" + "! kmg_CAM3_input_deck.inp" + "!" + "! DESCRIPTION" + "! This file is the mechanism input file." + "!" + "! Chemistry input file: T6 12:00PM 7/09/2008" + "! Reaction dictionary: Rxns_trop_strat_JPL06-2.db" + "! Setkin files generated: Thu Aug 21 18:18:20 2008" + "!" + "!=======================================================================" +End COMMENTS + + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH4, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4 + End Solution + + Fixed + M, N2, O2, H2O, OZONE, sulf, bcar1, bcar2, ocar1, ocar2, + sslt1, sslt2, sslt3, sslt4, dust1, dust2, dust3, dust4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO, CH4 + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4 + End implicit + END Solution classes + + CHEMISTRY + Photolysis +[jo1d] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[ho2_ho2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[oh_dms] DMS + OH -> 0.75*SO2 +[so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2, CO + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + Spatial Dimensions + Longitude points = 128 + Latitude points = 64 + Vertical points = 66 + End Spatial Dimensions + + Numerical Control + Implicit Iterations = 11 + End Numerical Control + + Surface Flux + + End Surface Flux + + Surface Deposition + O3, OH, HO2, H2O2, NO, NO2, HNO3, CO, CH2O, CH3O2, CH3OOH + SO4 + End Surface Deposition + + Version Options + machine = ibm + model = cam + model_architecture = SCALAR + architecture = hybrid +* vec_ftns = on + namemod = on + End Version Options + + Outputs + File + Transported Species = avrg + All + End Transported Species + Surface Flux = avrg + + End Surface Flux + Deposition velocity = avrg + O3, OH, HO2, H2O2, NO, NO2, HNO3, CO, CH2O, CH3O2, CH3OOH + SO4 + End Deposition velocity + External Forcing = avrg + + End External Forcing + End File + End Outputs + + End Simulation Parameters + +ENDSIM diff --git a/chem_proc/inputs/modal_aerosols_3mode.in b/chem_proc/inputs/modal_aerosols_3mode.in new file mode 100644 index 0000000000..a8d45c0bfe --- /dev/null +++ b/chem_proc/inputs/modal_aerosols_3mode.in @@ -0,0 +1,83 @@ + SPECIES + + Solution + H2O2, H2SO4, SO2, DMS -> CH3SCH3, SOAG -> C + so4_a1 -> NH4HSO4 + pom_a1 -> C, soa_a1 -> C, bc_a1 -> C + dst_a1 -> AlSiO5, ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> NH4HSO4 + soa_a2 -> C, ncl_a2 -> NaCl + num_a2 -> H + dst_a3 -> AlSiO5, ncl_a3 -> NaCl + so4_a3 -> NH4HSO4 + num_a3 -> H + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, H2SO4, SO2, DMS, SOAG + so4_a1, pom_a1 + soa_a1, bc_a1, dst_a1, ncl_a1 + num_a1 + so4_a2, soa_a2, ncl_a2, num_a2 + dst_a3, ncl_a3, so4_a3, num_a3 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + [usr_SO2_OH] SO2 + OH -> H2SO4 + DMS + OH -> SO2 ; 9.6e-12, -234. + [usr_DMS_OH] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + pom_a1 <- dataset + bc_a1 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/modal_aerosols_3mode_aerocom.in b/chem_proc/inputs/modal_aerosols_3mode_aerocom.in new file mode 100644 index 0000000000..369746f634 --- /dev/null +++ b/chem_proc/inputs/modal_aerosols_3mode_aerocom.in @@ -0,0 +1,81 @@ + SPECIES + + Solution + H2O2, H2SO4, SO2, DMS -> CH3SCH3, SOAG -> C + so4_a1 -> NH4HSO4 + pom_a1 -> C, soa_a1 -> C, bc_a1 -> C + dst_a1 -> AlSiO5, ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> NH4HSO4 + soa_a2 -> C, ncl_a2 -> NaCl + num_a2 -> H + dst_a3 -> AlSiO5, ncl_a3 -> NaCl + so4_a3 -> NH4HSO4 + num_a3 -> H + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, H2SO4, SO2, DMS, SOAG + so4_a1, pom_a1 + soa_a1, bc_a1, dst_a1, ncl_a1 + num_a1 + so4_a2, soa_a2, ncl_a2, num_a2 + dst_a3, ncl_a3, so4_a3, num_a3 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + [usr23] SO2 + OH -> H2SO4 + DMS + OH -> SO2 ; 9.6e-12, -234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/modal_aerosols_7mode.in b/chem_proc/inputs/modal_aerosols_7mode.in new file mode 100644 index 0000000000..50fa66c36d --- /dev/null +++ b/chem_proc/inputs/modal_aerosols_7mode.in @@ -0,0 +1,108 @@ + SPECIES + + Solution + H2O2, H2SO4, SO2, DMS -> CH3SCH3, NH3, + SOAG -> C + so4_a1 -> SO4, + nh4_a1 -> NH4 + pom_a1 -> C, + soa_a1 -> C, + bc_a1 -> C, + ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> SO4, + nh4_a2 -> NH4 + soa_a2 -> C, + ncl_a2 -> NaCl + num_a2 -> H + pom_a3 -> C, + bc_a3 -> C + num_a3 -> H + ncl_a4 -> NaCl, + so4_a4 -> SO4 + nh4_a4 -> NH4, + num_a4 -> H + dst_a5 -> AlSiO5, + so4_a5 -> SO4 + nh4_a5 -> NH4, + num_a5 -> H + ncl_a6 -> NaCl, + so4_a6 -> SO4 + nh4_a6 -> NH4, + num_a6 -> H + dst_a7 -> AlSiO5, + so4_a7 -> SO4 + nh4_a7 -> NH4, + num_a7 -> H + End Solution + + Fixed + M, N2, O2, H2O, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, H2SO4, SO2, DMS, NH3, SOAG + so4_a1, nh4_a1, pom_a1 + soa_a1, bc_a1, ncl_a1, num_a1 + so4_a2, nh4_a2, soa_a2, ncl_a2 + num_a2 + pom_a3, bc_a3, num_a3 + ncl_a4, so4_a4, nh4_a4, num_a4 + dst_a5, so4_a5, nh4_a5, num_a5 + ncl_a6, so4_a6, nh4_a6, num_a6 + dst_a7, so4_a7, nh4_a7, num_a7 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + [usr_SO2_OH] SO2 + OH -> H2SO4 + DMS + OH -> SO2 ; 9.6e-12, -234. + [usr_DMS_OH] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/prog_carbon_sulfate.inp b/chem_proc/inputs/prog_carbon_sulfate.inp new file mode 100644 index 0000000000..34283bc489 --- /dev/null +++ b/chem_proc/inputs/prog_carbon_sulfate.inp @@ -0,0 +1,78 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_fixed_oxidants.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = prog_carbon_sulfate.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" +End Comments + + SPECIES + + Solution + H2O2, SO2, SO4, DMS -> CH3SCH3 + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C + End Solution + + Fixed + M, N2, O2, H2O + O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + H2O2, SO2, SO4, DMS + CB1, CB2, OC1, OC2 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + End Photolysis + + Reactions + CB1 -> CB2 ; 1.006e-05 + OC1 -> OC2 ; 1.006e-05 + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + SO4 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/super_fast_LLNL.in b/chem_proc/inputs/super_fast_LLNL.in new file mode 100644 index 0000000000..5ac9619bc3 --- /dev/null +++ b/chem_proc/inputs/super_fast_LLNL.in @@ -0,0 +1,88 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH4, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO, CH4 + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4 + End implicit + END Solution classes + + CHEMISTRY + Photolysis +*[jo1d] O3 + hv -> 2*OH +[jo1d->,jo3_a] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[ho2_ho2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[oh_dms] DMS + OH -> 0.75*SO2 +[so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2, CO + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.in b/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.in new file mode 100644 index 0000000000..ce6d8b7e70 --- /dev/null +++ b/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.in @@ -0,0 +1,89 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4 + End implicit + END Solution classes + + CHEMISTRY + Photolysis +[jo1d->,jo3_a] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[ho2_ho2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[oh_dms] DMS + OH -> 0.75*SO2 +[so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2, CO + SO2 <- dataset + SO4 <- dataset + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.isoprene+O3.in b/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.isoprene+O3.in new file mode 100644 index 0000000000..cf918d822b --- /dev/null +++ b/chem_proc/inputs/super_fast_LLNL.lut.fixed_ch4.isoprene+O3.in @@ -0,0 +1,92 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4, ISOP -> C5H8 + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4, ISOP + End implicit + END Solution classes + + CHEMISTRY + Photolysis +[jo1d->,jo3_a] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[usr_oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[usr_oh_dms] DMS + OH -> 0.75*SO2 +[tag_so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 +[isop_oh] ISOP + OH -> 2*CH3O2 -1.5*OH ; 2.700E-11, 390 +[isop_o3] ISOP + O3 -> 0.87*CH2O +1.86*CH3O2 +0.06*HO2 +0.05*CO ; 5.590E-15, -1814 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2 <- dataset + CO <- dataset + SO2 <- dataset + SO4 <- dataset + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/super_fast_LLNL.lut.in b/chem_proc/inputs/super_fast_LLNL.lut.in new file mode 100644 index 0000000000..3dcbc44035 --- /dev/null +++ b/chem_proc/inputs/super_fast_LLNL.lut.in @@ -0,0 +1,87 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH4, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO, CH4 + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4 + End implicit + END Solution classes + + CHEMISTRY + Photolysis +[jo1d->,jo3_a] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[usr_oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[usr_oh_dms] DMS + OH -> 0.75*SO2 +[tag_so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2, CO + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/super_fast_LLNL.tuv.in b/chem_proc/inputs/super_fast_LLNL.tuv.in new file mode 100644 index 0000000000..852dcfe1cc --- /dev/null +++ b/chem_proc/inputs/super_fast_LLNL.tuv.in @@ -0,0 +1,87 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH4, CH2O, CH3O2 + CH3OOH -> CH4O2, DMS -> C2H6S, SO2 -> O2S, + SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO, CH4 + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, SO4 + End implicit + END Solution classes + + CHEMISTRY + Photolysis +[jo1d] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +[usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[usr_oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +[usr_oh_dms] DMS + OH -> 0.75*SO2 +[tag_so2_oh_m] OH + SO2 + M -> SO4 ; 3.300E-31, 4.30, 1.600E-12, 0.00, 0.6 +[aq_so2_h2o2] H2O2 + SO2 -> SO4 +[aq_so2_o3] O3 + SO2 -> SO4 + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2, CO + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/super_fast_modal_3modes.in b/chem_proc/inputs/super_fast_modal_3modes.in new file mode 100644 index 0000000000..1538adb177 --- /dev/null +++ b/chem_proc/inputs/super_fast_modal_3modes.in @@ -0,0 +1,121 @@ + SPECIES + + Solution + O3, OH -> HO, HO2, H2O2, NO, NO2, HNO3, CO, CH2O, CH3O2 + CH3OOH -> CH4O2, ISOP -> C5H8 + H2SO4, SO2, DMS -> CH3SCH3, SOAG -> C + so4_a1 -> NH4HSO4 + pom_a1 -> C + soa_a1 -> C + bc_a1 -> C + dst_a1 -> AlSiO5 + ncl_a1 -> NaCl + num_a1 -> H + so4_a2 -> NH4HSO4 + soa_a2 -> C + ncl_a2 -> NaCl + num_a2 -> H + dst_a3 -> AlSiO5 + ncl_a3 -> NaCl + so4_a3 -> NH4HSO4 + num_a3 -> H + End Solution + + Fixed + M, N2, O2, H2O, CH4 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CO, SOAG + so4_a1, pom_a1, soa_a1, bc_a1, dst_a1, ncl_a1, num_a1 + so4_a2, soa_a2, ncl_a2, num_a2 + dst_a3, ncl_a3, so4_a3, num_a3 + End explicit + Implicit + O3, OH, HO2, H2O2, NO, NO2, HNO3, CH2O, CH3O2, CH3OOH + DMS, SO2, H2SO4, ISOP + End implicit + END Solution classes + + CHEMISTRY + Photolysis +*[jo1d] O3 + hv -> 2*OH +[jo1d->,jo3_a] O3 + hv -> 2*OH +[jh2o2] H2O2 + hv -> 2*OH +[jno2] NO2 + hv -> NO + O3 +[jch2o_a] CH2O + hv -> CO + 2*HO2 +[jch2o_b] CH2O + hv -> CO +[jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + End Photolysis + + Reactions + O3 + OH -> HO2 + O2 ; 1.700E-12, -940 +[out6] HO2 + O3 -> 2*O2 + OH ; 1.000E-14, -490 + HO2 + OH -> H2O + O2 ; 4.800E-11, 250 +*[ho2_ho2] HO2 + HO2 -> H2O2 + O2 + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 1.800E-12 + NO + O3 -> NO2 + O2 ; 3.000E-12, -1500 + HO2 + NO -> NO2 + OH ; 3.500E-12, 250 + NO2 + OH + M -> HNO3 ; 1.800E-30, 3.00, 2.800E-11, 0.00, 0.6 + CH4 + OH -> CH3O2 + H2O ; 2.450E-12, -1775 +[usr_oh_co] CO + OH -> HO2 + CH2O + OH -> CO + H2O + HO2 ; 5.500E-12, 125 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.100E-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 2.700E-12, 200 + CH3OOH + OH -> CH2O + H2O + OH ; 1.100E-12, 200 + CH3O2 + NO -> CH2O + HO2 + NO2 ; 2.800E-12, 300 + CH3O2 + CH3O2 -> 2*CH2O + 0.80*HO2 ; 9.500E-14, 390 +[het_no2_h2o] H2O + NO2 -> 0.50*HNO3 + DMS + OH -> SO2 ; 1.100E-11, -240 +*[oh_dms] DMS + OH -> 0.75*SO2 +[usr_oh_dms] DMS + OH -> 0.75*SO2 +* +* was labeled usr23 in X. Liu's version +* +[usr_SO2_OH] SO2 + OH -> H2SO4 +* +[tag_isop_oh] ISOP + OH -> 2*CH3O2 -1.5*OH ; 2.700E-11, 390 +[tag_isop_o3] ISOP + O3 -> 0.87*CH2O +1.86*CH3O2 +0.06*HO2 +0.05*CO ; 5.590E-15, -1814 +* + End reactions + + Heterogeneous + H2O2, HNO3, CH2O, SO2 + End heterogeneous + + Ext forcing + NO2 <- dataset + CO <- dataset + SO2 <- dataset + so4_a1 <- dataset + so4_a2 <- dataset + pom_a1 <- dataset + bc_a1 <- dataset + num_a1 <- dataset + num_a2 <- dataset + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + End Simulation Parameters diff --git a/chem_proc/inputs/trop_mozart_mech.in b/chem_proc/inputs/trop_mozart_mech.in new file mode 100644 index 0000000000..069b9055c3 --- /dev/null +++ b/chem_proc/inputs/trop_mozart_mech.in @@ -0,0 +1,325 @@ + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh] XOOH + hv -> OH + [jonitr] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/trop_mozart_table_tagged_mech.in b/chem_proc/inputs/trop_mozart_table_tagged_mech.in new file mode 100644 index 0000000000..ee19829b62 --- /dev/null +++ b/chem_proc/inputs/trop_mozart_table_tagged_mech.in @@ -0,0 +1,328 @@ + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2->,jo2_b] O2 + hv -> 2*O + [jo1d->,jo3_a] O3 + hv -> O1D + O2 + [jo3p->,jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5->,jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jno3_b] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2_a] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jho2no2_b] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmacr_b] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/trop_mozart_xactive_tagged_mech.in b/chem_proc/inputs/trop_mozart_xactive_tagged_mech.in new file mode 100644 index 0000000000..8b138a54c4 --- /dev/null +++ b/chem_proc/inputs/trop_mozart_xactive_tagged_mech.in @@ -0,0 +1,328 @@ + SPECIES + + Solution + O3, O, O1D -> O, N2O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, H2, OH, HO2, H2O2, + CH4,CO, CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHCHOH, XOOH -> HOCH2COOHCH3CHCHOH + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O3, TOLOOH -> C7H10O3 + XOH -> C7H10O4, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, SO4, DMS -> CH3SCH3, NH3, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + Rn, Pb, O3S -> O3, O3INERT -> O3, O3RAD -> O3, SYNOZ -> O3 + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + NH4, H2SO4 + End Solution + + Fixed + M, N2, O2, H2O + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + CH4, N2O, CO, Rn, Pb, H2, O3INERT, O3S, SYNOZ, O3RAD + End Explicit + Implicit + O3, O1D, O, NO, NO2, NO3, HNO3, HO2NO2, N2O5, OH, HO2, H2O2 + CH3O2, CH3OOH, CH2O, CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + CB1, CB2, SO2, SO4, DMS, NH3, NH4NO3, NH4, H2SO4 + OC1, OC2, SSLT01, SSLT02, SSLT03, SSLT04, SOA + DST01, DST02, DST03, DST04 + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jo2] O2 + hv -> 2*O + [jo1d] O3 + hv -> O1D + O2 + [jo3p] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno2] NO2 + hv -> NO + O + [jn2o5] N2O5 + hv -> NO2 + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3->,1.1236*jno3] NO3 + hv -> .89*NO2 + .11*NO + .89*O3 + [jho2no2] HO2NO2 + hv -> .33*OH + .33*NO3 + .66*NO2 + .66*HO2 + [jch3ooh] CH3OOH + hv -> CH2O + HO2 + OH + [jch2o_a] CH2O + hv -> CO + 2 * HO2 + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o2] H2O2 + hv -> 2*OH + [jch3cho_a] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_b] CH3CHO + hv -> CH3O2 + CO + HO2 + [jch3cho_c] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,userdefined] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac->,2.*jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + End Photolysis + + Reactions + [usr1] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8e-12, -2060 + [o1d_n2] O1D + N2 -> O + N2 ; 2.1e-11, 115 + [o1d_o2] O1D + O2 -> O + O2 ; 3.2e-11, 70 + [ox_l1] O1D + H2O -> 2*OH ; 2.2e-10 + H2 + O1D -> HO2 + OH ; 1.1e-10 + H2 + OH -> H2O + HO2 ; 5.5e-12, -2000 + O + OH -> HO2 + O2 ; 2.2e-11, 120 + HO2 + O -> OH + O2 ; 3e-11, 200 + [ox_l2] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr9] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1., 2.6e-11,0., .6 + N2O + O1D -> 2*NO ; 6.7e-11 + N2O + O1D -> N2 + O2 ; 4.9e-11 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + NO + O3 -> NO2 + O2 ; 3e-12, -1500 + NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + NO3 + HO2 -> OH + NO2 ; 2.3e-12, 170. + [usr2] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3] N2O5 + M -> NO2 + NO3 + M + [usr4] NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr5] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + [usr6] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr7] HO2NO2 + M -> HO2 + NO2 + M + [usr16] N2O5 -> 2 * HNO3 + [usr17] NO3 -> HNO3 + [usr17a] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH4 + O1D -> .75*CH3O2 + .75*OH + .25*CH2O + .4*HO2 + .05*H2 ; 1.5e-10 + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.e-13,-424 + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.9e-14,706 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O +HO2 ; 9.e-12 + [usr8] CO + OH -> CO2 + HO2 + [usr13] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.e-28,.8, 8.8e-12,0., .6 + [ox_l6] C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630 + + .12 * OH + .25 * CH3COOH + EO2 + NO -> EO + NO2 ; 4.2e-12,180 + EO + O2 -> GLYALD + HO2 ; 1.e-14 + EO -> 2 * CH2O + HO2 ; 1.6e11,-4150 + + C2H6 + OH -> C2H5O2 + H2O ; 8.7e-12, -1070 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.6e-12, 365 + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.5e-13, 700 + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.8e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.8e-12, 200 + [usr10] C3H6 + OH + M -> PO2 + M ; 8.e-27,3.5, 3.e-11,0, .5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH ; 6.5e-15, -1900 + + .08*CH4 + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.6e-13,-1156 + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.2e-12, 180 + PO2 + HO2 -> POOH + O2 ; 7.5e-13, 700 + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.8e-12, 200 + CH3CHO + OH -> CH3CO3 + H2O ; 5.6e-12, 270 + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.4e-12, -1900 + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.1e-12, 270 + [usr11] CH3CO3 + NO2 + M -> PAN + M ; 8.5e-29,6.5, 1.1e-11,1., .6 + CH3CO3 + HO2 -> .75*CH3COOOH + .25*CH3COOH + .25*O3 ; 4.3e-13, 1040 + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 + .9*CO2 + .1*CH3COOH ; 2.0e-12,500 + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1e-12 + [usr12] PAN + M -> CH3CO3 + NO2 + M + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.5e-12, 500 + C3H8 + OH -> C3H7O2 + H2O ; 1.0e-11, -660 + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.2e-12, 180 + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.5e-13, 700 + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40 + C3H7OOH + OH -> H2O + C3H7O2 ; 3.8e-12, 200 + [usr22] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.9e-12, 300 + RO2 + HO2 -> ROOH + O2 ; 8.6e-13, 700 + RO2 + CH3O2 -> .3*CH3CO3 + .8*CH2O + .3*HO2 + .2*HYAC ; 2.0e-12, 500 + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.8e-12, 200 + BIGENE + OH -> ENEO2 ; 5.4e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.2e-12, 180 + [soa5] BIGALK + OH -> ALKO2 ; 3.5e-12 + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 ; 4.2e-12, 180 + + .75*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.5e-13, 700 + ALKOOH + OH -> ALKO2 ; 3.8e-12, 200 + ONIT + OH -> NO2 + CH3COCHO ; 6.8e-13 + MEK + OH -> MEKO2 ; 2.3e-12, -170 + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.2e-12, 180 + MEKO2 + HO2 -> MEKOOH ; 7.5e-13, 700 + MEKOOH + OH -> MEKO2 ; 3.8e-12, 200 + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.7e-12, 352 + CRESOL + OH -> XOH ; 3.e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.e-11 + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.2e-12, 180 + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.5e-13, 700 + TOLOOH + OH -> TOLO2 ; 3.8e-12, 200 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.1e-11 + ISOP + OH -> ISOPO2 ; 2.54e-11, 410 + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000 + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .55 * CH2O ; 2.2e-12, 180 + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.4e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.e-13, 700 + ISOPOOH + OH -> .5 * XO2 + .5 * ISOPO2 ; 3.8e-12, 200 + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.e-13,400 + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O + CO2 ; 1.4e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + MVK + OH -> MACRO2 ; 4.13e-12, 452 + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH + .2 * O3 ; 7.52e-16,-1521 + + .06 * HO2 + .05 * CO + .04 * CH3CHO + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175 + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO + .2 * O3 ; 4.4e-15, -2500 + + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.7e-12, 360 + + .25 * CH3COCHO + .53 * CH3CO3 + .53 * GLYALD + + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.3e-13,360 + MACRO2 + NO3 -> NO2 + .47*HO2 + .25*CH2O + .25*CH3COCHO ; 2.4e-12 + + .22*CO + .53*GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.e-13, 700 + MACRO2 + CH3O2 -> .73*HO2 + .88*CH2O + .11*CO + .24*CH3COCHO ; 5.e-13,400 + + .26*GLYALD + .26*CH3CO3 + .25*CH3OH + .23*HYAC + MACRO2 + CH3CO3 -> .25*CH3COCHO + CH3O2 + .22*CO + .47*HO2 + CO2 ; 1.4e-11 + + .53*GLYALD + .22*HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.3e-11, 200 + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 + CO2 ; 5.3e-12, 360 + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 + CO2 ; 5.e-12 + MCO3 + HO2 -> .25*O3 + .25*CH3COOH + .75*CH3COOOH + .75*O2 ; 4.30e-13, 1040 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.0e-12,500 + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.6e-12, 530 + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.3e-12, 530 + [usr14] MCO3 + NO2 + M -> MPAN + M + [usr15] MPAN + M -> MCO3 + NO2 + M + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444 + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732 + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490 + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180 + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700 + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200 + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.e-13 + ISOP + NO3 -> ISOPNO3 ; 3.03e-12,-446 + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O + .167 * MACR ; 2.7e-12, 360 + + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR + .039 * MVK ; 2.4e-12 + + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> .206 * NO2 + .794 * HO2 + .008 * CH2O ; 8.e-13, 700 + + .167 * MACR + .039 * MVK + .794 * ONITR + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.4e-13,830 + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.4e-12, -1860 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.5e-11 + ONITR + NO3 -> HYDRALD + NO2 + HO2 ; 1.4e-12, -1860 + HYDRALD + OH -> XO2 ; 1.86e-11,175 + [ox_p11] XO2 + NO -> NO2 + 1.5*HO2 + CO ; 2.7e-12, 360 + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + 1.5*HO2 + CO + .25*HYAC ; 2.4e-12 + + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.e-13, 700 + XO2 + CH3O2 -> .3 * CH3OH + HO2 + .7 * CH2O ; 5.e-13,400 + + .4 * CO + .1 * HYAC + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> CO + CH3O2 + 1.5 * HO2 + CO2 ; 1.3e-12,640 + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190 + [usr21] XOOH + OH -> H2O + OH + CH3OH + OH -> HO2 + CH2O ; 7.3e-12,-620 + C2H5OH + OH -> HO2 + CH3CHO ; 6.9e-12,-230 + MPAN + OH -> .5*HYAC + .5*NO3 + .5*CH2O + .5*HO2 + .5*CO2 ; 8.e-27,3.5,3.e-11,0.,.5 + PAN + OH -> CH2O + NO3 + CO2 ; 4.e-14 + HYAC + OH -> CH3COCHO + HO2 ; 3.e-12 + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.e-11 + Rn -> Pb ; 2.1e-6 + CB1 -> CB2 ; 9.64506e-06 + [usr23] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.6e-12,-234. + [usr24] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + NH3 + OH -> H2O ; 1.7e-12, -710. + OC1 -> OC2 ; 9.64506e-06 + [usr26] HO2 -> 0.5*H2O2 + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, POOH, CH3COOOH, HO2NO2, ONIT, MVK, MACR + C2H5OOH, C3H7OOH, ROOH, CH3COCHO, Pb, MACROOH, XOOH, ONITR, ISOPOOH + CH3OH, C2H5OH, GLYALD, HYAC, HYDRALD, CH3CHO, ISOPNO3 + ALKOOH, MEKOOH, TOLOOH, TERPOOH, CH3COOH + SO2, NH4, NH3, H2SO4 + End Heterogeneous + + Ext Forcing + NO, CO, SYNOZ + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + diff --git a/chem_proc/inputs/trop_strat_bam_v1.inp b/chem_proc/inputs/trop_strat_bam_v1.inp new file mode 100644 index 0000000000..0fecc55dcf --- /dev/null +++ b/chem_proc/inputs/trop_strat_bam_v1.inp @@ -0,0 +1,604 @@ +BEGSIM +output_unit_number = 7 +output_file = trop_strat_bam_v1.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = trop_strat_bam_v1.dat + +Comments + " MOZART-4 mechanism (as in Emmons et al., 2010)" + " plus: HCN, CH3CN, C2H2, HCOOH, HOCH2OO" + " for use with photolysis lookup table" + " Nov 8, 2010: RO2+CH3O2 rate corrected" + " Jan 19, 2010: stratospheric species added (WACCM4)" + " April 26, 2011: sync 133spc to trop_mozart and JPL06" +End Comments + +SPECIES + + Solution + O3, O, O1D -> O + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH3OH, CH2O, CO + H2, H, OH, HO2, H2O2 + CLY, BRY + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, H2O + C2H5OH, C2H4, EO -> HOCH2CH2O, EO2 -> HOCH2CH2O2, CH3COOH, GLYALD -> HOCH2CHO + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH + CH3COCH3, RO2 -> CH3COCH2O2, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, ENEO2 -> C4H9O3 + MEK -> C4H8O, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + BIGALK -> C5H12, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2 + ISOP -> C5H8, ISOPO2 -> HOCH2COOCH3CHCH2, ISOPOOH -> HOCH2COOHCH3CHCH2 + MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH + MCO3 -> CH2CCH3CO3, HYDRALD -> HOCH2CCH3CHCHO, HYAC -> CH3COCH2OH + CH3COCHO, XO2 -> HOCH2COOCH3CHOHCHO, XOOH -> HOCH2COOHCH3CHOHCHO + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O5, TOLOOH -> C7H10O5 + XOH -> C7H10O6, BIGALD -> C5H6O2, GLYOXAL -> C2H2O2 + PAN -> CH3CO3NO2, ONIT -> CH3COCH2ONO2, MPAN -> CH2CCH3CO3NO2 + ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + CB1 -> C, CB2 -> C, OC1 -> C, OC2 -> C, SOA -> C12 + SO2, DMS -> CH3SCH3, SO4, NH3, NH4, NH4NO3 + SSLT01 -> NaCl, SSLT02 -> NaCl, SSLT03 -> NaCl, SSLT04 -> NaCl + DST01 -> AlSiO5, DST02 -> AlSiO5, DST03 -> AlSiO5, DST04 -> AlSiO5 + Rn, Pb + CO2, HCN, CH3CN, C2H2, HCOOH, HOCH2OO + End Solution + + Fixed + M, N2, O2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + +End SPECIES + +Solution Classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CLY, BRY + Rn, Pb + End Explicit + Implicit + O3, O, O1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, HCN, CH3CN, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2 + CH3OH, C2H5OH + C2H4, EO, EO2, CH3COOH, GLYALD + C2H6, C2H5O2, C2H5OOH, CH3CHO, CH3CO3, CH3COOOH + C3H6, C3H8, C3H7O2, C3H7OOH, PO2, POOH, CH3COCH3, RO2, ROOH + BIGENE, ENEO2, BIGALK, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH + ISOP, ISOPO2, ISOPOOH, MVK, MACR, MACRO2, MACROOH, MCO3 + HYDRALD, HYAC, CH3COCHO, XO2, XOOH + C10H16, TERPO2, TERPOOH + TOLUENE, CRESOL, TOLO2, TOLOOH, XOH, BIGALD, GLYOXAL + PAN, ONIT, MPAN, ISOPNO3, ONITR + SO2, DMS, SO4, NH3, NH4, NH4NO3, SOA + CB1, CB2, OC1, OC2 + C2H2, HCOOH, HOCH2OO + SSLT01, SSLT02, SSLT03, SSLT04 + DST01, DST02, DST03, DST04 + End Implicit +End Solution Classes + +CHEMISTRY + Photolysis + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2 + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + .4*CO2 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmacr_b] MACR -> .67*HO2 + .33*MCO3 + .67*CH2O + .67*CH3CO3 + .33*OH + .67*CO + [jmvk] MVK + hv -> .7*C3H6 + .7*CO + .3*CH3O2 + .3*CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> .82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,jch3cho] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL + .56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR +* +* for stratospheric chemistry +* + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr_O_O2] O + O2 + M -> O3 + M + O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr_O_O] O + O + M -> O2 + M +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [o1d_n2] O1D + N2 -> O + N2 ; 2.10e-11, 115. + [o1d_o2] O1D + O2 -> O + O2 ; 3.20e-11, 70. + [ox_l1] O1D + H2O -> 2*OH ; 2.20e-10 + O1D + H2 -> HO2 + OH ; 1.10e-10 + O1D + N2O -> N2 + O2 ; 4.90e-11 + O1D + N2O -> 2*NO ; 6.70e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + HCN -> OH ; 7.70e-11, 100. +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.70e-11, 0.2, 0.6 + H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + OH + O -> H + O2 ; 2.20e-11, 120. + [ox_l2] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.60e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + OH + HCN -> HO2 ; 4.28e-33, 0.0, 9.30e-15, -4.42, 0.8 + OH + CH3CN -> HO2 ; 7.80e-13, -1050. + HO2 + O -> OH + O2 ; 3.00e-11, 200. + [ox_l3] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + N + O2 -> NO + O ; 1.50e-11, -3600. + N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [ox_p1] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + NO2 + O -> NO + O2 ; 5.10e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [tag_NO2_NO3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr_N2O5_M] N2O5 + M -> NO2 + NO3 + M + [tag_NO2_OH] NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr_HNO3_OH] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [tag_NO2_HO2] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr_HO2NO2_M] HO2NO2 + M -> HO2 + NO2 + M +* -------------------------------------------------------------- +* C-1 Degradation (Methane, CO, CH2O and derivatives) +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + [ox_p2] CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.00e-13, -2058. + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr_CO_OH_b] CO + OH -> CO2 + H + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.00e-13, -424. + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.90e-14, 706. + CH3OH + OH -> HO2 + CH2O ; 2.90e-12, -345. + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.80e-12, 200. + HCOOH + OH -> HO2 + CO2 + H2O ; 4.5e-13 + CH2O + HO2 -> HOCH2OO ; 9.7e-15, 625. + HOCH2OO -> CH2O + HO2 ; 2.4e12, -7000. + HOCH2OO + NO -> HCOOH + NO2 + HO2 ; 2.6e-12, 265. + HOCH2OO + HO2 -> HCOOH ; 7.5e-13, 700. +* -------------------------------------------------------------- +* C-2 Degradation +* +* EO = HOCH2CH2O +* EO2 = HOCH2CH2O2 +* PAN = CH3CO3NO2 +* GLYALD = HOCH2CHO +* GLYOXAL= C2H2O2 +* C2H2 = C2H2 +* -------------------------------------------------------------- + C2H2 + OH + M -> .65*GLYOXAL + .65*OH + .35*HCOOH + .35*HO2 ; 5.5e-30, 0.0, 8.3e-13, -2.0, 0.6 + + .35*CO + M + C2H6 + OH -> C2H5O2 + H2O ; 8.70e-12, -1070. + [tag_C2H4_OH] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.00e-28, 0.8, 8.80e-12, 0.0, 0.6 + [ox_l6] C2H4 + O3 -> CH2O + .12*HO2 + .5*CO + .12*OH + .5*HCOOH ; 1.2e-14, -2630. + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.00e-13 + [ox_p5] C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.60e-12, 365. + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.50e-13, 700. + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.00e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.80e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.80e-12, 200. + CH3CHO + OH -> CH3CO3 + H2O ; 5.60e-12, 270. + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.40e-12, -1900. + [ox_p4] CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.10e-12, 270. + [tag_CH3CO3_NO2] CH3CO3 + NO2 + M -> PAN + M ; 8.50e-29, 6.5, 1.10e-11, 1.0, 0.6 + CH3CO3 + HO2 -> .75 * CH3COOOH + .25 * CH3COOH + .25 * O3 ; 4.30e-13, 1040. + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 ; 2.00e-12, 500. + + .9*CO2 + .1*CH3COOH + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.50e-12, 500. + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1.00e-12 + [ox_p16] EO2 + NO -> EO + NO2 ; 4.20e-12, 180. + EO + O2 -> GLYALD + HO2 ; 1.00e-14 + EO -> 2 * CH2O + HO2 ; 1.60e11, -4150. + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.00e-11 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.10e-11 + C2H5OH + OH -> HO2 + CH3CHO ; 6.90e-12, -230. + [usr_PAN_M] PAN + M -> CH3CO3 + NO2 + M + PAN + OH -> CH2O + NO3 ; 4.00e-14 +* -------------------------------------------------------------- +* C-3 Degradation +* +* PO2 = C3H6OHO2 +* POOH = C3H6OHOOH +* RO2 = CH3COCH2O2 +* ROOH = CH3COCH2OOH +* HYAC = CH3COCH2OH +* ONIT = CH3COCH2ONO2 +* -------------------------------------------------------------- + [tag_C3H6_OH] C3H6 + OH + M -> PO2 + M ; 8.00e-27, 3.5, 3.00e-11, 0.0, 0.5 + [ox_l4] C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH + .08*CH4 ; 6.50e-15, -1900. + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.60e-13, -1156. + [ox_p9] C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.20e-12, 180. + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.50e-13, 700. + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40. + C3H7OOH + OH -> H2O + C3H7O2 ; 3.80e-12, 200. + C3H8 + OH -> C3H7O2 + H2O ; 1.00e-11, -665. + [ox_p3] PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.20e-12, 180. + PO2 + HO2 -> POOH + O2 ; 7.50e-13, 700. + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.80e-12, 200. + [usr_CH3COCH3_OH] CH3COCH3 + OH -> RO2 + H2O + [ox_p10] RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.90e-12, 300. + RO2 + HO2 -> ROOH + O2 ; 8.60e-13, 700. + RO2 + CH3O2 -> .3*CH3CO3 + .8* CH2O + .3*HO2 + .2*HYAC ; 7.10e-13, 500. + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.80e-12, 200. + HYAC + OH -> CH3COCHO + HO2 ; 3.00e-12 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.40e-13, 830. + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.40e-12, -1860. + ONIT + OH -> NO2 + CH3COCHO ; 6.80e-13 +* -------------------------------------------------------------- +* C-4 Degradation +* BIGENE -> C4H8 +* ENEO2 = C4H9O3 +* MEK = C4H8O +* MEKO2 = C4H7O3 +* MEKOOH = C4H8O3 +* MVK = CH2CHCOCH3 +* MACR = CH2CCH3CHO +* MACRO2 = CH3COCHO2CH2OH +* MACROOH = CH3COCHOOHCH2OH +* MCO3 = CH2CCH3CO3 +* MPAN = CH2CCH3CO3NO2 +* -------------------------------------------------------------- + BIGENE + OH -> ENEO2 ; 5.40e-11 + [ox_p15] ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.20e-12, 180. + MVK + OH -> MACRO2 ; 4.13e-12, 452. + [ox_l7] MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH ; 7.52e-16, -1521. + + .2 * O3 + .06 * HO2 + .05 * CO + .04 * CH3CHO + MEK + OH -> MEKO2 ; 2.30e-12, -170. + [ox_p17] MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.20e-12, 180. + MEKO2 + HO2 -> MEKOOH ; 7.50e-13, 700. + MEKOOH + OH -> MEKO2 ; 3.80e-12, 200. + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175. + [ox_l8] MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO ; 4.40e-15, -2500. + + .2 * O3 + .7 * CH2O + .215 * OH + [ox_p7] MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.70e-12, 360. + + .53 * GLYALD + .25 * CH3COCHO + + .53 * CH3CO3 + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.30e-13, 360. + MACRO2 + NO3 -> NO2 + .47 * HO2 + .25 * CH2O ; 2.40e-12 + + .25 * CH3COCHO + .22 * CO + + .53 * GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.00e-13, 700. + MACRO2 + CH3O2 -> .73 * HO2 + .88 * CH2O + .11 * CO ; 5.00e-13, 400. + + .24 * CH3COCHO + + .26 * GLYALD + .26 * CH3CO3 + + .25 * CH3OH + .23 * HYAC + MACRO2 + CH3CO3 -> .25 * CH3COCHO + CH3O2 + .22 * CO ; 1.40e-11 + + .47 * HO2 + .53 * GLYALD + + .22 * HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.30e-11, 200. + [ox_p8] MCO3 + NO -> NO2 + CH2O + CH3CO3 ; 5.30e-12, 360. + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 ; 5.00e-12 + MCO3 + HO2 -> .25 * O3 + .25 * CH3COOH + .75 * CH3COOOH ; 4.30e-13, 1040. + + .75 * O2 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.00e-12, 500. + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.60e-12, 530. + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.30e-12, 530. + [usr_MCO3_NO2] MCO3 + NO2 + M -> MPAN + M + [usr_MPAN_M] MPAN + M -> MCO3 + NO2 + M + MPAN + OH -> .5 * HYAC + .5 * NO3 + .5 * CH2O + .5 *HO2 ; 8.00e-27, 3.5, 3.00e-11, 0.0, 0.5 +* -------------------------------------------------------------- +* C-5 Degradation +* +* ISOP = C5H8 +* ISOPO2 = HOCH2COOCH3CHCH2 +* ISOPNO3 = CH2CHCCH3OOCH2ONO2 +* ISOPOOH = HOCH2COOHCH3CHCH2 +* BIGALK = C5H12, +* ALKO2 = C5H11O2 +* ALKOOH = C5H12O2 +* ONITR = CH2CCH3CHONO2CH2OH +* XO2 = HOCH2COOCH3CHOHCHO +* XOOH = HOCH2COOHCH3CHOHCHO +* -------------------------------------------------------------- + ISOP + OH -> ISOPO2 ; 2.54e-11, 410. + [ox_l5] ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000. + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + NO3 -> ISOPNO3 ; 3.03e-12, -446. + [ox_p6] ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .51 * CH2O ; 4.40e-12, 180. + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.40e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.00e-13, 700. + ISOPOOH + OH -> .8 * XO2 + .2 * ISOPO2 ; 1.52e-11, 200. + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.00e-13, 400. + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O ; 1.40e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O ; 2.70e-12, 360. + + .167 * MACR + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR ; 2.40e-12 + + .039 * MVK + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> XOOH + .206 * NO2 + .794 *HO2 + .008*CH2O ; 8.00e-13, 700. + + .167 * MACR + .039 * MVK + .794 * ONITR + [soa5] BIGALK + OH -> ALKO2 ; 3.50e-12 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.50e-11 + ONITR + NO3 -> HO2 + NO2 + HYDRALD ; 1.40e-12, -1860. + HYDRALD + OH -> XO2 ; 1.86e-11, 175. + [ox_p14] ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 ; 4.20e-12, 180. + + .9*HO2 + .8*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.50e-13, 700. + ALKOOH + OH -> ALKO2 ; 3.80e-12, 200. + [ox_p11] XO2 + NO -> NO2 + HO2 + .5*CO + .25*GLYOXAL ; 2.7e-12, 360. + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + HO2 + 0.5*CO + .25*HYAC ; 2.40e-12 + + 0.25*GLYOXAL + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.00e-13, 700. + XO2 + CH3O2 -> .3 * CH3OH + 0.8*HO2 + .7 * CH2O ; 5.00e-13, 400. + + .2 * CO + .1 * HYAC + + .1*GLYOXAL + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> 0.5*CO + CH3O2 + HO2 + CO2 + .25*GLYOXAL ; 1.30e-12, 640. + + .25 * HYAC + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190. + [usr_XOOH_OH] XOOH + OH -> H2O + OH +* -------------------------------------------------------------- +* C-7 degradation +* +* TOLUENE = C7H8 +* CRESOL = C7H8O +* TOLO2 = C7H9O5 +* TOLOOH = C7H10O5 +* XOH = C7H10O6 +* -------------------------------------------------------------- + [soa4] TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.70e-12, 352. + [ox_p12] TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.20e-12, 180. + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.50e-13, 700. + TOLOOH + OH -> TOLO2 ; 3.80e-12, 200. + CRESOL + OH -> XOH ; 3.00e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.00e-11 +* -------------------------------------------------------------- +* C-10 degradation +* +* TERPO2 = C10H17O3 +* TERPOOH = C10H18O3 +* -------------------------------------------------------------- + [soa2] C10H16 + OH -> TERPO2 ; 1.2e-11, 444. + [soa1] C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732. + [soa3] C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490. + [ox_p13] TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180. + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700. + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200. +* -------------------------------------------------------------- +* Radon/Lead +* -------------------------------------------------------------- + Rn -> Pb ; 2.10e-6 +* -------------------------------------------------------------- +* Tropospheric Heterogeneous Reactions +* -------------------------------------------------------------- + [usr_N2O5_aer] N2O5 -> 2 * HNO3 + [usr_NO3_aer] NO3 -> HNO3 + [usr_NO2_aer] NO2 -> 0.5*OH + 0.5*NO + 0.5*HNO3 + CB1 -> CB2 ; 7.10e-6 + [usr_SO2_OH] SO2 + OH -> SO4 + DMS + OH -> SO2 ; 9.60e-12, -234. + [usr_DMS_OH] DMS + OH -> .5 * SO2 + .5 * HO2 + DMS + NO3 -> SO2 + HNO3 ; 1.90e-13, 520. + NH3 + OH -> H2O ; 1.70e-12, -710. + OC1 -> OC2 ; 7.10e-6 + [usr_HO2_aer] HO2 -> 0.5*H2O2 +* -------------------------------------------------------------- +* O1D reactions with halogens +* -------------------------------------------------------------- + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4*CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [tag_CLO_CLO] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr_CL2O2_M] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. +* -------------------------------------------------------------- +* Sulfate aerosol reactions (stratospheric) +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions (stratospheric) +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions (stratospheric) +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O + End Reactions + + Ext Forcing + NO <- dataset + NO2 <- dataset + CO <- dataset + SO2 <- dataset + CB1 <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/wa3.tst.inp b/chem_proc/inputs/wa3.tst.inp new file mode 100644 index 0000000000..8fc5017320 --- /dev/null +++ b/chem_proc/inputs/wa3.tst.inp @@ -0,0 +1,329 @@ +BEGSIM + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e + End Ext Forcing + + END Chemistry + +ENDSIM diff --git a/chem_proc/inputs/wa3.tst.spe.0.inp b/chem_proc/inputs/wa3.tst.spe.0.inp new file mode 100644 index 0000000000..75b57e6ebc --- /dev/null +++ b/chem_proc/inputs/wa3.tst.spe.0.inp @@ -0,0 +1,329 @@ +BEGSIM + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + +ENDSIM diff --git a/chem_proc/inputs/wa3.tst.spe.inp b/chem_proc/inputs/wa3.tst.spe.inp new file mode 100644 index 0000000000..c63b1c1b03 --- /dev/null +++ b/chem_proc/inputs/wa3.tst.spe.inp @@ -0,0 +1,360 @@ +BEGSIM +output_unit_number = 7 +output_file = cam_aer_ncep.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = cam_aer_ncep.dat + +Comments + "This is a mozart4 simulation with :" + "(1) New hydrocarbon chemistry (lumped alkane, alkene, aromatic)" + "(2) New aerosol chemistry" + "(3) No groups" + "(4) NCEP inputs (28 levels)" + "(5) no N atom" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = ibm + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/waccm3_57spc_JPL06_ccmval.inp b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval.inp new file mode 100644 index 0000000000..35416798ad --- /dev/null +++ b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval.inp @@ -0,0 +1,370 @@ +BEGSIM +output_unit_number = 7 +output_file = waccm3_57spc_JPL06_ccmval.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = waccm3_57spc_JPL06_ccmval.dat + +Comments + "This is a waccm3 simulation with:" + "(1) The new advection routine Lin Rood" + "(2) WACCM dynamical inputs" + "(3) Strat, Meso, and Thermospheric mechanism" + "(4) JPL06 Kinetics" + "(5) CCMVal Mechanism, 2008" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [jclo] CLO + hv -> O + CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr2] O + O + M -> O2 + M + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.00e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.90e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 1.80e-15, 45. + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 3.50e-11, -135. + O2_1S + CO2 -> O2_1D + CO2 ; 4.20e-13 + [ag2,cph] O2_1S -> O2 ; 8.50e-2 + [cph22,cph] O2_1D + O -> O2 + O ; 1.30e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.60e-18, -220. + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.00e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-04 +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [cph17,cph] O1D + N2 -> O + N2 ; 2.15e-11, 110. + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.135e-11, 55. + [cph29,cph] O1D + O2 -> O + O2 ; 1.65e-12, 55. + O1D + H2O -> 2*OH ; 1.63e-10, 60. + O1D + N2O -> 2*NO ; 6.70e-11, 20. + O1D + N2O -> N2 + O2 ; 4.70e-11, 20. + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + H2 -> H + OH ; 1.10e-10 + O1D + HCL -> CL + OH ; 1.50e-10 + O1D + HBR -> BR + OH ; 1.50e-10 +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.00e-12 +*[cph26,cph] N2D + O -> N + O ; 4.50e-13 + [cph26,cph] N2D + O -> N + O ; 7.00e-13 + [cph27,cph] N + O2 -> NO + O ; 1.50e-11, -3600. + [cph28,cph] N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + [cph12,cph] NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + [cph13,cph] NO2 + O -> NO + O2 ; 5.20e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 5.80e-16 + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.7e-11, 0.2, 0.6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + [cph3,cph] OH + O -> H + O2 ; 2.20e-11, 120. + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.6e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + [cph4,cph] HO2 + O -> OH + O2 ; 3.00e-11, 200. + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. + +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = ibm + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.in b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.in new file mode 100644 index 0000000000..3a4ca958bc --- /dev/null +++ b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.in @@ -0,0 +1,351 @@ + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CLY, BRY + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CLY, BRY + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [jclo] CLO + hv -> O + CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr_O_O2] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr_O_O] O + O + M -> O2 + M + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.00e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.90e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 1.80e-15, 45. + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 3.50e-11, -135. + O2_1S + CO2 -> O2_1D + CO2 ; 4.20e-13 + [ag2,cph] O2_1S -> O2 ; 8.50e-2 + [cph22,cph] O2_1D + O -> O2 + O ; 1.30e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.60e-18, -220. + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.00e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-04 +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [cph17,cph] O1D + N2 -> O + N2 ; 2.15e-11, 110. + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.135e-11, 55. + [cph29,cph] O1D + O2 -> O + O2 ; 1.65e-12, 55. + O1D + H2O -> 2*OH ; 1.63e-10, 60. + O1D + N2O -> 2*NO ; 6.70e-11, 20. + O1D + N2O -> N2 + O2 ; 4.70e-11, 20. + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + H2 -> H + OH ; 1.10e-10 + O1D + HCL -> CL + OH ; 1.50e-10 + O1D + HBR -> BR + OH ; 1.50e-10 +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.00e-12 +*[cph26,cph] N2D + O -> N + O ; 4.50e-13 + [cph26,cph] N2D + O -> N + O ; 7.00e-13 + [cph27,cph] N + O2 -> NO + O ; 1.50e-11, -3600. + [cph28,cph] N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + [cph12,cph] NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + [cph13,cph] NO2 + O -> NO + O2 ; 5.20e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [tag_NO2_NO3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr_N2O5_M] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr_HNO3_OH] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [tag_NO2_HO2] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr_HO2NO2_M] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 5.80e-16 + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr_CO_OH_b] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.7e-11, 0.2, 0.6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + [cph3,cph] OH + O -> H + O2 ; 2.20e-11, 120. + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.6e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + [cph4,cph] HO2 + O -> OH + O2 ; 3.00e-11, 200. + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [tag_CLO_CLO] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr_CL2O2_M] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. + +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO<-dataset, NO2<-dataset, CO<-dataset, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.inp b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.inp new file mode 100644 index 0000000000..f2038e2cd9 --- /dev/null +++ b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_clbrfam.inp @@ -0,0 +1,373 @@ +BEGSIM +output_unit_number = 7 +output_file = waccm3_57spc_JPL06_ccmval_clbrfam.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = waccm3_57spc_JPL06_ccmval_clbrfam.dat + +Comments + "This is a waccm3 simulation with:" + "(1) The new advection routine Lin Rood" + "(2) WACCM dynamical inputs" + "(3) Strat, Meso, and Thermospheric mechanism" + "(4) JPL06 Kinetics" + "(5) CCMVal Mechanism, 2008" + "(6) Transporting total ClOY" + "(6) Transporting total BROY" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CLY, BRY + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CLY, BRY + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [jclo] CLO + hv -> O + CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr_O_O2] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr_O_O] O + O + M -> O2 + M + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.00e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.90e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 1.80e-15, 45. + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 3.50e-11, -135. + O2_1S + CO2 -> O2_1D + CO2 ; 4.20e-13 + [ag2,cph] O2_1S -> O2 ; 8.50e-2 + [cph22,cph] O2_1D + O -> O2 + O ; 1.30e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.60e-18, -220. + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.00e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-04 +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [cph17,cph] O1D + N2 -> O + N2 ; 2.15e-11, 110. + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.135e-11, 55. + [cph29,cph] O1D + O2 -> O + O2 ; 1.65e-12, 55. + O1D + H2O -> 2*OH ; 1.63e-10, 60. + O1D + N2O -> 2*NO ; 6.70e-11, 20. + O1D + N2O -> N2 + O2 ; 4.70e-11, 20. + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + H2 -> H + OH ; 1.10e-10 + O1D + HCL -> CL + OH ; 1.50e-10 + O1D + HBR -> BR + OH ; 1.50e-10 +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.00e-12 +*[cph26,cph] N2D + O -> N + O ; 4.50e-13 + [cph26,cph] N2D + O -> N + O ; 7.00e-13 + [cph27,cph] N + O2 -> NO + O ; 1.50e-11, -3600. + [cph28,cph] N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + [cph12,cph] NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + [cph13,cph] NO2 + O -> NO + O2 ; 5.20e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [tag_NO2_NO3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr_N2O5_M] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr_HNO3_OH] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [tag_NO2_HO2] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr_HO2NO2_M] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 5.80e-16 + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr_CO_OH_b] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.7e-11, 0.2, 0.6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + [cph3,cph] OH + O -> H + O2 ; 2.20e-11, 120. + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.6e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + [cph4,cph] HO2 + O -> OH + O2 ; 3.00e-11, 200. + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [tag_CLO_CLO] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr_CL2O2_M] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. + +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO<-dataset, NO2<-dataset, CO<-dataset, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_cloytracer.inp b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_cloytracer.inp new file mode 100644 index 0000000000..95a69d0ee6 --- /dev/null +++ b/chem_proc/inputs/waccm3_57spc_JPL06_ccmval_cloytracer.inp @@ -0,0 +1,371 @@ +BEGSIM +output_unit_number = 7 +output_file = waccm3_57spc_JPL06_ccmval_cloytracer.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = waccm3_57spc_JPL06_ccmval_cloytracer.dat + +Comments + "This is a waccm3 simulation with:" + "(1) The new advection routine Lin Rood" + "(2) WACCM dynamical inputs" + "(3) Strat, Meso, and Thermospheric mechanism" + "(4) JPL06 Kinetics" + "(5) CCMVal Mechanism, 2008" + "(6) Transporting total ClOY" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2, CLY -> Cl13 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CLY + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [jclo] CLO + hv -> O + CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr2] O + O + M -> O2 + M + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.00e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.90e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 1.80e-15, 45. + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 3.50e-11, -135. + O2_1S + CO2 -> O2_1D + CO2 ; 4.20e-13 + [ag2,cph] O2_1S -> O2 ; 8.50e-2 + [cph22,cph] O2_1D + O -> O2 + O ; 1.30e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.60e-18, -220. + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.00e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-04 +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [cph17,cph] O1D + N2 -> O + N2 ; 2.15e-11, 110. + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.135e-11, 55. + [cph29,cph] O1D + O2 -> O + O2 ; 1.65e-12, 55. + O1D + H2O -> 2*OH ; 1.63e-10, 60. + O1D + N2O -> 2*NO ; 6.70e-11, 20. + O1D + N2O -> N2 + O2 ; 4.70e-11, 20. + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + H2 -> H + OH ; 1.10e-10 + O1D + HCL -> CL + OH ; 1.50e-10 + O1D + HBR -> BR + OH ; 1.50e-10 +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.00e-12 +*[cph26,cph] N2D + O -> N + O ; 4.50e-13 + [cph26,cph] N2D + O -> N + O ; 7.00e-13 + [cph27,cph] N + O2 -> NO + O ; 1.50e-11, -3600. + [cph28,cph] N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + [cph12,cph] NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + [cph13,cph] NO2 + O -> NO + O2 ; 5.20e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 5.80e-16 + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.7e-11, 0.2, 0.6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + [cph3,cph] OH + O -> H + O2 ; 2.20e-11, 120. + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.6e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + [cph4,cph] HO2 + O -> OH + O2 ; 3.00e-11, 200. + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. + +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS + +ENDSIM diff --git a/chem_proc/inputs/waccm_ions_spe.inp b/chem_proc/inputs/waccm_ions_spe.inp new file mode 100644 index 0000000000..302128ce15 --- /dev/null +++ b/chem_proc/inputs/waccm_ions_spe.inp @@ -0,0 +1,392 @@ +BEGSIM +output_unit_number = 7 +output_file = ions.marsh.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = ions.marsh.dat + +COMMENTS + "This is a waccm2 simulation with:" + "(1) The new advection routine Lin Rood" + "(2) WACCM dynamical inputs" + "(3) Strat, Meso, and Thermospheric mechanism" +End COMMENTS + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a] O2 + hv -> O + O1D + [jo2_b] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1] O + hv -> Op + e + [jeuv_2] O + hv -> Op + e + [jeuv_3] O + hv -> Op + e + [jeuv_4] N + hv -> Np + e + [jeuv_5] O2 + hv -> O2p + e + [jeuv_6] N2 + hv -> N2p + e + [jeuv_7] O2 + hv -> O + Op + e + [jeuv_8] O2 + hv -> O + Op + e + [jeuv_9] O2 + hv -> O + Op + e + [jeuv_10] N2 + hv -> N + Np + e + [jeuv_11] N2 + hv -> N2D + Np + e + [jeuv_12] O2 + hv -> 2*O + [jeuv_13] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14] O + hv -> Op + e + [jeuv_15] O + hv -> Op + e + [jeuv_16] O + hv -> Op + e + [jeuv_17] O2 + hv -> O2p + e + [jeuv_18] N2 + hv -> N2p + e + [jeuv_19] O2 + hv -> O + Op + e + [jeuv_20] O2 + hv -> O + Op + e + [jeuv_21] O2 + hv -> O + Op + e + [jeuv_22] N2 + hv -> N + Np + e + [jeuv_23] N2 + hv -> N2D + Np + e + [jeuv_24] O2 + hv -> 2*O + [jeuv_25] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Spatial Dimensions + Longitude points = 128 + Latitude points = 64 + Vertical points = 66 + End Spatial Dimensions + + Numerical Control + Implicit Iterations = 11 + End Numerical Control + + Surface Flux + NO, CH2O, CO + End Surface Flux + + Surface Deposition + O3, NO2, HNO3, CH3OOH, CH2O, CO, H2O2, NO, HO2NO2 + End Surface Deposition + + Version Options + machine = ibm + model = cam + model_architecture = SCALAR + architecture = hybrid +* vec_ftns = on + namemod = on + End Version Options + + Outputs + File + Transported Species = avrg + All + End Transported Species + Surface Flux = avrg + NO, H2, CH2O, CO + End Surface Flux + Deposition velocity = avrg + O3, NO2, HNO3, CH3OOH, CH2O, CO, H2O2, H2 + End Deposition velocity + External Forcing = avrg + NO, CO + End External Forcing + End File + End Outputs + + End Simulation Parameters + +ENDSIM diff --git a/chem_proc/inputs/waccm_mozart_mech.in b/chem_proc/inputs/waccm_mozart_mech.in new file mode 100644 index 0000000000..20efdef16e --- /dev/null +++ b/chem_proc/inputs/waccm_mozart_mech.in @@ -0,0 +1,374 @@ + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a] O2 + hv -> O + O1D + [jo2_b] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1] O + hv -> Op + e + [jeuv_2] O + hv -> Op + e + [jeuv_3] O + hv -> Op + e + [jeuv_4] N + hv -> Np + e + [jeuv_5] O2 + hv -> O2p + e + [jeuv_6] N2 + hv -> N2p + e + [jeuv_7] O2 + hv -> O + Op + e + [jeuv_8] O2 + hv -> O + Op + e + [jeuv_9] O2 + hv -> O + Op + e + [jeuv_10] N2 + hv -> N + Np + e + [jeuv_11] N2 + hv -> N2D + Np + e + [jeuv_12] O2 + hv -> 2*O + [jeuv_13] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14] O + hv -> Op + e + [jeuv_15] O + hv -> Op + e + [jeuv_16] O + hv -> Op + e + [jeuv_17] O2 + hv -> O2p + e + [jeuv_18] N2 + hv -> N2p + e + [jeuv_19] O2 + hv -> O + Op + e + [jeuv_20] O2 + hv -> O + Op + e + [jeuv_21] O2 + hv -> O + Op + e + [jeuv_22] N2 + hv -> N + Np + e + [jeuv_23] N2 + hv -> N2D + Np + e + [jeuv_24] O2 + hv -> 2*O + [jeuv_25] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Spatial Dimensions + Longitude points = 128 + Latitude points = 64 + Vertical points = 66 + End Spatial Dimensions + + Numerical Control + Implicit Iterations = 11 + End Numerical Control + + Surface Flux + NO, CH2O, CO + End Surface Flux + + Surface Deposition + O3, NO2, HNO3, CH3OOH, CH2O, CO, H2O2, NO, HO2NO2 + End Surface Deposition + + Version Options + machine = ibm + model = cam + model_architecture = SCALAR + architecture = hybrid +* vec_ftns = on + namemod = on + End Version Options + + Outputs + File + Transported Species = avrg + All + End Transported Species + Surface Flux = avrg + NO, H2, CH2O, CO + End Surface Flux + Deposition velocity = avrg + O3, NO2, HNO3, CH3OOH, CH2O, CO, H2O2, H2 + End Deposition velocity + External Forcing = avrg + NO, CO + End External Forcing + End File + End Outputs + + End Simulation Parameters diff --git a/chem_proc/inputs/waccm_mozart_tagged_mech.in b/chem_proc/inputs/waccm_mozart_tagged_mech.in new file mode 100644 index 0000000000..a14c056681 --- /dev/null +++ b/chem_proc/inputs/waccm_mozart_tagged_mech.in @@ -0,0 +1,340 @@ + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH2O, CO + H2, H, OH, HO2, H2O2 + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2 + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr1] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8e-12, -2060 + [usr2] O + O + M -> O2 + M + [cph17,cph] O1D + N2 -> O + N2 ; 1.8e-11, 110 + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.04e-11, 70 + [cph29,cph] O1D + O2 -> O + O2 ; 1.60e-12, 70 + O1D + H2O -> 2*OH ; 2.2e-10 + O1D + N2O -> 2*NO ; 6.7e-11 + O1D + N2O -> N2 + O2 ; 4.9e-11 + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.0e-11 + O1D + CH4 -> CH2O + H2 ; 7.5e-12 + O1D + H2 -> H + OH ; 1.1e-10 + O1D + HCL -> CL + OH ; 1.5e-10 + + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.9e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 2.1e-15 + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 2.2e-11 +*new reaction + O2_1S + CO2 -> O2_1D + CO2 ; 4.2e-13 + [ag2,cph] O2_1S -> O2 ; 8.5e-2 + + [cph22,cph] O2_1D + O -> O2 + O ; 1.3e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.6e-18,-220 + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-4 + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.e-12 +*[cph26,cph] N2D + O -> N + O ; 4.5e-13 + [cph26,cph] N2D + O -> N + O ; 7.e-13 + [cph27,cph] N + O2 -> NO + O ; 1.5e-11, -3600 + [cph28,cph] N + NO -> N2 + O ; 2.1e-11, 100 + NO + O + M -> NO2 + M ; 9.0e-32, 1.5, 3.0e-11, 0., 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.5e-12, 250 + [cph12,cph] NO + O3 -> NO2 + O2 ; 3e-12, -1500 + [cph13,cph] NO2 + O -> NO + O2 ; 5.6e-12, 180 + NO2 + O + M -> NO3 + M ; 2.5e-31, 1.8, 2.2e-11, .7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.2e-13, -2450 + [usr3] NO2 + NO3 + M -> N2O5 + M ; 2.e-30,4.4, 1.4e-12,.7, .6 + [usr3a] N2O5 + M -> NO2 + NO3 + M + NO2 + OH + M -> HNO3 + M ; 2.0e-30,3.0, 2.5e-11,0., .6 + [usr4] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.5e-11, 170 + NO3 + O -> NO2 + O2 ; 1.e-11 + NO3 + OH -> HO2 + NO2 ; 2.2e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.5e-12 + [usr5] NO2 + HO2 + M -> HO2NO2 + M ; 1.8e-31,3.2, 4.7e-12,1.4, .6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.3e-12, 380 + [usr5a] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Methane, CO, CH2O and derivatives +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775 + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.8e-12, 300 + CH3O2 + HO2 -> CH3OOH + O2 ; 4.1e-13, 750 + CH3OOH + OH -> CH3O2 + H2O ; 3.8e-12, 200 + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.0e-13, -2058 + CH2O + OH -> CO + H2O + H ; 9.e-12 + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600.0 + [usr6] CO + OH -> CO2 + H + +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 5.7e-32,1.6, 7.5e-11,0., .6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470.0 + H + HO2 -> 2*OH ; 7.21e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 7.29e-12 + H + HO2 -> H2O + O ; 1.62e-12 + [cph3,cph] OH + O -> H + O2 ; 2.2e-11, 120 + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.7e-12, -940 + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.8e-11, 250 + OH + OH -> H2O + O ; 4.2e-12, -240 + OH + OH + M -> H2O2 + M ; 6.9e-31,1.0, 2.6e-11, 0., .6 + OH + H2 -> H2O + H ; 5.5e-12, -2000 + OH + H2O2 -> H2O + HO2 ; 2.9e-12, -160 + [cph4,cph] HO2 + O -> OH + O2 ; 3e-11, 200 + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.e-14, -490 + [usr7] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.4e-12, -2000 + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200 + CL + H2 -> HCL + H ; 3.70e-11, -2300.0 + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980.0 + CL + HO2 -> HCL + O2 ; 1.80e-11, +170.0 + CL + HO2 -> OH + CLO ; 4.10e-11, -450.0 + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30.0 + CL + CH4 -> CH3O2 + HCL ; 9.60e-12, -1360 + CLO + O -> CL + O2 ; 3.00e-11, +70.0 + CLO + OH -> CL + HO2 ; 7.4e-12, 270 + CLO + OH -> HCL + O2 ; 6.0e-13, 230 + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220 + CLO + NO -> NO2 + CL ; 6.40e-12, +290.0 + CLO + NO2 + M -> CLONO2 + M ; 1.8e-31,3.4, 1.5e-11,1.9, .6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450.0 + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590.0 + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370.0 + [usr8] CLO + CLO + M -> CL2O2 + M ; 1.6e-32,4.5, 2.0e-12,2.4, .6 + [usr8a] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350 + HCL + O -> CL + OH ; 1.00e-11, -3300 + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130 + HOCL + OH -> H2O + CLO ; 3.00e-12, -500 + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800 + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330 + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 1.50e-11, -600. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 7.5e-11 + BRO + HO2 -> HOBR + O2 ; 3.40e-12, 540. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.2e-31,3.2, 6.9e-12,2.9, .6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.5e-12, 230. + HBR + OH -> BR + H2O ; 1.10e-11 + +* -------------------------------------------------------------- +* Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 3.20e-11, -1250 + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250 + CH3CCL3 + OH -> H2O + 3*CL ; 1.60e-12, -1520 + HCFC22 + OH -> CL + H2O + CF2O ; 4.00e-12, -1400 + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300 + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.4e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.e-10 + [ion8,cph] Np + O -> Op + N ; 1.e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.e-11 + O2p + N2 -> NOp + NO ; 5.e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Heterogeneous + H2O2, HNO3, CH2O, CH3OOH, HO2NO2, CLONO2, BRONO2, HCL, N2O5, HOCL, HOBR, HBR + End Heterogeneous + + Ext Forcing + NO, CO, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = ibm + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS diff --git a/chem_proc/inputs/waccm_tslt_v3.inp b/chem_proc/inputs/waccm_tslt_v3.inp new file mode 100644 index 0000000000..84d92745b2 --- /dev/null +++ b/chem_proc/inputs/waccm_tslt_v3.inp @@ -0,0 +1,650 @@ +BEGSIM +output_unit_number = 7 +output_file = waccm_tslt_v3.doc +procout_path = ../output/ +src_path = ../bkend/ +procfiles_path = ../procfiles/cam/ +sim_dat_path = ../output/ +sim_dat_filename = waccm_tslt_v3.dat + +Comments + "This is a waccm TSLT simulation with:" + "(1) The new advection routine Lin Rood" + "(2) WACCM dynamical inputs" + "(3) Strat, Meso, and Thermospheric mechanism" + "(4) JPL06 Kinetics" + "(5) CCMVal Mechanism, 2008" + "(6) Transporting total ClOY" + "(6) Transporting total BROY" +End Comments + + SPECIES + + Solution + O3, O, O1D -> O, O2, O2_1S -> O2, O2_1D -> O2 + N2O, N, NO, NO2, NO3, HNO3, HO2NO2, N2O5 + CH4, CH3O2, CH3OOH, CH3OH, CH2O, CO + H2, H, OH, HO2, H2O2 + CLY, BRY + CL -> Cl, CL2 -> Cl2, CLO -> ClO, OCLO -> OClO, CL2O2 -> Cl2O2 + HCL -> HCl, HOCL -> HOCl, CLONO2 -> ClONO2, BRCL -> BrCl + BR -> Br, BRO -> BrO, HBR -> HBr, HOBR -> HOBr, BRONO2 -> BrONO2 + HCN, CH3CN, C2H4, C2H6, C2H5O2, C2H5OOH, CH3CO3, CH3COOH, CH3CHO, C2H5OH, GLYALD -> HOCH2CHO + GLYOXAL -> C2H2O2, CH3COOOH, EO2 -> HOCH2CH2O2, EO -> HOCH2CH2O, PAN -> CH3CO3NO2 + C3H6, C3H8, C3H7O2, C3H7OOH, CH3COCH3, PO2 -> C3H6OHO2, POOH -> C3H6OHOOH, HYAC -> CH3COCH2OH + RO2 -> CH3COCH2O2, CH3COCHO, ROOH -> CH3COCH2OOH + BIGENE -> C4H8, BIGALK -> C5H12, MEK -> C4H8O, ENEO2 -> C4H9O3, MEKO2 -> C4H7O3, MEKOOH -> C4H8O3 + MCO3 -> CH2CCH3CO3, MVK -> CH2CHCOCH3, MACR -> CH2CCH3CHO + MACRO2 -> CH3COCHO2CH2OH, MACROOH -> CH3COCHOOHCH2OH, MPAN -> CH2CCH3CO3NO2, ONIT -> CH3COCH2ONO2 + ISOP -> C5H8, ALKO2 -> C5H11O2, ALKOOH -> C5H12O2, BIGALD -> C5H6O2, HYDRALD -> HOCH2CCH3CHCHO + ISOPO2 -> HOCH2COOCH3CHCH2, ISOPNO3 -> CH2CHCCH3OOCH2ONO2, ONITR -> CH2CCH3CHONO2CH2OH + XO2 -> HOCH2COOCH3CHOHCHO, XOOH -> HOCH2COOHCH3CHOHCHO, ISOPOOH -> HOCH2COOHCH3CHCH2 + TOLUENE -> C7H8, CRESOL -> C7H8O, TOLO2 -> C7H9O5, TOLOOH -> C7H10O6, XOH -> C7H10O6 + C10H16, TERPO2 -> C10H17O3, TERPOOH -> C10H18O3 + CH3CL -> CH3Cl, CH3BR -> CH3Br, CFC11 -> CFCl3, CFC12 -> CF2Cl2 + CFC113 -> CCl2FCClF2, HCFC22 -> CHF2Cl, CCL4 -> CCl4, CH3CCL3 -> CH3CCl3 + CF3BR -> CF3Br, CF2CLBR -> CF2ClBr, CO2, N2p -> N2, O2p -> O2 + Np -> N, Op -> O, NOp -> NO, e, N2D -> N, H2O + C2H2, HCOOH, HOCH2OO + End Solution + + Fixed + M, N2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + END Species + + Solution classes + Explicit + CH4, N2O, CO, H2, CH3CL, CH3BR, CFC11, CFC12, CFC113 + HCFC22, CCL4, CH3CCL3, CF3BR, CF2CLBR, CO2, CLY, BRY + End explicit + Implicit + O3, O, O1D, O2, O2_1S, O2_1D + N, NO, NO2, OH, NO3, HNO3, HO2NO2, N2O5 + CH3O2, CH3OOH, HCN, CH3CN, CH2O, H, HO2, H2O2, H2O + CL, CL2, CLO, OCLO, CL2O2, HCL, HOCL, CLONO2, BRCL + BR, BRO, HBR, HOBR, BRONO2, N2p, O2p, Np, Op, NOp, N2D, e + C3H6, ISOP, PO2, CH3CHO, CH3COOH + POOH, CH3CO3, CH3COOOH, PAN, ONIT, C2H6, C2H4, BIGALK, MPAN + BIGENE, ENEO2, ALKO2, ALKOOH, MEK, MEKO2, MEKOOH, TOLUENE + CRESOL, TOLO2, TOLOOH, XOH, TERPO2, TERPOOH, BIGALD, GLYOXAL + ISOPO2, MVK, MACR, MACRO2, MACROOH + MCO3, C2H5O2, C2H5OOH, C10H16 + C3H8, C3H7O2, C3H7OOH, CH3COCH3, ROOH + CH3OH, C2H5OH, GLYALD, HYAC, EO2 + EO, HYDRALD, RO2, CH3COCHO, ISOPNO3, ONITR + XO2, XOOH, ISOPOOH + C2H2, HCOOH, HOCH2OO + End implicit + End Solution classes + + CHEMISTRY + Photolysis + [jo2_a=userdefined,] O2 + hv -> O + O1D + [jo2_b=userdefined,] O2 + hv -> 2*O + [jo3_a] O3 + hv -> O1D + O2_1D + [jo3_b] O3 + hv -> O + O2 + [jn2o] N2O + hv -> O1D + N2 + [jno=userdefined,] NO + hv -> N + O + [jno_i] NO + hv -> NOp + e + [jno2] NO2 + hv -> NO + O + [jn2o5_a] N2O5 + hv -> NO2 + NO3 + [jn2o5_b] N2O5 + hv -> NO + O + NO3 + [jhno3] HNO3 + hv -> NO2 + OH + [jno3_a] NO3 + hv -> NO2 + O + [jno3_b] NO3 + hv -> NO + O2 + [jho2no2_a] HO2NO2 + hv -> OH + NO3 + [jho2no2_b] HO2NO2 + hv -> NO2 + HO2 + [jch3ooh] CH3OOH + hv -> CH2O + H + OH + [jch2o_a] CH2O + hv -> CO + 2*H + [jch2o_b] CH2O + hv -> CO + H2 + [jh2o_a] H2O + hv -> OH + H + [jh2o_b] H2O + hv -> H2 + O1D + [jh2o_c] H2O + hv -> 2*H + O + [jh2o2] H2O2 + hv -> 2*OH + [jcl2] CL2 + hv -> 2*CL + [joclo] OCLO + hv -> O + CLO + [jcl2o2] CL2O2 + hv -> 2*CL + [jhocl] HOCL + hv -> OH + CL + [jhcl] HCL + hv -> H + CL + [jclono2_a] CLONO2 + hv -> CL + NO3 + [jclono2_b] CLONO2 + hv -> CLO + NO2 + [jbrcl] BRCL + hv -> BR + CL + [jbro] BRO + hv -> BR + O + [jhobr] HOBR + hv -> BR + OH + [jbrono2_a] BRONO2 + hv -> BR + NO3 + [jbrono2_b] BRONO2 + hv -> BRO + NO2 + [jch3cl] CH3CL + hv -> CL + CH3O2 + [jccl4] CCL4 + hv -> 4*CL + [jch3ccl3] CH3CCL3 + hv -> 3*CL + [jcfcl3] CFC11 + hv -> 3*CL + [jcf2cl2] CFC12 + hv -> 2*CL + [jcfc113] CFC113 + hv -> 3*CL + [jhcfc22] HCFC22 + hv -> CL + [jch3br] CH3BR + hv -> BR + CH3O2 + [jcf3br] CF3BR + hv -> BR + [jcf2clbr] CF2CLBR + hv -> BR + CL + [jco2] CO2 + hv -> CO + O + [jch4_a] CH4 + hv -> H + CH3O2 + [jch4_b] CH4 + hv -> 1.44*H2 + .18*CH2O + .18*O + .66*OH + .44*CO2 + .38*CO + .05*H2O + [jch3cho] CH3CHO + hv -> CH3O2 + CO + HO2 + [jpooh->,jch3ooh] POOH + hv -> CH3CHO + CH2O + HO2 + OH + [jch3co3h->,0.28*jh2o2] CH3COOOH + hv -> CH3O2 + OH + CO2 + [jpan] PAN + hv -> .6*CH3CO3 + .6*NO2 + .4*CH3O2 + .4*NO3 + [jmpan->,jpan] MPAN + hv -> MCO3 + NO2 + [jmacr_a] MACR -> 1.34 * HO2 + .66 * MCO3 + 1.34 * CH2O + 1.34 * CH3CO3 + [jmacr_b] MACR -> .66 * OH + 1.34 * CO + [jmvk] MVK + hv -> .7 * C3H6 + .7 * CO + .3 * CH3O2 + .3 * CH3CO3 + [jc2h5ooh->,jch3ooh] C2H5OOH + hv -> CH3CHO + HO2 + OH + [jc3h7ooh->,jch3ooh] C3H7OOH + hv -> 0.82 * CH3COCH3 + OH + HO2 + [jrooh->,jch3ooh] ROOH + hv -> CH3CO3 + CH2O + OH + [jacet] CH3COCH3 + hv -> CH3CO3 + CH3O2 + [jmgly] CH3COCHO + hv -> CH3CO3 + CO + HO2 + [jxooh->,jch3ooh] XOOH + hv -> OH + [jonitr->,jch3ooh] ONITR + hv -> HO2 + CO + NO2 + CH2O + [jisopooh->,jch3ooh] ISOPOOH + hv -> .402 * MVK + .288 * MACR + .69 * CH2O + HO2 + [jhyac] HYAC + hv -> CH3CO3 + HO2 + CH2O + [jglyald] GLYALD + hv -> 2 * HO2 + CO + CH2O + [jmek->,jacet] MEK + hv -> CH3CO3 + C2H5O2 + [jbigald->,0.2*jno2] BIGALD + hv -> .45*CO + .13*GLYOXAL +.56*HO2 + .13*CH3CO3 + .18*CH3COCHO + [jglyoxal->,jmgly] GLYOXAL + hv -> 2*CO + 2*HO2 + [jalkooh->,jch3ooh] ALKOOH + hv -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 + .9*HO2 + .8*MEK + OH + [jmekooh->,jch3ooh] MEKOOH + hv -> OH + CH3CO3 + CH3CHO + [jtolooh->,jch3ooh] TOLOOH + hv -> OH + .45*GLYOXAL + .45*CH3COCHO + .9*BIGALD + [jterpooh->,jch3ooh] TERPOOH + hv -> OH + .1*CH3COCH3 + HO2 + MVK + MACR + +*------------------------------------------------------------------------------ +* photo-ionization +*------------------------------------------------------------------------------ + [jeuv_1=userdefined,userdefined] O + hv -> Op + e + [jeuv_2=userdefined,userdefined] O + hv -> Op + e + [jeuv_3=userdefined,userdefined] O + hv -> Op + e + [jeuv_4=userdefined,userdefined] N + hv -> Np + e + [jeuv_5=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_6=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_7=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_8=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_9=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_10=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_11=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_12=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_13=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + [jeuv_14=userdefined,userdefined] O + hv -> Op + e + [jeuv_15=userdefined,userdefined] O + hv -> Op + e + [jeuv_16=userdefined,userdefined] O + hv -> Op + e + [jeuv_17=userdefined,userdefined] O2 + hv -> O2p + e + [jeuv_18=userdefined,userdefined] N2 + hv -> N2p + e + [jeuv_19=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_20=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_21=userdefined,userdefined] O2 + hv -> O + Op + e + [jeuv_22=userdefined,userdefined] N2 + hv -> N + Np + e + [jeuv_23=userdefined,userdefined] N2 + hv -> N2D + Np + e + [jeuv_24=userdefined,userdefined] O2 + hv -> 2*O + [jeuv_25=userdefined,userdefined] N2 + hv -> 1.2*N2D + .8*N + [jeuv_26=userdefined,userdefined] CO2 + hv -> CO + O + End Photolysis + + Reactions +* -------------------------------------------------------------- +* Odd-Oxygen Reactions +* -------------------------------------------------------------- + [usr_O_O2] O + O2 + M -> O3 + M + [cph1,cph] O + O3 -> 2*O2 ; 8.00e-12, -2060. + [usr_O_O] O + O + M -> O2 + M + [cph18,cph] O2_1S + O -> O2_1D + O ; 8.00e-14 + [cph19,cph] O2_1S + O2 -> O2_1D + O2 ; 3.90e-17 + [cph20,cph] O2_1S + N2 -> O2_1D + N2 ; 1.80e-15, 45. + [cph21,cph] O2_1S + O3 -> O2_1D + O3 ; 3.50e-11, -135. + O2_1S + CO2 -> O2_1D + CO2 ; 4.20e-13 + [ag2,cph] O2_1S -> O2 ; 8.50e-2 + [cph22,cph] O2_1D + O -> O2 + O ; 1.30e-16 + [cph23,cph] O2_1D + O2 -> 2 * O2 ; 3.60e-18, -220. + [cph24,cph] O2_1D + N2 -> O2 + N2 ; 1.00e-20 + [ag1,cph] O2_1D -> O2 ; 2.58e-04 +* -------------------------------------------------------------- +* Odd-Oxygen Reactions (O1D only) +* -------------------------------------------------------------- + [cph17,cph] O1D + N2 -> O + N2 ; 2.15e-11, 110. + [cph16,cph] O1D + O2 -> O + O2_1S ; 3.135e-11, 55. + [cph29,cph] O1D + O2 -> O + O2 ; 1.65e-12, 55. + O1D + H2O -> 2*OH ; 1.63e-10, 60. + O1D + N2O -> 2*NO ; 6.70e-11, 20. + O1D + N2O -> N2 + O2 ; 4.70e-11, 20. + O1D + O3 -> O2 + O2 ; 1.20e-10 + O1D + CFC11 -> 3*CL ; 1.70e-10 + O1D + CFC12 -> 2*CL ; 1.20e-10 + O1D + CFC113 -> 3*CL ; 1.50e-10 + O1D + HCFC22 -> CL ; 7.20e-11 + O1D + CCL4 -> 4*CL ; 2.84e-10 + O1D + CH3BR -> BR ; 1.80e-10 + O1D + CF2CLBR -> BR ; 9.60e-11 + O1D + CF3BR -> BR ; 4.10e-11 + O1D + CH4 -> CH3O2 + OH ; 1.125e-10 + O1D + CH4 -> CH2O + H + HO2 ; 3.00e-11 + O1D + CH4 -> CH2O + H2 ; 7.50e-12 + O1D + H2 -> H + OH ; 1.10e-10 + O1D + HCL -> CL + OH ; 1.50e-10 + O1D + HBR -> BR + OH ; 1.50e-10 + O1D + HCN -> HO2 ; 7.70e-11, 100. +* -------------------------------------------------------------- +* Odd Hydrogen Reactions +* -------------------------------------------------------------- + [cph5,cph] H + O2 + M -> HO2 + M ; 4.40e-32, 1.3, 4.70e-11, 0.2, 0.6 + [cph7,cph] H + O3 -> OH + O2 ; 1.40e-10, -470. + H + HO2 -> 2*OH ; 7.20e-11 + [cph15,cph] H + HO2 -> H2 + O2 ; 6.90e-12 + H + HO2 -> H2O + O ; 1.60e-12 + [cph3,cph] OH + O -> H + O2 ; 2.20e-11, 120. + [cph11,cph] OH + O3 -> HO2 + O2 ; 1.70e-12, -940. + [cph14,cph] OH + HO2 -> H2O + O2 ; 4.80e-11, 250. + OH + OH -> H2O + O ; 1.80e-12 + OH + OH + M -> H2O2 + M ; 6.90e-31, 1.0, 2.60e-11, 0.0, 0.6 + OH + H2 -> H2O + H ; 2.80e-12, -1800. + OH + H2O2 -> H2O + HO2 ; 1.80e-12 + [cph4,cph] HO2 + O -> OH + O2 ; 3.00e-11, 200. + [cph9,cph] HO2 + O3 -> OH + 2*O2 ; 1.00e-14, -490. + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + O2 + H2O2 + O -> OH + HO2 ; 1.40e-12, -2000. + HCN + OH -> HO2 ; 4.28e-33, 0.0, 9.30e-15, -4.42, 0.8 + CH3CN + OH -> HO2 ; 7.80e-13, -1050. + +* -------------------------------------------------------------- +* Odd Nitrogen Reactions +* -------------------------------------------------------------- + [cph25,cph] N2D + O2 -> NO + O1D ; 5.00e-12 +*[cph26,cph] N2D + O -> N + O ; 4.50e-13 + [cph26,cph] N2D + O -> N + O ; 7.00e-13 + [cph27,cph] N + O2 -> NO + O ; 1.50e-11, -3600. + [cph28,cph] N + NO -> N2 + O ; 2.10e-11, 100. + N + NO2 -> N2O + O ; 5.80e-12, 220. + NO + O + M -> NO2 + M ; 9.00e-32, 1.5, 3.0e-11, 0.0, 0.6 + [cph8,cph] NO + HO2 -> NO2 + OH ; 3.50e-12, 250. + [cph12,cph] NO + O3 -> NO2 + O2 ; 3.00e-12, -1500. + [cph13,cph] NO2 + O -> NO + O2 ; 5.20e-12, 210. + NO2 + O + M -> NO3 + M ; 2.50e-31, 1.8, 2.2e-11, 0.7, 0.6 + NO2 + O3 -> NO3 + O2 ; 1.20e-13, -2450. + [tag_NO2_NO3] NO2 + NO3 + M -> N2O5 + M ; 2.00e-30, 4.4, 1.4e-12, 0.7, 0.6 + [usr_N2O5_M] N2O5 + M -> NO2 + NO3 + M + [tag_NO2_OH] NO2 + OH + M -> HNO3 + M ; 1.80e-30, 3.0, 2.8e-11, 0.0, 0.6 + [usr_HNO3_OH] HNO3 + OH -> NO3 + H2O + NO3 + NO -> 2*NO2 ; 1.50e-11, 170. + NO3 + O -> NO2 + O2 ; 1.00e-11 + NO3 + OH -> HO2 + NO2 ; 2.20e-11 + NO3 + HO2 -> OH + NO2 + O2 ; 3.50e-12 + [tag_NO2_HO2] NO2 + HO2 + M -> HO2NO2 + M ; 2.00e-31, 3.4, 2.9e-12, 1.1, 0.6 + HO2NO2 + OH -> H2O + NO2 + O2 ; 1.30e-12, 380. + [usr_HO2NO2_M] HO2NO2 + M -> HO2 + NO2 + M + +* -------------------------------------------------------------- +* Odd Chlorine Reactions +* -------------------------------------------------------------- + CL + O3 -> CLO + O2 ; 2.30e-11, -200. + CL + H2 -> HCL + H ; 3.05e-11, -2270. + CL + H2O2 -> HCL + HO2 ; 1.10e-11, -980. + CL + HO2 -> HCL + O2 ; 1.80e-11, 170. + CL + HO2 -> OH + CLO ; 4.10e-11, -450. + CL + CH2O -> HCL + HO2 + CO ; 8.10e-11, -30. + CL + CH4 -> CH3O2 + HCL ; 7.30e-12, -1280. + CLO + O -> CL + O2 ; 2.80e-11, 85. + CLO + OH -> CL + HO2 ; 7.40e-12, 270. + CLO + OH -> HCL + O2 ; 6.00e-13, 230. + CLO + HO2 -> O2 + HOCL ; 2.70e-12, 220. + CLO + NO -> NO2 + CL ; 6.40e-12 , 290. + CLO + NO2 + M -> CLONO2 + M ; 1.80e-31, 3.4, 1.5e-11, 1.9, 0.6 + CLO + CLO -> 2*CL + O2 ; 3.00e-11, -2450. + CLO + CLO -> CL2 + O2 ; 1.00e-12, -1590. + CLO + CLO -> CL + OCLO ; 3.50e-13, -1370. + [tag_CLO_CLO] CLO + CLO + M -> CL2O2 + M ; 1.60e-32, 4.5, 2.0e-12, 2.4, 0.6 + [usr_CL2O2_M] CL2O2 + M -> CLO + CLO + M + HCL + OH -> H2O + CL ; 2.60e-12, -350. + HCL + O -> CL + OH ; 1.00e-11, -3300. + HOCL + O -> CLO + OH ; 1.70e-13 + HOCL + CL -> HCL + CLO ; 2.50e-12, -130. + HOCL + OH -> H2O + CLO ; 3.00e-12, -500. + CLONO2 + O -> CLO + NO3 ; 2.90e-12, -800. + CLONO2 + OH -> HOCL + NO3 ; 1.20e-12, -330. + CLONO2 + CL -> CL2 + NO3 ; 6.50e-12, 135. + +* -------------------------------------------------------------- +* Odd Bromine Reactions +* -------------------------------------------------------------- + BR + O3 -> BRO + O2 ; 1.70e-11, -800. + BR + HO2 -> HBR + O2 ; 4.80e-12, -310. + BR + CH2O -> HBR + HO2 + CO ; 1.70e-11, -800. + BRO + O -> BR + O2 ; 1.90e-11, 230. + BRO + OH -> BR + HO2 ; 1.70e-11, 250. + BRO + HO2 -> HOBR + O2 ; 4.50e-12, 460. + BRO + NO -> BR + NO2 ; 8.80e-12, 260. + BRO + NO2 + M -> BRONO2 + M ; 5.20e-31, 3.2, 6.9e-12, 2.9, 0.6 + BRO + CLO -> BR + OCLO ; 9.50e-13, 550. + BRO + CLO -> BR + CL + O2 ; 2.30e-12, 260. + BRO + CLO -> BRCL + O2 ; 4.10e-13, 290. + BRO + BRO -> 2*BR + O2 ; 1.50e-12, 230. + HBR + OH -> BR + H2O ; 5.50e-12, 200. + HBR + O -> BR + OH ; 5.80e-12, -1500. + HOBR + O -> BRO + OH ; 1.20e-10, -430. + BRONO2 + O -> BRO + NO3 ; 1.90e-11, 215. +* -------------------------------------------------------------- +* Organic Halogens Reactions with Cl, OH +* -------------------------------------------------------------- + CH3CL + CL -> HO2 + CO + 2*HCL ; 2.17e-11, -1130. + CH3CL + OH -> CL + H2O + HO2 ; 2.40e-12, -1250. + CH3CCL3 + OH -> H2O + 3*CL ; 1.64e-12, -1520. + HCFC22 + OH -> CL + H2O + CF2O ; 1.05e-12, -1600. + CH3BR + OH -> BR + H2O + HO2 ; 2.35e-12, -1300. + +* -------------------------------------------------------------- +* C-1 Degradation (Methane, CO, CH2O and derivatives) +* -------------------------------------------------------------- + CH4 + OH -> CH3O2 + H2O ; 2.45e-12, -1775. + CH3O2 + NO -> CH2O + NO2 + HO2 ; 2.80e-12, 300. + CH3O2 + HO2 -> CH3OOH + O2 ; 4.10e-13, 750. + CH3OOH + OH -> CH3O2 + H2O ; 3.80e-12, 200. + CH2O + NO3 -> CO + HO2 + HNO3 ; 6.00e-13, -2058. + CH2O + OH -> CO + H2O + H ; 5.50e-12, 125. + CH2O + O -> HO2 + OH + CO ; 3.40e-11, -1600. + CO + OH + M -> CO2 + HO2 + M ; 5.90e-33, 1.4, 1.10e-12, -1.3, 0.6 + [usr_CO_OH_b] CO + OH -> CO2 + H + CH3O2 + CH3O2 -> 2 * CH2O + 2 * HO2 ; 5.00e-13, -424. + CH3O2 + CH3O2 -> CH2O + CH3OH ; 1.90e-14, 706. + CH3OH + OH -> HO2 + CH2O ; 2.90e-12, -345. + CH3OOH + OH -> .7 * CH3O2 + .3 * OH + .3 * CH2O + H2O ; 3.80e-12, 200. +*new (HCOOH+OH, etc.) + HCOOH + OH -> HO2 + CO2 + H2O ; 4.5e-13 + CH2O + HO2 -> HOCH2OO ; 9.7e-15, 625. + HOCH2OO -> CH2O + HO2 ; 2.4e12, -7000. + HOCH2OO + NO -> HCOOH + NO2 + HO2 ; 2.6e-12, 265. + HOCH2OO + HO2 -> HCOOH ; 7.5e-13, 700. + +* -------------------------------------------------------------- +* C-2 Degradation +* +* EO = HOCH2CH2O +* EO2 = HOCH2CH2O2 +* PAN = CH3CO3NO2 +* GLYALD = HOCH2CHO +* GLYOXAL= C2H2O2 +* C2H2 = C2H2 +* -------------------------------------------------------------- + C2H2 + CL + M -> CL ; 5.20e-30, 2.4, 2.2e-10, 0.7, 0.6 + C2H4 + CL + M -> CL ; 1.60e-29, 3.3, 3.1e-10, 1.0, 0.6 + C2H6 + CL -> HCL + C2H5O2 ; 7.20e-11, -70. + C2H2 + OH + M -> .65*GLYOXAL + .65*OH + .35*HCOOH + .35*HO2 ; 5.50e-30, 0.0, 8.3e-13, -2.0, 0.6 + + .35*CO + M + C2H6 + OH -> C2H5O2 + H2O ; 8.70e-12, -1070. + [tag_C2H4_OH] C2H4 + OH + M -> .75*EO2 + .5*CH2O + .25*HO2 + M ; 1.00e-28, 0.8, 8.80e-12, 0.0, 0.6 +* C2H4 + O3 -> CH2O + .12 * HO2 + .5 * CO ; 1.2e-14, -2630. +* + .12 * OH + .32 * CH3COOH + C2H4 + O3 -> CH2O + .12*HO2 + .5*CO + .12*OH + .5*HCOOH ; 1.2e-14, -2630. + CH3COOH + OH -> CH3O2 + CO2 + H2O ; 7.00e-13 + C2H5O2 + NO -> CH3CHO + HO2 + NO2 ; 2.60e-12, 365. + C2H5O2 + HO2 -> C2H5OOH + O2 ; 7.50e-13, 700. + C2H5O2 + CH3O2 -> .7 * CH2O + .8 * CH3CHO + HO2 ; 2.00e-13 + + .3 * CH3OH + .2 * C2H5OH + C2H5O2 + C2H5O2 -> 1.6 * CH3CHO + 1.2 * HO2 + .4 * C2H5OH ; 6.80e-14 + C2H5OOH + OH -> .5 * C2H5O2 + .5 * CH3CHO + .5 * OH ; 3.80e-12, 200. + CH3CHO + OH -> CH3CO3 + H2O ; 5.60e-12, 270. + CH3CHO + NO3 -> CH3CO3 + HNO3 ; 1.40e-12, -1900. + CH3CO3 + NO -> CH3O2 + CO2 + NO2 ; 8.10e-12, 270. + [tag_CH3CO3_NO2] CH3CO3 + NO2 + M -> PAN + M ; 8.50e-29, 6.5, 1.10e-11, 1.0, 0.6 + CH3CO3 + HO2 -> .75 * CH3COOOH + .25 * CH3COOH + .25 * O3 ; 4.30e-13, 1040. + CH3CO3 + CH3O2 -> .9*CH3O2 + CH2O + .9*HO2 ; 2.00e-12, 500. + + .9*CO2 + .1*CH3COOH + CH3CO3 + CH3CO3 -> 2*CH3O2 + 2*CO2 ; 2.50e-12, 500. + CH3COOOH + OH -> .5*CH3CO3 + .5*CH2O + .5*CO2 + H2O ; 1.00e-12 + EO2 + NO -> EO + NO2 ; 4.20e-12, 180. + EO + O2 -> GLYALD + HO2 ; 1.00e-14 + EO -> 2 * CH2O + HO2 ; 1.60e11, -4150. + GLYALD + OH -> HO2 + .2*GLYOXAL + .8*CH2O + .8*CO2 ; 1.00e-11 + GLYOXAL + OH -> HO2 + CO + CO2 ; 1.15e-11 + C2H5OH + OH -> HO2 + CH3CHO ; 6.90e-12, -230. + [usr_PAN_M] PAN + M -> CH3CO3 + NO2 + M + PAN + OH -> CH2O + NO3 ; 4.00e-14 + +* -------------------------------------------------------------- +* C-3 Degradation +* +* PO2 = C3H6OHO2 +* POOH = C3H6OHOOH +* RO2 = CH3COCH2O2 +* ROOH = CH3COCH2OOH +* HYAC = CH3COCH2OH +* ONIT = CH3COCH2ONO2 +* -------------------------------------------------------------- + [tag_C3H6_OH] C3H6 + OH + M -> PO2 + M ; 8.00e-27, 3.5, 3.00e-11, 0.0, 0.5 + C3H6 + O3 -> .54*CH2O + .19*HO2 + .33*OH + .08*CH4 ; 6.50e-15, -1900. + + .56*CO + .5*CH3CHO + .31*CH3O2 + .25*CH3COOH + C3H6 + NO3 -> ONIT ; 4.60e-13, -1156. + C3H7O2 + NO -> .82 * CH3COCH3 + NO2 + HO2 + .27 * CH3CHO ; 4.20e-12, 180. + C3H7O2 + HO2 -> C3H7OOH + O2 ; 7.50e-13, 700. + C3H7O2 + CH3O2 -> CH2O + HO2 + .82 * CH3COCH3 ; 3.75e-13, -40. + C3H7OOH + OH -> H2O + C3H7O2 ; 3.80e-12, 200. + C3H8 + OH -> C3H7O2 + H2O ; 8.70e-12, -615. + PO2 + NO -> CH3CHO + CH2O + HO2 + NO2 ; 4.20e-12, 180. + PO2 + HO2 -> POOH + O2 ; 7.50e-13, 700. + POOH + OH -> .5*PO2 + .5*OH + .5*HYAC + H2O ; 3.80e-12, 200. + [usr_CH3COCH3_OH] CH3COCH3 + OH -> RO2 + H2O + RO2 + NO -> CH3CO3 + CH2O + NO2 ; 2.90e-12, 300. + RO2 + HO2 -> ROOH + O2 ; 8.60e-13, 700. + RO2 + CH3O2 -> .3*CH3CO3 + .8* CH2O + .3*HO2 + .2*HYAC ; 7.10e-12, 500. + + .5*CH3COCHO + .5*CH3OH + ROOH + OH -> RO2 + H2O ; 3.80e-12, 200. + HYAC + OH -> CH3COCHO + HO2 ; 1.20e-12 + CH3COCHO + OH -> CH3CO3 + CO + H2O ; 8.40e-13, 830. + CH3COCHO + NO3 -> HNO3 + CO + CH3CO3 ; 1.40e-12, -1860. + ONIT + OH -> NO2 + CH3COCHO ; 6.80e-13 + +* -------------------------------------------------------------- +* C-4 Degradation +* BIGENE -> C4H8 +* ENEO2 = C4H9O3 +* MEK = C4H8O +* MEKO2 = C4H7O3 +* MEKOOH = C4H8O3 +* MVK = CH2CHCOCH3 +* MACR = CH2CCH3CHO +* MACRO2 = CH3COCHO2CH2OH +* MACROOH = CH3COCHOOHCH2OH +* MCO3 = CH2CCH3CO3 +* MPAN = CH2CCH3CO3NO2 +* -------------------------------------------------------------- + BIGENE + OH -> ENEO2 ; 5.40e-11 + ENEO2 + NO -> CH3CHO + .5*CH2O + .5*CH3COCH3 + HO2 + NO2 ; 4.20e-12, 180. + MVK + OH -> MACRO2 ; 4.13e-12, 452. + MVK + O3 -> .8 * CH2O + .95 * CH3COCHO + .08 * OH ; 7.52e-16, -1521. + + .2 * O3 + .06 * HO2 + .05 * CO + .04 * CH3CHO + MEK + OH -> MEKO2 ; 2.30e-12, -170. + MEKO2 + NO -> CH3CO3 + CH3CHO + NO2 ; 4.20e-12, 180. + MEKO2 + HO2 -> MEKOOH ; 7.50e-13, 700. + MEKOOH + OH -> MEKO2 ; 3.80e-12, 200. + MACR + OH -> .5 * MACRO2 + .5 * H2O + .5 * MCO3 ; 1.86e-11, 175. + MACR + O3 -> .8 * CH3COCHO + .275 * HO2 + .2 * CO ; 4.40e-15, -2500. + + .2 * O3 + .7 * CH2O + .215 * OH + MACRO2 + NO -> NO2 + .47 * HO2 + .25 * CH2O ; 2.70e-12, 360. + + .53 * GLYALD + .25 * CH3COCHO + + .53 * CH3CO3 + .22 * HYAC + .22 * CO + MACRO2 + NO -> 0.8*ONITR ; 1.30e-13, 360. + MACRO2 + NO3 -> NO2 + .47 * HO2 + .25 * CH2O ; 2.40e-12 + + .25 * CH3COCHO + .22 * CO + + .53 * GLYALD + .22*HYAC + .53*CH3CO3 + MACRO2 + HO2 -> MACROOH ; 8.00e-13, 700. + MACRO2 + CH3O2 -> .73 * HO2 + .88 * CH2O + .11 * CO ; 5.00e-13, 400. + + .24 * CH3COCHO + + .26 * GLYALD + .26 * CH3CO3 + + .25 * CH3OH + .23 * HYAC + MACRO2 + CH3CO3 -> .25 * CH3COCHO + CH3O2 + .22 * CO ; 1.40e-11 + + .47 * HO2 + .53 * GLYALD + + .22 * HYAC + .25*CH2O + .53*CH3CO3 + MACROOH + OH -> .5 * MCO3 + .2*MACRO2 + .1*OH + .2*HO2 ; 2.30e-11, 200. + MCO3 + NO -> NO2 + CH2O + CH3CO3 ; 5.30e-12, 360. + MCO3 + NO3 -> NO2 + CH2O + CH3CO3 ; 5.00e-12 + MCO3 + HO2 -> .25 * O3 + .25 * CH3COOH + .75 * CH3COOOH ; 4.30e-13, 1040. + + .75 * O2 + MCO3 + CH3O2 -> 2 * CH2O + HO2 + CO2 + CH3CO3 ; 2.00e-12, 500. + MCO3 + CH3CO3 -> 2 * CO2 + CH3O2 + CH2O + CH3CO3 ; 4.60e-12, 530. + MCO3 + MCO3 -> 2 * CO2 + 2 * CH2O + 2 * CH3CO3 ; 2.30e-12, 530. + [usr_MCO3_NO2] MCO3 + NO2 + M -> MPAN + M + [usr_MPAN_M] MPAN + M -> MCO3 + NO2 + M + MPAN + OH -> .5 * HYAC + .5 * NO3 + .5 * CH2O + .5 *HO2 ; 8.00e-27, 3.5, 3.00e-11, 0.0, 0.5 + +* -------------------------------------------------------------- +* C-5 Degradation +* +* ISOP = C5H8 +* ISOPO2 = HOCH2COOCH3CHCH2 +* ISOPNO3 = CH2CHCCH3OOCH2ONO2 +* ISOPOOH = HOCH2COOHCH3CHCH2 +* BIGALK = C5H12, +* ALKO2 = C5H11O2 +* ALKOOH = C5H12O2 +* ONITR = CH2CCH3CHONO2CH2OH +* XO2 = HOCH2COOCH3CHOHCHO +* XOOH = HOCH2COOHCH3CHOHCHO +* -------------------------------------------------------------- + ISOP + OH -> ISOPO2 ; 2.54e-11, 410. + ISOP + O3 -> .4 * MACR + .2 * MVK + .07 * C3H6 + .27 * OH ; 1.05e-14, -2000. + + .06 * HO2 + .6 * CH2O + .3 * CO + .1 * O3 + + .2 * MCO3 + .2 * CH3COOH + ISOP + NO3 -> ISOPNO3 ; 3.03e-12, -446. + ISOPO2 + NO -> .08 * ONITR + .92 * NO2 + HO2 + .51 * CH2O ; 4.40e-12, 180. + + .23 * MACR + .32 * MVK + .37 * HYDRALD + ISOPO2 + NO3 -> HO2 + NO2 + .6 * CH2O + .25 * MACR ; 2.40e-12 + + .35 * MVK + .4 * HYDRALD + ISOPO2 + HO2 -> ISOPOOH ; 8.00e-13, 700. + ISOPOOH + OH -> .8 * XO2 + .2 * ISOPO2 ; 1.52e-11, 200. + ISOPO2 + CH3O2 -> .25 * CH3OH + HO2 + 1.2 * CH2O ; 5.00e-13, 400. + + .19 * MACR + .26 * MVK + .3 * HYDRALD + ISOPO2 + CH3CO3 -> CH3O2 + HO2 + .6 * CH2O ; 1.40e-11 + + .25 * MACR + .35 * MVK + .4 * HYDRALD + ISOPNO3 + NO -> 1.206 * NO2 + .794 * HO2 + .072 * CH2O ; 2.70e-12, 360. + + .167 * MACR + .039 * MVK + .794 * ONITR + ISOPNO3 + NO3 -> 1.206 * NO2 + .072 * CH2O + .167 * MACR ; 2.40e-12 + + .039 * MVK + .794 * ONITR + .794 * HO2 + ISOPNO3 + HO2 -> XOOH + .206 * NO2 + .794 *HO2 + .008*CH2O ; 8.00e-13, 700. + + .167 * MACR + .039 * MVK + .794 * ONITR + BIGALK + OH -> ALKO2 ; 3.50e-12 + ONITR + OH -> HYDRALD + .4*NO2 + HO2 ; 4.50e-11 + ONITR + NO3 -> HO2 + NO2 + HYDRALD ; 1.40e-12, -1860. + HYDRALD + OH -> XO2 ; 1.86e-11, 175. + + + ALKO2 + NO -> .4*CH3CHO + .1*CH2O + .25*CH3COCH3 ; 4.20e-12, 180. + + .9*HO2 + .8*MEK + .9*NO2 + .1*ONIT + ALKO2 + HO2 -> ALKOOH ; 7.50e-13, 700. + ALKOOH + OH -> ALKO2 ; 3.80e-12, 200. + XO2 + NO -> NO2 + HO2 + .5*CO + .25*GLYOXAL ; 2.7e-12, 360. + + .25*HYAC + .25*CH3COCHO + .25*GLYALD + XO2 + NO3 -> NO2 + HO2 + 0.5*CO + .25*HYAC ; 2.40e-12 + + 0.25*GLYOXAL + .25*CH3COCHO + .25*GLYALD + XO2 + HO2 -> XOOH ; 8.00e-13, 700. + XO2 + CH3O2 -> .3 * CH3OH + .8*HO2 + .7 * CH2O ; 5.e-13, 400. + + .2 * CO + .1 * HYAC + .1*GLYOXAL + + .1 * CH3COCHO + .1 * GLYALD + XO2 + CH3CO3 -> .5*CO + CH3O2 + HO2 + CO2 + .25*HYAC ; 1.3e-12, 640. + + .25*GLYOXAL + .25 * CH3COCHO + .25 * GLYALD + XOOH + OH -> H2O + XO2 ; 1.90e-12, 190. + [usr_XOOH_OH] XOOH + OH -> H2O + OH + +* -------------------------------------------------------------- +* C-7 degradation +* +* TOLUENE = C7H8 +* CRESOL = C7H8O +* TOLO2 = C7H9O5 +* TOLOOH = C7H10O5 +* XOH = C7H10O6 +* -------------------------------------------------------------- + TOLUENE + OH -> .25*CRESOL + .25*HO2 + .7*TOLO2 ; 1.70e-12, 352. + TOLO2 + NO -> .45*GLYOXAL + .45*CH3COCHO +.9*BIGALD ; 4.20e-12, 180. + + .9*NO2 + .9*HO2 + TOLO2 + HO2 -> TOLOOH ; 7.50e-13, 700. + TOLOOH + OH -> TOLO2 ; 3.80e-12, 200. + CRESOL + OH -> XOH ; 3.00e-12 + XOH + NO2 -> .7*NO2 + .7*BIGALD + .7*HO2 ; 1.00e-11 + +* -------------------------------------------------------------- +* C-10 degradation +* +* TERPO2 = C10H17O3 +* TERPOOH = C10H18O3 +* -------------------------------------------------------------- + C10H16 + OH -> TERPO2 ; 1.2e-11, 444. + C10H16 + O3 -> .7*OH + MVK + MACR + HO2 ; 1.e-15, -732. + C10H16 + NO3 -> TERPO2 + NO2 ; 1.2e-12, 490. + TERPO2 + NO -> .1*CH3COCH3 + HO2 + MVK + MACR + NO2 ; 4.2e-12, 180. + TERPO2 + HO2 -> TERPOOH ; 7.5e-13, 700. + TERPOOH + OH -> TERPO2 ; 3.8e-12, 200. + +* -------------------------------------------------------------- +* Sulfate aerosol reactions +* -------------------------------------------------------------- + [het1] N2O5 -> 2*HNO3 + [het2] CLONO2 -> HOCL + HNO3 + [het3] BRONO2 -> HOBR + HNO3 + [het4] CLONO2 + HCL -> CL2 + HNO3 + [het5] HOCL + HCL -> CL2 + H2O + [het6] HOBR + HCL -> BRCL + H2O + +* -------------------------------------------------------------- +* Nitric acid Di-hydrate reactions +* -------------------------------------------------------------- + [het7] N2O5 -> 2*HNO3 + [het8] CLONO2 -> HOCL + HNO3 + [het9] CLONO2 + HCL -> CL2 + HNO3 + [het10] HOCL + HCL -> CL2 + H2O + [het11] BRONO2 -> HOBR + HNO3 + +* -------------------------------------------------------------- +* Ice aerosol reactions +* -------------------------------------------------------------- + [het12] N2O5 -> 2*HNO3 + [het13] CLONO2 -> HOCL + HNO3 + [het14] BRONO2 -> HOBR + HNO3 + [het15] CLONO2 + HCL -> CL2 + HNO3 + [het16] HOCL + HCL -> CL2 + H2O + [het17] HOBR + HCL -> BRCL + H2O + +* -------------------------------------------------------------- +* Ion reactions +* -------------------------------------------------------------- + [ion1] Op + O2 -> O2p + O + [ion2] Op + N2 -> NOp + N + Op + CO2 -> O2p + CO ; 9.0e-10 + [ion3] N2p + O -> NOp + N2D + [ion4,cph] O2p + N -> NOp + O ; 1.00e-10 + [ion5,cph] O2p + NO -> NOp + O2 ; 4.40e-10 + [ion6,cph] Np + O2 -> O2p + N ; 4.00e-10 + [ion7,cph] Np + O2 -> NOp + O ; 2.00e-10 + [ion8,cph] Np + O -> Op + N ; 1.00e-12 + [ion9,cph] N2p + O2 -> O2p + N2 ; 6.00e-11 + O2p + N2 -> NOp + NO ; 5.00e-16 + [ion11] N2p + O -> Op + N2 + [elec1] NOp + e -> .2*N + .8*N2D + O + [elec2] O2p + e -> 1.15*O + .85*O1D + [elec3] N2p + e -> 1.1*N + .9*N2D + End Reactions + + Ext Forcing + NO<-dataset, NO2<-dataset, CO<-dataset, Op, O2p, Np, N2p, N2D, N, e, OH + End Ext Forcing + + END Chemistry + + SIMULATION PARAMETERS + + Version Options + machine = intel + model = cam + model_architecture = SCALAR + architecture = hybrid + namemod = on + End Version Options + + End Simulation Parameters +ENDSIM diff --git a/chem_proc/procfiles/cam/mo_chem.mod b/chem_proc/procfiles/cam/mo_chem.mod new file mode 100644 index 0000000000..e1f6353fd0 --- /dev/null +++ b/chem_proc/procfiles/cam/mo_chem.mod @@ -0,0 +1,68 @@ + + module chem_mods +!-------------------------------------------------------------- +! ... Basic chemistry parameters and arrays +!-------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + + implicit none + + save + + integer, parameter :: phtcnt = PHTCNT, & ! number of photolysis reactions + rxntot = RXNCNT, & ! number of total reactions + gascnt = GASCNT, & ! number of gas phase reactions + nabscol = NCOL, & ! number of absorbing column densities + gas_pcnst = PCNST, & ! number of "gas phase" species + nfs = NFS, & ! number of "fixed" species + relcnt = RELCNT, & ! number of relationship species + grpcnt = GRPCNT, & ! number of group members + nzcnt = IMP_NZCNT, & ! number of non-zero matrix entries + extcnt = EXTCNT, & ! number of species with external forcing + clscnt1 = CLSCNT1, & ! number of species in explicit class + clscnt2 = CLSCNT2, & ! number of species in hov class + clscnt3 = CLSCNT3, & ! number of species in ebi class + clscnt4 = CLSCNT4, & ! number of species in implicit class + clscnt5 = CLSCNT5, & ! number of species in rodas class + indexm = INDEXM, & ! index of total atm density in invariant array + indexh2o = INDEXH2O, & ! index of water vapor density + clsze = CLSZE, & ! loop length for implicit chemistry + rxt_tag_cnt = RXTTAGCNT, & + enthalpy_cnt = ENTHALPYCNT, & + nslvd = NSLVD + + integer :: clscnt(5) = 0 + integer :: cls_rxt_cnt(4,5) = 0 + integer :: clsmap(gas_pcnst,5) = 0 + integer :: permute(gas_pcnst,5) = 0 +# if CLSCNT4 != 0 + integer :: diag_map(clscnt4) = 0 +# elif CLSCNT5 != 0 + integer :: diag_map(clscnt5) = 0 +# endif + real(r8) :: adv_mass(gas_pcnst) = 0._r8 + real(r8) :: crb_mass(gas_pcnst) = 0._r8 + real(r8) :: fix_mass(max(1,nfs)) +# if GRPCNT != 0 + real(r8) :: nadv_mass(grpcnt) = 0._r8 +# endif + real(r8), allocatable :: cph_enthalpy(:) + integer, allocatable :: cph_rid(:) + integer, allocatable :: num_rnts(:) + + integer, allocatable :: rxt_tag_map(:) + real(r8), allocatable :: pht_alias_mult(:,:) + character(len=32), allocatable :: rxt_tag_lst(:) + character(len=16), allocatable :: pht_alias_lst(:,:) + character(len=16) :: inv_lst(max(1,nfs)) + character(len=16) :: extfrc_lst(max(1,extcnt)) + logical :: frc_from_dataset(max(1,extcnt)) + logical :: is_vector + logical :: is_scalar + character(len=16) :: slvd_lst(max(1,nslvd)) +# if VECLEN !=0 + integer, parameter :: veclen = VECLEN +# endif + + end module chem_mods diff --git a/chem_proc/procfiles/cam/mo_exp_sol_scalar.F90 b/chem_proc/procfiles/cam/mo_exp_sol_scalar.F90 new file mode 100644 index 0000000000..0824807a06 --- /dev/null +++ b/chem_proc/procfiles/cam/mo_exp_sol_scalar.F90 @@ -0,0 +1,102 @@ + +module mo_exp_sol + + private + public :: exp_sol + public :: exp_sol_inti + +contains + + subroutine exp_sol_inti + + use mo_tracname, only : solsym + use chem_mods, only : clscnt1, clsmap + use ppgrid, only : pver + use cam_history, only : addfld + + implicit none + + integer :: i,j + + do i = 1,clscnt1 + + j = clsmap(i,1) + call addfld( trim(solsym(j))//'_CHMP', (/ 'lev' /), 'I', '/cm3/s', 'chemical production rate' ) + call addfld( trim(solsym(j))//'_CHML', (/ 'lev' /), 'I', '/cm3/s', 'chemical loss rate' ) + + enddo + end subroutine exp_sol_inti + + + subroutine exp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, xhnm, ncol, lchnk, ltrop ) + !----------------------------------------------------------------------- + ! ... Exp_sol advances the volumetric mixing ratio + ! forward one time step via the fully explicit + ! Euler scheme + !----------------------------------------------------------------------- + + use chem_mods, only : clscnt1, extcnt, gas_pcnst, clsmap, rxntot + use ppgrid, only : pcols, pver + use mo_prod_loss, only : exp_prod_loss + use mo_indprd, only : indprd + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_history, only : outfld + use mo_tracname, only : solsym + + implicit none + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! het rates (1/cm^3/s) + real(r8), intent(in) :: reaction_rates(ncol,pver,rxntot) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol,pver,extcnt) ! "external insitu forcing" (1/cm^3/s) + real(r8), intent(in) :: xhnm(ncol,pver) + integer, intent(in) :: ltrop(pcols) ! chemistry troposphere boundary (index) + real(r8), intent(inout) :: base_sol(ncol,pver,gas_pcnst) ! working mixing ratios (vmr) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: i, k, l, m + real(r8), dimension(ncol,pver,clscnt1) :: & + prod, & + loss, & + ind_prd + + real(r8), dimension(ncol,pver) :: wrk + + !----------------------------------------------------------------------- + ! ... Put "independent" production in the forcing + !----------------------------------------------------------------------- + call indprd( 1, ind_prd, clscnt1, base_sol, extfrc, & + reaction_rates, ncol ) + + !----------------------------------------------------------------------- + ! ... Form F(y) + !----------------------------------------------------------------------- + call exp_prod_loss( prod, loss, base_sol, reaction_rates, het_rates ) + + !----------------------------------------------------------------------- + ! ... Solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + do m = 1,clscnt1 + l = clsmap(m,1) + do i = 1,ncol + do k = ltrop(i)+1,pver + base_sol(i,k,l) = base_sol(i,k,l) + delt * (prod(i,k,m) + ind_prd(i,k,m) - loss(i,k,m)) + end do + end do + + wrk(:,:) = (prod(:,:,m) + ind_prd(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHMP', wrk(:,:), ncol, lchnk ) + wrk(:,:) = (loss(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHML', wrk(:,:), ncol, lchnk ) + + end do + + end subroutine exp_sol + +end module mo_exp_sol diff --git a/chem_proc/procfiles/cam/mo_exp_sol_vector.F90 b/chem_proc/procfiles/cam/mo_exp_sol_vector.F90 new file mode 100644 index 0000000000..62c7e8bde6 --- /dev/null +++ b/chem_proc/procfiles/cam/mo_exp_sol_vector.F90 @@ -0,0 +1,104 @@ + +module mo_exp_sol + + private + public :: exp_sol + public :: exp_sol_inti + +contains + + subroutine exp_sol_inti + + use mo_tracname, only : solsym + use chem_mods, only : clscnt1, clsmap + use cam_history, only : addfld + + implicit none + + integer :: i,j + + do i = 1,clscnt1 + + j = clsmap(i,1) + call addfld( trim(solsym(j))//'_CHMP', (/ 'lev' /), 'I', '/cm3/s', 'chemical production rate' ) + call addfld( trim(solsym(j))//'_CHML', (/ 'lev' /), 'I', '/cm3/s', 'chemical loss rate' ) + + enddo + end subroutine exp_sol_inti + + + subroutine exp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, xhnm, ncol, lchnk, ltrop ) + !----------------------------------------------------------------------- + ! ... Exp_sol advances the volumetric mixing ratio + ! forward one time step via the fully explicit + ! Euler scheme + !----------------------------------------------------------------------- + + use chem_mods, only : clscnt1, extcnt, gas_pcnst, clsmap, rxntot + use ppgrid, only : pcols, pver + use mo_prod_loss, only : exp_prod_loss + use mo_indprd, only : indprd + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_history, only : outfld + use mo_tracname, only : solsym + + implicit none + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! het rates (1/cm^3/s) + real(r8), intent(in) :: reaction_rates(ncol,pver,rxntot) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol,pver,extcnt) ! "external insitu forcing" (1/cm^3/s) + real(r8), intent(in) :: xhnm(ncol,pver) + integer, intent(in) :: ltrop(pcols) ! chemistry troposphere boundary (index) + real(r8), intent(inout) :: base_sol(ncol,pver,gas_pcnst) ! working mixing ratios (vmr) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: i, k, l, m + integer :: chnkpnts + real(r8), dimension(ncol,pver,max(1,clscnt1)) :: & + prod, & + loss + real(r8), dimension(ncol,pver,clscnt1) :: ind_prd + + real(r8), dimension(ncol,pver) :: wrk + + chnkpnts = ncol*pver + !----------------------------------------------------------------------- + ! ... Put "independent" production in the forcing + !----------------------------------------------------------------------- + call indprd( 1, ind_prd, clscnt1, base_sol, extfrc, & + reaction_rates, chnkpnts ) + + !----------------------------------------------------------------------- + ! ... Form F(y) + !----------------------------------------------------------------------- + call exp_prod_loss( 1, chnkpnts, prod, loss, base_sol, reaction_rates, & + het_rates, chnkpnts ) + + !----------------------------------------------------------------------- + ! ... Solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + do m = 1,clscnt1 + l = clsmap(m,1) + do i = 1,ncol + do k = ltrop(i)+1,pver + base_sol(i,k,l) = base_sol(i,k,l) + delt * (prod(i,k,m) + ind_prd(i,k,m) - loss(i,k,m)) + end do + end do + + wrk(:,:) = (prod(:,:,m) + ind_prd(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHMP', wrk(:,:), ncol, lchnk ) + wrk(:,:) = (loss(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHML', wrk(:,:), ncol, lchnk ) + + end do + + end subroutine exp_sol + +end module mo_exp_sol diff --git a/chem_proc/procfiles/cam/mo_imp_sol_cache.F90 b/chem_proc/procfiles/cam/mo_imp_sol_cache.F90 new file mode 100644 index 0000000000..9f67fbfa4e --- /dev/null +++ b/chem_proc/procfiles/cam/mo_imp_sol_cache.F90 @@ -0,0 +1,480 @@ + + module mo_imp_sol + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, gas_pcnst, clsmap + + implicit none + +!----------------------------------------------------------------------- +! Newton-Raphson iteration limits +!----------------------------------------------------------------------- + integer, parameter :: itermax = 11 + integer, parameter :: cut_limit = 5 + + save + + real(r8) :: small + real(r8) :: epsilon(clscnt4) + logical :: factor(itermax) + + private + public :: imp_slv_inti, imp_sol + + contains + + subroutine imp_slv_inti +!----------------------------------------------------------------------- +! ... Initialize the implict solver +!----------------------------------------------------------------------- + + use m_spc_id + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: m + real(r8) :: eps(gas_pcnst) + + small = 1.e6_r8 * tiny( small ) + factor(:) = .true. + eps(:) = .001_r8 + eps((/id_o3,id_no,id_no2,id_no3,id_hno3,id_ho2no2,id_n2o5,id_oh,id_ho2/)) = .0001_r8 + do m = 1,clscnt4 + epsilon(m) = eps(clsmap(m,4)) + end do + + end subroutine imp_slv_inti + + subroutine imp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, & + ncol, lchnk ) +!----------------------------------------------------------------------- +! ... Imp_sol advances the volumetric mixing ratio +! forward one time step via the fully implicit +! Euler scheme +!----------------------------------------------------------------------- + + use chem_mods, only : rxntot, extcnt, nzcnt, clsze, diag_map, permute, cls_rxt_cnt + use mo_tracname, only : solsym + use ppgrid, only : pver + use pmgrid, only : iam + use mo_lin_matrix, only : linmat + use mo_nln_matrix, only : nlnmat + use mo_lu_factor, only : lu_fac + use mo_lu_solve, only : lu_slv + use mo_prod_loss, only : imp_prod_loss + use mo_indprd, only : indprd + use time_manager, only : get_nstep + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: reaction_rates(ncol,pver,rxntot), & ! rxt rates (1/cm^3/s) + extfrc(ncol,pver,extcnt), & ! external in-situ forcing (1/cm^3/s) + het_rates(ncol,pver,max(1,gas_pcnst)) ! washout rates (1/s) + real(r8), intent(inout) :: base_sol(ncol,pver,gas_pcnst) ! species mixing ratios (vmr) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: nr_iter, & + lev, & + ofl, ofu, & + i, isec, isecu, & + j, & + k, l, & + m, cols + integer :: nstep + integer :: stp_con_cnt, cut_cnt, fail_cnt + real(r8) :: interval_done, dt, dti + real(r8) :: max_delta(clscnt4) + real(r8), dimension(clsze,nzcnt) :: & + sys_jac, & + lin_jac + real(r8), dimension(clsze,clscnt4) :: & + solution, & + forcing, & + iter_invariant, & + prod, & + loss + real(r8) :: lrxt(clsze,rxntot) + real(r8) :: lhet(clsze,max(1,gas_pcnst)) + real(r8) :: lsol(clsze,gas_pcnst) + real(r8), dimension(clsze) :: & + wrk + real(r8), dimension(ncol,pver,clscnt4) :: & + ind_prd + logical :: convergence + logical :: iter_conv(clsze) + logical :: converged(clscnt4) + logical :: do_diag + +!----------------------------------------------------------------------- +! ... Class independent forcing +!----------------------------------------------------------------------- +#ifdef DEBUG + call t_startf('indprd') +#endif + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + call indprd( 4, ind_prd, clscnt4, base_sol, extfrc, & + reaction_rates, ncol ) + else + do m = 1,max(1,clscnt4) + ind_prd(:,:,m) = 0._r8 + end do + end if +#ifdef DEBUG + call t_stopf('indprd') +#endif + isecu = (ncol - 1)/clsze + 1 +Level_loop : & + do lev = 1,pver +Column_loop : & + do isec = 1,isecu + ofl = (isec - 1)*clsze + 1 + ofu = min( ncol,ofl + clsze - 1 ) + cols = ofu - ofl + 1 +!----------------------------------------------------------------------- +! ... Transfer from base to local work arrays +!----------------------------------------------------------------------- + do m = 1,rxntot + lrxt(:cols,m) = reaction_rates(ofl:ofu,lev,m) + end do + do m = 1,gas_pcnst + lhet(:cols,m) = het_rates(ofl:ofu,lev,m) + end do +! do_diag = lev == 5 .and. isec == 2 .and. lchnk == 290 + do_diag = .false. + if( do_diag ) then + write(*,*) ' ' + write(*,*) 'imp_sol: lchnk,lev,isec,cols = ',lchnk,lev,isec,cols + write(*,*) ' ' + write(*,*) 'imp_sol: lrxt' + write(*,'(1p,4g20.10)') lrxt(1,:) + write(*,*) 'imp_sol: lhet' + write(*,'(1p,4g20.10)') lhet(1,:) + end if +!----------------------------------------------------------------------- +! ... Time step loop +!----------------------------------------------------------------------- + dt = delt + cut_cnt = 0 + stp_con_cnt = 0 + fail_cnt = 0 + interval_done = 0._r8 +Time_step_loop : & + do + dti = 1._r8 / dt +!----------------------------------------------------------------------- +! ... Transfer from base to local work arrays +!----------------------------------------------------------------------- + do m = 1,gas_pcnst + lsol(:cols,m) = base_sol(ofl:ofu,lev,m) + end do +!----------------------------------------------------------------------- +! ... Transfer from base to class array +!----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + solution(:cols,m) = lsol(:cols,j) + end do + if( do_diag ) then + write(*,*) ' ' + write(*,*) 'imp_sol: solution' + write(*,'(1p,4g20.10)') solution(1,:) + end if +!----------------------------------------------------------------------- +! ... Set the iteration invariant part of the function F(y) +! ... If there is "independent" production put it in the forcing +!----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + do m = 1,clscnt4 + iter_invariant(:cols,m) = dti * solution(:cols,m) + ind_prd(ofl:ofu,lev,m) + end do + else + do m = 1,clscnt4 + iter_invariant(:cols,m) = dti * solution(:cols,m) + end do + end if +!----------------------------------------------------------------------- +! ... The linear component +!----------------------------------------------------------------------- +#ifdef DEBUG + call t_startf('lin_mat') +#endif + if( cls_rxt_cnt(2,4) > 0 ) then + call linmat( lin_jac, lsol, lrxt, lhet, cols ) + end if +#ifdef DEBUG + call t_stopf('lin_mat') +#endif + +!======================================================================= +! The Newton-Raphson iteration for F(y) = 0 +!======================================================================= +Iteration_loop : & + do nr_iter = 1,itermax +!----------------------------------------------------------------------- +! ... The non-linear component +!----------------------------------------------------------------------- + if( factor(nr_iter) ) then +#ifdef DEBUG + call t_startf('nln_mat') +#endif + call nlnmat( sys_jac, lsol, lrxt, lin_jac, dti, cols ) +#ifdef DEBUG + call t_stopf('nln_mat') + call t_startf('lu_fac') +#endif +!----------------------------------------------------------------------- +! ... Factor the "system" matrix +!----------------------------------------------------------------------- +#ifdef DEBUG_LU + if( do_diag ) then + write(*,*) 'imp_sol: before lu_fac - lchnk,lev,isec,iter,dt = ',lchnk,lev,isec,nr_iter,dt + write(*,*) 'imp_sol: lu(110,20,21,109)' + write(*,'(1p,4g20.10)') sys_jac(:cols,110) + write(*,'(1p,4g20.10)') sys_jac(:cols,20) + write(*,'(1p,4g20.10)') sys_jac(:cols,21) + write(*,'(1p,4g20.10)') sys_jac(:cols,109) + write(*,*) 'imp_sol: maxval sys_jac(3,:) = ',maxval( sys_jac(3,:) ) + write(*,*) 'imp_sol: maxval sys_jac(4,:) = ',maxval( sys_jac(4,:) ) + end if +#endif + call lu_fac( sys_jac, cols ) +#ifdef DEBUG_LU + if( do_diag ) then + write(*,*) 'imp_sol: after lu_fac - lchnk,lev,isec,iter,dt = ',lchnk,lev,isec,nr_iter,dt + write(*,*) 'imp_sol: lu(110,20,21,109)' + write(*,'(1p,4g20.10)') sys_jac(:cols,110) + write(*,'(1p,4g20.10)') sys_jac(:cols,20) + write(*,'(1p,4g20.10)') sys_jac(:cols,21) + write(*,'(1p,4g20.10)') sys_jac(:cols,109) + write(*,*) 'imp_sol: maxval sys_jac(3,:) = ',maxval( sys_jac(3,:) ) + write(*,*) 'imp_sol: maxval sys_jac(4,:) = ',maxval( sys_jac(4,:) ) + end if +#endif +#ifdef DEBUG + call t_stopf('lu_fac') +#endif + end if +!----------------------------------------------------------------------- +! ... Form F(y) +!----------------------------------------------------------------------- +#ifdef DEBUG + call t_startf('frcing') +#endif + call imp_prod_loss( prod, loss, lsol, lrxt, lhet, cols ) + do m = 1,clscnt4 + forcing(:cols,m) = solution(:cols,m)*dti - (iter_invariant(:cols,m) + prod(:cols,m) - loss(:cols,m)) + end do + + if( do_diag ) then + write(*,*) ' ' + write(*,*) 'imp_sol: frcing @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') forcing(1,:) + write(*,*) ' ' + write(*,*) 'imp_sol: iter_invariant @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') iter_invariant(1,:) + write(*,*) ' ' + write(*,*) 'imp_sol: prod @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') prod(1,:) + write(*,*) ' ' + write(*,*) 'imp_sol: loss @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') loss(1,:) + end if +#ifdef DEBUG + call t_stopf('frcing') + call t_startf('lu_slv') +#endif +!----------------------------------------------------------------------- +! ... Solve for the mixing ratio at t(n+1) +!----------------------------------------------------------------------- + call lu_slv( sys_jac, forcing, cols ) + if( do_diag ) then + write(*,*) ' ' + write(*,*) 'imp_sol: frcing @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') forcing(1,:) + end if + do m = 1,clscnt4 + solution(:cols,m) = solution(:cols,m) + forcing(:cols,m) + end do + if( do_diag ) then + write(*,*) ' ' + write(*,*) 'imp_sol: solution @ iter,dt = ',nr_iter,dt + write(*,'(1p,4g20.10)') solution(1,:) + end if +#ifdef DEBUG + call t_stopf('lu_slv') +#endif +!----------------------------------------------------------------------- +! ... Convergence measures +!----------------------------------------------------------------------- +#ifdef DEBUG + call t_startf('inner1_conv') +#endif + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + do i = 1,cols + if( abs(solution(i,m)) > 1.e-40_r8 ) then + wrk(i) = abs( forcing(i,m)/solution(i,m) ) + else + wrk(i) = 0._r8 + end if + end do +! where( abs(solution(:cols,m)) > 1.e-40_r8 ) +! wrk(:cols) = abs( forcing(:cols,m)/solution(:cols,m) ) +! elsewhere +! wrk(:cols) = 0._r8 +! endwhere + max_delta(k) = maxval( wrk(:cols) ) + end do + end if +#ifdef DEBUG + call t_stopf('inner1_conv') + call t_startf('inner2_conv') +#endif +!----------------------------------------------------------------------- +! ... Limit iterate +!----------------------------------------------------------------------- + do m = 1,clscnt4 +! where( solution(:cols,m) < 0._r8 ) +! solution(:cols,m) = 0._r8 +! endwhere + do i = 1,cols + if( solution(i,m) < 0. ) then + solution(i,m) = 0. + end if + end do + end do +!----------------------------------------------------------------------- +! ... Transfer latest solution back to work array +!----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + do i = 1,cols + lsol(i,j) = solution(i,m) + end do +! lsol(:cols,j) = solution(:cols,m) + end do +#ifdef DEBUG + call t_stopf('inner2_conv') + call t_startf('inner3_conv') +#endif +!----------------------------------------------------------------------- +! ... Check for convergence +!----------------------------------------------------------------------- + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + do i = 1,cols + if( abs( forcing(i,m) ) > small ) then + iter_conv(i) = abs(forcing(i,m)) <= epsilon(k)*abs(solution(i,m)) + else + iter_conv(i) = .true. + end if + end do + converged(k) = all( iter_conv(:cols) ) + end do + convergence = all( converged(:clscnt4) ) + if( convergence ) then +#ifdef DEBUG + call t_stopf('inner3_conv') +#endif + exit Iteration_loop + end if + end if +#ifdef DEBUG + call t_stopf('inner3_conv') +#endif + end do Iteration_loop + +!----------------------------------------------------------------------- +! ... Check for Newton-Raphson convergence +!----------------------------------------------------------------------- +#ifdef DEBUG + call t_startf('outer_conv') +#endif + if( .not. convergence ) then +!----------------------------------------------------------------------- +! ... Non-convergence +!----------------------------------------------------------------------- + fail_cnt = fail_cnt + 1 + nstep = get_nstep() + write(*,'('' imp_sol: Time step '',1p,e21.13,'' failed to converge @ (lchnk,lev,isec,nstep) = '',4i6)') dt,lchnk,lev,isec,nstep + stp_con_cnt = 0 + if( cut_cnt < cut_limit ) then + cut_cnt = cut_cnt + 1 + if( cut_cnt < cut_limit ) then + dt = .5_r8 * dt + else + dt = .1_r8 * dt + end if + cycle Time_step_loop + else + write(*,'('' imp_sol: Failed to converge @ (lchnk,lev,isec,nstep,dt,time) = '',4i6,1p,2e21.13)') & + lchnk,lev,isec,nstep,dt,interval_done+dt + do m = 1,clscnt4 + if( .not. converged(m) ) then + write(*,'(1x,a8,1x,1pe10.3)') solsym(clsmap(m,4)), max_delta(m) + end if + end do + end if + end if +!----------------------------------------------------------------------- +! ... Check for interval done +!----------------------------------------------------------------------- + interval_done = interval_done + dt + if( abs( delt - interval_done ) <= .0001_r8 ) then + if( fail_cnt > 0 ) then + write(*,*) 'imp_sol : @ (lchnk,lev,isec) = ',lchnk,lev,isec,' failed ',fail_cnt,' times' + end if +#ifdef DEBUG + call t_stopf('outer_conv') +#endif + exit Time_step_loop + else +!----------------------------------------------------------------------- +! ... Transfer latest solution back to base array +!----------------------------------------------------------------------- + if( convergence ) then + stp_con_cnt = stp_con_cnt + 1 + end if + do m = 1,gas_pcnst + base_sol(ofl:ofu,lev,m) = lsol(:cols,m) + end do + if( stp_con_cnt >= 2 ) then + dt = 2._r8*dt + stp_con_cnt = 0 + end if + dt = min( dt,delt-interval_done ) +! write(*,'('' imp_sol: New time step '',1p,e21.13)') dt + end if +#ifdef DEBUG + call t_stopf('outer_conv') +#endif + end do Time_step_loop +!----------------------------------------------------------------------- +! ... Transfer latest solution back to base array +!----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + base_sol(ofl:ofu,lev,j) = solution(:cols,m) + end do + end do Column_loop + end do Level_loop + + end subroutine imp_sol + + end module mo_imp_sol diff --git a/chem_proc/procfiles/cam/mo_imp_sol_scalar.F90 b/chem_proc/procfiles/cam/mo_imp_sol_scalar.F90 new file mode 100644 index 0000000000..54061ea07a --- /dev/null +++ b/chem_proc/procfiles/cam/mo_imp_sol_scalar.F90 @@ -0,0 +1,417 @@ + +module mo_imp_sol + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, gas_pcnst, clsmap + use cam_logfile, only : iulog + + implicit none + private + public :: imp_slv_inti, imp_sol + save + + real(r8), parameter :: rel_err = 1.e-3_r8 + real(r8), parameter :: high_rel_err = 1.e-4_r8 + !----------------------------------------------------------------------- + ! Newton-Raphson iteration limits + !----------------------------------------------------------------------- + integer, parameter :: itermax = 11 + integer, parameter :: cut_limit = 5 + + + real(r8), parameter :: small = 1.e-40_r8 + + real(r8) :: epsilon(clscnt4) + logical :: factor(itermax) + +contains + + subroutine imp_slv_inti + !----------------------------------------------------------------------- + ! ... Initialize the implict solver + !----------------------------------------------------------------------- + use mo_chem_utls, only : get_spc_ndx + + implicit none + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: m, ox_ndx, o3a_ndx + real(r8) :: eps(gas_pcnst) + + factor(:) = .true. + eps(:) = rel_err + + ox_ndx = get_spc_ndx( 'OX' ) + if( ox_ndx < 1 ) then + ox_ndx = get_spc_ndx( 'O3' ) + end if + if( ox_ndx > 0 ) then + eps(ox_ndx) = high_rel_err + end if + m = get_spc_ndx( 'NO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'N2O5' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'OH' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + o3a_ndx = get_spc_ndx( 'O3A' ) + if( o3a_ndx > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + do m = 1,clscnt4 + epsilon(m) = eps(clsmap(m,4)) + end do + + end subroutine imp_slv_inti + + subroutine imp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, & + ncol,nlev, lchnk, prod_out, loss_out ) + !----------------------------------------------------------------------- + ! ... imp_sol advances the volumetric mixing ratio + ! forward one time step via the fully implicit euler scheme. + ! this source is meant for small l1 cache machines such as + ! the intel pentium and itanium cpus + !----------------------------------------------------------------------- + + use chem_mods, only : rxntot, extcnt, nzcnt, permute, cls_rxt_cnt + use mo_tracname, only : solsym + use mo_lin_matrix, only : linmat + use mo_nln_matrix, only : nlnmat + use mo_lu_factor, only : lu_fac + use mo_lu_solve, only : lu_slv + use mo_prod_loss, only : imp_prod_loss + use mo_indprd, only : indprd + use time_manager, only : get_nstep + use perf_mod, only : t_startf, t_stopf + + implicit none + + !----------------------------------------------------------------------- + ! ... dummy args + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: nlev + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + + real(r8), intent(in) :: reaction_rates(ncol,nlev,max(1,rxntot)) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol,nlev,max(1,extcnt)) ! external in-situ forcing (1/cm^3/s) + real(r8), intent(in) :: het_rates(ncol,nlev,max(1,gas_pcnst)) ! washout rates (1/s) + real(r8), intent(inout) :: base_sol(ncol,nlev,gas_pcnst) ! species mixing ratios (vmr) + + real(r8), intent(out) :: prod_out(ncol,nlev,max(1,clscnt4)) + real(r8), intent(out) :: loss_out(ncol,nlev,max(1,clscnt4)) + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: nr_iter, & + lev, & + i, & + j, & + k, l, & + m + integer :: fail_cnt, cut_cnt, stp_con_cnt + integer :: nstep + real(r8) :: interval_done, dt, dti + real(r8) :: max_delta(max(1,clscnt4)) + real(r8) :: sys_jac(max(1,nzcnt)) + real(r8) :: lin_jac(max(1,nzcnt)) + real(r8), dimension(max(1,clscnt4)) :: & + solution, & + forcing, & + iter_invariant, & + prod, & + loss + real(r8) :: lrxt(max(1,rxntot)) + real(r8) :: lsol(max(1,gas_pcnst)) + real(r8) :: lhet(max(1,gas_pcnst)) + real(r8), dimension(ncol,nlev,max(1,clscnt4)) :: & + ind_prd + logical :: convergence + logical :: frc_mask, iter_conv + logical :: converged(max(1,clscnt4)) + + solution(:) = 0._r8 + !----------------------------------------------------------------------- + ! ... class independent forcing + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + call indprd( 4, ind_prd, clscnt4, base_sol, extfrc, & + reaction_rates, ncol ) + else + do m = 1,max(1,clscnt4) + ind_prd(:,:,m) = 0._r8 + end do + end if + level_loop : do lev = 1,nlev + column_loop : do i = 1,ncol + + !----------------------------------------------------------------------- + ! ... transfer from base to local work arrays + !----------------------------------------------------------------------- + do m = 1,rxntot + lrxt(m) = reaction_rates(i,lev,m) + end do + if( gas_pcnst > 0 ) then + do m = 1,gas_pcnst + lhet(m) = het_rates(i,lev,m) + end do + end if + !----------------------------------------------------------------------- + ! ... time step loop + !----------------------------------------------------------------------- + dt = delt + cut_cnt = 0 + fail_cnt = 0 + stp_con_cnt = 0 + interval_done = 0._r8 + time_step_loop : do + dti = 1._r8 / dt + !----------------------------------------------------------------------- + ! ... transfer from base to local work arrays + !----------------------------------------------------------------------- + do m = 1,gas_pcnst + lsol(m) = base_sol(i,lev,m) + end do + !----------------------------------------------------------------------- + ! ... transfer from base to class array + !----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + solution(m) = lsol(j) + end do + !----------------------------------------------------------------------- + ! ... set the iteration invariant part of the function f(y) + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + do m = 1,clscnt4 + iter_invariant(m) = dti * solution(m) + ind_prd(i,lev,m) + end do + else + do m = 1,clscnt4 + iter_invariant(m) = dti * solution(m) + end do + end if + !----------------------------------------------------------------------- + ! ... the linear component + !----------------------------------------------------------------------- + if( cls_rxt_cnt(2,4) > 0 ) then + call t_startf( 'lin_mat' ) + call linmat( lin_jac, lsol, lrxt, lhet ) + call t_stopf( 'lin_mat' ) + end if + !======================================================================= + ! the newton-raphson iteration for f(y) = 0 + !======================================================================= + iter_loop : do nr_iter = 1,itermax + !----------------------------------------------------------------------- + ! ... the non-linear component + !----------------------------------------------------------------------- + if( factor(nr_iter) ) then + call t_startf( 'nln_mat' ) + call nlnmat( sys_jac, lsol, lrxt, lin_jac, dti ) + call t_stopf( 'nln_mat' ) + !----------------------------------------------------------------------- + ! ... factor the "system" matrix + !----------------------------------------------------------------------- + call t_startf( 'lu_fac' ) + call lu_fac( sys_jac ) + call t_stopf( 'lu_fac' ) + end if + !----------------------------------------------------------------------- + ! ... form f(y) + !----------------------------------------------------------------------- + call t_startf( 'prod_loss' ) + call imp_prod_loss( prod, loss, lsol, lrxt, lhet ) + call t_stopf( 'prod_loss' ) + do m = 1,clscnt4 + forcing(m) = solution(m)*dti - (iter_invariant(m) + prod(m) - loss(m)) + end do + !----------------------------------------------------------------------- + ! ... solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + call t_startf( 'lu_slv' ) + call lu_slv( sys_jac, forcing ) + call t_stopf( 'lu_slv' ) + do m = 1,clscnt4 + solution(m) = solution(m) + forcing(m) + end do + !----------------------------------------------------------------------- + ! ... convergence measures + !----------------------------------------------------------------------- + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + if( abs(solution(m)) > 1.e-20_r8 ) then + max_delta(k) = abs( forcing(m)/solution(m) ) + else + max_delta(k) = 0._r8 + end if + end do + end if + !----------------------------------------------------------------------- + ! ... limit iterate + !----------------------------------------------------------------------- + where( solution(:) < 0._r8 ) + solution(:) = 0._r8 + endwhere + !----------------------------------------------------------------------- + ! ... transfer latest solution back to work array + !----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + lsol(j) = solution(m) + end do + !----------------------------------------------------------------------- + ! ... check for convergence + !----------------------------------------------------------------------- + converged(:) = .true. + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + frc_mask = abs( forcing(m) ) > small + if( frc_mask ) then + converged(k) = abs(forcing(m)) <= epsilon(k)*abs(solution(m)) + else + converged(k) = .true. + end if + end do + convergence = all( converged(:) ) + if( convergence ) then + exit + end if + end if + end do iter_loop + !----------------------------------------------------------------------- + ! ... check for newton-raphson convergence + !----------------------------------------------------------------------- + if( .not. convergence ) then + !----------------------------------------------------------------------- + ! ... non-convergence + !----------------------------------------------------------------------- + fail_cnt = fail_cnt + 1 + nstep = get_nstep() + write(iulog,'('' imp_sol: Time step '',1p,e21.13,'' failed to converge @ (lchnk,lev,col,nstep) = '',4i6)') & + dt,lchnk,lev,i,nstep + stp_con_cnt = 0 + if( cut_cnt < cut_limit ) then + cut_cnt = cut_cnt + 1 + if( cut_cnt < cut_limit ) then + dt = .5_r8 * dt + else + dt = .1_r8 * dt + end if + cycle time_step_loop + else + write(iulog,'('' imp_sol: Failed to converge @ (lchnk,lev,col,nstep,dt,time) = '',4i6,1p,2e21.13)') & + lchnk,lev,i,nstep,dt,interval_done+dt + do m = 1,clscnt4 + if( .not. converged(m) ) then + write(iulog,'(1x,a8,1x,1pe10.3)') solsym(clsmap(m,4)), max_delta(m) + end if + end do + end if + end if + !----------------------------------------------------------------------- + ! ... check for interval done + !----------------------------------------------------------------------- + interval_done = interval_done + dt + if( abs( delt - interval_done ) <= .0001_r8 ) then + if( fail_cnt > 0 ) then + write(iulog,*) 'imp_sol : @ (lchnk,lev,col) = ',lchnk,lev,i,' failed ',fail_cnt,' times' + end if + exit time_step_loop + else + !----------------------------------------------------------------------- + ! ... transfer latest solution back to base array + !----------------------------------------------------------------------- + if( convergence ) then + stp_con_cnt = stp_con_cnt + 1 + end if + do m = 1,gas_pcnst + base_sol(i,lev,m) = lsol(m) + end do + if( stp_con_cnt >= 2 ) then + dt = 2._r8*dt + stp_con_cnt = 0 + end if + dt = min( dt,delt-interval_done ) + ! write(iulog,'('' imp_sol: New time step '',1p,e21.13)') dt + end if + end do time_step_loop + !----------------------------------------------------------------------- + ! ... Transfer latest solution back to base array + !----------------------------------------------------------------------- + cls_loop: do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + base_sol(i,lev,j) = solution(m) + + ! output diagnostics + prod_out(i,lev,k) = prod(k) + ind_prd(i,lev,k) + loss_out(i,lev,k) = loss(k) + end do cls_loop + + end do column_loop + end do level_loop + end subroutine imp_sol +end module mo_imp_sol diff --git a/chem_proc/procfiles/cam/mo_imp_sol_vector.F90 b/chem_proc/procfiles/cam/mo_imp_sol_vector.F90 new file mode 100644 index 0000000000..63df62e8f2 --- /dev/null +++ b/chem_proc/procfiles/cam/mo_imp_sol_vector.F90 @@ -0,0 +1,436 @@ +module mo_imp_sol + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, gas_pcnst, clsmap, veclen + use cam_logfile, only : iulog + implicit none + private + public :: imp_slv_inti, imp_sol + save + real(r8), parameter :: rel_err = 1.e-3_r8 + real(r8), parameter :: high_rel_err = 1.e-4_r8 + !----------------------------------------------------------------------- + ! Newton-Raphson iteration limits + !----------------------------------------------------------------------- + integer, parameter :: itermax = 11 + integer, parameter :: cut_limit = 5 + real(r8), parameter :: sol_min = 1.e-20_r8 + real(r8), parameter :: small = 1.e-40_r8 + real(r8) :: epsilon(clscnt4) + logical :: factor(itermax) +contains + subroutine imp_slv_inti + !----------------------------------------------------------------------- + ! ... Initialize the implict solver + !----------------------------------------------------------------------- + use mo_chem_utls, only : get_spc_ndx + implicit none + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: m, ox_ndx, o3a_ndx + real(r8) :: eps(gas_pcnst) + factor(:) = .true. + eps(:) = rel_err + ox_ndx = get_spc_ndx( 'OX' ) + if( ox_ndx < 1 ) then + ox_ndx = get_spc_ndx( 'O3' ) + end if + if( ox_ndx > 0 ) then + eps(ox_ndx) = high_rel_err + end if + m = get_spc_ndx( 'NO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'N2O5' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'OH' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + o3a_ndx = get_spc_ndx( 'O3A' ) + if( o3a_ndx > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + do m = 1,clscnt4 + epsilon(m) = eps(clsmap(m,4)) + end do + end subroutine imp_slv_inti + subroutine imp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, & + ncol, nlev, lchnk, prod_out, loss_out ) + !----------------------------------------------------------------------- + ! ... imp_sol advances the volumetric mixing ratio + ! forward one time step via the fully implicit euler scheme. + ! this source is meant for vector architectures such as the + ! nec sx6 and cray x1 + !----------------------------------------------------------------------- + use chem_mods, only : rxntot, extcnt, nzcnt, permute, cls_rxt_cnt + use mo_tracname, only : solsym + use mo_lin_matrix, only : linmat + use mo_nln_matrix, only : nlnmat + use mo_lu_factor, only : lu_fac + use mo_lu_solve, only : lu_slv + use mo_prod_loss, only : imp_prod_loss + use mo_indprd, only : indprd + use time_manager, only : get_nstep + use perf_mod, only : t_startf, t_stopf + implicit none + !----------------------------------------------------------------------- + ! ... dummy args + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: nlev + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: reaction_rates(ncol*nlev,max(1,rxntot)) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol*nlev,max(1,extcnt)) ! external in-situ forcing (1/cm^3/s) + real(r8), intent(in) :: het_rates(ncol*nlev,max(1,gas_pcnst)) ! washout rates (1/s) + real(r8), intent(inout) :: base_sol(ncol*nlev,gas_pcnst) ! species mixing ratios (vmr) + real(r8), intent(out) :: prod_out(ncol*nlev,max(1,clscnt4)) + real(r8), intent(out) :: loss_out(ncol*nlev,max(1,clscnt4)) + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: nr_iter + integer :: ofl + integer :: ofu + integer :: avec_len + integer :: bndx ! base index + integer :: cndx ! class index + integer :: pndx ! permuted class index + integer :: i,m + integer :: fail_cnt(veclen) + integer :: cut_cnt(veclen) + integer :: stp_con_cnt(veclen) + integer :: nstep + real(r8) :: interval_done(veclen) + real(r8) :: dt(veclen) + real(r8) :: dti(veclen) + real(r8) :: max_delta(max(1,clscnt4)) + real(r8) :: ind_prd(ncol*nlev,max(1,clscnt4)) + logical :: convergence + integer :: chnkpnts ! total spatial points in chunk; ncol*ncol + logical :: diags_out(ncol*nlev,max(1,clscnt4)) + real(r8) :: sys_jac_blk(veclen,max(1,nzcnt)) + real(r8) :: lin_jac_blk(veclen,max(1,nzcnt)) + real(r8) :: solution_blk(veclen,max(1,clscnt4)) + real(r8) :: forcing_blk(veclen,max(1,clscnt4)) + real(r8) :: iter_invariant_blk(veclen,max(1,clscnt4)) + real(r8) :: prod_blk(veclen,max(1,clscnt4)) + real(r8) :: loss_blk(veclen,max(1,clscnt4)) + real(r8) :: ind_prd_blk(veclen,max(1,clscnt4)) + real(r8) :: sbase_sol_blk(veclen,gas_pcnst) + real(r8) :: wrk_blk(veclen) + logical :: spc_conv_blk(veclen,max(1,clscnt4)) + logical :: cls_conv_blk(veclen) + logical :: time_stp_done_blk(veclen) + real(r8) :: reaction_rates_blk(veclen,max(1,rxntot)) + real(r8) :: extfrc_blk(veclen,max(1,extcnt)) + real(r8) :: het_rates_blk(veclen,max(1,gas_pcnst)) + real(r8) :: base_sol_blk(veclen,gas_pcnst) + chnkpnts = ncol*nlev + prod_out = 0._r8 + loss_out = 0._r8 + diags_out = .false. + !----------------------------------------------------------------------- + ! ... class independent forcing + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + call indprd( 4, ind_prd, clscnt4, base_sol, extfrc, & + reaction_rates, chnkpnts ) + else + do m = 1,clscnt4 + ind_prd(:,m) = 0._r8 + end do + end if + nstep = get_nstep() + ofl = 1 + chnkpnts_loop : do + ofu = min( chnkpnts,ofl + veclen - 1 ) + avec_len = (ofu - ofl) + 1 + reaction_rates_blk(1:avec_len,:) = reaction_rates(ofl:ofu,:) + extfrc_blk(1:avec_len,:) = extfrc(ofl:ofu,:) + het_rates_blk(1:avec_len,:) = het_rates(ofl:ofu,:) + ind_prd_blk(1:avec_len,:) = ind_prd(ofl:ofu,:) + base_sol_blk(1:avec_len,:) = base_sol(ofl:ofu,:) + cls_conv_blk(1:avec_len) = .false. + dt(1:avec_len) = delt + cut_cnt(1:avec_len) = 0 + fail_cnt(1:avec_len) = 0 + stp_con_cnt(1:avec_len) = 0 + interval_done(1:avec_len) = 0._r8 + time_stp_done_blk(1:avec_len) = .false. + !----------------------------------------------------------------------- + ! ... time step loop + !----------------------------------------------------------------------- + time_step_loop : do + dti(1:avec_len) = 1._r8 / dt(1:avec_len) + !----------------------------------------------------------------------- + ! ... transfer from base to class array + !----------------------------------------------------------------------- + do cndx = 1,clscnt4 + bndx = clsmap(cndx,4) + pndx = permute(cndx,4) + do i = 1, avec_len + solution_blk(i,pndx) = base_sol_blk(i,bndx) + end do + end do + do m = 1,gas_pcnst + sbase_sol_blk(1:avec_len,m) = base_sol_blk(1:avec_len,m) + end do + !----------------------------------------------------------------------- + ! ... set the iteration invariant part of the function f(y) + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + do m = 1,clscnt4 + do i = 1, avec_len + iter_invariant_blk(i,m) = dti(i) * solution_blk(i,m) + ind_prd_blk(i,m) + end do + end do + else + do m = 1,clscnt4 + do i = 1, avec_len + iter_invariant_blk(i,m) = dti(i) * solution_blk(i,m) + end do + end do + end if + !----------------------------------------------------------------------- + ! ... the linear component + !----------------------------------------------------------------------- + if( cls_rxt_cnt(2,4) > 0 ) then + call t_startf( 'lin_mat' ) + call linmat( avec_len, lin_jac_blk, base_sol_blk, & + reaction_rates_blk, het_rates_blk ) + call t_stopf( 'lin_mat' ) + end if + !======================================================================= + ! the newton-raphson iteration for f(y) = 0 + !======================================================================= + iter_loop : do nr_iter = 1,itermax + !----------------------------------------------------------------------- + ! ... the non-linear component + !----------------------------------------------------------------------- + if( factor(nr_iter) ) then + call t_startf( 'nln_mat' ) + call nlnmat( avec_len, sys_jac_blk, base_sol_blk, & + reaction_rates_blk, lin_jac_blk, dti ) + call t_stopf( 'nln_mat' ) + !----------------------------------------------------------------------- + ! ... factor the "system" matrix + !----------------------------------------------------------------------- + call t_startf( 'lu_fac' ) + call lu_fac( avec_len, sys_jac_blk ) + call t_stopf( 'lu_fac' ) + end if + !----------------------------------------------------------------------- + ! ... form f(y) + !----------------------------------------------------------------------- + call t_startf( 'prod_loss' ) + call imp_prod_loss( avec_len, prod_blk, loss_blk, & + base_sol_blk, reaction_rates_blk, het_rates_blk ) + call t_stopf( 'prod_loss' ) + do m = 1,clscnt4 + do i = 1, avec_len + forcing_blk(i,m) = solution_blk(i,m)*dti(i) & + - (iter_invariant_blk(i,m) + prod_blk(i,m) - loss_blk(i,m)) + end do + end do + !----------------------------------------------------------------------- + ! ... solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + call t_startf( 'lu_slv' ) + call lu_slv( avec_len, sys_jac_blk, forcing_blk ) + call t_stopf( 'lu_slv' ) + do m = 1,clscnt4 + do i = 1, avec_len + if( .not. cls_conv_blk(i) )then + solution_blk(i,m) = solution_blk(i,m) + forcing_blk(i,m) + else + forcing_blk(i,m) = 0._r8 + endif + end do + end do + !----------------------------------------------------------------------- + ! ... convergence measures and test + !----------------------------------------------------------------------- + conv_chk : if( nr_iter > 1 ) then + !----------------------------------------------------------------------- + ! ... check for convergence + !----------------------------------------------------------------------- + do cndx = 1,clscnt4 + pndx = permute(cndx,4) + bndx = clsmap(cndx,4) + do i = 1, avec_len + if ( abs( solution_blk(i,pndx) ) > sol_min ) then + wrk_blk(i) = abs( forcing_blk(i,pndx)/solution_blk(i,pndx) ) + else + wrk_blk(i) = 0._r8 + endif + enddo + max_delta(cndx) = maxval( wrk_blk(1:avec_len) ) + do i = 1, avec_len + solution_blk(i,pndx) = max( 0._r8,solution_blk(i,pndx) ) + base_sol_blk(i,bndx) = solution_blk(i,pndx) + if ( abs( forcing_blk(i,pndx) ) > small ) then + spc_conv_blk(i,cndx) = abs(forcing_blk(i,pndx)) <= epsilon(cndx)*abs(solution_blk(i,pndx)) + else + spc_conv_blk(i,cndx) = .true. + endif + enddo + where( spc_conv_blk(1:avec_len,cndx) .and. .not.diags_out(ofl:ofu,cndx) ) + ! capture output production and loss diagnostics at converged ponits + prod_out(ofl:ofu,cndx) = prod_blk(1:avec_len,cndx) + ind_prd_blk(1:avec_len,cndx) + loss_out(ofl:ofu,cndx) = loss_blk(1:avec_len,cndx) + diags_out(ofl:ofu,cndx) = .true. + endwhere + end do + do i = 1, avec_len + if( .not. cls_conv_blk(i) ) then + cls_conv_blk(i) = all( spc_conv_blk(i,:) ) + end if + end do + convergence = all( cls_conv_blk(:) ) + if( convergence ) then + exit iter_loop + end if + else conv_chk +!----------------------------------------------------------------------- +! ... limit iterate +!----------------------------------------------------------------------- + do m = 1,clscnt4 + do i = 1, avec_len + solution_blk(i,m) = max( 0._r8,solution_blk(i,m) ) + end do + end do +!----------------------------------------------------------------------- +! ... transfer latest solution back to base array +!----------------------------------------------------------------------- + do cndx = 1,clscnt4 + pndx = permute(cndx,4) + bndx = clsmap(cndx,4) + do i = 1, avec_len + base_sol_blk(i,bndx) = solution_blk(i,pndx) + end do + end do + end if conv_chk + end do iter_loop + !----------------------------------------------------------------------- + ! ... check for newton-raphson convergence + !----------------------------------------------------------------------- + do i = 1,avec_len + if( .not. cls_conv_blk(i) ) then + fail_cnt(i) = fail_cnt(i) + 1 + write(iulog,'('' imp_sol: time step '',1p,g15.7,'' failed to converge @ (lchnk,vctrpos,nstep) = '',3i8)') & + dt(i),lchnk,ofl+i-1,nstep + stp_con_cnt(i) = 0 + if( cut_cnt(i) < cut_limit ) then + cut_cnt(i) = cut_cnt(i) + 1 + if( cut_cnt(i) < cut_limit ) then + dt(i) = .5_r8 * dt(i) + else + dt(i) = .1_r8 * dt(i) + end if + base_sol_blk(i,:) = sbase_sol_blk(i,:) + else + write(iulog,'('' imp_sol: step failed to converge @ (lchnk,vctrpos,nstep,dt,time) = '',3i8,1p,2g15.7)') & + lchnk,ofl+i-1,nstep,dt(i),interval_done+dt(i) + do m = 1,clscnt4 + if( .not. spc_conv_blk(i,m) ) then + write(iulog,'(1x,a16,1x,1pe10.3)') solsym(clsmap(m,4)), max_delta(m) + end if + end do + cls_conv_blk(i) = .true. + if( .not. time_stp_done_blk(i) ) then + interval_done(i) = interval_done(i) + dt(i) + time_stp_done_blk(i) = abs( delt - interval_done(i) ) <= .0001_r8 + endif + end if + elseif( .not. time_stp_done_blk(i) ) then + interval_done(i) = interval_done(i) + dt(i) + time_stp_done_blk(i) = abs( delt - interval_done(i) ) <= .0001_r8 + stp_con_cnt(i) = stp_con_cnt(i) + 1 + if( .not. time_stp_done_blk(i) ) then + if( stp_con_cnt(i) >= 2 ) then + dt(i) = 2._r8*dt(i) + stp_con_cnt(i) = 0 + end if + dt(i) = min( dt(i),delt-interval_done(i) ) + else + base_sol(ofl+i-1,1:gas_pcnst) = base_sol_blk(i,1:gas_pcnst) + endif + endif + end do + convergence = all( cls_conv_blk(:) ) + do i = 1,avec_len + if( cls_conv_blk(i) .and. .not. time_stp_done_blk(i) ) then + cls_conv_blk(i) = .false. + endif + end do + if( .not. convergence ) then + cycle time_step_loop + endif + !----------------------------------------------------------------------- + ! ... check for time step done + !----------------------------------------------------------------------- + if( all( time_stp_done_blk(1:avec_len) ) ) then + exit time_step_loop + end if + end do time_step_loop + + ofl = ofu + 1 + if( ofl > chnkpnts ) then + exit chnkpnts_loop + end if + end do chnkpnts_loop + end subroutine imp_sol +end module mo_imp_sol diff --git a/chem_proc/procfiles/mo_chem.mod b/chem_proc/procfiles/mo_chem.mod new file mode 100644 index 0000000000..e7d53dcb5a --- /dev/null +++ b/chem_proc/procfiles/mo_chem.mod @@ -0,0 +1,141 @@ + + module chem_mods +!-------------------------------------------------------------- +! ... basic chemistry array parameters +!-------------------------------------------------------------- + + use mo_grid, only : pcnstm1 + + implicit none + + save + + integer, parameter :: hetcnt = HETCNT, & ! number of heterogeneous processes + phtcnt = PHTCNT, & ! number of photo processes + rxntot = RXNCNT, & ! number of total reactions + gascnt = GASCNT, & ! number of gas phase reactions + nfs = NFS, & ! number of "fixed" species + relcnt = RELCNT, & ! number of relationship species + grpcnt = GRPCNT, & ! number of group members + imp_nzcnt = IMP_NZCNT, & ! number of non-zero implicit matrix entries + rod_nzcnt = ROD_NZCNT, & ! number of non-zero rodas matrix entries + extcnt = EXTCNT, & ! number of species with external forcing + clscnt1 = CLSCNT1, & ! number of species in explicit class + clscnt2 = CLSCNT2, & ! number of species in hov class + clscnt3 = CLSCNT3, & ! number of species in ebi class + clscnt4 = CLSCNT4, & ! number of species in implicit class + clscnt5 = CLSCNT5, & ! number of species in rodas class + indexm = INDEXM, & ! index of total atm density in invariant array + ncol_abs = NCOL, & ! number of column densities + indexh2o = INDEXH2O, & ! index of water vapor density + clsze = CLSZE ! loop length for implicit chemistry + + integer :: ngrp = 0 + integer :: drydep_cnt = 0 + integer :: srfems_cnt = 0 + integer :: rxt_alias_cnt = 0 + integer :: fbc_cnt(2) = 0 + integer, allocatable :: grp_mem_cnt(:) + integer, allocatable :: rxt_alias_map(:) + real :: adv_mass(pcnstm1) + real :: nadv_mass(grpcnt) + character(len=16), allocatable :: rxt_alias_lst(:) + character(len=8), allocatable :: drydep_lst(:) + character(len=8), allocatable :: srfems_lst(:) + character(len=8), allocatable :: grp_lst(:) + character(len=8), allocatable :: flbc_lst(:) + character(len=8) :: het_lst(max(1,hetcnt)) + character(len=8) :: extfrc_lst(max(1,extcnt)) + character(len=8) :: inv_lst(max(1,nfs)) + + type solver_class + integer :: clscnt + integer :: lin_rxt_cnt + integer :: nln_rxt_cnt + integer :: indprd_cnt + integer :: iter_max + integer :: cls_rxt_cnt(4) + integer, pointer :: permute(:) + integer, pointer :: diag_map(:) + integer, pointer :: clsmap(:) + end type solver_class + + type(solver_class) :: explicit, implicit, rodas + + contains + + subroutine chem_mods_inti +!-------------------------------------------------------------- +! ... intialize the class derived type +!-------------------------------------------------------------- + + implicit none + + integer :: astat + + explicit%clscnt = CLSCNT1 + explicit%indprd_cnt = CLSINDPRD1 + + implicit%clscnt = CLSCNT4 + implicit%lin_rxt_cnt = IMP_LINCNT + implicit%nln_rxt_cnt = IMP_NLNCNT + implicit%indprd_cnt = CLSINDPRD4 + implicit%iter_max = IMPITERMAX + + rodas%clscnt = CLSCNT5 + rodas%lin_rxt_cnt = ROD_LINCNT + rodas%nln_rxt_cnt = ROD_NLNCNT + rodas%indprd_cnt = CLSINDPRD5 + + if( explicit%clscnt > 0 ) then + allocate( explicit%clsmap(explicit%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate explicit%clsmap ; error = ',astat + call endrun + end if + explicit%clsmap(:) = 0 + end if + if( implicit%clscnt > 0 ) then + allocate( implicit%permute(implicit%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate implicit%permute ; error = ',astat + call endrun + end if + implicit%permute(:) = 0 + allocate( implicit%diag_map(implicit%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate implicit%diag_map ; error = ',astat + call endrun + end if + implicit%diag_map(:) = 0 + allocate( implicit%clsmap(implicit%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate implicit%clsmap ; error = ',astat + call endrun + end if + implicit%clsmap(:) = 0 + end if + if( rodas%clscnt > 0 ) then + allocate( rodas%permute(rodas%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate rodas%permute ; error = ',astat + call endrun + end if + rodas%permute(:) = 0 + allocate( rodas%diag_map(rodas%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate rodas%diag_map ; error = ',astat + call endrun + end if + rodas%diag_map(:) = 0 + allocate( rodas%clsmap(rodas%clscnt),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'chem_mods_inti: failed to allocate rodas%clsmap ; error = ',astat + call endrun + end if + rodas%clsmap(:) = 0 + end if + + end subroutine chem_mods_inti + + end module chem_mods diff --git a/chem_proc/procfiles/mo_grid.mod b/chem_proc/procfiles/mo_grid.mod new file mode 100644 index 0000000000..f36e2ff917 --- /dev/null +++ b/chem_proc/procfiles/mo_grid.mod @@ -0,0 +1,32 @@ + + module mo_grid +!--------------------------------------------------------------------- +! ... Basic grid point resolution parameters +!--------------------------------------------------------------------- + implicit none + + save + + integer, parameter :: & + pcnst = PCNST+1, & ! number of advected constituents including cloud water + pcnstm1 = PCNST, & ! number of advected constituents excluding cloud water + plev = PLEV, & ! number of vertical levels + plevp = plev+1, & ! plev plus 1 + plevm = plev-1, & ! plev minus 1 + plon = PLON, & ! number of longitudes + plat = PLAT ! number of latitudes + + integer, parameter :: & + pnats = GRPCNT ! number of non-advected trace species + +#ifdef STRAT_CHEM + integer, parameter :: & + phmu = PCNST ! number of long-lived species +#endif + + integer :: nodes ! mpi task count + integer :: plonl ! longitude tile dimension + integer :: pplon ! longitude tile count + integer :: plnplv ! plonl * plev + + end module mo_grid diff --git a/chem_proc/src/Base_Srclist_f b/chem_proc/src/Base_Srclist_f new file mode 100644 index 0000000000..0659d178fb --- /dev/null +++ b/chem_proc/src/Base_Srclist_f @@ -0,0 +1,49 @@ +mozpp.mods.f +mass_diags.f +make_lu_slv.f +res_hdr.f +chm_hdr.f +make_names.f +slt_hdr.f +eqrep.f +rxt_equations.f +sol_cls.f +hist_hdr.f +exe_opts.f +sp_utils.f +mozpp.subs.f +sparse_pat.f +files_hdr.f +params_hdr.f +hist_inp.f +nln_code.f +spat_dim.f +hist_out.f +num_ctl.f +srfflx.f +ipd_code.f +padj_code.f +sub_scan.f +pl_code.f +symbol.f +job_ctl.f +prd_map.f +tokens.f +lin_code.f +radj_code.f +usrsubs.f +mak_grp_vmr.f +rate_code.f +ver_hdr.f +make_lu_fac.f +rate_tab.f +ver_opts.f +rxt_names.f +het_names.f +chem.f +make_map.f +rmod_code.f +cls_map.f +bndy_conds.f +make_sim_dat.f +mozpp.main.f diff --git a/chem_proc/src/Makefile b/chem_proc/src/Makefile new file mode 100644 index 0000000000..113024679c --- /dev/null +++ b/chem_proc/src/Makefile @@ -0,0 +1,174 @@ +#----------------------------------------------------------------------- +# This Makefile is for building MOZART2 Pre-processor +#------------------------------------------------------------------------ + +# Set up special characters +null := +space := $(null) $(null) + +# Check for directory in which to put executable +ifeq ($(MODEL_EXEDIR),$(null)) +MODEL_EXEDIR := ../bin +endif + +# Check for name of executable +ifeq ($(EXENAME),$(null)) +EXENAME := campp +endif + +# Check for source list +ifeq ($(SRCLIST),$(null)) +SRCLIST := Base_Srclist_f +endif + +ifeq ($(OBJ_DIR),$(null)) +OBJ_DIR := ./OBJ +endif + +# Load dependency search path. +# Check for source directories +ifeq ($(SRCDIRS),$(null)) +dirs := ./cam_chempp +else +dirs := ./ $(SRCDIRS) +endif + +# Determine platform +UNAMES := $(shell uname -s) +UNAMEM := $(shell uname -m) + +# Set cpp search path, include netcdf +cpp_dirs := $(dirs) +cpp_path := $(foreach dir,$(cpp_dirs),-I$(dir)) # format for command line + +# Expand any tildes in directory names. Change spaces to colons. +VPATH := $(foreach dir,$(cpp_dirs),$(dir)) +VPATH := $(subst $(space),:,$(VPATH)) + +# Get list of files and determine objects and dependency files +base_srclist_f := $(shell cat $(SRCLIST)) +OBJS := $(foreach file,$(base_srclist_f),$(OBJ_DIR)/$(file:.f=.o)) + +all: $(MODEL_EXEDIR)/$(EXENAME) + +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ + +# guess default compiler +ifeq ($(USER_FC),$(null)) + +#------------------------------------------------------------------------ +# Linux -- including pleiades +#------------------------------------------------------------------------ +ifeq ($(UNAMES),Linux) + USER_FC := pgf95 +endif +#------------------------------------------------------------------------ +# Altix (columbia) +#------------------------------------------------------------------------ +ifeq ($(UNAMEM),ia64) + USER_FC := ifort +endif +#------------------------------------------------------------------------ +# Alpha +#------------------------------------------------------------------------ +ifeq ($(UNAMEM),alpha) + USER_FC := f95 +endif +#------------------------------------------------------------------------ +# AIX ? +#------------------------------------------------------------------------ +ifeq ($(UNAMES),AIX) + USER_FC := xlf95 +endif +#------------------------------------------------------------------------ +# BG/L, BG/P +#------------------------------------------------------------------------ +ifeq ($(UNAMEM),ppc64) + USER_FC := xlf95 +endif +#------------------------------------------------------------------------ +# SGI +#------------------------------------------------------------------------ +ifeq ($(UNAMES),IRIX64) + USER_FC := f90 + MACHFLGS := -OPT:Olimit=8200 +endif + +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ + +endif + +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ +# set compiler flags ... +#------------------------------------------------------------------------ +ifeq ($(USER_FC),ifort) + FFLAGS := -O2 -c -132 -ftz -g -FR -I $(OBJ_DIR) + ifeq ($(DEBUG),TRUE) + FFLAGS += -CB + endif +endif +ifeq ($(USER_FC),lf95) + ifeq ($(DEBUG),TRUE) + FFLAGS := --nfix --nap --chk --g --npca --nsav --trace --trap -c --mod $(OBJ_DIR) -O + else + FFLAGS := --nfix --nap --nchk --ng --npca --nsav --ntrace -c --mod $(OBJ_DIR) -O2 + endif +endif +ifeq ($(USER_FC),pgf90) + FFLAGS := -O1 -c -g -Mfree -module $(OBJ_DIR) + ifeq ($(DEBUG),TRUE) + FFLAGS += -C + endif +endif +ifeq ($(USER_FC),pgf95) + FFLAGS := -O1 -c -g -Mfree -module $(OBJ_DIR) + ifeq ($(DEBUG),TRUE) + FFLAGS += -C + endif +endif +ifeq ($(USER_FC),f90) + FFLAGS := -c -freeform -I $(OBJ_DIR) -O2 $(MACHFLGS) +endif +ifeq ($(USER_FC),f95) + FFLAGS := -O4 -c -tune host -arch host -free -module $(OBJ_DIR) -I $(OBJ_DIR) +endif +ifeq ($(USER_FC),xlf95) + FFLAGS := -g -c -qarch=auto -qnosave -qfree=f90 -qmoddir=$(OBJ_DIR) -I $(OBJ_DIR) -qstrict -O3 +endif +ifeq ($(USER_FC),gfortran) + FFLAGS := -g -c -ffree-form +endif +ifeq ($(USER_FC),g95) + FFLAGS := -g -c -ffree-form +endif + +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ +#------------------------------------------------------------------------ + +FC := $(USER_FC) + +#------------------------------------------------------------------------ +# Default rules +#------------------------------------------------------------------------ + +.SUFFIXES: +.SUFFIXES: .f .F .c .o + +$(OBJ_DIR)/%.o : %.f + $(FC) $(FFLAGS) -o $@ $< + +$(MODEL_EXEDIR)/$(EXENAME): $(OBJS) + $(FC) -o $@ $(OBJS) $(LDFLAGS) + +RM := rm + +clean: + $(RM) -f $(OBJ_DIR)/*.o $(OBJ_DIR)/*.mod $(MODEL_EXEDIR)/$(EXENAME) + +realclean: + $(RM) -f $(OBJ_DIR)/*.o *.d $(MODEL_EXEDIR)/$(EXENAME) diff --git a/chem_proc/src/cam_chempp/alloc.f b/chem_proc/src/cam_chempp/alloc.f new file mode 100644 index 0000000000..92f549aa6b --- /dev/null +++ b/chem_proc/src/cam_chempp/alloc.f @@ -0,0 +1,330 @@ + + module REALLOC +!----------------------------------------------------------------------- +! ... Reallocation module for integer, real, and character arrays +!----------------------------------------------------------------------- + + implicit none + + interface REALLOCATE + module PROCEDURE R3_ALLOCATE, R2_ALLOCATE, R1_ALLOCATE + $, I3_ALLOCATE, I2_ALLOCATE, I1_ALLOCATE + $, C2_ALLOCATE, C1_ALLOCATE + end interface + + CONTAINS + + subroutine R3_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Real realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real, pointer :: array(:,:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz(3) + real, allocatable :: temp(:,:,:) + + siz(1) = SIZE( array,1 ) + siz(2) = SIZE( array,2 ) + siz(3) = SIZE( array,3 ) + ALLOCATE( temp(siz(1),siz(2),siz(3)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R3_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz(1),' x ',siz(2),' x ',siz(3) + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz(1),siz(2),siz(3)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R3_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',siz(1),' x ',siz(2),' x ',siz(3) + stop + end if + array = 0. + array(:siz(1),:,:) = temp(:siz(1),:,:) + DEALLOCATE( temp ) + + end subroutine R3_ALLOCATE + + subroutine R2_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Real realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real, pointer :: array(:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz(2) + real, allocatable :: temp(:,:) + + siz(1) = SIZE( array,1 ) + siz(2) = SIZE( array,2 ) + ALLOCATE( temp(siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R2_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz(1),' x ',siz(2) + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R2_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz(1),' x ',siz(2) + stop + end if + array = 0. + array(:siz(1),:) = temp(:siz(1),:) + DEALLOCATE( temp ) + + end subroutine R2_ALLOCATE + + subroutine R1_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Real realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real, pointer :: array(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz + real, allocatable :: temp(:) + + siz = SIZE( array ) + ALLOCATE( temp(siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R1_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'R1_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz + stop + end if + array = 0. + array(:siz) = temp(:siz) + DEALLOCATE( temp ) + + end subroutine R1_ALLOCATE + + subroutine I3_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Integer realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, pointer :: array(:,:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz(3) + integer, allocatable :: temp(:,:,:) + + siz(1) = SIZE( array,1 ) + siz(2) = SIZE( array,2 ) + siz(3) = SIZE( array,3 ) + ALLOCATE( temp(siz(1),siz(2),siz(3)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I3_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz(1),' x ',siz(2),' x ',siz(3) + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz(1),siz(2),siz(3)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I3_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',siz(1),' x ',siz(2),' x ',siz(3) + stop + end if + array = 0 + array(:siz(1),:,:) = temp(:siz(1),:,:) + DEALLOCATE( temp ) + + end subroutine I3_ALLOCATE + + subroutine I2_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Integer realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, pointer :: array(:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz(2) + integer, allocatable :: temp(:,:) + + siz(1) = SIZE( array,1 ) + siz(2) = SIZE( array,2 ) + ALLOCATE( temp(siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I2_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz(1),' x ',siz(2) + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I2_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz(1),' x ',siz(2) + stop + end if + array = 0 + array(:siz(1),:) = temp(:siz(1),:) + DEALLOCATE( temp ) + + end subroutine I2_ALLOCATE + + subroutine I1_ALLOCATE( array ) +!----------------------------------------------------------------------- +! ... Integer realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, pointer :: array(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz + integer, allocatable :: temp(:) + + siz = SIZE( array ) + ALLOCATE( temp(siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I1_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'I1_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz + stop + end if + array = 0 + array(:siz) = temp(:siz) + DEALLOCATE( temp ) + + end subroutine I1_ALLOCATE + + subroutine C1_ALLOCATE( array, clen ) +!----------------------------------------------------------------------- +! ... Character realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: clen ! length of array elements + character(len=clen), pointer :: array(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz + character(len=clen), allocatable :: temp(:) + + siz = SIZE( array ) + ALLOCATE( temp(siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'C1_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'C1_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz + stop + end if + array = ' ' + array(:siz) = temp(:siz) + DEALLOCATE( temp ) + + end subroutine C1_ALLOCATE + + subroutine C2_ALLOCATE( array, clen ) +!----------------------------------------------------------------------- +! ... Character realloc +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: clen ! length of array elements + character(len=clen), pointer :: array(:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + integer :: siz(2) + character(len=clen), allocatable :: temp(:,:) + + siz(1) = SIZE( array,1 ) + siz(2) = SIZE( array,2 ) + ALLOCATE( temp(siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'C2_ALLOCATE: Failed to allocate temp array' + write(*,*) ' Size = ',siz(1),' x ',siz(2) + stop + end if + temp = array + DEALLOCATE( array ) + ALLOCATE( array(2*siz(1),siz(2)),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'C2_ALLOCATE: Failed to allocate new array' + write(*,*) ' Size = ',2*siz(1),' x ',siz(2) + stop + end if + array = ' ' + array(:siz(1),:) = temp(:siz(1),:) + DEALLOCATE( temp ) + + end subroutine C2_ALLOCATE + + end module REALLOC diff --git a/chem_proc/src/cam_chempp/bndy_conds.f b/chem_proc/src/cam_chempp/bndy_conds.f new file mode 100644 index 0000000000..a071a3e3cd --- /dev/null +++ b/chem_proc/src/cam_chempp/bndy_conds.f @@ -0,0 +1,120 @@ + + module mo_bndy_conds + + private + public :: bndy_conds + + contains + + subroutine bndy_conds( lin, lout, new_nq, new_solsym, bc_is_fixed, bc_cnt ) + + use var_mod, only : var_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: lin, & ! input unit number + lout, & ! output unit number + new_nq ! species count + integer, intent(inout) :: bc_cnt(:) ! count of species with fixed bc + logical, intent(inout) :: bc_is_fixed(:,:) ! fixed bndy condition matrix + character(len=16), intent(in) :: new_solsym(:) ! species names + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: nchar + integer :: toklen(20) + integer :: j, k + integer :: no_tokens + integer :: parsw(2) = 0 + integer :: bndy + + character(len=320) :: buff + character(len=320) :: buffh + character(len=16) :: tokens(20) + + logical :: found + + integer, parameter :: symlen = 8 + +!----------------------------------------------------------------------- +! ... Read the species boundary conditions +!----------------------------------------------------------------------- +section_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDBNDYCONDS' ) then + exit + end if + if( buffh == 'FIXEDLOWERBC' ) then + bndy = 1 + if( parsw(bndy) /= 0 ) then + call errmes( ' BNDY_COND: Fixed Lower BC already specified@', lout, buff, 1, buff ) + end if + else if( buffh == 'FIXEDUPPERBC' ) then + bndy = 2 + if( parsw(bndy) /= 0 ) then + call errmes( ' BNDY_COND: Fixed Upper BC already specified@', lout, buff, 1, buff ) + end if + else + call errmes( ' BNDY_COND: # is an invalid keyword @', lout, buff, 1, buff ) + end if + parsw(bndy) = 1 + +bndy_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDFIXEDLOWERBC' ) then + if( bndy /= 1 ) then + call errmes( ' BNDY_COND: In Fixed Upper BC @', lout, buff, 1, buff ) + else if( parsw(bndy) /= 1 ) then + call errmes( ' BNDY_COND: Fixed Lower BC not entered@', lout, buff, 1, buff ) + end if + exit + else if( buffh == 'ENDFIXEDUPPERBC' ) then + if( bndy /= 2 ) then + call errmes( ' BNDY_COND: In Fixed Lower BC @', lout, buff, 1, buff ) + else if( parsw(bndy) /= 1 ) then + call errmes( ' BNDY_COND: Fixed Upper BC not entered@', lout, buff, 1, buff ) + end if + exit + end if + call gettokens( buff, nchar, ',', symlen, & + tokens, toklen, 20, no_tokens ) + if( no_tokens == 0 ) then + call errmes( ' BNDY_COND: Species input line in error@', lout, buff, 1, buff ) + end if +token_loop : & + do j = 1,no_tokens + bc_cnt(bndy) = bc_cnt(bndy) + 1 + if( bc_cnt(bndy) > var_lim ) then + call errmes( ' BNDY_COND: Species count exceeds limit@', lout, buff, 1, buff ) + end if + found = .false. + do k = 1,new_nq + if( tokens(j) == new_solsym(k) ) then + if( bc_is_fixed(k,bndy) ) then + call errmes( '# is already specified @', lout, tokens(j), toklen(j), buff ) + end if + bc_is_fixed(k,bndy) = .true. + found = .true. + exit + end if + end do + if( .not. found ) then + call errmes( '# is not in solution species list@', lout, tokens(j), toklen(j), buff ) + end if + end do token_loop + end do bndy_loop + end do section_loop + + end subroutine bndy_conds + + end module mo_bndy_conds diff --git a/chem_proc/src/cam_chempp/chem.f b/chem_proc/src/cam_chempp/chem.f new file mode 100644 index 0000000000..b313f56ac9 --- /dev/null +++ b/chem_proc/src/cam_chempp/chem.f @@ -0,0 +1,1341 @@ + + module mo_chem + + implicit none + + private + public :: chem + + character(len=256) :: buff + character(len=256) :: buffh + + integer, private,parameter :: dp = selected_real_kind( 12 ) + + contains + + subroutine chem +!----------------------------------------------------------------------- +! ... Scan chemical reactions and produce base chemistry maps +!----------------------------------------------------------------------- + + use io, only : lin, lout + use var_mod, only : solsym, fixsym, pcesym, & + nq, nfs, spcsym, spccnt, var_lim + use rxt_mod, only : rxno => rxntot, irc => rxmcnt, & + prdcnt, ipcep, ipcel, fixcnt, prdmap, & + fixmap, pcep, pcel, rxmap, hetcnt, & + hetmap, usrcnt, usrmap, rates => rxparm, & + troe_rxparm, troetab, troecnt, troe_sym_rates, & + rattab => rxptab, rateno => rxpcnt, & + pcoeff_cnt, pcoeff_ind, pcoeff, sym_rates, & + phtsym, phtcnt, pht_alias, pht_alias_mult, rxt_lim, rxt_tag, & + prd_lim, rxtnt_lim + use rxt_mod, only : has_cph => cph_flg, enthalpy + use rxt_mod, only : frc_from_dataset + use rxt_mod, only : num_rnts + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +! nsr = number of solution reactants +! nsp = number of solution products +! nf = number of fixed reactants +! npr = number of pce reactants +! npp = number of pce products +!----------------------------------------------------------------------- + integer, parameter :: photolysis = 1, gas_phase = 2 + integer, parameter :: heterogeneous = 3, extraneous = 4 + + character(len=16) :: param + character(len=32) :: rxparms(prd_lim) + character(len=16) :: sym_rate(5) + character(len=16) :: keywords(4) = (/ 'PHOTOLYSIS ', & + 'REACTIONS ', & + 'HETEROGENEOUS ', & + 'EXTFORCING ' /) + +!----------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------- + integer :: nchar, k, nr, np, nsr, nsp, nf, & + npr, npp, ic, kc, i, npl, l, j, m, ipp, im, & + photo, rxtn, npce = 0, ipl + integer :: il, iu, istat + integer :: beg_alias + integer :: rxttab(5,prd_lim) + integer :: parsw(4), & + count1(var_lim), & + count2(var_lim) + integer, allocatable :: toklen(:) + integer :: tokcnt + + character(len=128) :: line + character(len=32) :: loc_rxt_tag + character(len=32) :: loc_pht_alias(2) + character(len=16) :: wrk_char + character(len=16) :: rxtsym(rxtnt_lim) + character(len=16) :: prdsym(prd_lim) + character(len=1) :: char + character(len=24), allocatable :: ext_tokens(:) + character(len=16), allocatable :: tokens(:) + + real :: number + real :: rate(5), pcoeffs(prd_lim) + + logical :: cph_flg + real(dp) :: cph_val + logical :: coeff_flg + logical :: found + + photo = 0 + usrcnt = 0 + rxtn = 1 + rxno = 0 + ipl = 0 + rateno = 0 + parsw = 0 + +keyword_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDCHEMISTRY' ) then + exit + end if + found = .false. + do i = 1,4 + if( buffh == keywords(i) ) then + if( parsw(i) /= 0 ) then + call errmes ( ' # Keyword already used@', & + lout, & + keywords(i), & + len_trim(keywords(i)), & + buff ) + else if( i == 1 .and. parsw(2) /= 0 ) then + call errmes ( 'Must specify Photolysis before Reactions@', & + lout, char, 1, buff ) + end if + parsw(i) = 1 + found = .true. + exit + end if + end do + if( .not. found ) then + call errmes( 'CHEM: # is not a keyword@', & + lout, & + buff, & + len_trim(buff), & + buff ) + end if + select case( i ) + case( photolysis ) +!======================================================================= +! ... The photolysis chemistry processing +!======================================================================= + write(lout,*) ' ' + write(lout,240) +photolysis_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDPHOTOLYSIS' ) then + phtcnt = rxno +!----------------------------------------------------------------------- +! ... Check that all photorates have a reaction tag +!----------------------------------------------------------------------- + if( phtcnt > 0 ) then + k = count( rxt_tag(:phtcnt) /= ' ' ) + if( k /= phtcnt ) then + call errmes( 'All photoreactions must have a reaction tag@', lout, char, 1, buff ) + end if + do ic = 1,phtcnt + if( any( pht_alias(ic,:) /= ' ' ) ) then + line = ' ' + m = len_trim(rxt_tag(ic)) + line = rxt_tag(ic)(:m) // ' -> ' + do k = 1,2 + if( pht_alias(ic,k) /= ' ' ) then + if( k == 2 .and. pht_alias(ic,1) /= ' ' ) then + line(len_trim(line)+1:) = ',' + end if + m = len_trim(pht_alias_mult(ic,k)) + line(len_trim(line)+2:) = pht_alias_mult(ic,k)(:m) // ' * ' + m = len_trim(pht_alias(ic,k)) + line(len_trim(line)+2:) = pht_alias(ic,k)(:m) + end if + end do + end if + end do + end if + cycle keyword_loop + end if + rxtsym(1:3) = ' ' + prdsym(1:4) = ' ' + sym_rate(:) = ' ' +!----------------------------------------------------------------------- +! ... Reaction parsing routine +!----------------------------------------------------------------------- + call rxtprs( nchar, nr, np, rxtsym, prdsym, & + rate, pcoeffs, coeff_flg, rxparms, sym_rate, & + loc_rxt_tag, cph_flg, cph_val, .true. ) +!----------------------------------------------------------------------- +! ... Check for reaction string errors from parsing routine +!----------------------------------------------------------------------- + if( nr < 0 ) then + call errmes ( 'gross syntax errors in reaction string@', lout, char, 1, buff ) + end if + +!----------------------------------------------------------------------- +! ... Reaction mapping routine +!----------------------------------------------------------------------- + call mapper( nq, nfs, npce, nr, np, & + rxtsym, prdsym, solsym, fixsym, pcesym, & + nsr, nsp, nf, npr, npp, & + rxttab, photo, coeff_flg,pcoeffs ) + +!----------------------------------------------------------------------- +! ... Check for logic errors in reaction +!----------------------------------------------------------------------- + if( (nf + nsr + npr) == 0 ) then + call errmes ( 'photo-reaction has no reactants@', lout, char, 1, buff ) + else if( (nf+nsr+npr) >= 2 ) then + call errmes ( 'photo-reaction has two or more reactants@', lout, char, 1, buff ) + end if + if( nf == 1 ) then + if( nsp == 0 .and. npp == 0 ) then + call errmes( 'fixed species photolysis produces nothing@', lout, char, 1, buff ) + end if + rxno = rxno + 1 +!----------------------------------------------------------------------- +! ... Photolysis of an invariant species; check for products +!----------------------------------------------------------------------- + if( nsp /= 0 ) then +!----------------------------------------------------------------------- +! ... Solution species production from fixed species photolysis +!----------------------------------------------------------------------- + prdcnt = prdcnt + 1 + prdmap(prdcnt,1) = rxno + prdmap(prdcnt,2:nsp+1) = rxttab(3,1:nsp) + end if + if( npp /= 0 ) then +!----------------------------------------------------------------------- +! ... Pce species production from fixed species photolysis +!----------------------------------------------------------------------- + ipl = ipl + 1 + do k = 1,npp + ipcep(1) = ipcep(1) + 1 + ic = ipcep(1) + pcep(ic,1,1) = rxttab(5,k) + pcep(ic,2,1) = rxno + pcep(ic,3,1) = ipl + end do + end if +!----------------------------------------------------------------------- +! ... Set the fixed reactants map +!----------------------------------------------------------------------- + fixcnt(1) = fixcnt(1) + 1 + ic = fixcnt(1) + fixmap(ic,1,1) = -rxno + fixmap(ic,2,1) = rxttab(1,1) + kc = rxttab(1,1) + phtsym(rxno) = fixsym(kc) + else if( npr == 1 ) then +!----------------------------------------------------------------------- +! ... Pce species photolysis; put into pce loss map +!----------------------------------------------------------------------- + if( npp /= 0 ) then +!----------------------------------------------------------------------- +! ... Check to see that a pce is not a product species +!----------------------------------------------------------------------- + call errmes( 'pce reactants and products in same reaction@', lout, char, 1, buff ) + end if + rxno = rxno + 1 + ipcel(1) = ipcel(1) + 1 + ic = ipcel(1) + pcel(ic,1,1) = rxttab(4,1) + pcel(ic,2,1) = rxno + kc = rxttab(4,1) + phtsym(rxno) = pcesym(kc) + if( nsp /= 0 ) then + pcel(ic,3:nsp+2,1) = rxttab(3,1:nsp) + end if +!----------------------------------------------------------------------- +! ... Solution species photolysis +!----------------------------------------------------------------------- + else + rxno = rxno + 1 + irc(1) = irc(1) + 1 + ic = irc(1) + rxmap(ic,2,1) = rxttab(2,1) + rxmap(ic,1,1) = rxno + kc = rxttab(2,1) + phtsym(rxno) = solsym(kc) + if( nsp /= 0 ) then +!--------------------------------------------------------------------- +! ... Solution species production from solution photolysis +!--------------------------------------------------------------------- + rxmap(ic,3:2+nsp,1) = rxttab(3,1:nsp) + end if + if( npp /= 0 ) then +!---------------------------------------------------------------------- +! ... Pce species production from solution photolysis +!---------------------------------------------------------------------- + ipl = ipl + 1 + do k = 1,npp + ipcep(2) = ipcep(2)+1 + ic = ipcep(2) + pcep(ic,1,2) = rxttab(5,k) + pcep(ic,2,2) = rxno + pcep(ic,3,2) = rxttab(2,1) + pcep(ic,4,2) = ipl + end do + end if + end if + if( rxno > rxt_lim ) then + call errmes( ' Reaction count exceeds limit@', lout, buff, 1, buff ) + end if +!----------------------------------------------------------------------- +! ... Check for non-unity product coefficients +!----------------------------------------------------------------------- + if( coeff_flg ) then + pcoeff_cnt = pcoeff_cnt + 1 + pcoeff_ind(rxno) = pcoeff_cnt + pcoeff(1:nsp,pcoeff_cnt) = pcoeffs(1:nsp) + end if +!----------------------------------------------------------------------- +! ... Check for photorate alias +!----------------------------------------------------------------------- + m = index( loc_rxt_tag, '=' ) + if( m /= 0 ) then + beg_alias = m + 1 + else + m = index( loc_rxt_tag, '->' ) + if( m > 0 ) then + beg_alias = m + 2 + end if + end if + if( m > 0 ) then + loc_pht_alias(1) = loc_rxt_tag(beg_alias:) + loc_rxt_tag(m:) = ' ' + m = index( loc_pht_alias(1), ',' ) + il = 1 + iu = 2 + if( m == 0 ) then + iu = 1 + else if( m == 1 ) then + il = 2 + loc_pht_alias(2) = loc_pht_alias(1)(2:) + else + loc_pht_alias(2) = loc_pht_alias(1)(m+1:) + loc_pht_alias(1) = loc_pht_alias(1)(:m-1) + end if + do ic = il,iu + k = index( loc_pht_alias(ic), '*' ) + if( k == 0 ) then + pht_alias(rxno,ic) = loc_pht_alias(ic) + else + pht_alias_mult(rxno,ic) = loc_pht_alias(ic)(:k-1) + read(pht_alias_mult(rxno,ic),*,iostat=istat) number + if( istat /= 0 ) then + call errmes ( ' # is not a valid number@', & + lout, & + pht_alias_mult(rxno,ic), & + len_trim(pht_alias_mult(rxno,ic)), & + buff ) + end if + pht_alias(rxno,ic) = loc_pht_alias(ic)(k+1:) + end if + end do + end if +!----------------------------------------------------------------------- +! ... Check for duplicate reaction tag +!----------------------------------------------------------------------- + do m = 1,rxno-1 + if( trim( loc_rxt_tag ) /= ' ' ) then + if( trim( rxt_tag(m) ) == trim( loc_rxt_tag ) ) then + call errmes ( ' # rxtnt alias already in use@', & + lout, & + loc_rxt_tag, & + len_trim(loc_rxt_tag), & + buff ) + end if + end if + end do + rxt_tag(rxno) = loc_rxt_tag + has_cph(rxno) = cph_flg +!----------------------------------------------------------------------- +! ... Print the reaction on unit lout +!----------------------------------------------------------------------- + call outp( rxparms, nr, np, rxtsym, prdsym, sym_rate, rxno, rate, loc_rxt_tag, lout ) + end do photolysis_loop + + case( gas_phase ) +!======================================================================= +! ... The chemical reactions +!======================================================================= + write(lout,*) ' ' + write(lout,260) +gas_phase_rxt_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDREACTIONS' ) then + cycle keyword_loop + end if + + rxtsym(1:3) = ' ' + prdsym(1:4) = ' ' + sym_rate = ' ' + call rxtprs( nchar, nr, np, rxtsym, prdsym, & + rate, pcoeffs, coeff_flg, rxparms, sym_rate, & + loc_rxt_tag, cph_flg, cph_val, .false. ) + + if( nr < 0 ) then + call errmes ( 'there are no reactants@', lout, char, 1, buff ) + end if + num_rnts(rxno+1) = nr + + call mapper( nq, nfs, npce, nr, np, & + rxtsym, prdsym, solsym, fixsym, pcesym, & + nsr, nsp, nf, npr, npp, & + rxttab, rxtn, coeff_flg,pcoeffs ) + + if( nsr == 3 ) then + call errmes ( ' three solution species reactants@', lout, char, 1, buff ) + end if + if( npr >= 2 ) then + call errmes ( ' there are two or more pce reactants@', lout, char, 1, buff ) + end if + if( nsr == 2 .and. npr /= 0 ) then + call errmes ( ' there are two solution and one pce reactants@', lout, char, 1, buff ) + end if + if( (nf+nsr+npr) /= nr ) then + call errmes ( ' reaction parsing algorithm error@', lout, char, 1, buff ) + end if + rxno = rxno + 1 + if( rxno > rxt_lim ) then + call errmes( ' Reaction count exceeds limit@', lout, buff, 1, buff ) + end if +!----------------------------------------------------------------------- +! ... User specified reaction rate ? +!----------------------------------------------------------------------- + if( sym_rate(1) /= ' ' ) then + if( sym_rate(3) == ' ' ) then + rateno = rateno + 1 + rattab(rateno) = rxno + rates(:2,rateno) = rate(:2) + sym_rates(:2,rateno) = sym_rate(:2) + else if( sym_rate(5) /= ' ' ) then + troecnt = troecnt + 1 + troetab(troecnt) = rxno + troe_rxparm(:,troecnt) = rate(:) + troe_sym_rates(:,troecnt) = sym_rate(:) + end if + end if +!----------------------------------------------------------------------- +! ... Check for duplicate reaction tag +!----------------------------------------------------------------------- + do m = 1, rxno-1 + if( trim( loc_rxt_tag ) /= ' ' ) then + if( trim( rxt_tag(m) ) == trim( loc_rxt_tag ) ) then + call errmes ( ' # rxtnt alias already in use@', & + lout, & + loc_rxt_tag, & + len_trim(loc_rxt_tag), & + buff ) + end if + end if + end do + rxt_tag(rxno) = loc_rxt_tag + has_cph(rxno) = cph_flg + if (cph_flg) enthalpy(rxno) = cph_val + call outp( rxparms, nr, np, rxtsym, prdsym, sym_rate, rxno-phtcnt, rate, loc_rxt_tag, lout ) + + if( nf /= 0 ) then + fixcnt(nf) = fixcnt(nf) + 1 + ic = fixcnt(nf) + fixmap(ic,1,nf) = rxno + fixmap(ic,2:1+nf,nf) = rxttab(1,1:nf) + if( nf == nr ) then +!----------------------------------------------------------------------- +! ... Fixed reactants only +!----------------------------------------------------------------------- + prdcnt = prdcnt+1 + fixmap(ic,1,nf) = -rxno + prdmap(prdcnt,1) = rxno + if( nsp /= 0 ) then + prdmap(prdcnt,2:1+nsp) = rxttab(3,1:nsp) + end if + if( npp /= 0 ) then + ipl = ipl + 1 + do k = 1,npp + ipcep(1) = ipcep(1) + 1 + ic = ipcep(1) + pcep(ic,1,1) = rxttab(5,k) + pcep(ic,2,1) = rxno + pcep(ic,3,1) = ipl + end do + end if + cycle + end if + end if + + if( nsr == nr .or. npr == 0 ) then +!----------------------------------------------------------------------- +! ... Solution reactants only +!----------------------------------------------------------------------- + irc(nsr) = irc(nsr) + 1 + ic = irc(nsr) + rxmap(ic,1,nsr) = rxno + rxmap(ic,2:1+nsr,nsr) = rxttab(2,1:nsr) + if( nsp /= 0 ) then + rxmap(ic,nsr+2:nsr+nsp+1,nsr) = rxttab(3,1:nsp) + end if + if( npp /= 0 ) then + ipl = ipl + 1 + npl = nsr + 1 + do k = 1,npp + ipcep(npl) = ipcep(npl) + 1 + ic = ipcep(npl) + pcep(ic,1,npl) = rxttab(5,k) + pcep(ic,2,npl) = rxno + pcep(ic,nsr+3,npl) = ipl + pcep(ic,3:2+nsr,npl) = rxttab(2,1:nsr) + end do + end if + else +!----------------------------------------------------------------------- +! Solution,fixed, and pce reactants possible. +! There is a pce reactant, and either a solution/fixed +! reactant or both. If there is a pce product then +! terminate with a reaction logic error. +!----------------------------------------------------------------------- + if( npp /= 0 ) then + call errmes( ' Reaction has both reactant and product pce species@', lout, char, 1, buff ) + end if + npl = nsr + 1 + ipcel(npl) = ipcel(npl)+1 + ic = ipcel(npl) + pcel(ic,1,npl) = rxttab(4,1) + pcel(ic,2,npl) = rxno + if( npl == 2 ) then + pcel(ic,3,2) = rxttab(2,1) + end if + if( nsp == 0 ) then + cycle + end if + pcel(ic,npl+2:npl+nsp+1,npl) = rxttab(3,1:nsp) + end if +!----------------------------------------------------------------------- +! ... Check for non-unity product coefficients +!----------------------------------------------------------------------- + if( coeff_flg ) then + pcoeff_cnt = pcoeff_cnt + 1 + pcoeff_ind(rxno) = pcoeff_cnt + pcoeff(1:nsp,pcoeff_cnt) = pcoeffs(1:nsp) + end if + end do gas_phase_rxt_loop + + case( heterogeneous ) +!======================================================================= +! The heterogeneous loss chemistry list +!======================================================================= + write(lout,*) ' ' + write(lout,7175) + allocate( toklen(64) ) + allocate( tokens(64) ) +hetero_loop : do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDHETEROGENEOUS' ) then + deallocate( toklen ) + deallocate( tokens ) + cycle keyword_loop + end if + + call gettokens( buff, nchar, ',', 8, tokens, toklen, 64, tokcnt ) + if( tokcnt <= 0 ) then + deallocate( toklen ) + deallocate( tokens ) + call errmes ( ' Error in het list@', lout, param, k, buff ) + end if + end do hetero_loop + + case( extraneous ) +!======================================================================= +! ... The extraneous prod/loss chemistry list +!======================================================================= + write(lout,*) ' ' + write(lout,8175) + allocate( toklen(64) ) + allocate( ext_tokens(64) ) +extfrc_loop : do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDEXTFORCING' ) then + deallocate( toklen ) + deallocate( ext_tokens ) + cycle keyword_loop + end if + + call gettokens( buff, nchar, ',', 24, ext_tokens, toklen, 64, tokcnt ) + if( tokcnt <= 0 ) then + deallocate( toklen ) + deallocate( ext_tokens ) + call errmes ( ' Error in ext prod list@', lout, param, k, buff ) + end if +ext_tok_loop : do j = 1,tokcnt + do m = 1,spccnt(1) + k = index( ext_tokens(j), '<' ) - 1 + if( k < 1 ) then + found = .false. + k = len_trim( ext_tokens(j) ) + else + found = .true. + end if + if( ext_tokens(j)(:k) == spcsym(m,1) ) then + if( usrcnt > 1 ) then + if( any(usrmap(:usrcnt) == m ) ) then + call errmes( ' # is already in ext frc list@', lout, ext_tokens(j), toklen(j), buff ) + end if + end if + usrcnt = usrcnt + 1 + if( usrcnt > rxt_lim ) then + call errmes( ' Extran reaction count exceeds limit@', lout, buff, 1, buff ) + end if + usrmap(usrcnt) = m + !write(lout,'(1x,''('',i2,'')'',3x,a)') usrcnt, trim(spcsym(m,1)) + + if( .not. found ) then + write(lout,'(1x,''('',i2,'')'',3x,a)') usrcnt, trim(spcsym(m,1)) + else + frc_from_dataset(usrcnt) = .true. + write(lout,'(1x,''('',i2,'')'',3x,a,3x,''(dataset)'')') usrcnt, trim(spcsym(m,1)) + end if + + + cycle ext_tok_loop + end if + end do + call errmes ( ' # is not in Solution list@', lout, ext_tokens(j), toklen(j), buff ) + end do ext_tok_loop + end do extfrc_loop + end select + end do keyword_loop + hetcnt = spccnt(1) + do j=1,hetcnt + hetmap(j,1) = j + enddo +!----------------------------------------------------------------------- +! ... Check for pce,sol reaction validity +!----------------------------------------------------------------------- + il = ipcel(2) + ipp = ipcep(3) + if( il == 0 .or. ipp == 0 ) then + return + end if + do i = 1,il + im = pcel(i,1,2) + count1(im) = 1 + end do + do i = 1,ipp + im = pcep(i,1,3) + count2(im) = 1 + end do + do i = 1,npce + if( count1(i) == 1 .and. count2(i) == 1 ) then + call errmes ( 'pce species # violates use rules@', lout, pcesym(i), 8, buff ) + end if + count1(i) = 0 + end do + +240 format(5x,'Photolysis') +260 format(5x,'Reactions') +7175 format('Heterogeneous loss species') +7177 format(1x,'(',i2,')',3x,a8) +8175 format('Extraneous prod/loss species') +!----------------------------------------------------------------------- +! ... End of the chemistry processing code +!----------------------------------------------------------------------- + + end subroutine chem + + subroutine rxtprs( nchar, & + rxtcnt, & + prdcnt, & + rxtsym, & + prdsym, & + rate, & + pcoeffs, & + coeff_flg, & + prdprms, & + sym_rate, & + loc_rxt_tag, & + cph_flg, cph_val, & + is_photorate ) + + use io, only : lin, lout + use rxt_mod, only : rxtnt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Rxtprs parses the reaction and places the symbols +! in the reactant and product character arrays rxtsym & +! prdsym. The reactants and products are checked for +! symbol length violations. The number of reactants +! and products are limited to three each. Reaction rate +! information is checked for numeric validity. There +! must be at least one reactant. No other error checking +! is performed in this subroutine. +!----------------------------------------------------------------------- + + integer, parameter :: symlen = 16 + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: nchar + integer, intent(out) :: rxtcnt, prdcnt + real, intent(out) :: rate(*), pcoeffs(prd_lim) + character(len=*), intent(out) :: loc_rxt_tag + character(len=*), intent(out) :: rxtsym(rxtnt_lim), prdsym(prd_lim) + character(len=*), intent(out) :: prdprms(prd_lim) + character(len=*), intent(out) :: sym_rate(*) + logical, intent(in) :: is_photorate + logical, intent(out) :: coeff_flg + logical, intent(out) :: cph_flg + real(dp), intent(out) :: cph_val + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: retcod + integer :: ncharl, tprdcnt + integer :: comma + integer :: cphndx, eqlndx + integer :: k, j, length, ratcnt, start, position + integer, allocatable :: slen(:) + character(len=320) :: buffl, buffhl + character(len=16), allocatable :: rxparms(:) + character(len=320) :: cph_val_str + + cph_val = -999. + rxtcnt = 0 + prdcnt = 0 + coeff_flg = .false. + cph_flg = .false. + + rate(:5) = 0. + pcoeffs(:) = 1. + ncharl = nchar + allocate( slen(MAX(5,prd_lim)) ) + allocate( rxparms(MAX(5,prd_lim)) ) +!----------------------------------------------------------------------- +! ... Check for reaction name alias, cph +!----------------------------------------------------------------------- + k = index( buff(:ncharl), ']' ) - 1 + if( k > 0 ) then + j = index( buff(:ncharl), '[' ) + 1 + loc_rxt_tag = buff(j:k) + comma = index( buff(j:k), ',' ) + if( comma /= 0 ) then + cphndx = index( buff(j+comma:k),'cph' ) + if (cphndx>0) then + eqlndx = index( buff(j+comma+cphndx:k),'=' ) + if (eqlndx>0) then + cph_val_str = buff(j+comma+cphndx+eqlndx:k) + read(cph_val_str,fmt=*) cph_val + else + cph_val = 0 + endif + cph_flg = .true. + loc_rxt_tag = buff(j:j+comma-2) + end if + end if + buff = buff(k+2:ncharl) + ncharl = nchar - (k+1) + else + loc_rxt_tag = ' ' + end if + + length = index( buff(:ncharl), '=' ) + if( length == 0 ) then + length = index( buff(:ncharl), '->' ) + end if + + if( length <= 1 ) then + if( length == 0 ) then + write(6,102) + else if( length == 1 ) then + write(6,100) + end if + rxtcnt = -1 + return + end if + +!----------------------------------------------------------------------- +! ... Parse out the reactants +!----------------------------------------------------------------------- + call gettokens( buff, & + length-1, & + '+', & + symlen, & + rxtsym, & + slen, & + rxtnt_lim, & + rxtcnt ) + if( rxtcnt < 0 ) then + call errmes( 'Too many reactants in reaction@', lout, buff, 1, buff ) + else if ( rxtcnt == 0 ) then + call errmes( 'Reactant symbol exceeds symbol length@', lout, buff, 1, buff ) + end if + + if( index( buff(:ncharl),'->' ) /= 0 ) then + length = length + 1 + end if + if( length == ncharl ) then ! reaction has reactants only + return + end if + start = length + 1 ! char after "=" sign + position = index( buff(start:ncharl), ';' ) + if( position == 0 ) then ! products, no rates + length = ncharl - start + 1 + else if( position /= 1 ) then + length = position - 1 + end if + +!----------------------------------------------------------------------- +! ... Parse out the products and multipliers +!----------------------------------------------------------------------- + if( position /= 1 ) then + call gettokens( buff(start:), & + length, & + '+', & + len(prdprms(1)), & + prdprms, & + slen, & + prd_lim, & + prdcnt ) + + if( prdcnt < 0 ) then + call errmes( 'Too many products in reaction@', lout, buff, 1, buff ) + else if ( prdcnt == 0 ) then + call errmes( 'Product symbol exceeds symbol length@', lout, buff, 1, buff ) + end if +!----------------------------------------------------------------------- +! ... Check each "product" token for an explicit multiplier +!----------------------------------------------------------------------- + do k = 1,prdcnt + j = index( prdprms(k)(:slen(k)), '*' ) + if( j == 0 ) then + prdsym(k) = prdprms(k)(:symlen) + cycle + else if( j == 1 .or. j == slen(k) ) then + call errmes( ' Product & multiplier syntax error@', lout, prdprms(k), 1, prdprms(k) ) + end if + read(prdprms(k)(:j-1),*,iostat=retcod) pcoeffs(k) + if( retcod /= 0 ) then + call errmes( 'number format error in product multiplier #@', lout, & + prdprms(k), slen(k), buff ) + end if + prdsym(k) = prdprms(k)(j+1:) + if( pcoeffs(k) /= 1. ) then + coeff_flg = .true. + end if + end do + end if + +!----------------------------------------------------------------------- +! ... Set any reaction rate parms +!----------------------------------------------------------------------- + if( position /= 0 ) then + start = start + position + call gettokens( buff(start:), & + ncharl-start+1, & + ',', & + len(rxparms(1)), & + rxparms, & + slen, & + 5, & + ratcnt ) + + if( ratcnt <= 0 ) then + call errmes( ' Syntax error in reaction rate parameters@', lout, buff, 1, buff ) + end if + do k = 1,ratcnt + if( rxparms(k) /= ' ' ) then + read(rxparms(k)(:slen(k)),*,iostat=retcod) rate(k) + if( retcod /= 0 ) then + call errmes( 'number format error in reaction rate #@', lout, rxparms(k), slen(k), buff ) + end if + sym_rate(k) = rxparms(k)(:slen(k)) + else + rate(k) = 0. + sym_rate(k) = ' ' + end if + end do + end if + +!----------------------------------------------------------------------- +! ... New code for extended product lines +!----------------------------------------------------------------------- + do + call cardin( lin, buffl, ncharl ) + + buffhl = buffl + call upcase( buffhl ) + if( .not. is_photorate .and. buffhl == 'ENDREACTIONS' ) then + backspace( lin ) + exit + else if( is_photorate .and. buffhl == 'ENDPHOTOLYSIS' ) then + backspace( lin ) + exit + else + length = index( buffl(:ncharl), '=' ) + if( length == 0 ) then + length = index( buffl(:ncharl), '->' ) + end if + if( length /= 0 ) then + backspace( lin ) + exit + end if + end if + if( buffl(1:1) /= '+' ) then + call errmes ( 'Extended Reactions must start with + delimiter@', lout, buffl, 1, buffl ) + end if + if( prdcnt >= prd_lim ) then + call errmes( 'Too many products in reaction@', lout, buffl, 1, buffl ) + end if +!----------------------------------------------------------------------- +! ... Parse out the products and multipliers +!----------------------------------------------------------------------- + call gettokens( buffl(2:), & + ncharl-1, & + '+', & + len(prdprms(prdcnt+1)), & + prdprms(prdcnt+1), & + slen(prdcnt+1), & + prd_lim-prdcnt, & + tprdcnt ) + if( tprdcnt < 0 ) then + call errmes( 'Too many products in reaction@', lout, buffl, 1, buffl ) + else if ( tprdcnt == 0 ) then + call errmes( 'Product symbol exceeds symbol length@', lout, buffl, 1, buffl ) + end if +!----------------------------------------------------------------------- +! ... Check each "product" token for an explicit multiplier +!----------------------------------------------------------------------- + do k = prdcnt+1,prdcnt+tprdcnt + j = index( prdprms(k)(:slen(k)), '*' ) + if( j == 0 ) then + prdsym(k) = prdprms(k)(:symlen) + cycle + else if( j == 1 .or. j == slen(k) ) then + call errmes( ' Product & multiplier syntax error@', lout, prdprms(k), 1, prdprms(k) ) + end if + read(prdprms(k)(:j-1),*,iostat=retcod) pcoeffs(k) + if( retcod /= 0 ) then + call errmes( 'number format error in product multiplier #@', lout, & + prdprms(k), slen(k), buff ) + end if + prdsym(k) = prdprms(k)(j+1:) + if( pcoeffs(k) /= 1. ) then + coeff_flg = .true. + end if + end do + prdcnt = prdcnt + tprdcnt + end do + + deallocate( slen ) + deallocate( rxparms ) + +!----------------------------------------------------------------------- +! ... Formats +!----------------------------------------------------------------------- +100 format('0 **** reaction string has no reactants ****') +102 format('0 **** reaction string has no = sign separator ****') + + end subroutine rxtprs + + subroutine mapper( nsol, nfix, npce, rxtcnt, & + prdcnt, rxtsym, prdsym, solsym, & + fixsym, pcesym, nsr, nsp, & + nf, npr, npp, rxttab, & + rxtype, coeff_flg,pcoeffs ) + + use io, only : lout + use rxt_mod, only : rxtnt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: nsol, nfix, npce, & + rxtcnt, prdcnt, rxtype + integer, intent(out) :: nsr, nsp, nf, npr, npp + integer, intent(out) :: rxttab(5,*) + real, intent(inout) :: pcoeffs(prd_lim) + logical, intent(inout) :: coeff_flg + character(len=*), intent(in) :: rxtsym(rxtnt_lim), prdsym(prd_lim) + character(len=*), intent(in) :: solsym(:), fixsym(:), pcesym(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: k, l, photo = 0 + logical :: local_flag + + nf = 0 + nsp = 0 + nsr = 0 + npr = 0 + npp = 0 + +rxtnt_scan : & + do k = 1,rxtcnt + if( rxtype == photo ) then + if( k == 2 ) then + if( rxtsym(k) /= 'hv' ) then + call errmes( 'Photo reaction has misplaced or missing "hv" operator@', lout, buff, 1, buff ) + end if + cycle rxtnt_scan + else if( k > 2 ) then + call errmes( 'Photo-reaction can have only one reactant@', lout, buff, 1, buff ) + else if( rxtsym(k) == 'hv' ) then + call errmes( 'Photo-reaction has misplaced "hv" operator@', lout, buff, 1, buff ) + end if + else if( rxtsym(k) == 'hv' ) then + call errmes( ' Photolysis operator "hv" is illegal in a non-photolysis reaction@', lout, buff, 1, buff ) + end if +!----------------------------------------------------------------------- +! ... Parse out fixed reactants +!----------------------------------------------------------------------- + if( nfix /= 0 ) then + do l = 1,nfix + if( rxtsym(k) == fixsym(l) ) then + nf = nf + 1 + rxttab(1,nf) = l + cycle rxtnt_scan + end if + end do + end if +!----------------------------------------------------------------------- +! ... Parse out solution reactants +!----------------------------------------------------------------------- + do l = 1,nsol + if( rxtsym(k) == solsym(l) ) then + nsr = nsr + 1 + rxttab(2,nsr) = l + cycle rxtnt_scan + end if + end do +!----------------------------------------------------------------------- +! ... Parse out the pce reactants +!----------------------------------------------------------------------- + if( npce /= 0 .and. (nsr+nf) /= rxtcnt ) then + do l = 1,npce + if( rxtsym(k) == pcesym(l) ) then + npr = npr + 1 + rxttab(4,npr) = l + cycle rxtnt_scan + end if + end do + end if + call errmes( ' Reactant "#" is not in sol, pce, or fixed lists@', lout, rxtsym(k), len_trim(rxtsym(k)), buff ) + end do rxtnt_scan + +!----------------------------------------------------------------------- +! ... Parse out solution products +!----------------------------------------------------------------------- + local_flag = .false. + do k = 1,prdcnt + do l = 1,nsol + if( prdsym(k) == solsym(l) ) then + nsp = nsp + 1 + rxttab(3,nsp) = l + if( coeff_flg ) then + pcoeffs(nsp) = pcoeffs(k) + if( pcoeffs(k) /= 1.e0 ) then + local_flag = .true. + end if + end if + exit + end if + end do + end do + coeff_flg = local_flag +!----------------------------------------------------------------------- +! ... Parse out the pce products +!----------------------------------------------------------------------- + do k = 1,prdcnt + do l = 1,npce + if( prdsym(k) == pcesym(l) ) then + npp = npp + 1 + rxttab(5,npp) = l + exit + end if + end do + end do + + end subroutine mapper + + subroutine outp( rxparms, & + nr, & + np, & + rxtsym, & + prdsym, & + sym_rate, & + irxn, & + rate, & + loc_rxt_tag, & + lout ) + + use rxt_mod, only : rxtnt_lim, prd_lim + use var_mod, only : nq, nfs, solsym, fixsym + + implicit none + +!----------------------------------------------------------------------- +! OUTP OUTPuts a single reaction and rate +! +! Inputs: +! nr - number of reactants +! np - number of products +! rxparms - vector of "full" product terms (including +! multipliers) +! rxtsym - reactant symbol(s) +! prdsym - product symbol(s) +! irxn - reaction number +! rate - vector of reaction rate parameters +! lout - logical OUTPut unit number +! Outputs: +! NONE +!----------------------------------------------------------------------- + + integer, intent(in) :: nr, np, irxn, lout + real, intent(in) :: rate(:) + character(len=*), intent(in) :: rxparms(prd_lim) + character(len=*), intent(in) :: sym_rate(5) + character(len=*), intent(in) :: loc_rxt_tag + character(len=*), intent(in) :: rxtsym(rxtnt_lim), prdsym(prd_lim) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, j, k, kl, length, slen, retcod, line_cnt + integer :: buff_pos, arrow_pos + real :: coeff + character(len=320) :: buff + character(len=64) :: rx_piece + +!----------------------------------------------------------------------- +! ... function declarations +!----------------------------------------------------------------------- + integer :: inclist + + buff = ' ' + j = 1 + +!----------------------------------------------------------------------- +! ... Form the reactants +!----------------------------------------------------------------------- + do i = 1,nr + length = len_trim( rxtsym(i) ) + buff(j:length+j-1) = rxtsym(i)(:length) + j = length + j + 1 + if( i == nr ) then + buff(j:) = '->' + j = j + 3 + else + buff(j:) = '+' + j = j + 2 + end if + end do + buff_pos = j ; arrow_pos = j + +!----------------------------------------------------------------------- +! ... Form the products +!----------------------------------------------------------------------- + line_cnt = 1 + if( np /= 0 ) then + do i = 1,np + if( i /= 1 ) then + rx_piece = '+' + else + rx_piece = ' ' + end if + j = 1 + length = index( rxparms(i), '*' ) + if( length /= 0 ) then + read(rxparms(i)(:length-1),*,iostat=retcod) coeff + if( retcod /= 0 ) then + call errmes( ' # is not a valid real number@', & + lout, & + rxparms(i), & + length-1, & + buff ) + end if + if( coeff /= 1. ) then + length = length + 1 + slen = len_trim( rx_piece ) + rx_piece(slen+2:slen+length+1) = rxparms(i)(:length-1) + j = len_trim( rx_piece ) + 1 + else + j = len_trim( rx_piece ) + 2 + end if + else + j = len_trim( rx_piece ) + 2 + end if + kl = inclist( trim(prdsym(i)), solsym, nq ) + if( kl < 1 .and. nfs > 0 ) then + kl = inclist( trim(prdsym(i)), fixsym, nfs ) + end if + length = len_trim( prdsym(i) ) + if( kl > 0 ) then + rx_piece(j:length+j-1) = prdsym(i)(:length) + else + rx_piece(j:length+j+1) = '{' // prdsym(i)(:length) // '}' + end if + length = len_trim( rx_piece ) + if( (buff_pos + length) <= 69 ) then + buff(buff_pos:) = trim( rx_piece ) + buff_pos = buff_pos + length + 1 + if( i == np ) then + kl = line_cnt + do k = kl,max(4,line_cnt) + call write_rxt( buff, sym_rate, rate, loc_rxt_tag, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + else + call write_rxt( buff, sym_rate, rate, loc_rxt_tag, irxn, line_cnt ) + line_cnt = line_cnt + 1 + buff(arrow_pos+1:) = trim( rx_piece ) + buff_pos = len_trim( buff ) + 2 + if( i == np ) then + kl = line_cnt + do k = kl,max(4,line_cnt) + call write_rxt( buff, sym_rate, rate, loc_rxt_tag, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + end if + end do + else + buff(j:) = '(No products)' + do k = 1,3 + call write_rxt( buff, sym_rate, rate, loc_rxt_tag, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + + end subroutine outp + + subroutine write_rxt( buff, sym_rate, rate, loc_rxt_tag, irxn, line_cnt ) +!----------------------------------------------------------------------- +! ... Print the reaction rate +!----------------------------------------------------------------------- + + use io, only : lout + use rxt_mod, only : phtcnt + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: line_cnt, irxn + real, intent(in) :: rate(:) + character(len=*), intent(inout) :: buff + character(len=*), intent(in) :: sym_rate(:) + character(len=*), intent(in) :: loc_rxt_tag + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + logical :: troe_rate + + if( line_cnt <= 3 ) then + if( sym_rate(1) /= ' ' ) then + troe_rate = rate(1) /= 0. .and. rate(3) /= 0. + if( line_cnt == 1 ) then + if( rate(1) == 0. ) then + buff(69:) = ' rate = 0.' + write(lout,100) loc_rxt_tag, irxn, buff, irxn+phtcnt + else if( .not. troe_rate ) then + buff(69:) = ' rate = ' + write(buff(77:),'(1pe8.2)') rate(1) + if( rate(2) /= 0. ) then + buff(85:) = '*exp(' + write(buff(90:),'(f8.0)') rate(2) + buff(98:) = '/t)' + end if + write(lout,100) loc_rxt_tag, irxn, buff, irxn+phtcnt + else + buff(69:) = ' troe : ko=' + write(buff(80:),'(1pe8.2)') rate(1) + if( rate(2) /= 0. ) then + buff(88:) = '*(300/t)**' + if ( rate(2)>=0. ) then + write(buff(98:),'(f4.2)') rate(2) + else + write(buff(98:),'(f5.2)') rate(2) + endif + end if + write(lout,110) loc_rxt_tag, irxn, buff, irxn+phtcnt + end if + else if( troe_rate ) then + if( line_cnt == 2 ) then + buff(69:) = ' ki=' + write(buff(80:),'(1pe8.2)') rate(3) + if( rate(4) /= 0. ) then + if( rate(4) /= 1. ) then + buff(88:) = '*(300/t)**' + if ( rate(4)>=0. ) then + write(buff(98:),'(f4.2)') rate(4) + else + write(buff(98:),'(f5.2)') rate(4) + endif + else + buff(88:) = '*(300/t)' + end if + end if + else if( line_cnt == 3 ) then + buff(69:) = ' f=' + write(buff(80:),'(f4.2)') rate(5) + end if + write(lout,120) buff + else if( buff /= ' ' ) then + write(lout,120) buff + end if + else + if( line_cnt == 1 ) then + buff(69:) = ' rate = ** User defined **' + write(lout,100) loc_rxt_tag, irxn, buff, irxn+phtcnt + else if( buff /= ' ' ) then + write(lout,120) buff + end if + end if + else if( buff /= ' ' ) then + write(lout,120) buff + end if + buff = ' ' + +!----------------------------------------------------------------------- +! ... Formats +!----------------------------------------------------------------------- +100 format(2x,a16,1x,'(',i3,')',3x,a100,3x,'(',i3,')') +110 format(2x,a16,1x,'(',i3,')',3x,a101,2x,'(',i3,')') +120 format(27x,a103) + + end subroutine write_rxt + + end module mo_chem diff --git a/chem_proc/src/cam_chempp/chm_hdr.f b/chem_proc/src/cam_chempp/chm_hdr.f new file mode 100644 index 0000000000..67085f9887 --- /dev/null +++ b/chem_proc/src/cam_chempp/chm_hdr.f @@ -0,0 +1,110 @@ + + subroutine chm_hdr( rxt_tag_cnt, enthalpy_cnt, hetcnt, usrcnt, cls_rxt_cnt, radj_flag, phtcnt, & + rxpcnt, rxparm, rxntot, ncol, nfs, nslvd, & + indexm, indexh2o, spcno, relcnt, grpcnt, & + clscnt, iter_counts, nzcnt, vec_ftns, machine, chemistry, veclen ) +!----------------------------------------------------------------------- +! ... Write the chemistry "header" file +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: rxt_tag_cnt + integer, intent(in) :: enthalpy_cnt + integer, intent(in) :: hetcnt ! count of washout processes + integer, intent(in) :: usrcnt ! count of extraneous forcing + integer, intent(in) :: phtcnt ! count of photorates + integer, intent(in) :: rxpcnt ! count of specified rates + integer, intent(in) :: rxntot ! count of totol reactions + integer, intent(in) :: ncol ! number of column integrals + integer, intent(in) :: nfs ! number of "fixed" species + integer, intent(in) :: nslvd ! number of "short lived" species + integer, intent(in) :: indexm ! index for "m" + integer, intent(in) :: indexh2o ! index for h2o + integer, intent(in) :: spcno ! total number of xported species + integer, intent(in) :: relcnt ! number of "relative" species + integer, intent(in) :: grpcnt ! number of group species + integer, intent(in) :: nzcnt(2) ! number of non-zero entries in lu + integer, intent(in) :: clscnt(5) ! solution class count + integer, intent(in) :: iter_counts(4) ! iteration counts + integer, intent(in) :: cls_rxt_cnt(4,5) ! class reaction count + + real, intent(in) :: rxparm(2,*) ! rxtn rate parms + logical, intent(in) :: radj_flag ! rxt adjust flag + logical, intent(in) :: vec_ftns ! vector function flag + logical, intent(in) :: chemistry ! chemistry flag + + character(len=16), intent(in) :: machine ! target machine + integer, intent(in) :: veclen ! vector length in vectorized solver + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: gascnt ! number of gas phase rxtns + logical :: lexist + + inquire( file = 'chem.h', exist = lexist ) + if( lexist ) then + call system( 'rm chem.h' ) + end if + open( unit = 30, file = 'chem.h' ) + + write(30,'(''# define RXTTAGCNT '',i5)') rxt_tag_cnt + write(30,'(''# define ENTHALPYCNT '',i5)') enthalpy_cnt + write(30,'(''# define HETCNT '',i5)') hetcnt + write(30,'(''# define EXTCNT '',i5)') usrcnt + gascnt = sum( cls_rxt_cnt(1,1:5) ) + write(30,'(''# define CLSINDPRD '',i5)') gascnt + write(30,'(''# define CLSINDPRD1 '',i5)') cls_rxt_cnt(1,1) + write(30,'(''# define CLSINDPRD2 '',i5)') cls_rxt_cnt(1,2) + write(30,'(''# define CLSINDPRD3 '',i5)') cls_rxt_cnt(1,3) + write(30,'(''# define CLSINDPRD4 '',i5)') cls_rxt_cnt(1,4) + write(30,'(''# define CLSINDPRD5 '',i5)') cls_rxt_cnt(1,5) + write(30,'(''# define IMP_NZCNT '',i5)') nzcnt(1) + write(30,'(''# define ROD_NZCNT '',i5)') nzcnt(2) + gascnt = cls_rxt_cnt(2,4) + cls_rxt_cnt(4,4) + write(30,'(''# define IMP_LINCNT '',i5)') gascnt + gascnt = cls_rxt_cnt(2,5) + cls_rxt_cnt(4,5) + write(30,'(''# define ROD_LINCNT '',i5)') gascnt + write(30,'(''# define IMP_NLNCNT '',i5)') cls_rxt_cnt(3,4) + write(30,'(''# define ROD_NLNCNT '',i5)') cls_rxt_cnt(3,5) + if( radj_flag ) then + write(30,'(''# define RADJFLAG'')') + end if + write(30,'(''# define PHTCNT '',i5)') phtcnt + write(30,'(''# define PHTCNTP1 '',i5)') phtcnt+1 + write(30,'(''# define RXNCNT '',i5)') rxntot + gascnt = rxntot - phtcnt + write(30,'(''# define GASCNT '',i5)') gascnt + write(30,'(''# define SETRXNCNT '',i5)') rxpcnt + write(30,'(''# define USRRXNCNT '',i5)') gascnt - rxpcnt + gascnt = count( rxparm(2,1:rxpcnt) /= 0. ) + write(30,'(''# define TDEPCNT '',i5)') gascnt + write(30,'(''# define NCOL '',i5)') ncol + write(30,'(''# define NFS '',i5)') nfs + write(30,'(''# define NSLVD '',i5)') nslvd + write(30,'(''# define VECLEN '',i5)') veclen + write(30,'(''# define INDEXM '',i5)') indexm + write(30,'(''# define INDEXH2O '',i5)') indexh2o + write(30,'(''# define PCNST '',i5)') spcno + write(30,'(''# define PCNSTP2 '',i5)') spcno+2 + write(30,'(''# define RELCNT '',i5)') relcnt + write(30,'(''# define GRPCNT '',i5)') grpcnt + write(30,'(''# define CLSCNT1 '',i5)') clscnt(1) + write(30,'(''# define CLSCNT2 '',i5)') clscnt(2) + write(30,'(''# define CLSCNT3 '',i5)') clscnt(3) + write(30,'(''# define CLSCNT4 '',i5)') clscnt(4) + write(30,'(''# define CLSCNT5 '',i5)') clscnt(5) + write(30,'(''# define EBIITERMAX '',i5)') MAX( 1,iter_counts(4) ) + write(30,'(''# define HOVITERMAX '',i5)') MAX( 1,iter_counts(1) ) + write(30,'(''# define IMPITERMAX '',i5)') MAX( 1,iter_counts(2) ) + write(30,'(''# define IMPJACITER '',i5)') MAX( 1,iter_counts(3) ) + if( chemistry ) then + write(30,'(''# define TROP_CHEM'')') + end if + close( 30 ) + + end subroutine chm_hdr diff --git a/chem_proc/src/cam_chempp/cls_map.f b/chem_proc/src/cam_chempp/cls_map.f new file mode 100644 index 0000000000..a4e884ce9b --- /dev/null +++ b/chem_proc/src/cam_chempp/cls_map.f @@ -0,0 +1,239 @@ + + subroutine CLS_MAPS( ) +!----------------------------------------------------------------------- +! ... Form the individual method reaction maps from the +! overall reaction map +!----------------------------------------------------------------------- + + use IO, only : lout + use VAR_MOD, only : extcnt + use RXT_MOD, only : cls_rxt_map, cls_rxt_cnt, rxmap, rxmcnt, & + prdmap, prdcnt, hetmap, hetcnt, usrmap, & + usrcnt, prd_lim, prd_limp1 + use MO_MAKE_MAP, only : MAKE_MAP + use MO_PRD_MAP, only : PRD_MAP + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, allocatable :: template(:,:) + integer :: i, j, astat + integer :: class + integer :: index + integer :: row + integer :: rxno + integer :: rxtnt(2), rxtnt_cls(2) + + integer :: XLATE + +!----------------------------------------------------------------------- +! ... In the following the 1st column of template +! represents the count of products in each class. +! The 2nd column represents the class # of the product. +! On input the 3rd column represents the master +! product number and on output represents the product +! number in the specific class. +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... Scan the base "pure" production map +! for class pure production entries +!----------------------------------------------------------------------- + ALLOCATE( template(MAX(5,prd_lim),3),stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'CLS_MAP: Failed to allocate template array; error = ',astat + stop + end if + do i = 1,prdcnt + template(:prd_lim,3) = prdmap(i,2:prd_limp1) + call PRD_MAP( template ) + rxno = prdmap(i,1) + do class = 1,5 + if( template(class,1) /= 0 ) then + index = cls_rxt_cnt(1,class) + 1 + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(1,class), & + class, & + rxno, & + template(class,1), & + template ) + end if + end do + end do + +!----------------------------------------------------------------------- +! ... Scan the base linear reaction map +! for class pure production entries +!----------------------------------------------------------------------- + do i = 1,rxmcnt(1) + template(:prd_lim,3) = rxmap(i,3:prd_lim+2,1) + call PRD_MAP( template ) + rxtnt(1) = ABS( rxmap(i,2,1) ) + rxtnt_cls(1) = XLATE( rxtnt(1) ) + rxno = rxmap(i,1,1) + do class = 1,5 + if( class /= rxtnt_cls(1) .and. template(class,1) /= 0 ) then + index = cls_rxt_cnt(1,class) + 1 + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(1,class), & + class, & + rxno, & + template(class,1), & + template ) + cls_rxt_map(index,2,class) = ABS( rxmap(i,2,1) ) + end if + end do + end do + +!----------------------------------------------------------------------- +! ... Scan the base nonlinear reaction map +! for class pure production entries +!----------------------------------------------------------------------- + do i = 1,rxmcnt(2) + template(:prd_lim,3) = rxmap(i,4:prd_lim+3,2) + call PRD_MAP( template ) + rxtnt = ABS( rxmap(i,2:3,2) ) + rxno = rxmap(i,1,2) + do j = 1,2 + rxtnt_cls(j) = XLATE( rxtnt(j) ) + end do + do class = 1,5 + if( class /= rxtnt_cls(1) .and. class /= rxtnt_cls(2) .and. template(class,1) /= 0 ) then + index = cls_rxt_cnt(1,class) + 1 + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(1,class), & + class, & + rxno, & + template(class,1), & + template ) + cls_rxt_map(index,2:3,class) = ABS( rxmap(i,2:3,2) ) + end if + end do + end do + +!----------------------------------------------------------------------- +! ... Scan the base linear reaction map +! for entries in the class linear map +!----------------------------------------------------------------------- + do i = 1,rxmcnt(1) + template(:prd_lim,3) = rxmap(i,3:prd_lim+2,1) + call PRD_MAP( template ) + rxtnt(1) = ABS( rxmap(i,2,1) ) + class = XLATE( rxtnt(1) ) + rxno = rxmap(i,1,1) + if( template(class,1) /= 0 ) then + index = MAX( SUM(cls_rxt_cnt(1:2,class))+1,1 ) + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(2,class), & + class, & + rxno, & + template(class,1), & + template ) + cls_rxt_map(index,2,class) = rxmap(i,2,1) + else if( rxmap(i,2,1) > 0 ) then + cls_rxt_cnt(2,class) = cls_rxt_cnt(2,class) + 1 + row = SUM( cls_rxt_cnt(1:2,class) ) + cls_rxt_map(row,1:2,class) = rxmap(i,1:2,1) + end if + end do + +!----------------------------------------------------------------------- +! ... Scan the base nonlinear reaction map +! for entries in the class linear map +!----------------------------------------------------------------------- + do i = 1,rxmcnt(2) + do j = 1,2 + rxtnt(j) = ABS( rxmap(i,j+1,2) ) + rxtnt_cls(j) = XLATE( rxtnt(j) ) + end do + if( rxtnt_cls(1) /= rxtnt_cls(2) ) then + template(:prd_lim,3) = rxmap(i,4:prd_lim+3,2) + call PRD_MAP( template ) + do j = 1,2 + class = rxtnt_cls(j) + if( template(class,1) /= 0 ) then + index = MAX( SUM(cls_rxt_cnt(1:2,class))+1,1 ) + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(2,class), & + class, & + rxmap(i,1,2), & + template(class,1), & + template ) + cls_rxt_map(index,2,class) = rxmap(i,j+1,2) + if( j == 1 ) then + cls_rxt_map(index,3,class) = ABS( rxmap(i,3,2) ) + else + cls_rxt_map(index,3,class) = ABS( rxmap(i,2,2) ) + end if + else if( rxmap(i,j+1,2) > 0 ) then + cls_rxt_cnt(2,class) = cls_rxt_cnt(2,class) + 1 + row = cls_rxt_cnt(1,class) + cls_rxt_cnt(2,class) + cls_rxt_map(row,1,class) = rxmap(i,1,2) + if( j == 1 ) then + cls_rxt_map(row,2:3,class) = ABS( rxmap(i,2:3,2) ) + else + cls_rxt_map(row,2:3,class) = ABS( rxmap(i,3:2:-1,2) ) + end if + end if + end do + end if + end do + +!----------------------------------------------------------------------- +! ... Scan the base nonlinear reaction map +! for entries in the class nonlinear map +!----------------------------------------------------------------------- + do i = 1,rxmcnt(2) + do j = 1,2 + rxtnt(j) = ABS( rxmap(i,j+1,2) ) + rxtnt_cls(j) = XLATE( rxtnt(j) ) + end do + if( rxtnt_cls(1) == rxtnt_cls(2) ) then + template(:prd_lim,3) = rxmap(i,4:prd_lim+3,2) + call PRD_MAP( template ) + class = rxtnt_cls(1) + if( template(class,1) /= 0 ) then + index = MAX( 1,SUM(cls_rxt_cnt(1:3,class))+1 ) + call MAKE_MAP( cls_rxt_map(index,:,class), & + cls_rxt_cnt(3,class), & + class, & + rxmap(i,1,2), & + template(class,1), & + template ) + cls_rxt_map(index,2:3,class) = rxmap(i,2:3,2) + else if( rxmap(i,2,2) > 0 .or. rxmap(i,3,2) > 0 ) then + cls_rxt_cnt(3,class) = cls_rxt_cnt(3,class) + 1 + row = SUM( cls_rxt_cnt(1:3,class) ) + cls_rxt_map(row,1:3,class) = rxmap(i,1:3,2) + end if + end if + end do + +!----------------------------------------------------------------------- +! ... Scan the heterogeneous reactions +!----------------------------------------------------------------------- + do i = 1,hetcnt + rxtnt(1) = ABS( hetmap(i,1) ) + class = XLATE( rxtnt(1) ) + cls_rxt_cnt(4,class) = cls_rxt_cnt(4,class) + 1 + index = SUM( cls_rxt_cnt(1:4,class) ) + cls_rxt_map(index,1,class) = i + cls_rxt_map(index,2,class) = rxtnt(1) + end do + +!----------------------------------------------------------------------- +! ... Scan the extraneous forcing +!----------------------------------------------------------------------- + do i = 1,usrcnt + rxtnt(1) = ABS( usrmap(i) ) + class = XLATE( rxtnt(1) ) + extcnt(class) = extcnt(class) + 1 + index = SUM( cls_rxt_cnt(1:4,class) ) + extcnt(class) + cls_rxt_map(index,1,class) = i + cls_rxt_map(index,2,class) = rxtnt(1) + end do + + DEALLOCATE( template ) + + end subroutine CLS_MAPS diff --git a/chem_proc/src/cam_chempp/eqrep.f b/chem_proc/src/cam_chempp/eqrep.f new file mode 100644 index 0000000000..7a387f6332 --- /dev/null +++ b/chem_proc/src/cam_chempp/eqrep.f @@ -0,0 +1,420 @@ +module utils + + contains + subroutine EQUATION_REP( & + nq, & + solsym, & + nfix, & + fixsym, & + prdcnt, & + prdmap, & + rxntot, & + rxmcnt, & + rxmap, & + coeff_cnt, & + coeff_ind, & + coeffs, & + fxmcnt, & + fixmap, & + phtcnt ) + + use IO, only : lout + use VAR_MOD, only : var_lim + use RXT_MOD, only : rxt_lim, prd_lim, prd_limp1 + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: nq, & + nfix, & + prdcnt, & + rxntot, & + coeff_cnt, & + phtcnt + integer, intent(in) :: prdmap(var_lim,prd_limp1), & + rxmcnt(2), & + rxmap(rxt_lim,prd_lim+3,2), & + coeff_ind(rxt_lim), & + fxmcnt(2), & + fixmap(var_lim,3,2) + + real, intent(in) :: coeffs(prd_lim,rxt_lim) + + character(len=16), intent(in) :: solsym(*), & + fixsym(*) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, j, k, l + integer :: spc_num, length, beg_mark + integer :: line_pos, line_num, buf_pos, rxno + + character(len=320) :: lines(2) + character(len=80) :: eq_piece + character(len=16) :: symbol + + logical :: production, destruction, blow_off, quadratic + + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,'('' Equation Report'')') + write(lout,*) ' ' + + do spc_num = 1,nq + production = .false. + destruction = .false. + line_num = 1 + lines = ' ' + lines(1) = ' d(' + length = LEN_TRIM( solsym(spc_num) ) + lines(1)(7:) = solsym(spc_num)(:length) + line_pos = 7 + length + lines(1)(line_pos:) = ')/dt = ' + line_pos = line_pos + 7 + beg_mark = line_pos +!----------------------------------------------------------------------- +! ... Scan the "independent" production map for product target +!----------------------------------------------------------------------- + do i = 1,prdcnt + do k = 2,prd_limp1 + if( prdmap(i,k) == 0 ) then + exit + else if( prdmap(i,k) /= spc_num ) then + cycle + end if + eq_piece = ' ' + if( production ) then + eq_piece = ' + ' + buf_pos = 4 + else + buf_pos = 1 + end if + production = .true. + rxno = prdmap(i,1) + if( coeff_ind(rxno) /= 0 ) then + if( coeffs(k-1,coeff_ind(rxno)) /= 1.e0 ) then + call NUMCON( eq_piece(buf_pos:), coeffs(k-1,coeff_ind(rxno)), 'l' ) + buf_pos = LEN_TRIM( eq_piece ) + 1 + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = '*r' + else + eq_piece(buf_pos:) = '*j' + end if + buf_pos = buf_pos + 2 + else + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = 'r' + else + eq_piece(buf_pos:) = 'j' + end if + buf_pos = buf_pos + 1 + end if + else + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = 'r' + else + eq_piece(buf_pos:) = 'j' + end if + buf_pos = buf_pos + 1 + end if + if( rxno > phtcnt ) then + call NUMCON( eq_piece(buf_pos:), REAL(rxno-phtcnt), 'l' ) + else + call NUMCON( eq_piece(buf_pos:), REAL(rxno), 'l' ) + end if + buf_pos = LEN_TRIM( eq_piece ) + 1 + call SET_FIXED_REACTANTS( fixmap, var_lim, 3, & + rxno, fixsym, eq_piece, buf_pos, & + phtcnt ) + length = buf_pos + if( (line_pos+length) > 120 ) then ! inc line count + line_pos = beg_mark + line_num = line_num + 1 + if( line_num > 2 ) then ! write out the buffer + write(lout,'(a120)') lines + line_num = 1 + lines = ' ' + end if + end if + lines(line_num)(line_pos:) = eq_piece(:length) + line_pos = line_pos + length + end do + end do + +!----------------------------------------------------------------------- +! ... Scan the "regular" reaction map for product target +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + do k = i+2,i+prd_limp1 + if( rxmap(j,k,i) == 0 ) then + exit + else if( rxmap(j,k,i) /= spc_num ) then + cycle + end if + eq_piece = ' ' + if( production ) then + eq_piece = ' + ' + buf_pos = 4 + else + buf_pos = 1 + end if + production = .true. + rxno = rxmap(j,1,i) + if( coeff_ind(rxno) /= 0 ) then + if ( coeffs(k-(i+1),coeff_ind(rxno)) /= 1.e0 ) then + call NUMCON( eq_piece(buf_pos:), coeffs(k-(i+1),coeff_ind(rxno)), 'l' ) + buf_pos = LEN_TRIM( eq_piece ) + 1 + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = '*r' + else + eq_piece(buf_pos:) = '*j' + end if + buf_pos = buf_pos + 2 + else + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = 'r' + else + eq_piece(buf_pos:) = 'j' + end if + buf_pos = buf_pos + 1 + end if + else + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = 'r' + else + eq_piece(buf_pos:) = 'j' + end if + buf_pos = buf_pos + 1 + end if + + if( rxno > phtcnt ) then + call NUMCON( eq_piece(buf_pos:), REAL(rxno-phtcnt), 'l' ) + else + call NUMCON( eq_piece(buf_pos:), REAL(rxno), 'l' ) + end if + buf_pos = LEN_TRIM( eq_piece ) + 1 + call SET_FIXED_REACTANTS( fixmap, var_lim, 3, & + rxno, fixsym, eq_piece, buf_pos, & + phtcnt ) + do l = 2,i+1 + if( rxmap(j,l,i) == 0 ) then + exit + end if + symbol = solsym(ABS(rxmap(j,l,i))) + length = LEN_TRIM( symbol ) + eq_piece(buf_pos:) = '*' // symbol(:length) + buf_pos = buf_pos + length + 1 + end do + length = buf_pos + if( (line_pos+length) > 120 ) then !inc line count + line_pos = beg_mark + line_num = line_num + 1 + if( line_num > 2 ) then !write out the buffer + write(lout,'(a120)') lines + line_num = 1 + lines = ' ' + end if + end if + lines(line_num)(line_pos:) = eq_piece(:length) + line_pos = line_pos + length + end do + end do + end do +!----------------------------------------------------------------------- +! ... If buffer has unprinted lines flush it +!----------------------------------------------------------------------- + if( production ) then + do l = 1,line_num + if( lines(l) /= ' ' ) then + write(lout,'(a120)') lines(l) + end if + end do + lines(1:line_num) = ' ' + line_num = 1 + line_pos = beg_mark + end if + +!----------------------------------------------------------------------- +! ... Scan the "regular" reaction map for reactant target +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + blow_off = .false. + quadratic = .false. + do k = 2,i+1 + eq_piece = ' ' + if( rxmap(j,k,i) /= spc_num ) then + cycle + end if + eq_piece = ' - ' + buf_pos = 4 + if( i == 2 .and. k == 2 ) then + if( rxmap(j,3,i) == spc_num ) then + eq_piece(buf_pos:) = '2*' + buf_pos = buf_pos + 2 + blow_off = .true. + quadratic = .true. + else + quadratic = .false. + end if + end if + destruction = .true. + rxno = rxmap(j,1,i) + if( rxno > phtcnt ) then + eq_piece(buf_pos:) = 'r' + else + eq_piece(buf_pos:) = 'j' + end if + buf_pos = buf_pos + 1 + if( rxno > phtcnt ) then + call NUMCON( eq_piece(buf_pos:), REAL(rxno-phtcnt), 'l' ) + else + call NUMCON( eq_piece(buf_pos:), REAL(rxno), 'l' ) + end if + buf_pos = LEN_TRIM( eq_piece ) + 1 + if( i == 1 ) then + blow_off = .true. + end if + call SET_FIXED_REACTANTS( fixmap, var_lim, 3, & + rxno, fixsym, eq_piece, buf_pos, & + phtcnt ) + if( blow_off ) then + symbol = solsym(spc_num) + else + do l = 2,i+1 + if( ABS(rxmap(j,l,i)) == spc_num ) then + cycle + end if + symbol = solsym(ABS(rxmap(j,l,i))) + end do + end if + length = LEN_TRIM( symbol ) + eq_piece(buf_pos:) = '*' // symbol(:length) + buf_pos = buf_pos + length + 1 + if( .not. blow_off .or. quadratic ) then + symbol = solsym(spc_num) + length = LEN_TRIM( symbol ) + eq_piece(buf_pos:) = '*' // symbol(:length) + buf_pos = buf_pos + length + 1 + end if + length = buf_pos + if( (line_pos+length) > 120 ) then ! inc line count + line_pos = beg_mark + line_num = line_num + 1 + if( line_num > 2 ) then ! write out the buffer + write(lout,'(a120)') lines + line_num = 1 + lines = ' ' + end if + end if + lines(line_num)(line_pos:) = eq_piece(:length) + line_pos = line_pos + length + if( blow_off ) then + exit + end if + end do + end do + end do + + if( .not. production .and. .not. destruction ) then + lines(line_num)(line_pos:) = '0' + end if + +!----------------------------------------------------------------------- +! ... If buffer has unprinted lines flush it +!----------------------------------------------------------------------- + do l = 1,line_num + if( lines(l) /= ' ' ) then + write(lout,'(a120)') lines(l) + end if + end do + + end do + + end subroutine EQUATION_REP + + integer function GET_INDEX( array, rdim, cdim, scol, key ) + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: rdim, cdim, scol, key + integer, intent(in) :: array(rdim,cdim) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i + + do i = 1,rdim + if( array(i,scol) == key ) then + GET_INDEX = i + return + end if + end do + + GET_INDEX = 0 + + end function GET_INDEX + + subroutine SET_FIXED_REACTANTS( & + fixmap, & + rowdim, & + coldim, & + rxno, & + fixsym, & + eq_piece, & + buf_pos, & + phtcnt ) + + use VAR_MOD, only : var_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: rowdim, coldim, phtcnt + integer, intent(in) :: fixmap(rowdim,coldim,2) + integer, intent(inout) :: rxno + integer, intent(inout) :: buf_pos + + character(len=80), intent(out) :: eq_piece + character(len=16), intent(in) :: fixsym(*) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: j, l, index, length + character(len=16) :: symbol + + if( rxno < phtcnt ) then + rxno = - rxno + end if + do j = 1,2 + index = GET_INDEX( fixmap(1,1,j), var_lim, 3, 1, rxno ) + if( index /= 0 ) then + do l = 2,3 + if( fixmap(index,l,j) == 0 ) then + return + end if + symbol = fixsym(fixmap(index,l,j)) + length = LEN_TRIM( symbol ) + eq_piece(buf_pos:) = '*' // symbol(:length) + buf_pos = buf_pos + length + 1 + end do + exit + end if + end do + + + + end subroutine SET_FIXED_REACTANTS + +end module utils diff --git a/chem_proc/src/cam_chempp/exe_opts.f b/chem_proc/src/cam_chempp/exe_opts.f new file mode 100644 index 0000000000..2fb893b971 --- /dev/null +++ b/chem_proc/src/cam_chempp/exe_opts.f @@ -0,0 +1,87 @@ + subroutine EXE_OPTS( options, & + lin, & + lout ) +!----------------------------------------------------------------------- +! ... Set the execution options +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: lin + integer, intent(in) :: lout + logical, intent(out) :: options(3) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: kpar, nchar, k + integer :: parsw(3) + + character(len=80) :: buff + character(len=20) :: parkey(3), keywrd + logical :: found + + integer :: LENOF + + parkey(1) = 'QSUBFILE' + parkey(2) = 'SUBMIT' + parkey(3) = 'FIXER' + + parsw = 0 + +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + call UPCASE ( buff ) + if( buff == 'ENDEXECUTIONOPTIONS' ) then + exit + end if + k = INDEX( buff(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buff(:k-1) + found = .false. + do kpar = 1,6 + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES ( ' # is an invalid options' & + // ' parameter keyword@', lout, keywrd, & + LENOF(20,keywrd), buff ) + end if + else +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call ERRMES( ' option specification has no = operator@', & + lout, buff, 1, buff ) + end if + +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( parsw(kpar) /= 0 ) then + call ERRMES( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + +!----------------------------------------------------------------------- +! ... Set individual options +!----------------------------------------------------------------------- + if( buff(k+1:nchar) == 'ON' .or. & + buff(k+1:nchar) == 'YES' ) then + options(kpar) = .true. + else + options(kpar) = .false. + end if + parsw(kpar) = 1 + end do + + end subroutine EXE_OPTS diff --git a/chem_proc/src/cam_chempp/files_hdr.f b/chem_proc/src/cam_chempp/files_hdr.f new file mode 100644 index 0000000000..99fe0eeddc --- /dev/null +++ b/chem_proc/src/cam_chempp/files_hdr.f @@ -0,0 +1,39 @@ + + module mo_files_hdr + + use io, only : temp_path, procfiles_path + + contains + + subroutine files_hdr + + implicit none + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + integer :: slen + logical :: lexist + + inquire( file = 'files.h', exist = lexist ) + if( lexist ) then + call system( 'rm files.h' ) + end if + open( unit = 30, file = 'files.h' ) + + write(30,'(''#define SETRXTFILE '',a)') TRIM( temp_path ) // 'mo_setrxt.F' + write(30,'(''#define ADJRXTFILE '',a)') TRIM( temp_path ) // 'mo_adjrxt.F' + write(30,'(''#define PHTADJFILE '',a)') TRIM( temp_path ) // 'mo_phtadj.F' + write(30,'(''#define RXTMODFILE '',a)') TRIM( temp_path ) // 'mo_rxt_mod.F' + write(30,'(''#define GRPVMRFILE '',a)') TRIM( temp_path ) // 'mo_make_grp_vmr.F' + write(30,'(''#define SETDATFILE '',a)') TRIM( temp_path ) // 'mo_sim_dat.F' + slen = len_trim( procfiles_path ) + write(30,'(''#define EXPSLVPATH '',a)') procfiles_path(:slen-1) + write(30,'(''#define IMPSLVPATH '',a)') procfiles_path(:slen-1) + write(30,'(''#define MODSPATH '',a)') procfiles_path(:slen-1) + + close(30) + + end subroutine files_hdr + + end module mo_files_hdr diff --git a/chem_proc/src/cam_chempp/het_names.f b/chem_proc/src/cam_chempp/het_names.f new file mode 100644 index 0000000000..e165eae0e5 --- /dev/null +++ b/chem_proc/src/cam_chempp/het_names.f @@ -0,0 +1,54 @@ + + subroutine MAKE_HET_NAME_MOD +!-------------------------------------------------------------------------------- +! ... Makes a module of parameter reaction names +!-------------------------------------------------------------------------------- + + use RXT_MOD, only : hetcnt, hetmap + use VAR_MOD, only : spc_cnt => new_nq, spc_names => new_solsym + use IO, only : temp_path + + implicit none + +!-------------------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------------------- + integer :: i, m + character(len=80) :: buff + character(len=5) :: num + logical :: lexist + +!-------------------------------------------------------------------------------- +! ... Check mod file existence; remove if found +!-------------------------------------------------------------------------------- + INQUIRE( file = TRIM( temp_path ) // 'het_names.mod', exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // TRIM( temp_path ) // 'het_names.mod' ) + end if + OPEN( unit = 30, file = TRIM( temp_path ) // 'het_names.mod' ) + + buff = '' + write(30,'(a)') buff + buff(7:) = 'module m_het_id' + write(30,'(a)') buff + buff = '' + write(30,'(a)') buff + buff(7:) = 'implicit none' + write(30,'(a)') buff + buff = '' + write(30,'(a)') buff + + do i = 1,hetcnt + m = hetmap(i,1) + write(buff(7:),'(''integer, parameter :: hid_'',a,1x,''='',1x,i4)') & + spc_names(m)(:LEN_TRIM(spc_names(m))), i + write(30,'(a)') buff + end do + + buff = '' + write(30,'(a)') buff + buff(7:) = 'end module m_het_id' + write(30,'(a)') buff + CLOSE(30) + + end subroutine MAKE_HET_NAME_MOD diff --git a/chem_proc/src/cam_chempp/hist_hdr.f b/chem_proc/src/cam_chempp/hist_hdr.f new file mode 100644 index 0000000000..35ca4fe91d --- /dev/null +++ b/chem_proc/src/cam_chempp/hist_hdr.f @@ -0,0 +1,439 @@ + + subroutine HIST_HDR( hst_file_cnt, & + histout_cnt, & + histout_map, & + user_hst_names, & + hist_type, & + dyn_hst_fld_cnt, & + spcsym, & + spccnt, & + hetmap, & + usrmap, & + ptplen, & + filename, & + model ) +!----------------------------------------------------------------------- +! ... Process all output history tape controls +!----------------------------------------------------------------------- + + use MASS_DIAGS + use VAR_MOD, only : var_lim, hst_file_lim, class_prod_cnt, class_loss_cnt, clsmap + use RXT_MOD, only : rxt_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: hst_file_cnt ! number of history files + integer, intent(in) :: histout_cnt(20,2,hst_file_lim) ! number of outputs in each catagory + integer, intent(in) :: histout_map(1000,20,2,hst_file_lim) ! map of outputs + integer, intent(in) :: dyn_hst_fld_cnt(2) + integer, intent(in) :: spccnt(*) ! number of symbols in each catagory + integer, intent(in) :: hetmap(*) ! wet dep map + integer, intent(in) :: usrmap(*) ! ext frc map + integer, intent(out) :: ptplen ! total hist tape fields + character(len=64), intent(in) :: hist_type ! type of dyn hist tape ( short/long ) + character(len=16), intent(in) :: user_hst_names(var_lim,4) + character(len=16), intent(in) :: spcsym(var_lim,*) ! list of symbols + character(len=*), intent(in) :: filename ! path/name of simulation data file + character(len=*), intent(in) :: model ! model name + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: inst = 1, avgr = 2 + + integer :: i, j, m, n, typind, id_ox = 0 + integer :: file + integer :: istat + integer :: class, classno + integer :: summ(2), sums(2) + character(len=32) :: fld_name(4) + character(len=16) :: namtag(1000) + character(len=4) :: numa + character(len=4) :: oper_tag(2) = (/ 'inst', 'avrg' /) + character(len=3) :: num + logical :: lexist + + CLOSE( 30 ) + OPEN( unit = 30, & + file = 'hist.h', & + status = 'replace', & + iostat = istat ) + if( istat /= 0 ) then + write(*,*) 'HIST_HDR: Failed to open hist.h' + stop + end if +!----------------------------------------------------------------------- +! ... Locate index for ox +!----------------------------------------------------------------------- + do i = 1,spccnt(6) + if( spcsym(i,6) == 'OX' ) then + id_ox = i + exit + end if + end do + + do typind = inst,avgr + summ(typind) = SUM( histout_cnt(:2,typind,1) ) + SUM( histout_cnt(5:6,typind,1) ) & + + SUM( histout_cnt(8:11,typind,1) ) + histout_cnt(13,typind,1) + end do + write(30,'(''# define PMULTI '',i3)') summ(1) + summ(2) + write(30,'(''# define PMULTA '',i3)') summ(2) + sums(1) = histout_cnt(3,inst,1) + histout_cnt(4,inst,1) + histout_cnt(7,inst,1) & + + histout_cnt(12,inst,1) + sums(2) = histout_cnt(3,avgr,1) + histout_cnt(4,avgr,1) + histout_cnt(12,avgr,1) + write(30,'(''# define PSINGL '',i3)') sums(1) + sums(2) + write(30,'(''# define PSINGLA '',i3)') sums(2) + ptplen = summ(1) + sums(1) + summ(2) + sums(2) + write(30,'(''# define PTPLEN '',i3)') ptplen + i = SUM( histout_cnt(:4,inst,1) ) + SUM( histout_cnt(8:13,inst,1) ) & + + SUM( histout_cnt(:4,avgr,1) ) + SUM( histout_cnt(8:13,avgr,1) ) + write(30,'(''# define HSTLEN '',i3)') i + write(30,'(''# define HSTOFFSET '',i3)') SUM( histout_cnt(5:7,inst,1) ) + write(30,'(''# define HSTINSCNT '',i3)') SUM( histout_cnt(:17,inst,1) ) + write(30,'(''# define HSTINSCNTM '',i3)') & + SUM( histout_cnt(:4,inst,1) ) & + + SUM( histout_cnt(8:13,inst,1) ) + write(30,'(''# define HSTPHTCNT '',i3)') histout_cnt(8,inst,1) + write(30,'(''# define HSTRXTCNT '',i3)') histout_cnt(9,inst,1) + write(30,'(''# define HSTPHTCNTA '',i3)') histout_cnt(8,avgr,1) + write(30,'(''# define HSTRXTCNTA '',i3)') histout_cnt(9,avgr,1) + write(30,'(''# define HSTRXTIND '',i3)') SUM( histout_cnt(:4,inst,1) ) + write(30,'(''# define HSTUSRINDI '',i3)') SUM( histout_cnt(:4,inst,1) ) & + + SUM( histout_cnt(8:11,inst,1) ) + write(30,'(''# define HSTRXTINDA '',i3)') SUM( histout_cnt(:4,inst,1) ) & + + SUM( histout_cnt(8:13,inst,1) ) & + + SUM( histout_cnt(:4,avgr,1) ) + write(30,'(''# define HSTUSRINDA '',i3)') SUM( histout_cnt(:4,inst,1) ) & + + SUM( histout_cnt(8:13,inst,1) ) & + + SUM( histout_cnt(:11,avgr,1) ) + write(30,'(''# define HSTAVGCNT '',i3)') SUM( histout_cnt(:17,avgr,1) ) + write(30,'(''# define HSTXPTICNT '',i3)') histout_cnt(1,inst,1) + write(30,'(''# define HSTXPTACNT '',i3)') histout_cnt(1,avgr,1) + write(30,'(''# define HSTPCEICNT '',i3)') histout_cnt(2,inst,1) + write(30,'(''# define HSTPCEACNT '',i3)') histout_cnt(2,avgr,1) + write(30,'(''# define HSTSFLXICNT '',i3)') histout_cnt(3,inst,1) + write(30,'(''# define HSTSFLXACNT '',i3)') histout_cnt(3,avgr,1) + write(30,'(''# define HSTDVELICNT '',i3)') histout_cnt(4,inst,1) + write(30,'(''# define HSTDVELACNT '',i3)') histout_cnt(4,avgr,1) + write(30,'(''# define HSTWDEPICNT '',i3)') histout_cnt(10,inst,1) + write(30,'(''# define HSTWDEPACNT '',i3)') histout_cnt(10,avgr,1) + write(30,'(''# define HSTEXTICNT '',i3)') histout_cnt(11,inst,1) + write(30,'(''# define HSTEXTACNT '',i3)') histout_cnt(11,avgr,1) + write(30,'(''# define HSTUSRSICNT '',i3)') histout_cnt(12,inst,1) + write(30,'(''# define HSTUSRMICNT '',i3)') histout_cnt(13,inst,1) + write(30,'(''# define HSTUSRSACNT '',i3)') histout_cnt(12,avgr,1) + write(30,'(''# define HSTUSRMACNT '',i3)') histout_cnt(13,avgr,1) + write(30,'(''# define HSTPROD '',i3)') histout_cnt(14,inst,1) + write(30,'(''# define HSTPRODA '',i3)') histout_cnt(14,avgr,1) + write(30,'(''# define HSTLOSS '',i3)') histout_cnt(15,inst,1) + write(30,'(''# define HSTLOSSA '',i3)') histout_cnt(15,avgr,1) + write(30,'(''# define HSTPLCNT1 '',i3)') MAX( MAXVAL(class_prod_cnt(1,:)),MAXVAL(class_loss_cnt(1,:)) ) + write(30,'(''# define HSTPLCNT2 '',i3)') MAX( MAXVAL(class_prod_cnt(2,:)),MAXVAL(class_loss_cnt(2,:)) ) + write(30,'(''# define HSTPLCNT3 '',i3)') MAX( MAXVAL(class_prod_cnt(3,:)),MAXVAL(class_loss_cnt(3,:)) ) + write(30,'(''# define HSTPLCNT4 '',i3)') MAX( MAXVAL(class_prod_cnt(4,:)),MAXVAL(class_loss_cnt(4,:)) ) + write(30,'(''# define HSTPLCNT5 '',i3)') MAX( MAXVAL(class_prod_cnt(5,:)),MAXVAL(class_loss_cnt(5,:)) ) + write(30,'(''# define SW_MDI_CNT '',i3)') histout_cnt(16,inst,1) + write(30,'(''# define SW_MDA_CNT '',i3)') histout_cnt(16,avgr,1) + write(30,'(''# define SW_HINST '',i5)') SUM(histout_cnt(:4,inst,1)) & + + SUM(histout_cnt(8:11,inst,1)) & + + SUM(histout_cnt(14:17,inst,1)) + write(30,'(''# define SW_HTIMAV '',i5)') SUM(histout_cnt(:4,avgr,1)) & + + SUM(histout_cnt(8:11,avgr,1)) & + + SUM(histout_cnt(14:17,avgr,1)) + if( SUM(histout_cnt(14,:,1)+histout_cnt(15,:,1)) /= 0 ) then + write(30,'(''# define HSTPRDLOSS'')') + end if + if( SUM( histout_cnt(17,:,1) ) /= 0 ) then + write(30,'(''# define HSTMDIAGS'')') + end if + if( id_ox /= 0 ) then + do i = 14,15 + if( ANY( histout_map(:histout_cnt(i,1,1),i,1,1) == id_ox ) .or. & + ANY( histout_map(:histout_cnt(i,2,1),i,2,1) == id_ox ) ) then + if( i == 14 ) then + write(30,'(''# define OX_PROD '')') + else + write(30,'(''# define OX_LOSS '')') + end if + end if + end do + end if + if( SUM( histout_cnt(12:13,inst,1) ) + SUM( histout_cnt(12:13,avgr,1) ) /= 0 ) then + write(30,'(''# define HSTUSR'')') + end if + +!----------------------------------------------------------------------- +! ... Group history output flag +!----------------------------------------------------------------------- + if( (histout_cnt(2,inst,1) + histout_cnt(2,avgr,1)) /= 0 ) then + write(30,'(''# define GRPHST'')') + end if + + CLOSE(30) + + if( model == 'MOZART') then +!----------------------------------------------------------------------- +! ... Write the history output tape information +! 1. item count by category +! 2. xported species +! 3. "pce" species +! 4. surface emissions +! 5. deposition velocities +! 6. washout rates +! 7. "extraneous" forcing rates +!----------------------------------------------------------------------- + OPEN( unit = 30, & + file = TRIM(filename), & + status = 'old', & + position = 'append', & + iostat = istat ) + if( istat /= 0 ) then + write(*,*) 'HIST_HDR: Failed to open '//TRIM(filename) + stop + end if + write(30,'(i4)') hst_file_cnt + write(30,'(10i4)') histout_cnt(:,:,:hst_file_cnt) + if( ptplen /= 0 ) then +file_loop : & + do file = 1,hst_file_cnt +output_type : & + do typind = 1,2 + if( histout_cnt(1,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(1,typind,file) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(histout_map(j,1,typind,file),6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_VMR_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(1,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(1,typind,file),1,typind,file) + end if + + if( histout_cnt(2,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(2,typind,file) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(histout_map(j,2,typind,file),7) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_VMR_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(2,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(2,typind,file),2,typind,file) + end if + + if( histout_cnt(3,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(3,typind,file) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(histout_map(j,3,typind,file),6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_SRF_EMIS_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(3,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(3,typind,file),3,typind,file) + end if + + if( histout_cnt(4,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(4,typind,file) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(histout_map(j,4,typind,file),6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_DEP_VEL_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(4,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(4,typind,file),4,typind,file) + end if + + if( histout_cnt(8,typind,file) /= 0 ) then + do j = 1,histout_cnt(8,typind,file) + m = MOD( j-1,4 ) + 1 + write(numa,'(i4)') histout_map(j,8,typind,file) + 1000 + fld_name(m) = 'J_' // numa(2:4) // '_' // oper_tag(typind) + if( m == 4 .or. j == histout_cnt(8,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(8,typind,file),8,typind,file) + end if + + if( histout_cnt(9,typind,file) /= 0 ) then + do j = 1,histout_cnt(9,typind,file) + m = MOD( j-1,4 ) + 1 + write(numa,'(i4)') histout_map(j,9,typind,file) + 1000 + fld_name(m) = 'R_' // numa(2:4) // '_' // oper_tag(typind) + if( m == 4 .or. j == histout_cnt(9,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(9,typind,file),9,typind,file) + end if + + if( histout_cnt(10,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(10,typind,file) + m = MOD( j-1,4 ) + 1 + i = hetmap(histout_map(j,10,typind,file)) + write(fld_name(m),'(a)') TRIM( spcsym(i,6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_WET_DEP_RATE_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(10,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(10,typind,file),10,typind,file) + end if + + if( histout_cnt(11,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(11,typind,file) + m = MOD( j-1,4 ) + 1 + i = usrmap(histout_map(j,11,typind,file)) + write(fld_name(m),'(a)') TRIM( spcsym(i,6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_EXT_FRC_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(11,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(11,typind,file),11,typind,file) + end if + + if( histout_cnt(12,typind,file) /= 0 ) then + do j = 1,histout_cnt(12,typind,file) + m = MOD( j-1,4 ) + 1 + fld_name(m) = TRIM( user_hst_names(j,2*(typind-1)+1) ) // '_' // oper_tag(typind) + if( m == 4 .or. j == histout_cnt(12,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + end if + + if( histout_cnt(13,typind,file) /= 0 ) then + do j = 1,histout_cnt(13,typind,file) + m = MOD( j-1,4 ) + 1 + fld_name(m) = TRIM( user_hst_names(j,2*(typind-1)+2) ) // '_' // oper_tag(typind) + if( m == 4 .or. j == histout_cnt(13,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + end if + + if( histout_cnt(14,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(14,typind,file) + class = histout_map(j,14,typind,file)/1000 + classno = MOD( histout_map(j,14,typind,file),1000 ) + n = clsmap(classno,class,2) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(n,6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_PROD_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(14,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(14,typind,file),14,typind,file) + end if + + if( histout_cnt(15,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(15,typind,file) + class = histout_map(j,15,typind,file)/1000 + classno = MOD( histout_map(j,15,typind,file),1000 ) + n = clsmap(classno,class,2) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(n,6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_LOSS_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(15,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(15,typind,file),15,typind,file) + end if + + if( histout_cnt(16,typind,file) /= 0 ) then + do j = 1,histout_cnt(16,typind,file),8 + fld_name(:) = ' ' + do i = 1,4 + select case (i) + case( 1 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_ADV_'',a4)') oper_tag(typind) + case( 2 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_DPS_'',a4)') oper_tag(typind) + case( 3 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_CNV_'',a4)') oper_tag(typind) + case( 4 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_DIF_'',a4)') oper_tag(typind) + write(30,'(4a32)') fld_name(:) + end select + end do + fld_name(:) = ' ' + do i = 1,4 + select case (i) + case( 1 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_CHM_'',a4)') oper_tag(typind) + case( 2 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_XFLX_'',a4)') oper_tag(typind) + case( 3 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_YFLX_'',a4)') oper_tag(typind) + case( 4 ) + write(fld_name(i),'(a)') TRIM( spcsym(histout_map(j,16,typind,file),6) ) + write(fld_name(i)(LEN_TRIM(fld_name(i))+1:),'(''_ZFLX_'',a4)') oper_tag(typind) + write(30,'(4a32)') fld_name(:) + end select + end do + end do + write(30,'(20i4)') histout_map(:histout_cnt(16,typind,file),16,typind,file) + end if + + if( histout_cnt(17,typind,file) /= 0 ) then + fld_name(:) = ' ' + do j = 1,histout_cnt(17,typind,file) + m = MOD( j-1,4 ) + 1 + write(fld_name(m),'(a)') TRIM( spcsym(histout_map(j,17,typind,file),6) ) + write(fld_name(m)(LEN_TRIM(fld_name(m))+1:),'(''_DRY_DEP_FLX_'',a4)') oper_tag(typind) + if( m == 4 .or. j == histout_cnt(17,typind,file) ) then + write(30,'(4a32)') fld_name(:m) + fld_name(:) = ' ' + end if + end do + write(30,'(20i4)') histout_map(:histout_cnt(17,typind,file),17,typind,file) + end if + end do output_type + end do file_loop + end if +!----------------------------------------------------------------------- +! ... Write out the diagnostics +!----------------------------------------------------------------------- + call MASS_DIAGS_SERIALIZE( 30 ) + + CLOSE(30) + + end if + + end subroutine HIST_HDR diff --git a/chem_proc/src/cam_chempp/hist_inp.f b/chem_proc/src/cam_chempp/hist_inp.f new file mode 100644 index 0000000000..1708ed1e17 --- /dev/null +++ b/chem_proc/src/cam_chempp/hist_inp.f @@ -0,0 +1,127 @@ + subroutine HIST_INP( lin, & + lout, & + histinp, & + dyn_hst_fld_cnt ) + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: lin + integer, intent(in) :: lout + integer, intent(out) :: dyn_hst_fld_cnt(2) + character(len=64), intent(out) :: histinp(4) ! hist tape inputs + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: kpar, nchar, k + integer :: retcod, slen + integer :: parsw(6) + real :: time + character(len=80) :: buff + character(len=80) :: buffh + character(len=20) :: parkey(6), keywrd + logical :: found + + integer :: LENOF + + parkey(1) = 'DYNAMICSMSSFILE' + parkey(2) = 'STARTTIME' + parkey(3) = 'ICMSSFILE' + parkey(4) = 'DYNHISTTAPE' + parkey(5) = 'MULTILEVELFIELDS' + parkey(6) = 'SINGLELEVELFIELDS' + + parsw = 0 + dyn_hst_fld_cnt = -1 + +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE ( buffh ) + if( buffh == 'ENDINPUTS' ) then + if( dyn_hst_fld_cnt(1) == -1 .and. dyn_hst_fld_cnt(2) == -1 ) then + if( histinp(4) == 'LONG' ) then + dyn_hst_fld_cnt(1) = 57 + dyn_hst_fld_cnt(2) = 44 + else if( histinp(4) == 'SHORT' ) then + dyn_hst_fld_cnt(1) = 10 + dyn_hst_fld_cnt(2) = 4 + end if + end if + exit + end if + k = INDEX( buffh(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buffh(:k-1) + found = .false. + do kpar = 1,6 + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES ( ' # is an invalid job control' & + // ' parameter keyword@', & + lout, & + keywrd, & + LENOF(20,keywrd), & + buffh ) + end if + else +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call ERRMES ( ' Job ctl specification has no = operator@', & + lout, buff, 1, buff ) + end if + +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( parsw(kpar) /= 0 ) then + call ERRMES( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + +!----------------------------------------------------------------------- +! ... Set individual options +!----------------------------------------------------------------------- + if( kpar == 2 ) then + call TIMCON( buff(k+1:nchar), time, lout ) + histinp(2) = buff(k+1:nchar) + else if( kpar == 4 ) then + histinp(4) = buffh(k+1:nchar) + else if( kpar == 5 ) then + slen = LEN_TRIM( buff(k+1:nchar) ) + call INTCON( buff(k+1:nchar), slen, dyn_hst_fld_cnt(1), retcod ) + if( retcod /= 0 .or. dyn_hst_fld_cnt(1) < 0 ) then + call ERRMES ( ' # is an invalid Dyn hst tape field count@', & + lout, & + buff(k+1:nchar), & + slen, & + buffh ) + end if + else if( kpar == 6 ) then + slen = LEN_TRIM( buff(k+1:nchar) ) + call INTCON( buff(k+1:nchar), slen, dyn_hst_fld_cnt(2), retcod ) + if( retcod /= 0 .or. dyn_hst_fld_cnt(2) < 0 ) then + call ERRMES ( ' Dyn hst tape has invalid field count@', & + lout, & + buff(k+1:nchar), & + slen, & + buffh ) + end if + else + histinp(kpar) = buff(k+1:nchar) + end if + parsw(kpar) = 1 + end do + + end subroutine HIST_INP diff --git a/chem_proc/src/cam_chempp/hist_out.f b/chem_proc/src/cam_chempp/hist_out.f new file mode 100644 index 0000000000..890d97464c --- /dev/null +++ b/chem_proc/src/cam_chempp/hist_out.f @@ -0,0 +1,507 @@ + + module mo_hist_out + + private + public :: hist_out + + contains + + subroutine hist_out( histout, longnames, hst_file_cnt ) +!----------------------------------------------------------------------- +! ... Process all output history file controls +!----------------------------------------------------------------------- + + use io + use var_mod, only : indexh2o, srf_flx_cnt, dvel_cnt, spccnt, & + histout_cnt, histout_map, user_hst_names, & + spcsym, class_prod_cnt, class_loss_cnt, & + clscnt, clsmap, hst_map_lim + use rxt_mod, only : hetcnt, hetmap, usrcnt, usrmap, gascnt, phtcnt + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(out) :: hst_file_cnt ! count of history files + character (len=64), intent(inout) :: histout(6) ! hist tape outputs + logical, intent(inout) :: longnames + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: maxparms = 26 + integer, parameter :: inst = 1, avgr = 2 + integer, parameter :: singl = 1, multi = 2 + integer, parameter :: symlen = 8 + + integer :: class, kpar, nchar, k, kkk, j, khold, m + integer :: time_ind, level_ind + integer :: fileno = 1 + integer :: retcod + integer :: kindex + integer :: tokcnt, cnt + integer :: parsw(maxparms,2) + integer :: toklen(20) + integer :: wrk(hst_map_lim) + real :: time + character (len=23) :: parkeyend(maxparms) + character (len=20) :: parkey(maxparms), keywrd + character (len=16) :: tokens(20) + character (len=16) :: temp + logical :: found, doing_file + +!----------------------------------------------------------------------- +! ... Function declarations +!----------------------------------------------------------------------- + integer :: lenof + integer :: inclist + integer :: inilist + integer :: xlate + + parkey(1) = 'RETENTIONTIME' + parkey(2) = 'WRITEFREQUENCY' + parkey(3) = 'STARTFILENUMBER' + parkey(4) = 'DENSITY' + parkey(5) = 'PASSWORD' + + parkey(6) = 'TRANSPORTEDSPECIES' + parkey(7) = 'GROUPMEMBERS' + parkey(8) = 'SURFACEFLUX' + parkey(9) = 'DEPOSITIONVELOCITY' + parkey(10) = 'TEMPERATURE' + parkey(11) = 'WATERVAPOR' + parkey(12) = 'SURFACEPRESSURE' + parkey(13) = 'PHOTORATES' + parkey(14) = 'REACTIONRATES' + parkey(15) = 'WASHOUTRATES' + parkey(16) = 'EXTERNALFORCING' + + parkey(17) = 'DEFAULTOUTPUTS' + parkey(18) = 'USERDEFINED' + parkey(19) = 'PRODUCTION' + parkey(20) = 'LOSS' + parkey(21) = 'MASSDIAGS' + parkey(22) = 'DEPOSITIONFLUX' + parkey(23) = 'WASHOUTFLUX' + parkey(24) = 'LIFETIME' + parkey(25) = 'PRINTFREQUENCY' + parkey(26) = 'LONGNAMES' + + parkeyend(6) = 'ENDTRANSPORTEDSPECIES' + parkeyend(7) = 'ENDGROUPMEMBERS' + parkeyend(8) = 'ENDSURFACEFLUX' + parkeyend(9) = 'ENDDEPOSITIONVELOCITY' + parkeyend(10) = 'ENDTEMPERATURE' + parkeyend(11) = 'ENDWATERVAPOR' + parkeyend(12) = 'ENDSURFACEPRESSURE' + parkeyend(13) = 'ENDPHOTORATES' + parkeyend(14) = 'ENDREACTIONRATES' + parkeyend(15) = 'ENDWASHOUTRATES' + parkeyend(16) = 'ENDEXTERNALFORCING' + + parkeyend(17) = 'ENDDEFAULTOUTPUTS' + parkeyend(18) = 'ENDUSERDEFINED' + parkeyend(19) = 'ENDPRODUCTION' + parkeyend(20) = 'ENDLOSS' + parkeyend(21) = 'ENDMASSDIAGS' + parkeyend(22) = 'ENDDEPOSITIONFLUX' + parkeyend(23) = 'ENDWASHOUTFLUX' + parkeyend(24) = 'ENDLIFETIME' + + parsw(:,:) = 0 + histout_cnt(:,:,:) = 0 + +!----------------------------------------------------------------------- +! ... Check for intial file header +!----------------------------------------------------------------------- + call cardin( lin, buff, nchar ) + buffh = buff + call upcase ( buffh ) + if( buffh /= 'FILE' ) then + call errmes( ' FILE keyword must follow OUTPUTS keyword@', & + lout, & + buff, & + nchar, & + buff ) + end if +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + doing_file = .true. +read_loop : & + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase ( buffh ) + if( buffh == 'FILE' ) then + if( doing_file ) then + call errmes( ' ENDFILE must follow FILE keyword@', & + lout, buff, nchar, buff ) + end if + if( fileno >= 10 ) then + call errmes( ' Only 10 output files allowed@', & + lout, buff, nchar, buff ) + end if + fileno = fileno + 1 + doing_file = .true. + parsw(:,:) = 0 + cycle read_loop + else if( buffh == 'ENDFILE' ) then +!----------------------------------------------------------------------- +! ... Recast mass diags into individual deltas and fluxes +! Note : only allow for 25 diagnostics +!----------------------------------------------------------------------- + if( .not. doing_file ) then + call errmes( ' ENDFILE not preceeded by FILE keyword@', & + lout, buff, nchar, buff ) + end if + do time_ind = inst,avgr + if( histout_cnt(16,time_ind,fileno) /= 0 ) then + k = min( histout_cnt(16,time_ind,fileno),25 ) + j = 8*k + histout_cnt(16,time_ind,fileno) = j + wrk(:k) = histout_map(:k,16,time_ind,fileno) + do j = 1,k + histout_map(8*(j-1)+1:8*j,16,time_ind,fileno) = wrk(j) + end do + end if + end do + doing_file = .false. + cycle read_loop + else if( buffh == 'ENDOUTPUTS' ) then + if( doing_file ) then + call errmes( ' ENDFILE must follow FILE keyword@', & + lout, buff, nchar, buff ) + end if + hst_file_cnt = fileno + exit + end if + k = index( buffh(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buffh(:k-1) + else + keywrd = buffh(:nchar) + end if + found = .false. + do kpar = 1,maxparms + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call errmes ( ' # is an invalid job control parameter keyword@', & + lout, keywrd, lenof(20,keywrd), buffh ) + end if +!----------------------------------------------------------------------- +! ... Check for instantaneous or averaged qualifier +!----------------------------------------------------------------------- +output_type_qualifier : & + if( kpar > 5 .and. kpar < maxparms-1 ) then +assignment_test : & + if( k /= 0 ) then + if( kpar == 18 ) then + j = index( buffh(:nchar), ',' ) + if( j == 0 ) then + j = nchar + else + j = j - 1 + end if + else + j = nchar + end if + if( buffh(k+1:j) == 'INST' ) then + time_ind = inst + else if( buffh(k+1:j) == 'AVRG' ) then + time_ind = avgr + else + call errmes( '0 *** # is invalid time qualifier@', & + lout, buff(k+1:j), j-k, buff ) + end if + if( kpar == 18 ) then + k = index( buffh(:nchar), ',' ) + if( k /= 0 ) then + if( buffh(k+1:nchar) == 'SINGLE' ) then + level_ind = singl + else if( buffh(k+1:nchar) == 'MULTI' ) then + level_ind = multi + else + call errmes( '0 *** # is invalid level qualifier@', & + lout, buff(k+1:), nchar-k, buff ) + end if + else + level_ind = multi + end if + end if + else + if( kpar == 18 ) then + call errmes( ' User defined type must have time qualifier@', & + lout, buff, nchar, buff ) + end if + time_ind = inst + end if assignment_test + else + time_ind = inst + end if output_type_qualifier +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( kpar == 18 ) then + if( parsw(kpar,time_ind) == level_ind ) then + call errmes( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + parsw(kpar,time_ind) = level_ind + else + if( parsw(kpar,time_ind) /= 0 ) then + call errmes( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + parsw(kpar,time_ind) = 1 + end if + +!----------------------------------------------------------------------- +! ... Set individual options +!----------------------------------------------------------------------- + if( kpar >= 6 ) then +output_variables : & + select case( kpar ) + case( 17 ) +!----------------------------------------------------------------------- +! ... The "default" option +!----------------------------------------------------------------------- + histout_cnt(1:20,time_ind,fileno) = 0 + histout_cnt(1,time_ind,fileno) = spccnt(6) + histout_cnt(2,time_ind,fileno) = spccnt(7) + histout_cnt(3,time_ind,fileno) = spccnt(6) + histout_cnt(4,time_ind,fileno) = spccnt(6) + if( time_ind == inst ) then + histout_cnt(5,inst,fileno) = 1 + if( indexh2o /= 0 ) then + histout_cnt(6,inst,fileno) = 1 + end if + histout_cnt(7,inst,fileno) = 1 + end if + do k = 1,spccnt(6) + histout_map(k,1,time_ind,fileno) = k + histout_map(k,3,time_ind,fileno) = k + histout_map(k,4,time_ind,fileno) = k + end do + do k = 1,spccnt(7) + histout_map(k,2,time_ind,fileno) = k + end do + case(maxparms-1) +!----------------------------------------------------------------------- +! ... The printout frequency option +!----------------------------------------------------------------------- + call timcon( buff(k+1:nchar), & + time, & + lout ) + histout(6) = buff(k+1:nchar) + case( maxparms ) +!----------------------------------------------------------------------- +! ... The longnames flag +!----------------------------------------------------------------------- + longnames = .true. + case( 10:12 ) +!----------------------------------------------------------------------- +! ... The temp, water vapor, and surf press options +!----------------------------------------------------------------------- + if( time_ind == inst ) then + histout_cnt(kpar-5,inst,fileno) = 1 + end if + case default +!----------------------------------------------------------------------- +! ... All other options +!----------------------------------------------------------------------- + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + khold = kpar + do + if( buffh == parkeyend(khold) ) then + exit + end if + kpar = khold + call GETTOKENS( buff, & + nchar, & + ',', & + symlen, & + tokens, & + toklen, & + 20, & + tokcnt ) + if( tokcnt == 0 ) then + call errmes( ' Hist tape output list in error@', & + lout, & + buff, & + 1, & + buff ) + end if + if( kpar == 18 ) then + if( histout_cnt(11+level_ind,time_ind,fileno) + tokcnt > hst_map_lim ) then + call errmes( ' Hist tape output list > hst_map_lim elements@', & + lout, & + buff, & + 1, & + buff ) + end if + else if( histout_cnt(kpar-5,time_ind,fileno) + tokcnt > hst_map_lim ) then + call errmes( ' Hist tape output list > hst_map_lim elements@', & + lout, & + buff, & + 1, & + buff ) + end if + if( kpar == 18 ) then + do j = 1,tokcnt + cnt = histout_cnt(11+level_ind,time_ind,fileno) + 1 + histout_cnt(11+level_ind,time_ind,fileno) = cnt + user_hst_names(cnt,2*(time_ind-1)+level_ind) = tokens(j) + end do + else if( kpar <= 9 .or. kpar >= 13 ) then + temp = tokens(1) + if( kpar /= 7 ) then + kindex = 6 + else + kindex = 7 + end if + kpar = kpar - 5 + call upcase( temp ) +!----------------------------------------------------------------------- +! ... Handle the "all" list specifier +!----------------------------------------------------------------------- + if( tokcnt == 1 .and. temp == 'ALL' ) then + if( kpar <= 4 ) then + do j = 1,spccnt(kindex) + histout_map(j,kpar,time_ind,fileno) = j + end do + histout_cnt(kpar,time_ind,fileno) = spccnt(kindex) + else if( kpar >= 8 ) then + select case( kpar ) + case( 8 ) + do j = 1,phtcnt + histout_map(j,kpar,time_ind,fileno) = j + end do + histout_cnt(kpar,time_ind,fileno) = phtcnt + case( 9 ) + do j = 1,gascnt + histout_map(j,kpar,time_ind,fileno) = j + end do + histout_cnt(kpar,time_ind,fileno) = gascnt + case( 10 ) + do j = 1,hetcnt + histout_map(j,kpar,time_ind,fileno) = j + end do + histout_cnt(kpar,time_ind,fileno) = hetcnt + case( 11 ) + do j = 1,usrcnt + histout_map(j,kpar,time_ind,fileno) = j + end do + histout_cnt(kpar,time_ind,fileno) = usrcnt + end select + end if +!----------------------------------------------------------------------- +! ... Handle individual list elements +!----------------------------------------------------------------------- + else + do j = 1,tokcnt + if( kpar == 8 .or. kpar == 9 ) then + call intcon( tokens(j), & ! input string to convert + toklen(j), & ! length of input string + k, & ! surrogate for converted number + retcod ) ! return code + if( retcod /= 0 ) then + call errmes( ' # is not a valid integer@', & + lout, tokens(j), toklen(j), buff ) + end if + if( kpar == 8 .and. k > phtcnt) then + call errmes( ' # out of photolysis rate numbering@', & + lout, tokens(j), toklen(j), buff ) + else if( k > gascnt ) then + call errmes( ' # out of reaction rate numbering@', & + lout, tokens(j), toklen(j), buff ) + end if + histout_cnt(kpar,time_ind,fileno) = histout_cnt(kpar,time_ind,fileno) + 1 + histout_map(histout_cnt(kpar,time_ind,fileno),kpar,time_ind,fileno) = k + else + class = 0 + k = inclist( tokens(j), & + spcsym(1,kindex), & + spccnt(kindex) ) + if( k == 0 ) then + call errmes( '# not in list@', & + lout, & + tokens(j), & + toklen(j), & + buff ) + end if + if( kpar >= 10 ) then + if( kpar == 10 ) then + k = inilist( k, hetmap, hetcnt ) + else if( kpar == 11 ) then + k = inilist( k, usrmap, usrcnt ) + else if( kpar == 18 ) then + class = inilist( k, hetmap, hetcnt ) + end if + if( k == 0 ) then + call errmes( '# not in list@', & + lout, & + tokens(j), & + toklen(j), & + buff ) + end if + if( kpar == 14 .or. kpar == 15 .or. kpar == 19 ) then + kkk = k + class = xlate( kkk ) + do m = 1,clscnt(class) + if( clsmap(m,class,2) == k ) then + exit + end if + end do + k = m + if( class /= 0 ) then + if( kpar == 14 ) then + class_prod_cnt(class,time_ind) = class_prod_cnt(class,time_ind) + 1 + else if( kpar == 15 ) then + class_loss_cnt(class,time_ind) = class_loss_cnt(class,time_ind) + 1 + end if + end if + end if + end if + histout_cnt(kpar,time_ind,fileno) = histout_cnt(kpar,time_ind,fileno) + 1 + histout_map(histout_cnt(kpar,time_ind,fileno),kpar,time_ind,fileno) = 1000*class + k + end if + end do + end if + end if + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + end do + end select output_variables + else if( kpar <= 2 ) then + call timcon( buff(k+1:nchar), time, lout ) + histout(kpar) = buff(k+1:nchar) + else if( kpar == 3 ) then + call intcon( buff(k+1:nchar), & ! input string to convert + nchar - k, & ! length of input string + toklen(1), & ! surrogate for converted number + toklen(2) ) ! surrogate for error code + if( toklen(2) /= 0 ) then + call errmes( ' # is not a valid integer@', & + lout, buff(k+1:nchar), nchar - k, buff ) + end if + histout(kpar) = buff(k+1:nchar) + else + histout(kpar) = buff(k+1:nchar) + end if + end do read_loop + + end subroutine hist_out + + end module mo_hist_out diff --git a/chem_proc/src/cam_chempp/ipd_code.f b/chem_proc/src/cam_chempp/ipd_code.f new file mode 100644 index 0000000000..338925cabf --- /dev/null +++ b/chem_proc/src/cam_chempp/ipd_code.f @@ -0,0 +1,518 @@ + + module ind_prod + + use io, only : temp_path + + contains + + subroutine ipd_code( spccnt, & + clscnt, & + clsmap, & + cls_rxt_cnt, & + extcnt, & + cls_rxt_map, & + pcoeff_ind, & + pcoeff, & + permute, & + model, & + march ) + + use var_mod, only : var_lim + use rxt_mod, only : rxt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: spccnt + integer, intent(in) :: clscnt(5), & + extcnt(5), & + clsmap(var_lim,5,2), & + cls_rxt_map(rxt_lim,prd_lim+3,5), & + cls_rxt_cnt(4,5) + integer, intent(in) :: permute(var_lim,5) + integer, intent(in) :: pcoeff_ind(*) + real, intent(in) :: pcoeff(prd_lim,*) + character(len=*), intent(in) :: model + character(len=*), intent(in) :: march + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_len = 90 + integer :: i, k, kl, ku, l, m, n, prdndx + integer :: length, index + integer :: line_pos, cnt + integer :: class + integer :: base + integer :: species + integer :: match_cnt + integer :: max_loc(1) + integer :: match_ind(4) + integer :: freq(spccnt) + integer, allocatable :: indexer(:) + real :: rate + character(len=max_len) :: line + character(len=max_len) :: buff + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + character(len=3) :: num + logical :: beg_line + logical :: lexist, first, indprds + logical :: first_class = .true. + logical :: is_vector + logical, allocatable, dimension(:,:) :: match_mask, pmask + + inquire( file = trim( temp_path ) // 'indprd.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'indprd.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'indprd.F' ) + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + is_vector = march == 'VECTOR' + + line = ' ' + write(30,100) trim(line) + line = ' module mo_indprd' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'CAM' ) then + line = ' use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + end if + line = ' private' + write(30,100) trim(line) + line = ' public :: indprd' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model /= 'CAM' ) then + line = ' subroutine indprd( class, prod, y, extfrc, rxt )' + else + if( .not. is_vector ) then + line = ' subroutine indprd( class, prod, nprod, y, extfrc, rxt, ncol )' + else + line = ' subroutine indprd( class, prod, nprod, y, extfrc, rxt, chnkpnts )' +! line = ' subroutine indprd( class, prod, y, extfrc, rxt )' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' use chem_mods, only : gas_pcnst, extcnt, rxntot' + if( .not. is_vector ) then + write(30,100) trim(line) + line = ' use ppgrid, only : pver' + end if + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = ' integer, intent(in) :: class' + write(30,100) trim(line) + if( model /= 'CAM' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: extfrc(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: prod(:,:)' + write(30,100) trim(line) + else + if( .not. is_vector ) then + line = ' integer, intent(in) :: ncol' + write(30,100) trim(line) + line = ' integer, intent(in) :: nprod' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(ncol,pver,gas_pcnst)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(ncol,pver,rxntot)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: extfrc(ncol,pver,extcnt)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: prod(ncol,pver,nprod)' + write(30,100) trim(line) + else + line = ' integer, intent(in) :: chnkpnts' + write(30,100) trim(line) + line = ' integer, intent(in) :: nprod' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(chnkpnts,gas_pcnst)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(chnkpnts,rxntot)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: extfrc(chnkpnts,extcnt)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: prod(chnkpnts,nprod)' + write(30,100) trim(line) +! line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:)' +! write(30,100) trim(line) +! line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:)' +! write(30,100) trim(line) +! line = ' real' // trim(dec_suffix) // ', intent(in) :: extfrc(:,:)' +! write(30,100) trim(line) +! line = ' real' // trim(dec_suffix) // ', intent(inout) :: prod(:,:)' +! write(30,100) trim(line) + end if + end if + line = ' ' + write(30,100) trim(line) + line = ' ' + +Class_loop : & + do class = 1,5 + if( clscnt(class) /= 0 ) then + if( allocated( match_mask ) ) then + deallocate( match_mask ) + end if + if( allocated( pmask ) ) then + deallocate( pmask ) + end if + if( allocated( indexer ) ) then + deallocate( indexer ) + end if + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... "independent" production for' + length = len_trim( line ) + 2 + if( class == 1 ) then + line(length:) = 'Explicit species' + else if( class == 2 ) then + line(length:) = 'Ebi species' + else if( class == 3 ) then + line(length:) = 'Hov species' + else if( class == 4 ) then + line(length:) = 'Implicit species' + else if( class == 5 ) then + line(length:) = 'Rodas species' + end if + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + if( first_class ) then + line = ' if( class ==' + first_class = .false. + else + line = ' else if( class ==' + end if + write(line(len_trim(line)+2:),'(i1)') class + line(len_trim(line)+2:) = ') then' + write(30,100) trim(line) +100 format(a) + ku = MAX( cls_rxt_cnt(1,class),extcnt(class) ) + if( ku == 0 ) then + do species = 1,clscnt(class) + write(num,'(i3)') species + num = adjustl( num ) + line = ' ' + if( model /= 'CAM' ) then + line(10:) = 'prod(:,' // num(:len_trim(num)) // ') = 0.' + else + if( .not. is_vector ) then + line(10:) = 'prod(:,:,' // num(:len_trim(num)) // ') = 0._r8' + else + line(10:) = 'prod(:,' // num(:len_trim(num)) // ') = 0._r8' + end if + end if + write(30,100) trim(line) + end do + cycle Class_loop + end if + kl = 1 + allocate( match_mask(ku,3) ) + allocate( indexer(ku) ) + allocate( pmask(ku,prd_lim) ) + +Species_loop : & + do species = 1,clscnt(class) + line = ' ' + write(num,'(i3)') permute(species,class) + num = adjustl( num ) + if( model /= 'CAM' ) then + line(10:) = 'prod(:,' // num(:len_trim(num)) // ') = ' + else + if( .not. is_vector ) then + line(10:) = 'prod(:,:,' // num(:len_trim(num)) // ') = ' + else + line(10:) = 'prod(:,' // num(:len_trim(num)) // ') = ' + end if + end if + ku = cls_rxt_cnt(1,class) +!----------------------------------------------------------------------- +! ...Write code for "independent" production processes +!----------------------------------------------------------------------- + do k = kl,ku + pmask(k,:) = cls_rxt_map(k,4:prd_lim+3,class) == species + match_mask(k,1) = any( pmask(k,:) ) + end do +!----------------------------------------------------------------------- +! ... No species products +!----------------------------------------------------------------------- + if( count( match_mask(kl:ku,1) ) /= 0 ) then + indprds = .true. + first = .true. + do + do m = 1,spccnt + match_mask(kl:ku,3) = (abs(cls_rxt_map(kl:ku,2,class)) == m .or. & + abs(cls_rxt_map(kl:ku,3,class)) == m) .and.& + match_mask(kl:ku,1) + freq(m) = count( match_mask(kl:ku,3) ) + end do + max_loc = maxloc( freq(:spccnt) ) + cnt = maxvaL( freq(:spccnt) ) + if( cnt /= 0 ) then + match_mask(kl:ku,3) = (abs(cls_rxt_map(kl:ku,2,class)) == max_loc(1) .or. & + abs(cls_rxt_map(kl:ku,3,class)) == max_loc(1)) .and. & + match_mask(kl:ku,1) + do k = kl,ku + if( match_mask(k,3) ) then + if( abs( cls_rxt_map(k,2,class) ) == max_loc(1) ) then + indexer(k) = 3 + else + indexer(k) = 2 + end if + end if + end do + else + match_mask(kl:ku,3) = match_mask(kl:ku,1) + indexer(kl:ku) = 0 + cnt = count( match_mask(kl:ku,3) ) + end if + if( cnt > 1 ) then + if( first ) then + buff = ' (' + else + buff = ' + (' + end if + else if( first ) then + buff = ' ' + else + buff = ' +' + end if + if( first ) then + first = .false. + end if + m = cnt + do k = kl,ku + if( match_mask(k,3) ) then + index = pcoeff_ind(cls_rxt_map(k,1,class)) + if( index == 0 ) then + rate = 1. + else + rate = 0. + do prdndx = 1,prd_lim + if( pmask(k,prdndx) ) then + rate = rate + pcoeff(prdndx,index) + end if + end do + end if + if( rate /= 0. .and. rate /= 1. ) then + call r2c( buff(len_trim(buff)+1:), rate, 'l' ) + buff(len_trim( buff )+1:) = trim(num_suffix) // '*' + end if + write(num,'(i3)') cls_rxt_map(k,1,class) + num = adjustl( num ) + if( model /= 'CAM' ) then + buff(len_trim(buff)+1:) = 'rxt(:,' // num(:len_trim(num)) // ')' + else + if( .not. is_vector ) then + buff(len_trim(buff)+1:) = 'rxt(:,:,' // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = 'rxt(:,' // num(:len_trim(num)) // ')' + end if + end if + if( indexer(k) /= 0 ) then + if( abs( cls_rxt_map(k,indexer(k),class) ) /= 0 ) then + write(num,'(i3)') abs( cls_rxt_map(k,indexer(k),class) ) + num = adjustl( num ) + if( model /= 'CAM' ) then + if( m > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ') +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // '))' + else + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ')' + end if + else + if( .not. is_vector ) then + if( m > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,:,' // num(:len_trim(num)) // ') +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,:,' // num(:len_trim(num)) // '))' + else + buff(len_trim(buff)+1:) = '*y(:,:,' // num(:len_trim(num)) // ')' + end if + else + if( m > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ') +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // '))' + else + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ')' + end if + end if + end if + else + if( m > 1 ) then + buff(len_trim(buff)+1:) = ' +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = ')' + end if + end if + else + if( m > 1 ) then + buff(len_trim(buff)+1:) = ' +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = ')' + end if + end if + call put_in_line + if( m == 1 ) then + if( indexer(k) /= 0 ) then + write(num,'(i3)') max_loc(1) + num = adjustl( num ) + if( model /= 'CAM' ) then + buff = '*y(:,' // num(:len_trim(num)) // ')' + else + if( .not. is_vector ) then + buff = '*y(:,:,' // num(:len_trim(num)) // ')' + else + buff = '*y(:,' // num(:len_trim(num)) // ')' + end if + end if + end if + call put_in_line + exit + end if + m = m - 1 + end if + end do + where( match_mask(kl:ku,3) ) + match_mask(kl:ku,1) = .false. + endwhere + if( count( match_mask(kl:ku,1) ) == 0 ) then + exit + end if + end do + else + indprds = .false. + end if +!----------------------------------------------------------------------- +! ... Write code for "extraneous" production processes +!----------------------------------------------------------------------- + base = sum( cls_rxt_cnt(1:4,class) ) + match_mask(:,2) = .false. + match_mask(:extcnt(class),2) = cls_rxt_map(base+1:base+extcnt(class),2,class) == species + if( count( match_mask(:extcnt(class),2) ) /= 0 ) then + do k = base+1,base+extcnt(class) + if( cls_rxt_map(k,2,class) == species ) then + write(num,'(i3)') cls_rxt_map(k,1,class) + num = adjustl( num ) + n = len_trim( num ) + if( model /= 'CAM' ) then + buff = ' + extfrc(:,' // num(:n) // ')' + else + if( .not. is_vector ) then + buff = ' + extfrc(:,:,' // num(:n) // ')' + else + buff = ' + extfrc(:,' // num(:n) // ')' + end if + end if + call put_in_line + end if + end do + else if( .not. indprds ) then + buff = ' 0._r8' + call put_in_line + end if + if( line /= ' ' ) then + write(30,100) trim(line) + end if + line = ' ' + write(30,100) line + end do Species_loop + end if + end do Class_loop + + if ( .not. first_class ) then + line = ' end if' + write(30,100) line + endif + + line = ' ' + write(30,100) line + line = ' end subroutine indprd' + write(30,100) line + line = ' ' + write(30,100) line + line = ' end module mo_indprd' + write(30,100) line + + if( allocated( match_mask ) ) then + deallocate( match_mask ) + end if + if( allocated( pmask ) ) then + deallocate( pmask ) + end if + if( allocated( indexer ) ) then + deallocate( indexer ) + end if + close( 30 ) + + contains + + subroutine put_in_line +!----------------------------------------------------------------------- +! ... Put line piece in buff into the line +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: blen, llen + + blen = len_trim( buff ) + llen = len_trim( line ) + 1 + if( blen + llen < max_len-2 ) then + line(llen:) = buff(:blen) + else + line(len_trim(line)+1:) = ' &' + write(30,'(a)') trim(line) + line = ' ' + line(18:) = buff(:blen) + end if + buff = ' ' + + end subroutine put_in_line + + end subroutine ipd_code + + end module ind_prod diff --git a/chem_proc/src/cam_chempp/jcl.f b/chem_proc/src/cam_chempp/jcl.f new file mode 100644 index 0000000000..97d8c5054b --- /dev/null +++ b/chem_proc/src/cam_chempp/jcl.f @@ -0,0 +1,751 @@ + + subroutine JCL( jobctl, & + histinp, & + histout, & + options, & + sub_cnt, & + imp_cls_cnt, & + hostname, & + jobname, & + machine, & + wrk_dir, & + subfile, & + cpucnt ) + + use IO, only : lin, lout + +!------------------------------------------------------- +! ... Input arguments +!------------------------------------------------------- + integer, intent(in) :: sub_cnt ! user subroutine count + integer, intent(in) :: imp_cls_cnt ! implicit soln class count + integer, intent(in) :: cpucnt ! cpu count for distributed environs + + character(len=16), intent(in) :: hostname ! user machine hostname + character(len=16), intent(in) :: jobname ! unique name for file + character(len=16), intent(in) :: jobctl(8) ! job control parms + character(len=64), intent(in) :: histinp(3) ! "history" tape input parms + character(len=64), intent(in) :: histout(6) ! "history" tape output parms + character(len=64), intent(in) :: wrk_dir ! working directory on target machine + character(len=64), intent(inout) :: subfile ! submission filespec + character(len=16), intent(in) :: machine ! target machine "name" + + logical, intent(in), target :: options(*) ! run options + +!------------------------------------------------------- +! ... Local variables +!------------------------------------------------------- + integer :: spos + real :: time, days, seconds + real :: dtime + character(len=320) :: buff + character(len=64) :: caps + character(len=64) :: fpth + character(len=64) :: fname + character(len=6) :: date + character(len=1) :: char + logical :: lexist + logical, pointer :: f90 + logical, pointer :: usemods + +!------------------------------------------------------- +! ... Function declarations +!------------------------------------------------------- + integer :: STRLEN + logical :: ISNUM + +!----------------------------------------------------- +! ... The options array has the following mapping: +! +! (1) Chemistry (on/off) (2) Target machine == cray (yes/no) +! (3) Diffusion (on/off) (4) Convection (on/off) +! (5) Iter norms (on/off) (6) Conservation (on/off) +! (7) Source code (yes/no) (8) Submission files (yes/no) +! (9) Execution (yes/no) (10) SLT fixer (on/off) +! (11) Multitasking (yes/no) (12) Rxt rate lookup table (on/off) +! (13) Relative humidity (yes/no) (14) New compiler (yes/no) +! (15) Height field (yes/no ) (16) User "hook" (yes/no) +! (17) Use f90 modules (yes/no) (18) - (20) Unused +!----------------------------------------------------- + + f90 => options(14) + usemods => options(17) +!------------------------------------------------------- +! ... Open "script" file and make script +!------------------------------------------------------- + if( machine == 'CRAYYMP' ) then + if( subfile == ' ' ) then + subfile = 'ctm.ymp.job' + end if + INQUIRE( file = subfile, exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // subfile(:LEN_TRIM(subfile)) ) + end if + CLOSE( 3 ) + OPEN( unit = 3, & + file = subfile, & + status = 'new' ) + + buff = '#QSUB -s /bin/csh' + else if( machine == 'CRAY3' ) then + if( subfile == ' ' ) then + subfile = 'ctm.c3.job' + end if + INQUIRE( file = subfile, exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // subfile(:LEN_TRIM(subfile)) ) + end if + CLOSE( 3 ) + OPEN( unit = 3, & + file = subfile, & + status = 'new' ) + + buff = '#QSUB -s /bin/csh' + else if( machine == 'T3D' ) then + if( subfile == ' ' ) then + subfile = 'ctm.t3d.job' + end if + INQUIRE( file = subfile, exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // subfile(:LEN_TRIM(subfile)) ) + end if + CLOSE( 3 ) + OPEN( unit = 3, & + file = subfile, & + status = 'new' ) + + buff = '#QSUB -s /bin/csh' + else if( machine == 'RS6000' ) then + if( subfile == ' ' ) then + subfile = 'ctm.rs6000.job' + end if + INQUIRE( file = subfile, exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // subfile(:LEN_TRIM(subfile)) ) + end if + CLOSE( 3 ) + OPEN( unit = 3, & + file = subfile, & + status = 'new' ) + + buff = '#! /bin/csh' + end if + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... Check for account override +!------------------------------------------------------- + if( jobctl(5) /= ' ' .and. machine /= 'CRAY3' ) then + buff = '#QSUB -A ' // jobctl(5)(:STRLEN(jobctl(5))) + write(3,100) buff(:STRLEN(buff)) + end if +!------------------------------------------------------- +! ... "Write" the que +!------------------------------------------------------- + if( options(2) ) then + if( jobctl(8) /= ' ' ) then + caps = jobctl(8) + call UPCASE( caps ) + if( caps(:4) == 'PREM' ) then + buff = '#QSUB -q prem' + else if( caps(:4) == 'ECON' ) then + buff = '#QSUB -q econ' + else if( caps(:3) == 'REG' ) then + buff = '#QSUB -q reg' + else if( caps(:2) == 'LM' ) then + buff = '#QSUB -q lm' + else + buff = '#QSUB -q reg' + endif + else + buff = '#QSUB -q prem' + end if + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... "Write" the cpu limit +!------------------------------------------------------- + if( options(2) ) then + if( cpucnt > 1 ) then + buff = '#QSUB -la ' + if( machine /= 'CRAY3' ) then + write(buff(11:12),'(i2)') MIN( cpucnt,16 ) + end if + buff(13:) = 'cpus' + write(3,100) buff(:STRLEN(buff)) + buff = ' ' + end if + end if + +!------------------------------------------------------- +! ... "Write" the time limit +!------------------------------------------------------- + call TIMCON( jobctl(2)(:STRLEN(jobctl(2))), & + time, & + lout ) + write(buff,'(''#QSUB -lT '',i6)') INT(time) + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... "Write" the memory limit +!------------------------------------------------------- + buff = '#QSUB -lM ' // jobctl(4)(:STRLEN(jobctl(4))) // 'Mw' + write(3,100) buff(:STRLEN(buff)) + + buff = 'set echo' + write(3,100) buff(:STRLEN(buff)) + buff = 'set timestamp' + write(3,100) buff(:STRLEN(buff)) + buff = 'date' + write(3,100) buff(:STRLEN(buff)) + end if +!------------------------------------------------------- +! ... Change to working directory +!------------------------------------------------------- + if( options(2) ) then + if( wrk_dir == ' ' ) then + buff = 'cd $TMPDIR' + else + buff = 'cd ' // wrk_dir(:LEN_TRIM(wrk_dir)) + end if + else if( machine == 'RS6000' ) then + buff = 'set echo' + write(3,100) buff(:STRLEN(buff)) + buff = 'set timestamp' + write(3,100) buff(:STRLEN(buff)) + buff = 'date' + write(3,100) buff(:STRLEN(buff)) + buff = 'if( ! -e /usr/tmp/stacy ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' mkdir /usr/tmp/stacy' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cd /usr/tmp/stacy' + end if + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... "Write" the namelist inputs +!------------------------------------------------------- + buff = 'if ( -e ctm.dat ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm ctm.dat' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cat > ctm.dat << ''END1''' + write(3,100) buff(:STRLEN(buff)) + buff = 'ctm off-line (ver 2.0 ) : case = ' // jobctl(6)(:STRLEN(jobctl(6))) + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... "Experiment" definition +!------------------------------------------------------- + buff = ' &EXPDEF' + write(3,100) buff(:STRLEN(buff)) + caps = jobctl(7) + call UPCASE( caps ) + if( caps == 'TRUE' ) then + buff = ' NSREST = 1,' + write(3,100) buff(:STRLEN(buff)) + end if + if( histout(5) /= ' ' ) then + buff = ' WPASS = ''' // histout(5)(:STRLEN(histout(5))) // ''',' + write(3,100) buff(:STRLEN(buff)) + end if + if( histout(1) /= ' ' ) then + call TIMCON( histout(1)(:STRLEN(histout(1))), & + time, & + lout ) + write(buff,'('' IRT = '',i5,'','')') INT( time/8.64e4 + .01 ) + write(3,100) buff(:STRLEN(buff)) + end if + buff = ' CASEID = ''' // jobctl(6)(:STRLEN(jobctl(6))) // ''',' + write(3,100) buff(:STRLEN(buff)) + buff = ' /' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... "Run" definition +!------------------------------------------------------- + buff = ' &NEWRUN' + write(3,100) buff(:STRLEN(buff)) + call TIMCON( jobctl(1)(:STRLEN(jobctl(1))), & + dtime, & + lout ) + write(buff,'('' DTIME = '',i5,'','')') INT(dtime) + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... Simulation duration in time steps +!------------------------------------------------------- + spos = STRLEN( jobctl(3) ) + char = jobctl(3)(spos:spos) + if( ISNUM( char ) ) then + buff = ' NESTEP = ' // jobctl(3)(:spos) // ',' + else + call TIMCON( jobctl(3)(:spos), & + time, & + lout ) + write(buff,'('' NESTEP = '',i5,'','')') INT( (time + .01)/dtime ) + end if + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... History tape output frequency +!------------------------------------------------------- + if( histout(2) /= ' ' ) then + spos = STRLEN( histout(2) ) + char = histout(2)(spos:spos) + if( char >= '0' .and. char <= '9' ) then + buff = ' NNUMWT = ' // histout(2)(:spos) // ',' + else + call TIMCON( histout(2)(:spos), & + time, & + lout ) + write(buff,'('' NNUMWT = '',i5,'','')') INT( (time + .01)/dtime ) + end if + else + buff = ' NNUMWT = 0,' + end if + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... Simulation printout frequency +!------------------------------------------------------- + if( histout(6) /= ' ' ) then + spos = STRLEN( histout(6) ) + char = histout(6)(spos:spos) + if( char >= '0' .and. char <= '9' ) then + buff = ' PRFREQ = ' // histout(6)(:spos) // ',' + else + call TIMCON( histout(6)(:spos), & + time, & + lout ) + write(buff,'('' PRFREQ = '',i5,'','')') INT( (time + .01)/dtime ) + end if + write(3,100) buff(:STRLEN(buff)) + end if +!------------------------------------------------------- +! ... Output history tape density +!------------------------------------------------------- + if( histout(4) /= ' ' ) then + buff = ' NDENS = ' // histout(4)(:STRLEN(histout(4))) // ',' + write(3,100) buff(:STRLEN(buff)) + end if + if( options(10) ) then + buff = ' LFIXER = .TRUE.,' + write(3,100) buff(:STRLEN(buff)) + buff = ' LIMFIX = .TRUE.,' + write(3,100) buff(:STRLEN(buff)) + end if + if( histout(3) /= ' ' ) then + buff = ' STFNUM = ' // histout(3)(:STRLEN(histout(3))) + write(3,100) buff(:STRLEN(buff)) + end if + buff = ' /' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... "Input" definition +!------------------------------------------------------- + buff = ' &INPUT' + write(3,100) buff(:STRLEN(buff)) + call PARSE_FLPTH( histinp(1), fname, fpth ) + spos = STRLEN(fpth) + if( fpth(spos:spos) == '/' ) then + fpth(spos:spos) = ' ' + end if + buff = ' MSPATH = ''' // fpth(:STRLEN(fpth)) // ''',' + write(3,100) buff(:STRLEN(buff)) + buff = ' MSFN = ''' // fname(:STRLEN(fname)) // ''',' + write(3,100) buff(:STRLEN(buff)) + spos = STRLEN(histinp(3)) + if( spos /= 0 ) then + buff = ' ICFLNM = ''' // histinp(3)(:spos) // ''',' + write(3,100) buff(:STRLEN(buff)) + end if + call TIMCON_D( histinp(2)(:STRLEN(histinp(2))), & + days, & + seconds) + call MKDATE( days, date ) + buff = ' ICDATE = ' // date // ',' + write(3,100) buff(:STRLEN(buff)) + write(buff,'('' ICSEC = '',i5,'','')') INT( seconds ) + write(3,100) buff(:STRLEN(buff)) + buff = ' /' + write(3,100) buff(:STRLEN(buff)) + + buff = '''END1''' + write(3,100) buff(:STRLEN(buff)) + + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... Write the sim.dat file +!------------------------------------------------------- + buff = 'if ( -e sim.dat ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm sim.dat' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cat > sim.dat << ''END1''' + write(3,100) buff(:STRLEN(buff)) + CLOSE(2) + OPEN( unit = 2, & + file = 'sim.dat', & + status = 'old' ) + do + read(2,100,end=200) buff + write(3,100) buff(:STRLEN(buff)) + end do + +200 continue + buff = '''END1''' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... Write the modules file +!------------------------------------------------------- + if( usemods ) then + buff = 'if ( -e ctm.mods.f ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm ctm.mods.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cat > ctm.mods.f << ''END1''' + write(3,100) buff(:STRLEN(buff)) + CLOSE(2) + OPEN( unit = 2, & + file = 'ctm.mods.f', & + status = 'old' ) + do + read(2,100,end=211) buff + write(3,100) buff(:STRLEN(buff)) + end do +211 continue + buff = '''END1''' + write(3,100) buff(:STRLEN(buff)) + end if + +!------------------------------------------------------- +! ... Write the main file +!------------------------------------------------------- + buff = 'if ( -e ctm.main.f ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm ctm.main.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cat > ctm.main.f << ''END1''' + write(3,100) buff(:STRLEN(buff)) + CLOSE(2) + OPEN( unit = 2, & + file = 'ctm.main.f', & + status = 'old' ) + do + read(2,100,end=210) buff + write(3,100) buff(:STRLEN(buff)) + end do + +210 continue + buff = '''END1''' + write(3,100) buff(:STRLEN(buff)) + + if( options(7) .or. sub_cnt /= 0 ) then +!------------------------------------------------------- +! ... Write the subroutine file +!------------------------------------------------------- + buff = 'if ( -e ctm.subs.f ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm ctm.subs.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'cat > ctm.subs.f << ''END1''' + write(3,100) buff(:STRLEN(buff)) + CLOSE(2) + OPEN( unit = 2, & + file = 'ctm.subs.f', & + status = 'old' ) + do + read(2,100,end=220) buff + write(3,100) buff(:STRLEN(buff)) + end do + +220 continue + buff = '''END1''' + write(3,100) buff(:STRLEN(buff)) + end if + +!------------------------------------------------------- +! ... Compile the sources +!------------------------------------------------------- + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + if( options(2) ) then +!------------------------------------------------------- +! ... Compile for a Cray ( not T3D ) +!------------------------------------------------------- + buff = 'ja' + write(3,100) buff(:STRLEN(buff)) + if( machine /= 'CRAY3' ) then + if( usemods ) then + buff = 'f90 -c ctm.mods.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo ctm.mods.f compile failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + end if + buff = 'f90 -c ctm.main.f' + else + if( options(11) ) then + buff = '/u0/cs/bin/f77 -c -h fmp ctm.main.f' + else + buff = '/u0/cs/bin/f77 -c ctm.main.f' + end if + end if + write(3,100) buff(:STRLEN(buff)) + else if( machine == 'RS6000' ) then + buff = 's2d ctm.main.f > Main.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo ctm.main.f s2d failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 's2d ctm.subs.f > Subs.f' + write(3,100) buff(:STRLEN(buff)) + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo ctm.subs.f s2d failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = 'xlf -c -O3 Main.f' + write(3,100) buff(:STRLEN(buff)) + end if + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo ctm.main.f compile failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + + if( options(7) .or. sub_cnt /= 0 ) then + if( options(2) ) then + if( machine /= 'CRAY3' ) then + buff = 'f90 -c ctm.subs.f' + else + buff = '/u0/cs/bin/f77 -c ctm.subs.f' + end if + else if( machine == 'RS6000' ) then + buff = 'xlf -c -O3 Subs.f' + end if + write(3,100) buff(:STRLEN(buff)) + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo ctm.subs.f compile failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + end if + +!------------------------------------------------------- +! ... Form the executable +!------------------------------------------------------- + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + if( options(2) ) then + if( options(7) ) then + if( imp_cls_cnt /= 0 .and. machine /= 'CRAY3' ) then + if( f90 ) then + buff = 'f90 -Wl"-f indef" ctm.main.o ctm.subs.o /crestone/u2/stacy/ctm/lib/fsim.o \\' + else + buff = 'segldr -f indef ctm.main.o ctm.subs.o /crestone/u2/stacy/ctm/lib/fsim.o \\' + end if + else + buff = 'segldr -f indef ctm.main.o ctm.subs.o \\ ' + end if + write(3,100) buff(:STRLEN(buff)) + if( f90 ) then + buff = ' -L /usr/local/lib -lncaro,hpf,mss' + else + buff = ' -L /lib,/usr/lib,/usr/local/lib \\' + end if + write(3,100) buff(:STRLEN(buff)) + if( machine /= 'CRAY3' ) then + if( .not. f90 ) then + buff = ' -l ncaro,hpf,mss -M ,s' + end if + else + if( options(11) ) then + buff = ' -l ncaro,hpf,mss,net,pll -M ,s' + else + buff = ' -l ncaro,hpf,mss,net -M ,s' + end if + end if + else if( sub_cnt == 0 ) then + if( imp_cls_cnt /= 0 .and. machine /= 'CRAY3' ) then + buff = 'segldr -f indef ctm.main.o /crestone/u2/stacy/ctm/lib/fsim.o \\' + else + buff = 'segldr -f indef ctm.main.o \\' + end if + write(3,100) buff(:STRLEN(buff)) + buff = ' -L /lib,/usr/lib,/usr/local/lib,/u0/stacy/ctm/lib \\' + write(3,100) buff(:STRLEN(buff)) + buff = ' -l ncaro,hpf,mss,ctm -M ,s' + else + buff = 'segldr -f indef ctm.main.o ctm.subs.o \\ ' + write(3,100) buff(:STRLEN(buff)) + buff = ' -L /lib,/usr/lib,/usr/local/lib,/u2/stacy/ctm/lib \\' + write(3,100) buff(:STRLEN(buff)) + buff = ' -l ncaro,hpf,mss,ctm -M ,s' + end if + else if( machine == 'RS6000' ) then + if( cpucnt == 1 ) then + buff = 'xlf Main.o Subs.o -L/usr/local/lib -lmss -lncaru -lessl' + else + buff = 'xlf Main.o Subs.o -L /usr/lpp/pvm/lib -lpvm -lf2c \\' + write(3,100) buff(:STRLEN(buff)) + buff = ' -L/usr/local/lib -lmss -lncaru -lessl \\' + write(3,100) buff(:STRLEN(buff)) + buff = ' -bI:/usr/lpp/pvm/lib/pvme.exp' + end if + end if + if( .not. f90 ) then + write(3,100) buff(:STRLEN(buff)) + end if + buff = 'if ( $status ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' echo segldr failed' + write(3,100) buff(:STRLEN(buff)) + buff = ' goto errexit' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... Execution +!------------------------------------------------------- + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + buff = 'if ( -e ctm.out.$$ ) then' + write(3,100) buff(:STRLEN(buff)) + buff = ' rm ctm.out.$$' + write(3,100) buff(:STRLEN(buff)) + buff = 'endif' + write(3,100) buff(:STRLEN(buff)) + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + if( options(2) ) then + if( cpucnt > 1 ) then + buff = 'setenv NCPUS ' + if( machine /= 'CRAY3' ) then + write(buff(14:),'(i2)') MIN( cpucnt,16 ) + else + write(buff(14:),'(i1)') MIN( cpucnt,2 ) + end if + write(3,100) buff(:STRLEN(buff)) + buff = ' ' + end if + end if + buff = 'a.out < ctm.dat > ctm.out.$$' + write(3,100) buff(:STRLEN(buff)) + +!------------------------------------------------------- +! ... Disperse printouts; normal termination +!------------------------------------------------------- + buff = ' ' + write(3,100) buff(:STRLEN(buff)) + buff = 'rcp ctm.out.$$ \\' + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' ) then + buff = ' ' // hostname(:STRLEN(hostname)) // '.acd.ucar.edu:rje/ctm.out.$$' + else + buff = ' acd.ucar.edu:rje/ctm.out.$$' + end if + write(3,100) buff(:STRLEN(buff)) + if( options(2) ) then + if( machine /= 'CRAY3' ) then + buff = 'ja -schflt > accnting.$$' + else + buff = 'ja -scflt > accnting.$$' + end if + write(3,100) buff(:STRLEN(buff)) + buff = 'rcp accnting.$$ \\' + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' ) then + buff = ' ' // hostname(:STRLEN(hostname)) // '.acd.ucar.edu:rje/accnting.$$' + else + buff = ' acd.ucar.edu:rje/accnting.$$' + end if + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' .and. options(9) ) then + buff = 'cd $home' + write(3,100) buff(:STRLEN(buff)) + buff = 'echo "rcp /usr/tmp/O' // jobname(:STRLEN(jobname)) // ' ' // hostname(:STRLEN(hostname)) & + // '.acd.ucar.edu:rje/O' // jobname(:STRLEN(jobname)) // '" | at now + 2 minute' + write(3,100) buff(:STRLEN(buff)) + end if + end if + buff = 'exit( 0 )' + write(3,100) buff(:STRLEN(buff)) + + buff = ' ' + write(3,100) buff(:STRLEN(buff)) +!------------------------------------------------------- +! ... Disperse printouts; error termination +!------------------------------------------------------- + buff = 'errexit:' + write(3,100) buff(:STRLEN(buff)) + buff = 'rcp ctm.out.$$ \\' + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' ) then + buff = ' ' // hostname(:STRLEN(hostname)) // '.acd.ucar.edu:rje/ctm.out.$$' + else + buff = ' acd.ucar.edu:rje/ctm.out.$$' + end if + write(3,100) buff(:STRLEN(buff)) + if( options(2) ) then + if( machine /= 'CRAY3' ) then + buff = 'ja -schflt > accnting.$$' + else + buff = 'ja -scflt > accnting.$$' + end if + write(3,100) buff(:STRLEN(buff)) + buff = 'rcp accnting.$$ \\' + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' ) then + buff = ' ' // hostname(:STRLEN(hostname)) // '.acd.ucar.edu:rje/accnting.$$' + else + buff = ' acd.ucar.edu:rje/accnting.$$' + end if + write(3,100) buff(:STRLEN(buff)) + if( hostname /= 'acd' .and. options(9) ) then + buff = 'cd $home' + write(3,100) buff(:STRLEN(buff)) + buff = 'echo "rcp /usr/tmp/O' // jobname(:STRLEN(jobname)) // ' ' // hostname(:STRLEN(hostname)) & + // '.acd.ucar.edu:rje/O' // jobname(:STRLEN(jobname)) // '" | at now + 2 minute' + write(3,100) buff(:STRLEN(buff)) + end if + end if + buff = 'exit( -1 )' + write(3,100) buff(:STRLEN(buff)) + CLOSE(3) + +100 format(a) + + end diff --git a/chem_proc/src/cam_chempp/job_ctl.f b/chem_proc/src/cam_chempp/job_ctl.f new file mode 100644 index 0000000000..44ae799c55 --- /dev/null +++ b/chem_proc/src/cam_chempp/job_ctl.f @@ -0,0 +1,102 @@ + subroutine JOB_CTL( lin, & + lout, & + jobctl ) + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: lin, lout + character(len=16), intent(out) :: jobctl(8) ! job control variables + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: kpar, nchar, k + integer :: parsw(8) + + real :: time + + character(len=80) :: buff + character(len=80) :: buffh + character(len=20) :: parkey(8), keywrd + + logical :: found + + integer :: LENOF + + parkey(1) = 'SIMULATIONTIMESTEP' + parkey(2) = 'CRAYTIMELIMIT' + parkey(3) = 'SIMULATIONLENGTH' + parkey(4) = 'CRAYMEMORY' + parkey(5) = 'ACCOUNT' + parkey(6) = 'CASE' + parkey(7) = 'RESTART' + parkey(8) = 'CRAYQUE' + + parsw = 0 + +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE ( buffh ) + if( buffh == 'ENDJOBCONTROL' ) then + exit + end if + k = INDEX( buffh(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buffh(:k-1) + found = .false. + do kpar = 1,8 + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + else +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call ERRMES ( ' job ctl specification has no = operator@', lout, buff, 1, buff ) + end if + if( .not. found) then + call ERRMES ( ' # is an invalid job control parameter keyword@', & + lout, & + keywrd, & + LENOF(20,keywrd), & + buffh ) + end if + +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( parsw(kpar) /= 0 ) then + call ERRMES( '0 *** # has already been specified@', lout, parkey(kpar), k, ' ' ) + end if + +!----------------------------------------------------------------------- +! ... Set individual options +!----------------------------------------------------------------------- + if( kpar <= 3 ) then + if( kpar == 3 ) then + if( buffh(nchar-4:nchar) == 'STEPS' ) then + jobctl(3) = buff(k+1:nchar-5) + else + call TIMCON( buff(k+1:nchar), time, lout ) + jobctl(3) = buff(k+1:nchar) + end if + else + call TIMCON( buff(k+1:nchar), time, lout ) + jobctl(kpar) = buff(k+1:nchar) + end if + else + jobctl(kpar) = buff(k+1:nchar) + end if + parsw(kpar) = 1 + end do + + end subroutine JOB_CTL diff --git a/chem_proc/src/cam_chempp/lin_code.f b/chem_proc/src/cam_chempp/lin_code.f new file mode 100644 index 0000000000..100bf9ff61 --- /dev/null +++ b/chem_proc/src/cam_chempp/lin_code.f @@ -0,0 +1,685 @@ + + module lin_matrix + + use io, only : temp_path + + implicit none + + character(len=4) :: hdr, up_hdr + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + + contains + + subroutine make_lin( clscnt, clsmap, cls_rxt_cnt, cls_rxt_map, pcoeff_ind, & + pcoeff, permute, mat_map, class, & + lin_mat_pat, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran code for the linear components +! of the Jacobian matrix +!----------------------------------------------------------------------- + + use var_mod, only : var_lim + use rxt_mod, only : rxt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: clscnt, & + class, & + clsmap(var_lim,5,2), & + cls_rxt_map(rxt_lim,prd_lim+3), & + cls_rxt_cnt(4) + integer, intent(in) :: mat_map(max(1,clscnt),max(1,clscnt)) + integer, intent(in) :: permute(max(1,clscnt)) + integer, intent(in) :: pcoeff_ind(*) + real, intent(in) :: pcoeff(prd_lim,*) + character(len=16), intent(in) :: model ! target model + character(len=16), intent(in) :: march ! target architecture + logical, intent(out):: lin_mat_pat(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_len= 90 + integer :: i, j, k, l, m + integer :: length, index + integer :: row, col, sub_cnt + integer :: line_pos, rxno, target, line_cnt + integer :: base + integer :: species + integer :: mat_ind + integer :: match_cnt + integer :: list_cnt + integer :: other_ind + integer :: match_ind(var_lim) + integer :: scan(var_lim,3) + real :: rate + character(len=max_len+2) :: line + character(len=72) :: buff + character(len=12) :: het_piece + character(len= 6) :: mat_piece, rxt_piece + character(len= 4) :: sol_piece, num + logical :: beg_line, flush + logical :: lexist + + if( class == 4 ) then + inquire( file = trim( temp_path ) // 'linmat.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'linmat.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'linmat.F' ) + up_hdr = 'imp_' + hdr = 'imp_' + if( model == 'CAM' ) then + up_hdr = ' ' + hdr = ' ' + end if + else + open( unit = 30, file = trim( temp_path ) // 'linmat.F', position='append' ) + up_hdr = 'rod_' + hdr = 'rod_' + end if + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + line_cnt = 0 + line = ' ' + write(30,100) trim(line) + line = ' module mo_' // trim(up_hdr) // 'lin_matrix' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if (march=='VECTOR') then + line = ' use chem_mods, only: veclen' + write(30,100) trim(line) + endif + line = ' private' + write(30,100) trim(line) + line = ' public :: linmat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' contains' + write(30,100) trim(line) + if( clscnt == 0 .or. (cls_rxt_cnt(2)+cls_rxt_cnt(4)) == 0 ) then + sub_cnt = 0 + else + sub_cnt = 1 + end if + call make_lin_hdr( clscnt, sub_cnt, march, model ) + + select case( march ) + case( 'SCALAR' ) + mat_piece = 'mat(' + rxt_piece = 'rxt(' + sol_piece = 'y(' + het_piece = 'het_rates(' + case ( 'CACHE','VECTOR' ) + mat_piece = 'mat(k,' + rxt_piece = 'rxt(k,' + sol_piece = 'y(k,' + het_piece = 'het_rates(k,' + case default + mat_piece = 'mat(k,' + rxt_piece = 'rxt(k,' + sol_piece = 'y(k,' + het_piece = 'het_rates(k,' + end select + + lin_mat_pat(:) = .false. +Species_loop : & + do species = 1,clscnt + target = clsmap(species,class,2) + flush = .false. +!----------------------------------------------------------------------- +! ...Write code for linear loss entries +!----------------------------------------------------------------------- + row = permute(species) + mat_ind = mat_map(row,row) + write(num,'(i4)') mat_map(row,row) + num = adjustl( num ) + l = len_trim( num ) + line = ' ' + line(10:) = trim( mat_piece ) // num(:l) // ') = -(' + line_pos = len_trim( line ) + 2 + base = cls_rxt_cnt(1) + beg_line = .true. + do k = base+1,base+cls_rxt_cnt(2) + if( cls_rxt_map(k,2) == target ) then + lin_mat_pat(mat_ind) = .true. + flush = .true. + write(num,'(i4)') cls_rxt_map(k,1) + num = adjustl( num ) + l = len_trim( num ) + buff = trim( rxt_piece ) // num(:l) // ')' + if( cls_rxt_map(k,3) > 0 ) then + write(num,'(i4)') cls_rxt_map(k,3) + num = adjustl( num ) + l = len_trim( num ) + buff(len_trim(buff)+1:) = '*' // trim( sol_piece ) // num(:l) // ')' + end if + length = len_trim(buff) + if( (line_pos + length) <= max_len-2 ) then + if( beg_line ) then + line(line_pos:) = buff(:length) + beg_line = .false. + else + line(line_pos:) = ' + ' // buff(:length) + end if + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end if + end do + base = base + cls_rxt_cnt(2) + cls_rxt_cnt(3) + do k = base+1,base+cls_rxt_cnt(4) + if( cls_rxt_map(k,2) == species ) then + lin_mat_pat(mat_ind) = .true. + flush = .true. + write(num,'(i4)') cls_rxt_map(k,1) + num = adjustl( num ) + l = len_trim( num ) + buff = trim( het_piece ) // num(:l) // ')' + length = len_trim(buff) + if( (line_pos + length) <= max_len-2 ) then + if( beg_line ) then + line(line_pos:) = buff(:length) + beg_line = .false. + else + line(line_pos:) = ' + ' // buff(:length) + end if + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(18:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end if + end do + if( flush ) then + if( line_pos <= max_len-2 ) then + line(line_pos+1:) = ')' + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' )' + end if + write(30,100) trim(line) + line_cnt = line_cnt + 1 + end if + +!----------------------------------------------------------------------- +! ... Scan for production matches +!----------------------------------------------------------------------- + match_cnt = 0 + base = cls_rxt_cnt(1) + do k = base+1,base+cls_rxt_cnt(2) + other_ind = 0 + do l = 4,prd_lim+3 + if( cls_rxt_map(k,l) == species ) then + if( other_ind == 0 ) then + match_cnt = match_cnt + 1 + scan(match_cnt,1) = k + scan(match_cnt,2) = ABS(cls_rxt_map(k,2)) + end if + other_ind = other_ind + 1 + end if + end do + if( other_ind /= 0 ) then + scan(match_cnt,3) = other_ind + end if + end do + list_cnt = match_cnt + do while( list_cnt > 0 ) + do j = 1,match_cnt + if( scan(j,2) /= 0 ) then + index = scan(j,2) + exit + end if + end do + m = 0 + do j = 1,match_cnt + if( scan(j,2) == index ) then + m = m + 1 + match_ind(m) = j + scan(j,2) = 0 + list_cnt = list_cnt - 1 + end if + end do + row = permute(species) + col = permute(clsmap(index,class,1)) + mat_ind = mat_map(row,col) + lin_mat_pat(mat_ind) = .true. + write(num,'(i4)') mat_map(row,col) + num = adjustl( num ) + l = len_trim( num ) + line = ' ' + line(10:) = trim( mat_piece ) // num(:l) // ') =' + line_pos = len_trim( line ) + if( clsmap(index,class,1) == species ) then + line(len_trim(line)+2:) = trim( mat_piece ) // num(:l) // ') +' + end if + line_pos = len_trim( line ) + 2 + if( m > 0 ) then + beg_line = .true. + else + line(line_pos:) = '0.' + end if + do j = 1,m + l = match_ind(j) + rxno = cls_rxt_map(scan(l,1),1) + index = pcoeff_ind(rxno) + rate = 0. + if( index /= 0 ) then + do i = 4,prd_lim+3 + if( cls_rxt_map(scan(l,1),i) == species ) then + rate = rate + pcoeff(i-3,index) + end if + end do + else if( scan(l,3) /= 1 ) then + rate = REAL(scan(l,3)) + end if + buff = ' ' + if( rate /= 0. .and. rate /= 1. ) then + call r2c( buff, rate, 'l' ) + buff(len_trim(buff)+1:) = trim(num_suffix) // '*' + end if + write(num,'(i4)') rxno + num = adjustl( num ) + buff(len_trim(buff)+1:) = trim( rxt_piece ) // num(:len_trim(num)) // ')' + if( cls_rxt_map(scan(l,1),3) > 0 ) then + write(num,'(i4)') cls_rxt_map(scan(l,1),3) + num = adjustl( num ) + buff(len_trim(buff)+1:) = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + end if + length = len_trim(buff) + if( (line_pos + length) <= max_len-2 ) then + if( beg_line ) then + line(line_pos:) = buff(:length) + beg_line = .false. + else + line(line_pos:) = ' + ' // buff(:length) + end if + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end do + write(30,100) trim(line) + line_cnt = line_cnt + 1 + end do + line = ' ' + write(30,100) trim(line) + if( line_cnt > 200 ) then + if( march /= 'SCALAR' ) then + line = ' end do' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + write(num,'(i4)') 1000+sub_cnt + write(line,'('' end subroutine '',a,''linmat'',a)') trim(up_hdr),num(3:4) + write(30,100) trim(line) + line_cnt = 0 + if( species /= clscnt ) then + sub_cnt = sub_cnt + 1 + call make_lin_hdr( clscnt, sub_cnt, march, model ) + end if + end if + end do Species_loop + + if( line_cnt /= 0 ) then + if( march /= 'SCALAR' ) then + line = ' end do' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + write(num,'(i4)') 1000+sub_cnt + write(line,'('' end subroutine '',a,''linmat'',a)') trim(up_hdr),num(3:4) + write(30,100) trim(line) + end if + + if( clscnt > 0 .and. (cls_rxt_cnt(2)+cls_rxt_cnt(4)) > 0 ) then + call make_lin_hdr( clscnt, 0, march, model ) + end if + do m = 1,sub_cnt + write(num,'(i4)') 1000+m + select case( march ) + case ( 'VECTOR' ) + write(line,'('' call '',a,''linmat'',a,''( avec_len, mat, y, rxt, het_rates )'')') & + trim(up_hdr),num(3:4) + case ( 'SCALAR' ) + write(line,'('' call '',a,''linmat'',a,''( mat, y, rxt, het_rates )'')') trim(up_hdr),num(3:4) + case default + if( model == 'MOZART' ) then + write(line,'('' call '',a,''linmat'',a,''( mat, y, rxt, het_rates )'')') trim(up_hdr),num(3:4) + else if( model == 'CAM' ) then + write(line,'('' call '',a,''linmat'',a,''( mat, y, rxt, het_rates, cols )'')') trim(up_hdr),num(3:4) + else if( model == 'WRF' ) then + write(line,'('' call '',a,''linmat'',a,''( mat, y, rxt )'')') trim(up_hdr),num(3:4) + end if + end select + write(30,100) trim(line) + end do + line = ' ' + write(30,100) trim(line) + line = ' end subroutine ' // trim(up_hdr) // 'linmat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' end module mo_' // trim(up_hdr) // 'lin_matrix' + write(30,100) trim(line) + + close( 30 ) + +100 format(a) + + end subroutine make_lin + + subroutine make_lin_hdr( clscnt, sub_cnt, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran header code for the linear components +! of the Jacobian matrix +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: clscnt, sub_cnt + character(len=16), intent(in) :: march + character(len=16), intent(in) :: model + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: length + character(len=72) :: line + character(len=3) :: num + + line = ' ' + write(30,100) trim(line) + write(num,'(i3)') 100+sub_cnt + select case( march ) + case ( 'SCALAR' ) + if( sub_cnt /= 0 ) then + if( model == 'MOZART' .or. model == 'CAM' ) then + write(line,'('' subroutine '',a,''linmat'',a,''( mat, y, rxt, het_rates )'')') trim(up_hdr),num(2:3) + else if( model == 'WRF' ) then + write(line,'('' subroutine '',a,''linmat'',a,''( mat, y, rxt )'')') trim(up_hdr),num(2:3) + end if + else + if( model == 'MOZART' .or. model == 'CAM' ) then + write(line,'('' subroutine '',a,''linmat( mat, y, rxt, het_rates )'')') trim(up_hdr) + else if( model == 'WRF' ) then + write(line,'('' subroutine '',a,''linmat( mat, y, rxt )'')') trim(up_hdr) + end if + end if + case ( 'VECTOR' ) + if( sub_cnt /= 0 ) then + write(line,'('' subroutine '',a,''linmat'',a,''( avec_len, mat, y, rxt, het_rates )'')') & + trim(up_hdr),num(2:3) + else + write(line,'('' subroutine '',a,''linmat( avec_len, mat, y, rxt, het_rates )'')') & + trim(up_hdr) + end if + case default + if( sub_cnt /= 0 ) then + if( model == 'MOZART' ) then + write(line,'('' subroutine '',a,''linmat'',a,''( mat, y, rxt, het_rates )'')') trim(up_hdr),num(2:3) + else if( model == 'CAM' ) then + write(line,'('' subroutine '',a,''linmat'',a,''( mat, y, rxt, het_rates, cols )'')') trim(up_hdr),num(2:3) + else if( model == 'WRF' ) then + write(line,'('' subroutine '',a,''linmat'',a,''( mat, y, rxt )'')') trim(up_hdr),num(2:3) + end if + else + if( model == 'MOZART' ) then + write(line,'('' subroutine '',a,''linmat( mat, y, rxt, het_rates )'')') trim(up_hdr) + else if( model == 'CAM' ) then + write(line,'('' subroutine '',a,''linmat( mat, y, rxt, het_rates, cols )'')') trim(up_hdr) + else if( model == 'WRF' ) then + write(line,'('' subroutine '',a,''linmat( mat, y, rxt )'')') trim(up_hdr) + end if + end if + end select + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... linear matrix entries for' + length = len_trim( line ) + 2 + line(length:) = 'implicit species' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'MOZART' ) then + select case( march ) + case( 'SCALAR' ) + line = ' use mo_grid, only : pcnstm1' + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt' + case ( 'VECTOR' ) + line = ' use mo_grid, only : pcnstm1, plnplv' + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt' + case default + line = ' use mo_grid, only : pcnstm1' + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt, clsze' + end select + else if( model == 'CAM' ) then + select case( march ) + case( 'SCALAR' ) + line = ' use chem_mods, only : gas_pcnst, rxntot, nzcnt' + case ( 'VECTOR' ) + line = ' use chem_mods, only : gas_pcnst, rxntot, nzcnt' + case default + line = ' use chem_mods, only : gas_pcnst, rxntot, nzcnt, clsze' + end select + write(30,100) trim(line) + line = ' use shr_kind_mod, only : r8 => shr_kind_r8' + else if( model == 'WRF' ) then + line = '' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + if( model /= 'CAM' ) then + select case( march ) + case( 'SCALAR' ) + if( model /= 'WRF' ) then + line = ' real, intent(in) :: y(pcnstm1)' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(rxntot)' + write(30,100) trim(line) + line = ' real, intent(in) :: het_rates(gas_pcnst)' + write(30,100) trim(line) + line = ' real, intent(inout) :: mat(' // hdr // 'nzcnt)' + else + line = ' real, intent(in) :: y(:)' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(:)' + write(30,100) trim(line) + line = ' real, intent(inout) :: mat(:)' + end if + write(30,100) trim(line) + case ( 'VECTOR' ) + line = ' integer, intent(in) :: avec_len' + write(30,100) trim(line) + line = ' real, intent(in) :: y(veclen,gas_pcnst)' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(veclen,rxntot)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real, intent(in) :: het_rates(veclen,gas_pcnst)' + write(30,100) trim(line) + end if + line = ' real, intent(inout) :: mat(veclen,nzcnt)' + write(30,100) trim(line) + if( sub_cnt /= 0 ) then + line = ' ' + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... Local variables' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' integer :: k' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'do k = 1,avec_len' + write(30,100) trim(line) + end if + case default + line = ' real, intent(in) :: y(clsze,pcnstm1)' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(clsze,rxntot)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real, intent(in) :: het_rates(clsze,gas_pcnst)' + write(30,100) trim(line) + end if + line = ' real, intent(inout) :: mat(clsze,' // hdr // 'nzcnt)' + write(30,100) trim(line) + if( sub_cnt /= 0 ) then + line = ' ' + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' integer :: k' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( clscnt /= 0 ) then + line(7:) = 'do k = 1,clsze' + write(30,100) trim(line) + end if + end if + end select + else + select case( march ) + case ( 'SCALAR' ) + line = ' real(r8), intent(in) :: y(gas_pcnst)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: rxt(rxntot)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: het_rates(max(1,gas_pcnst))' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: mat(nzcnt)' + write(30,100) trim(line) + case ( 'VECTOR' ) + line = ' integer, intent(in) :: avec_len' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: y(veclen,gas_pcnst)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: rxt(veclen,rxntot)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: het_rates(veclen,gas_pcnst)' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: mat(veclen,nzcnt)' + write(30,100) trim(line) + if( sub_cnt /= 0 ) then + line = ' ' + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' integer :: k' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( clscnt /= 0 ) then + if( model == 'CAM' ) then + line(7:) = 'do k = 1,avec_len' + end if + write(30,100) trim(line) + end if + end if + case default + line = ' integer, intent(in) :: cols' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: y(clsze,gas_pcnst)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: rxt(clsze,rxntot)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: het_rates(clsze,max(1,gas_pcnst))' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: mat(clsze,nzcnt)' + write(30,100) trim(line) + if( sub_cnt /= 0 ) then + line = ' ' + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' integer :: k' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( clscnt /= 0 ) then + if( model == 'MOZART' ) then + line(7:) = 'do k = 1,clsze' + else if( model == 'CAM' ) then + line(7:) = 'do k = 1,cols' + end if + write(30,100) trim(line) + end if + end if + end select + end if + line = ' ' + write(30,100) trim(line) + +100 format(a) + + end subroutine make_lin_hdr + + end module lin_matrix diff --git a/chem_proc/src/cam_chempp/mak_grp_vmr.f b/chem_proc/src/cam_chempp/mak_grp_vmr.f new file mode 100644 index 0000000000..cb1ebb92fe --- /dev/null +++ b/chem_proc/src/cam_chempp/mak_grp_vmr.f @@ -0,0 +1,205 @@ + + subroutine mak_grp_vmr( grp_mem_cnt, mem2grp_map, model, march ) +!------------------------------------------------------------------- +! ... Write the group volume mixing ratios code +!------------------------------------------------------------------- + + use io, only : temp_path + + implicit none + +!------------------------------------------------------------------- +! ... Dummy args +!------------------------------------------------------------------- + integer, intent(in) :: grp_mem_cnt + integer, intent(in) :: mem2grp_map(*) + character(len=*), intent(in) :: model + character(len=*), intent(in) :: march + +!------------------------------------------------------------------- +! ... Local variables +!------------------------------------------------------------------- + integer, parameter :: max_len= 90 + integer :: m + character(len=max_len) :: line + logical :: lexist + + inquire( file = trim( temp_path ) // 'mo_make_grp_vmr.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_make_grp_vmr.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_make_grp_vmr.F' ) + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_make_grp_vmr' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: mak_grp_vmr' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line(7:) = 'subroutine mak_grp_vmr( vmr, group_ratios, group_vmrs, plonl )' + case( 'CAM' ) + if( march /= 'VECTOR' ) then + line(7:) = 'subroutine mak_grp_vmr( vmr, group_ratios, group_vmrs, plonl )' + else + line(7:) = 'subroutine mak_grp_vmr( vmr, group_ratios, group_vmrs, chnkpnts )' + end if + case( 'WRF' ) + line(7:) = 'subroutine mak_grp_vmr( vmr, group_ratios, group_vmrs )' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'MOZART' ) then + line(7:) = 'use mo_grid, only : plev, pcnstm1' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : grpcnt' + else if( model == 'CAM' ) then + line(7:) = 'use chem_mods, only : grpcnt, gas_pcnst' + write(30,100) trim(line) + if( march /= 'VECTOR' ) then + line(7:) = 'use ppgrid, only : pver' + write(30,100) trim(line) + end if + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + else if( model == 'WRF' ) then + line(7:) = ' ' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!----------------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!----------------------------------------------------------------------------' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line = ' integer, intent(in) :: plonl' + write(30,100) trim(line) + case( 'CAM' ) + if( march /= 'VECTOR' ) then + line = ' integer, intent(in) :: plonl' + else + line = ' integer, intent(in) :: chnkpnts' + end if + write(30,100) trim(line) + end select + if( model == 'MOZART' ) then + line = ' real, intent(in) :: vmr(plonl,plev,pcnstm1)' + write(30,100) trim(line) + line = ' real, intent(in) :: group_ratios(plonl,plev,grpcnt)' + write(30,100) trim(line) + line = ' real, intent(out) :: group_vmrs(plonl,plev,grpcnt)' + else if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + line = ' real(r8), intent(in) :: vmr(:,:,:)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: group_ratios(:,:,:)' + write(30,100) trim(line) + line = ' real(r8), intent(out) :: group_vmrs(:,:,:)' + else + line = ' real(r8), intent(in) :: vmr(chnkpnts,max(1,gas_pcnst))' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: group_ratios(chnkpnts,max(1,grpcnt))' + write(30,100) trim(line) + line = ' real(r8), intent(out) :: group_vmrs(chnkpnts,max(1,grpcnt))' + end if + else if( model == 'WRF' ) then + line = ' real, intent(in) :: vmr(:,:)' + write(30,100) trim(line) + line = ' real, intent(in) :: group_ratios(:,:)' + write(30,100) trim(line) + line = ' real, intent(out) :: group_vmrs(:,:)' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = '!----------------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!----------------------------------------------------------------------------' + write(30,100) trim(line) + line = ' integer :: k' + write(30,100) trim(line) + end if + if( grp_mem_cnt > 0 ) then + line = ' ' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line(7:) = 'do k = 1,plev' + write(30,100) trim(line) + case( 'CAM' ) + if( march /= 'VECTOR' ) then + line(7:) = 'do k = 1,plev' + else + line(7:) = 'do k = 1,chnkpnts' + end if + write(30,100) trim(line) + end select + do m = 1,grp_mem_cnt + line = ' ' + select case( model ) + case( 'MOZART' ) + line(10:) = 'group_vmrs(:,k, ) = group_ratios(:,k, )' + write(line(25:26),'(i2)') m + write(line(48:49),'(i2)') m + line(len_trim(line)+1:) = ' * vmr(:,k,' + case( 'CAM' ) + if( march /= 'VECTOR' ) then + line(10:) = 'group_vmrs(:,k, ) = group_ratios(:,k, )' + write(line(25:26),'(i2)') m + write(line(48:49),'(i2)') m + line(len_trim(line)+1:) = ' * vmr(:,k,' + else + line(10:) = 'group_vmrs(k, ) = group_ratios(k, )' + write(line(10:),'(''group_vmrs(k,'',i2,'') = group_ratios(k,'',i2,'')'')') m, m + line(len_trim(line)+1:) = ' * vmr(:,k,' + end if + case( 'WRF' ) + line(7:) = 'group_vmrs(:,' + write(line(len_trim(line)+1:),*) m + line(len_trim(line)+1:) = ') = group_ratios(:,' + write(line(len_trim(line)+1:),*) m + line(len_trim(line)+1:) = ') * vmr(:,' + end select + write(line(len_trim(line)+1:),'(i2,'')'')') mem2grp_map(m) + write(30,100) trim(line) + end do + if( model /= 'WRF' ) then + line = ' ' + line(7:) = 'end do' + write(30,100) trim(line) + end if + end if + line = ' ' + write(30,100) trim(line) + line(7:) = 'end subroutine mak_grp_vmr' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'end module mo_make_grp_vmr' + write(30,100) trim(line) + +100 format(a) + + end subroutine mak_grp_vmr diff --git a/chem_proc/src/cam_chempp/make_lu_fac.f b/chem_proc/src/cam_chempp/make_lu_fac.f new file mode 100644 index 0000000000..3817d022b8 --- /dev/null +++ b/chem_proc/src/cam_chempp/make_lu_fac.f @@ -0,0 +1,410 @@ + + module lu_factor + + use io, only : temp_path + + implicit none + + character(len=4) :: hdr, up_hdr + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + + contains + + subroutine make_lu_fac( n, class, lu_sp_pat, mat_sp_pat, sp_map, & + march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran code for the sparse matrix decomposition +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: n ! species in class count + integer, intent(in) :: class ! class number + integer, intent(in) :: sp_map(n,n) ! sparsity matrix map + character(len=16), intent(in) :: march ! target architecture + character(len=16), intent(in) :: model ! target model + logical, intent(in), dimension(n,n) :: lu_sp_pat, mat_sp_pat + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_lines = 50 + integer :: i, ip1, j, k, l, row, col, sub_cnt + integer :: indx, pos, line_cnt + character(len=90) :: code + character(len=72) :: comment, blank, buff + character(len= 6) :: mat_piece + character(len= 4) :: num + logical :: lexist + logical :: sp_pat(n,n) + +!----------------------------------------------------------------------- +! ... Create and open code file; if it exists remove first +!----------------------------------------------------------------------- + line_cnt = 0 + if( class == 4 ) then + inquire( file = trim( temp_path ) // 'lu_fac.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'lu_fac.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'lu_fac.F' ) + if( model /= 'CAM' ) then + hdr = 'imp_' + up_hdr = 'imp_' + else + hdr = ' ' + up_hdr = ' ' + end if + else + open( unit = 30, file = trim( temp_path ) // 'lu_fac.F', position='append' ) + hdr = 'rod_' + up_hdr = 'rod_' + end if + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + if( n == 0 ) then + sub_cnt = 0 + else + sub_cnt = 1 + end if + code = ' ' + write(30,100) trim(code) + if( model == 'MOZART' ) then + if( class == 4 ) then + code = ' module mo_imp_factor' + else if( class == 5 ) then + code = ' module mo_rod_factor' + end if + else if( model == 'CAM' ) then + if( class == 4 ) then + code = ' module mo_lu_factor' + end if + else if( model == 'WRF' ) then + if( class == 4 ) then + code = ' module mo_imp_factor' + end if + end if + write(30,100) trim(code) + code = ' ' + write(30,100) trim(code) + if (march=='VECTOR') then + code = ' use chem_mods, only: veclen' + write(30,100) trim(code) + endif + code = ' private' + write(30,100) trim(code) + code = ' public :: lu_fac' + write(30,100) trim(code) + code = ' ' + write(30,100) trim(code) + code = ' contains' + write(30,100) trim(code) + call make_lu_fac_hdr( sub_cnt, march, model ) + + code = ' ' ; blank = ' ' + if( n > 0 ) then + sp_pat = mat_sp_pat + comment = '!------------------------------------------------------------------------' + select case( march ) + case( 'SCALAR' ) + mat_piece = 'lu(' + case default + mat_piece = 'lu(k,' + end select + end if + +Column_loop : & + do i = 1,n +!----------------------------------------------------------------------- +! ... Form diagonal inverse +!----------------------------------------------------------------------- + indx = sp_map(i,i) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + code(10:) = trim( mat_piece ) // num(:l) // ') = 1.' // trim(num_suffix) // ' / ' // trim( mat_piece ) // num(:l) // ')' + write(30,100) trim(code) + line_cnt = line_cnt + 1 + buff = ' * ' // trim( mat_piece ) // num(:l) // ')' + ip1 = i + 1 +!----------------------------------------------------------------------- +! ... Multiply column below diagonal +!----------------------------------------------------------------------- + do row = ip1,n + if( sp_pat(row,i) ) then + indx = sp_map(row,i) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + code(10:) = trim( mat_piece ) // num(:l) // ') = ' // trim( mat_piece ) // num(:l) // ')' & + // buff(:len_trim(buff)) + write(30,100) trim(code) + line_cnt = line_cnt + 1 + end if + end do +!----------------------------------------------------------------------- +! ... Modify sub-matrix +!----------------------------------------------------------------------- + do col = ip1,n + if( sp_pat(i,col) ) then + indx = sp_map(i,col) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + buff = ' * ' // trim( mat_piece ) // num(:l) // ')' + do row = ip1,n + if( sp_pat(row,i) ) then + indx = sp_map(row,col) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + if( sp_pat(row,col) ) then + code(10:) = trim( mat_piece ) // num(:l) // ') = ' // trim( mat_piece ) // num(:l) // ')' + indx = sp_map(row,i) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + code(len_trim(code)+2:) = '- ' // trim( mat_piece ) // num(:l) // ')' // buff(:len_trim(buff)) + write(30,100) trim(code) + code(6:) = ' ' + else + sp_pat(row,col) = .true. + code(10:) = trim( mat_piece ) // num(:l) // ') = ' + indx = sp_map(row,i) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + pos = index( code,'=' ) + 2 + code(pos:) = '- ' // trim( mat_piece ) // num(:l) // ')' // buff(:len_trim(buff)) + write(30,100) trim(code) + line_cnt = line_cnt + 1 + end if + end if + end do + end if + end do + write(30,100) blank + if( line_cnt > max_lines ) then + if( march /= 'SCALAR' ) then + code = ' end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_fac'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + line_cnt = 0 + if( i /= n ) then + sub_cnt = sub_cnt + 1 + call make_lu_fac_hdr( sub_cnt, march, model ) + end if + code = ' ' + end if + end do Column_loop + + if( line_cnt /= 0 ) then + if( march /= 'SCALAR' ) then + code(7:) = 'end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_fac'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + end if + + if( n > 0 ) then + call make_lu_fac_hdr( 0, march, model ) + end if + do k = 1,sub_cnt + write(num,'(i3)') 100+k + select case( march ) + case( 'SCALAR' ) + write(code,'('' call '',a,''lu_fac'',a,''( lu )'')') trim(up_hdr),num(2:3) + case( 'VECTOR' ) + write(code,'('' call '',a,''lu_fac'',a,''( avec_len, lu )'')') trim(up_hdr),num(2:3) + case default + if( model /= 'CAM' ) then + write(code,'('' call '',a,''lu_fac'',a,''( lu )'')') trim(up_hdr),num(2:3) + else + write(code,'('' call '',a,''lu_fac'',a,''( lu, cols )'')') trim(up_hdr),num(2:3) + end if + end select + write(30,100) trim(code) + end do + write(30,100) blank + code(7:) = 'end subroutine ' // trim(up_hdr) // 'lu_fac' + write(30,100) trim(code) + write(30,100) blank + + if( model == 'MOZART' ) then + if( class == 4 ) then + code = ' end module mo_imp_factor' + else if( class == 5 ) then + code = ' end module mo_rod_factor' + end if + else if( model == 'CAM' ) then + if( class == 4 ) then + code = ' end module mo_lu_factor' + end if + else if( model == 'WRF' ) then + if( class == 4 ) then + code = ' end module mo_imp_factor' + end if + end if + write(30,100) trim(code) + + close( 30 ) + +100 format(a) + + end subroutine make_lu_fac + + subroutine make_lu_fac_hdr( sub_cnt, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran header code for the sparse matrix decomposition +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: sub_cnt + character(len=16), intent(in) :: march + character(len=16), intent(in) :: model + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, ip1, j, k, l, row, col + integer :: indx, pos + character(len=72) :: code, comment, blank, buff + character(len=3) :: num + + code = ' ' ; blank = ' ' + comment = '!------------------------------------------------------------------------' + + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + select case( march ) + case( 'SCALAR' ) + if( sub_cnt /= 0 ) then + write(code,'('' subroutine '',a,''lu_fac'',a,''( lu )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_fac( lu )'')') trim(up_hdr) + end if + case( 'VECTOR' ) + if( sub_cnt /= 0 ) then + write(code,'('' subroutine '',a,''lu_fac'',a,''( avec_len, lu )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_fac( avec_len, lu )'')') trim(up_hdr) + end if + case default + if( sub_cnt /= 0 ) then + if( model /= 'CAM' ) then + write(code,'('' subroutine '',a,''lu_fac'',a,''( lu )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_fac'',a,''( lu, cols )'')') trim(up_hdr),num(2:3) + end if + else + if( model /= 'CAM' ) then + write(code,'('' subroutine '',a,''lu_fac( lu )'')') trim(up_hdr) + else + write(code,'('' subroutine '',a,''lu_fac( lu, cols )'')') trim(up_hdr) + end if + end if + end select + write(30,100) trim(code) + write(30,100) blank + if( march == 'SCALAR' ) then + code(:) = ' ' + else if( march == 'VECTOR' ) then + if( model /= 'CAM' ) then + code(7:) = 'use mo_grid, only : plnplv' + write(30,100) trim(code) + code(7:) = 'use chem_mods, only : ' // hdr // 'nzcnt' + else + code(7:) = 'use chem_mods, only : nzcnt' + end if + else + if( model /= 'WRF' ) then + code(7:) = 'use chem_mods, only : ' // hdr // 'nzcnt, clsze' + else + code(:) = ' ' + end if + end if + write(30,100) trim(code) + if( model == 'CAM' ) then + code(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(code) + end if + write(30,100) blank + code(7:) = 'implicit none ' + write(30,100) trim(code) + write(30,100) blank + write(30,100) comment + code = '! ... dummy args' + write(30,100) trim(code) + write(30,100) comment + code = ' ' + if( model == 'CAM' .and. march == 'CACHE' ) then + code(7:) = 'integer, intent(in) :: cols' + write(30,100) trim(code) + end if + select case( march ) + case( 'SCALAR' ) + code(7:) = 'real' // trim(dec_suffix) // ', intent(inout) :: lu(:)' + case( 'VECTOR' ) + code(7:) = 'integer, intent(in) :: avec_len' + write(30,100) trim(code) + if( model /= 'CAM' ) then + code(7:) = 'real' // trim(dec_suffix) // ', intent(inout) :: lu(plnplv,' // hdr // 'nzcnt)' + else + code(7:) = 'real' // trim(dec_suffix) // ', intent(inout) :: lu(veclen,nzcnt)' + end if + case default + code(7:) = 'real' // trim(dec_suffix) // ', intent(inout) :: lu(clsze,' // hdr // 'nzcnt)' + end select + write(30,100) trim(code) + write(30,100) blank + if( sub_cnt /= 0 ) then + if( march /= 'SCALAR' ) then + write(30,100) comment + code = '! ... local variables' + write(30,100) trim(code) + write(30,100) comment + code = ' ' + code(7:) = 'integer :: k' + write(30,100) trim(code) + write(30,100) blank + code = ' ' + if( march == 'VECTOR' ) then + code(7:) = 'do k = 1,avec_len' + else if( march == 'CACHE' ) then + if( model == 'MOZART' ) then + code(7:) = 'do k = 1,clsze' + else if( model == 'CAM' ) then + code(7:) = 'do k = 1,cols' + end if + end if + write(30,100) trim(code) + end if + end if + +100 format(a) + + end subroutine make_lu_fac_hdr + + end module lu_factor diff --git a/chem_proc/src/cam_chempp/make_lu_slv.f b/chem_proc/src/cam_chempp/make_lu_slv.f new file mode 100644 index 0000000000..e48efeb89b --- /dev/null +++ b/chem_proc/src/cam_chempp/make_lu_slv.f @@ -0,0 +1,475 @@ + + module lu_solve + + use io, only : temp_path + + implicit none + + character(len=4) :: hdr, up_hdr + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + + contains + + subroutine make_lu_slv( n, class, lu_sp_pat, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran code for the sparse matrix solver +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: n ! count of species in class + integer, intent(in) :: class ! class number + character(len=16), intent(in) :: march ! target architecture + character(len=16), intent(in) :: model ! target model + logical, intent(in), dimension(n,n) :: lu_sp_pat + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, ip1, j, k, l, row, col, sub_cnt + integer :: indx, pos, line_cnt + integer :: sp_map(n,n) + character(len=72) :: code, comment, blank, buff + character(len= 6) :: mat_piece + character(len= 4) :: b_piece + character(len= 4) :: num + logical :: lexist + +!----------------------------------------------------------------------- +! ... Create and open code file; if it exists remove first +!----------------------------------------------------------------------- + line_cnt = 0 + if( class == 4 ) then + inquire( file = trim( temp_path ) // 'lu_slv.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'lu_slv.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'lu_slv.F' ) + if( model /= 'CAM' ) then + hdr = 'imp_' + up_hdr = 'imp_' + else + hdr = ' ' + up_hdr = ' ' + end if + else + open( unit = 30, file = trim( temp_path ) // 'lu_slv.F', position='append' ) + hdr = 'rod_' + up_hdr = 'rod_' + end if + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + if( n == 0 ) then + sub_cnt = 0 + else + sub_cnt = 1 + end if + code = ' ' + write(30,100) trim(code) + if( model == 'MOZART' ) then + if( class == 4 ) then + code = ' module mo_imp_solve' + else if( class == 5 ) then + code = ' module mo_rod_solve' + end if + else if( model == 'CAM' ) then + if( class == 4 ) then + code = ' module mo_lu_solve' + end if + else if( model == 'WRF' ) then + if( class == 4 ) then + code = ' module mo_imp_solve' + end if + end if + write(30,100) trim(code) + code = ' ' + write(30,100) trim(code) + if (march=='VECTOR') then + code = ' use chem_mods, only: veclen' + write(30,100) trim(code) + endif + code = ' private' + write(30,100) trim(code) + code = ' public :: lu_slv' + write(30,100) trim(code) + code = ' ' + write(30,100) trim(code) + code = ' contains' + write(30,100) trim(code) + call make_lu_slv_hdr( n, class, sub_cnt, march, model ) + + code = ' ' ; blank = ' ' + if( n > 0 ) then +!----------------------------------------------------------------------- +! ... Form the lu matrix map +!----------------------------------------------------------------------- + k = 0 ; sp_map = 0 + do i = 1,n + do j = 1,n + if( lu_sp_pat(j,i) ) then + k = k + 1 + sp_map(j,i) = k + end if + end do + end do + + code = ' ' ; blank = ' ' + comment = '!------------------------------------------------------------------------' + + if( march == 'SCALAR' ) then + mat_piece = 'lu(' + b_piece = 'b(' + else + mat_piece = 'lu(k,' + b_piece = 'b(k,' + end if + end if + +!----------------------------------------------------------------------- +! ... Solve L * y = b +!----------------------------------------------------------------------- +Forward_loop : & + do col = 1,n-1 + write(num,'(i4)') col + num = adjustl( num ) + l = len_trim( num ) + buff = ' * ' // trim( b_piece ) // num(:l) // ')' + do row = col+1,n + if( lu_sp_pat(row,col) ) then + write(num,'(i4)') row + num = adjustl( num ) + l = len_trim( num ) + code(10:) = trim( b_piece ) // num(:l) // ') = ' // trim( b_piece ) // num(:l) // ')' + indx = sp_map(row,col) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + code(len_trim(code)+2:) = '- ' // trim( mat_piece ) // num(:l) // ')' // buff(:len_trim(buff)) + write(30,100) trim(code) + line_cnt = line_cnt + 1 + end if + end do + write(30,100) blank + if( line_cnt > 200 ) then + if( march /= 'SCALAR' ) then + code = ' end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_slv'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + line_cnt = 0 + sub_cnt = sub_cnt + 1 + call make_lu_slv_hdr( n, class, sub_cnt, march, model ) + code = ' ' + end if + end do Forward_loop + + if( line_cnt /= 0 ) then + if( march /= 'SCALAR' ) then + code = ' end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_slv'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + line_cnt = 0 + sub_cnt = sub_cnt + 1 + call make_lu_slv_hdr( n, class, sub_cnt, march, model ) + code = ' ' + end if + + if( n > 0 ) then + write(30,100) blank + write(30,100) comment + code = '! ... Solve U * x = y' + write(30,100) trim(code) + write(30,100) comment + code = ' ' + end if + +!----------------------------------------------------------------------- +! ... Solve U * x = y +!----------------------------------------------------------------------- +Backward_loop : & + do col = n,1,-1 + write(num,'(i4)') col + num = adjustl( num ) + l = len_trim( num ) + code(10:) = trim( b_piece) // num(:l) // ') = ' // trim( b_piece ) // num(:l) // ')' + buff = ' * ' // trim( b_piece ) // num(:l) // ')' + write(num,'(i4)') sp_map(col,col) + num = adjustl( num ) + l = len_trim( num ) + code(len_trim(code)+2:) = '* ' // trim( mat_piece ) // num(:l) // ')' + write(30,100) trim(code) + line_cnt = line_cnt + 1 + do row = col-1,1,-1 + if( lu_sp_pat(row,col) ) then + write(num,'(i4)') row + num = adjustl( num ) + l = len_trim( num ) + code(10:) = trim( b_piece ) // num(:l) // ') = ' // trim( b_piece ) // num(:l) // ')' + indx = sp_map(row,col) + write(num,'(i4)') indx + num = adjustl( num ) + l = len_trim( num ) + code(len_trim(code)+2:) = '- ' // trim( mat_piece ) // num(:l) // ')' // buff(:len_trim(buff)) + write(30,100) trim(code) + line_cnt = line_cnt + 1 + end if + end do + write(30,100) blank + if( line_cnt > 200 ) then + if( march /= 'SCALAR' ) then + code = ' end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_slv'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + line_cnt = 0 + if( col /= 1 ) then + sub_cnt = sub_cnt + 1 + call make_lu_slv_hdr( n, class, sub_cnt, march, model ) + end if + code = ' ' + end if + end do Backward_loop + + if( line_cnt /= 0 ) then + if( march /= 'SCALAR' ) then + code = ' end do' + write(30,100) trim(code) + end if + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + write(code,'('' end subroutine '',a,''lu_slv'',a)') trim(up_hdr),num(2:3) + write(30,100) trim(code) + end if + + if( n > 0 ) then + call make_lu_slv_hdr( n, class, 0, march, model ) + end if + + do k = 1,sub_cnt + write(num,'(i3)') 100+k + select case( march ) + case( 'SCALAR' ) + write(code,'('' call '',a,''lu_slv'',a,''( lu, b )'')') trim(up_hdr),num(2:3) + case( 'VECTOR' ) + write(code,'('' call '',a,''lu_slv'',a,''( avec_len, lu, b )'')') trim(up_hdr),num(2:3) + case default + if( model /= 'CAM' ) then + write(code,'('' call '',a,''lu_slv'',a,''( lu, b )'')') trim(up_hdr),num(2:3) + else + write(code,'('' call '',a,''lu_slv'',a,''( lu, b, cols )'')') trim(up_hdr),num(2:3) + end if + end select + write(30,100) trim(code) + end do + + write(30,100) blank + code(7:) = 'end subroutine ' // trim(up_hdr) // 'lu_slv' + write(30,100) trim(code) + write(30,100) blank + if( model == 'MOZART' ) then + if( class == 4 ) then + code = ' end module mo_imp_solve' + else if( class == 5 ) then + code = ' end module mo_rod_solve' + end if + else if( model == 'CAM' ) then + if( class == 4 ) then + code = ' end module mo_lu_solve' + end if + else if( model == 'WRF' ) then + if( class == 4 ) then + code = ' end module mo_imp_solve' + end if + end if + write(30,100) trim(code) + + close( 30 ) + +100 format(a) + + end subroutine make_lu_slv + + subroutine make_lu_slv_hdr( n, class, sub_cnt, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran header code for the sparse matrix solver +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: n, class + integer, intent(in) :: sub_cnt + character(len=16), intent(in) :: march + character(len=16), intent(in) :: model + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + character(len=3) :: num + character(len=72) :: code, comment, blank + + + code = ' ' ; blank = ' ' + comment = '!------------------------------------------------------------------------' + + write(30,100) blank + write(num,'(i3)') 100+sub_cnt + select case( march ) + case( 'SCALAR' ) + if( sub_cnt /= 0 ) then + write(code,'('' subroutine '',a,''lu_slv'',a,''( lu, b )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_slv( lu, b )'')') trim(up_hdr) + end if + case( 'VECTOR' ) + if( sub_cnt /= 0 ) then + write(code,'('' subroutine '',a,''lu_slv'',a,''( avec_len, lu, b )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_slv( avec_len, lu, b )'')') trim(up_hdr) + end if + case default + if( sub_cnt /= 0 ) then + if( model /= 'CAM' ) then + write(code,'('' subroutine '',a,''lu_slv'',a,''( lu, b )'')') trim(up_hdr),num(2:3) + else + write(code,'('' subroutine '',a,''lu_slv'',a,''( lu, b, cols )'')') trim(up_hdr),num(2:3) + end if + else + if( model /= 'CAM' ) then + write(code,'('' subroutine '',a,''lu_slv( lu, b )'')') trim(up_hdr) + else + write(code,'('' subroutine '',a,''lu_slv( lu, b, cols )'')') trim(up_hdr) + end if + end if + end select + write(30,100) trim(code) + write(30,100) blank + if( march == 'SCALAR' ) then + code(:) = ' ' + else if( march == 'VECTOR' ) then + if( model /= 'CAM' ) then + code(7:) = 'use mo_grid, only : plnplv' + write(30,100) trim(code) + write(code(7:),'(''use chem_mods, only : ' // hdr // 'nzcnt, clscnt'',i1)') class + else + code(:) = ' ' + end if + else + if( model /= 'WRF' ) then + write(code(7:),'(''use chem_mods, only : ' // hdr // 'nzcnt, clsze, clscnt'',i1)') class + else + code(:) = ' ' + end if + end if + write(30,100) trim(code) + if( model == 'CAM' ) then + code(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(code) + code(7:) = 'use chem_mods, only : clscnt4, nzcnt' + write(30,100) trim(code) + end if + write(30,100) blank + code(7:) = 'implicit none ' + write(30,100) trim(code) + write(30,100) blank + write(30,100) comment + code = '! ... Dummy args' + write(30,100) trim(code) + write(30,100) comment + code = ' ' + if( model == 'CAM' .and. march == 'CACHE' ) then + code(7:) = 'integer, intent(in) :: cols' + write(30,100) trim(code) + end if + code = ' ' + if( march == 'SCALAR' ) then + if( model /= 'CAM' ) then + code(7:) = 'real, intent(in) :: lu(:)' + else + code(7:) = 'real(r8), intent(in) :: lu(:)' + end if + else + if( march == 'VECTOR' ) then + code(7:) = 'integer, intent(in) :: avec_len' + write(30,100) trim(code) + if( model /= 'CAM' ) then + code(7:) = 'real, intent(in) :: lu(plnplv,' // hdr // 'nzcnt)' + else + code(7:) = 'real(r8), intent(in) :: lu(veclen,max(1,nzcnt))' + end if + else + code(7:) = 'real, intent(in) :: lu(clsze,' // hdr // 'nzcnt)' + end if + end if + write(30,100) trim(code) + write(num,'(i3)') n + num = adjustl( num ) + if( march == 'SCALAR' ) then + code(7:) = 'real' // trim(dec_suffix) // ', intent(inout) :: b(:)' + else if( march == 'VECTOR' ) then + if( model /= 'CAM' ) then + write(code(7:),'(''real' // trim(dec_suffix) // ', intent(inout) :: b(plnplv,clscnt'',i1,'')'')') class + else + write(code(7:),'(''real' // trim(dec_suffix) // ', intent(inout) :: b(veclen,clscnt4)'')'')') + end if + else + write(code(7:),'(''real' // trim(dec_suffix) // ', intent(inout) :: b(clsze,clscnt'',i1,'')'')') class + end if + write(30,100) trim(code) + write(30,100) blank + if( sub_cnt /= 0 ) then + write(30,100) comment + code = '! ... Local variables' + write(30,100) trim(code) + write(30,100) comment + code = ' ' + if( march /= 'SCALAR' ) then + code(7:) = 'integer :: k' + write(30,100) trim(code) + end if + write(30,100) blank + write(30,100) comment + code = '! ... solve L * y = b' + write(30,100) trim(code) + write(30,100) comment + if( march /= 'SCALAR' ) then + code = ' ' + if( march == 'VECTOR' ) then + code(7:) = 'do k = 1,avec_len' + else + if( model == 'MOZART' ) then + code(7:) = 'do k = 1,clsze' + else if( model == 'CAM' ) then + code(7:) = 'do k = 1,cols' + end if + end if + write(30,100) trim(code) + end if + end if + +100 format(a) + + end subroutine make_lu_slv_hdr + + end module lu_solve diff --git a/chem_proc/src/cam_chempp/make_map.f b/chem_proc/src/cam_chempp/make_map.f new file mode 100644 index 0000000000..0b84dfe4a5 --- /dev/null +++ b/chem_proc/src/cam_chempp/make_map.f @@ -0,0 +1,49 @@ + + module MO_MAKE_MAP + + CONTAINS + + subroutine MAKE_MAP( cls_rxt_map, & + cls_rxt_cnt, & + clsno, & + rxno, & + cls_prd_cnt, & + template ) + + use RXT_MOD, only : rxt_lim, prd_lim + + implicit none + +!------------------------------------------------------------------------ +! ... Dummy args +!------------------------------------------------------------------------ + integer, intent(in) :: clsno, rxno, cls_prd_cnt + integer, intent(in) :: template(:,:) + integer, intent(inout) :: cls_rxt_cnt + integer, intent(inout) :: cls_rxt_map(:) + +!------------------------------------------------------------------------ +! ... Local variables +!------------------------------------------------------------------------ + integer :: count + integer :: k, kp3 + + count = 0 + cls_rxt_cnt = cls_rxt_cnt + 1 + cls_rxt_map(1) = rxno + do k = 1,prd_lim + kp3 = k + 3 + if( template(k,2) == clsno ) then + count = count + 1 + cls_rxt_map(kp3) = template(k,3) + if( count == cls_prd_cnt ) then + exit + end if + else + cls_rxt_map(kp3) = -huge(0) + end if + end do + + end subroutine MAKE_MAP + + end module MO_MAKE_MAP diff --git a/chem_proc/src/cam_chempp/make_names.f b/chem_proc/src/cam_chempp/make_names.f new file mode 100644 index 0000000000..cd5ffeb094 --- /dev/null +++ b/chem_proc/src/cam_chempp/make_names.f @@ -0,0 +1,97 @@ + + subroutine make_name_mod +!-------------------------------------------------------------------------------- +! ... Makes a module of parameter species names +!-------------------------------------------------------------------------------- + + use var_mod, only : spc_cnt => new_nq, spc_names => new_solsym, & + grp_mem_cnt, grp_mem_names => grp_mem_sym + use io, only : temp_path + + implicit none + +!-------------------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------------------- + integer :: i, j + integer :: beg, end + character(len=80) :: buff + character(len=63) :: legal = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' & + // 'abcdefghijklmnopqrstuvwxyz' & + // '0123456789_' + character(len=16) :: name + logical :: lexist + + inquire( file = trim( temp_path ) // 'spc_names.mod', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'spc_names.mod' ) + end if + open( unit = 30, & + file = trim( temp_path ) // 'spc_names.mod' ) + + buff = ' ' + write(30,*) ' ' + buff(7:) = 'module m_spc_id' + write(30,'(a)') buff + write(30,*) ' ' + buff(7:) = 'implicit none' + write(30,'(a)') buff + buff = ' ' + write(30,*) ' ' + + do i = 1,spc_cnt + name = spc_names(i) + end = len_trim(name) + beg = 1 + do + j = VERIFY( name(beg:end), legal ) + if( j == 0 ) then + exit + end if + j = j + beg - 1 + if( j == end ) then + end = end - 1 + exit + end if + name(j:j) = '_' + if( j >= end ) then + exit + end if + beg = j + 1 + end do + write(buff(7:),'(''integer, parameter :: id_'',a,1x,''='',1x,i3)') & + name(:end), i + write(30,'(a)') buff(:len_trim(buff)) + end do + write(30,*) ' ' + do i = 1,grp_mem_cnt + name = grp_mem_names(i) + end = len_trim(name) + beg = 1 + do + j = VERIFY( name(beg:end), legal ) + if( j == 0 ) then + exit + end if + j = j + beg - 1 + if( j == end ) then + end = end - 1 + exit + end if + name(j:j) = '_' + if( j >= end ) then + exit + end if + beg = j + 1 + end do + write(buff(7:),'(''integer, parameter :: id_'',a,1x,''='',1x,i3)') & + name(:end), i + write(30,'(a)') buff(:len_trim(buff)) + end do + buff = ' ' + write(30,*) ' ' + buff(7:) = 'end module m_spc_id' + write(30,'(a)') buff + CLOSE(30) + + end subroutine MAKE_NAME_MOD diff --git a/chem_proc/src/cam_chempp/make_sim_dat.f b/chem_proc/src/cam_chempp/make_sim_dat.f new file mode 100644 index 0000000000..77a5bd7d83 --- /dev/null +++ b/chem_proc/src/cam_chempp/make_sim_dat.f @@ -0,0 +1,872 @@ + + subroutine make_sim_dat( model, march, sparse ) +!------------------------------------------------------------------- +! ... write the simulation data routine; only for CAM +!------------------------------------------------------------------- + + use io, only : temp_path + use sp_mods, only : sparsity + use var_mod, only : clscnt, clsmap, permute, new_nq, new_solsym + use var_mod, only : nq, newind, mass, c_mass, temp_mass + use var_mod, only : nfs, fixsym + use var_mod, only : nslvd, slvdsym + use rxt_mod, only : cls_rxt_cnt, rxntot + use rxt_mod, only : rxt_has_tag, rxt_tag + use rxt_mod, only : phtcnt, pht_alias, pht_alias_mult + use rxt_mod, only : usrcnt, usrmap, frc_from_dataset + use rxt_mod, only : cph_flg, enthalpy, num_rnts + + implicit none + +!------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------- + character(len=16), intent(in) :: model + character(len=16), intent(in) :: march + type(sparsity), intent(in) :: sparse(2) + +!------------------------------------------------------------------- +! ... local variables +!------------------------------------------------------------------- + integer, parameter :: max_len= 132 + + integer :: i, l, m, m1, n, n1 + integer :: lpos + integer :: lstrt + integer, allocatable :: ndx(:) + character(len=max_len) :: line + character(len=64) :: frmt + character(len=24) :: number + character(len=12) :: num12 + character(len=32) :: rxt_string + character(len=16) :: wrk_chr(5) + logical :: flush + logical :: lexist + integer :: numlen + integer :: enthalpy_cnt + integer :: begcnt, endcnt + + inquire( file = trim( temp_path ) // 'mo_sim_dat.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_sim_dat.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_sim_dat.F' ) + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_sim_dat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: set_sim_dat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'subroutine set_sim_dat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : clscnt, cls_rxt_cnt, clsmap, permute, adv_mass, fix_mass, crb_mass' + write(30,100) trim(line) + if( clscnt(4) > 0 ) then + line(7:) = 'use chem_mods, only : diag_map' + write(30,100) trim(line) + endif + line(7:) = 'use chem_mods, only : phtcnt, rxt_tag_cnt, rxt_tag_lst, rxt_tag_map' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : pht_alias_lst, pht_alias_mult' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : extfrc_lst, inv_lst, slvd_lst' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : enthalpy_cnt, cph_enthalpy, cph_rid, num_rnts, rxntot' + write(30,100) trim(line) + line(7:) = 'use cam_abortutils,only : endrun' + write(30,100) trim(line) + line(7:) = 'use mo_tracname, only : solsym' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : frc_from_dataset' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : is_scalar, is_vector' + write(30,100) trim(line) + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line(7:) = 'use cam_logfile, only : iulog' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!--------------------------------------------------------------' + write(30,100) trim(line) + line = ' integer :: ios' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) +!------------------------------------------------------------------- +! ... Scalar or vector code? +!------------------------------------------------------------------- + if( march == 'VECTOR' ) then + line = ' is_scalar = .false.' + write(30,'(a)') trim(line) + line = ' is_vector = .true.' + elseif( march == 'SCALAR' ) then + line = ' is_scalar = .true.' + write(30,'(a)') trim(line) + line = ' is_vector = .false.' + endif + write(30,'(a)') trim(line) + line = ' ' + write(30,100) trim(line) +!------------------------------------------------------------------- +! ... set the simulation chemical mechanism data +! class species count +!------------------------------------------------------------------- + line = ' clscnt(:) = (/' + write(line(len_trim(line)+2:),'(5(I6,a))') clscnt(1),',',clscnt(2),',',clscnt(3),',',clscnt(4),',',clscnt(5), ' /)' + write(30,'(a)') trim(line) + line = ' ' + write(30,100) trim(line) + +!------------------------------------------------------------------- +! ... class reaction count +!------------------------------------------------------------------- + do i = 1,5 + if( clscnt(i) > 0 ) then + line = ' cls_rxt_cnt(:,' + write(line(len_trim(line)+1:),'(i1,") = (/")') i + m = len_trim(line) + 2 + write(line(m:),'(4(I6,a))') cls_rxt_cnt(1,i),',',cls_rxt_cnt(2,i),',',cls_rxt_cnt(3,i),',',cls_rxt_cnt(4,i),' /)' + write(30,'(a)') trim(line) + end if + end do + +!------------------------------------------------------------------- +! ... species symbols +!------------------------------------------------------------------- + line = ' ' + write(30,100) trim(line) + write(line,'(" solsym(:",i3,") = (/")') new_nq + m = len_trim(line) + 2 + do n = 1,new_nq,5 + n1 = min( n+4,new_nq ) + if( n1 /= new_nq ) then + write(line(m:),'(5("''",a16,"'',")," &")') new_solsym(n:n1) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '("''",a16,"'',"),"''",a16,"'' /)")' + else + frmt = '("''",a16,"'' /)")' + end if + write(line(m:),trim(frmt)) new_solsym(n:n1) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + +!------------------------------------------------------------------- +! ... species mass +!------------------------------------------------------------------- + if( nq > 0 ) then + line = ' ' + write(30,100) trim(line) + temp_mass(:) = 0. + do n = 1,nq + if( newind(n) /= 0 ) then + temp_mass(newind(n)) = mass(n) + end if + end do + line = ' adv_mass(:' + write(line(len_trim(line)+1:),'(i3,") = (/")') new_nq + m = len_trim(line) + 2 + lstrt = m + do n = 1,new_nq + number = ' ' + if ( temp_mass(n) > 1. ) then + write(num12,'(f12.6)') temp_mass(n) + else + write(num12,'(g12.6)') temp_mass(n) + endif + numlen = len_trim(num12) + number(12-numlen+1:12) = num12(1:numlen) + lpos = scan( number, '0123456789', back=.true. ) + 1 + if( n < new_nq ) then + if( mod(n,5) /= 0 ) then + number(lpos:) = '_r8,' + flush = .false. + else + number(lpos:) = '_r8, &' + flush = .true. + end if + else + number(lpos:) = '_r8 /)' + flush = .true. + end if + line(m:) = trim( number ) + if( .not. flush ) then + m = len_trim(line) + 2 + else + write(30,'(a)') trim(line) + line = ' ' + m = lstrt + end if + end do + end if + +!------------------------------------------------------------------- +! ... species carbon mass +!------------------------------------------------------------------- + if( nq > 0 ) then + line = ' ' + write(30,100) trim(line) + temp_mass(:) = 0. + do n = 1,nq + if( newind(n) /= 0 ) then + temp_mass(newind(n)) = c_mass(n) + end if + end do + line = ' crb_mass(:' + write(line(len_trim(line)+1:),'(i3,") = (/")') new_nq + m = len_trim(line) + 2 + lstrt = m + do n = 1,new_nq + number = ' ' + write(num12,'(f12.6)') temp_mass(n) + numlen = len_trim(num12) + number(12-numlen+1:12) = num12(1:numlen) + lpos = scan( number, '0123456789', back=.true. ) + 1 + if( n < new_nq ) then + if( mod(n,5) /= 0 ) then + number(lpos:) = '_r8,' + flush = .false. + else + number(lpos:) = '_r8, &' + flush = .true. + end if + else + number(lpos:) = '_r8 /)' + flush = .true. + end if + line(m:) = trim( number ) + if( .not. flush ) then + m = len_trim(line) + 2 + else + write(30,'(a)') trim(line) + line = ' ' + m = lstrt + end if + end do + end if +!------------------------------------------------------------------- +! ... fixed species masses +!------------------------------------------------------------------- + if( nfs > 0 ) then + line = ' ' + write(30,100) trim(line) + line = ' fix_mass(:' + write(line(len_trim(line)+1:),'(i3,") = (/")') nfs + m = len_trim(line) + 2 + lstrt = m + do n = 1,nfs + number = ' ' + write(number,'(g15.9)') mass(n+new_nq) + number = adjustl( number ) + lpos = scan( number, '0123456789', back=.true. ) + 1 + if( n < nfs ) then + if( mod(n,5) /= 0 ) then + number(lpos:) = '_r8,' + flush = .false. + else + number(lpos:) = '_r8, &' + flush = .true. + end if + else + number(lpos:) = '_r8 /)' + flush = .true. + end if + line(m:) = trim( number ) + if( .not. flush ) then + m = len_trim(line) + 2 + else + write(30,'(a)') trim(line) + line = ' ' + m = lstrt + end if + end do + end if + +!------------------------------------------------------------------- +! ... class map +!------------------------------------------------------------------- + line = ' ' + write(30,100) trim(line) + do i = 1,5 + if( clscnt(i) > 0 ) then + write(line,'(" clsmap(:",i3,",",i1,") = (/")') clscnt(i),i + m = len_trim(line) + 2 + do n = 1,clscnt(i),10 + n1 = min( n+9,clscnt(i) ) + if( n1 /= clscnt(i) ) then + write(line(m:),'(10(i4,",")," &")') clsmap(n:n1,i,2) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '(i4,","),i4," /)")' + else + frmt = '(i4," /)")' + end if + write(line(m:),trim(frmt)) clsmap(n:n1,i,2) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + end if + end do + +!------------------------------------------------------------------- +! ... class permutation map +!------------------------------------------------------------------- + line = ' ' + write(30,100) trim(line) + do i = 2,5 + if( clscnt(i) > 0 ) then + write(line,'(" permute(:",i3,",",i1,") = (/")') clscnt(i),i + m = len_trim(line) + 2 + do n = 1,clscnt(i),10 + n1 = min( n+9,clscnt(i) ) + if( n1 /= clscnt(i) ) then + write(line(m:),'(10(i4,",")," &")') permute(n:n1,i) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '(i4,","),i4," /)")' + else + frmt = '(i4," /)")' + end if + write(line(m:),trim(frmt)) permute(n:n1,i) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + end if + end do + +!------------------------------------------------------------------- +! ... class diagonal indicies +!------------------------------------------------------------------- + line = ' ' + write(30,100) trim(line) + do i = 4,4 + if( clscnt(i) > 0 ) then + write(line,'(" diag_map(:",i3,") = (/")') clscnt(i) + m = len_trim(line) + 2 + do n = 1,clscnt(i),10 + n1 = min( n+9,clscnt(i) ) + if( n1 /= clscnt(i) ) then + write(line(m:),'(10(i4,",")," &")') sparse(i-3)%diag_map(n:n1) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '(i4,","),i4," /)")' + else + frmt = '(i4," /)")' + end if + write(line(m:),trim(frmt)) sparse(i-3)%diag_map(n:n1) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + end if + end do + +!----------------------------------------------------------------------- +! ... Write the ext frcing species +!----------------------------------------------------------------------- + if( usrcnt > 0 ) then + line = ' ' + write(30,100) trim(line) + write(line,'(" extfrc_lst(:",i3,") = (/")') usrcnt + m = len_trim(line) + 2 + do n = 1,usrcnt,5 + wrk_chr(:) = ' ' + n1 = min( n+4,usrcnt ) + do i = 1,n1-n+1 !!n,n1 + wrk_chr(i) = new_solsym(usrmap(i+n-1)) + end do + if( n1 /= usrcnt ) then + write(line(m:),'(5("''",a16,"'',")," &")') wrk_chr(1:n1-n+1) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '("''",a16,"'',"),"''",a16,"'' /)")' + else + frmt = '("''",a16,"'' /)")' + end if + write(line(m:),trim(frmt)) wrk_chr(1:n1-n+1) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + +!----------------------------------------------------------------------- +! frc_from_dataset +!----------------------------------------------------------------------- + line = ' ' + write(30,100) trim(line) + write(line,'(" frc_from_dataset(:",i3,") = (/")') usrcnt + m1 = len_trim(line) + 2 + do n = 1,usrcnt,5 + n1 = min( n+4,usrcnt ) + m = m1 + do l = n,n1 + if( l /= usrcnt ) then + if( l /= n1 ) then + if( frc_from_dataset(l) ) then + write(line(m:),'(".true.,")') + else + write(line(m:),'(".false.,")') + end if + else + if( frc_from_dataset(l) ) then + write(line(m:),'(".true., &")') + else + write(line(m:),'(".false., &")') + end if + end if + else + if( frc_from_dataset(l) ) then + write(line(m:),'(".true. /)")') + else + write(line(m:),'(".false. /)")') + end if + end if + m = len_trim(line) + 2 + end do + write(30,'(a)') trim(line) + line = ' ' + end do + end if + +!------------------------------------------------------------------- +! ... fixed species +!------------------------------------------------------------------- + if( nfs > 0 ) then + line = ' ' + write(30,100) trim(line) + write(line,'(" inv_lst(:",i3,") = (/")') nfs + m1 = len_trim(line) + 2 + do n = 1,nfs,5 + n1 = min( n+4,nfs ) + m = m1 + do l = n,n1 + if( l /= nfs ) then + if( l /= n1 ) then + write(line(m:),'("''",a16,"'',")') fixsym(l) + else + write(line(m:),'("''",a16,"'', &")') fixsym(l) + end if + else + write(line(m:),'("''",a16,"'' /)")') fixsym(l) + end if + m = len_trim(line) + 2 + end do + write(30,'(a)') trim(line) + line = ' ' + end do + end if + +!------------------------------------------------------------------- +! ... short lived species +!------------------------------------------------------------------- + if( nslvd > 0 ) then + line = ' ' + write(30,100) trim(line) + write(line,'(" slvd_lst(:",i3,") = (/")') nslvd + m1 = len_trim(line) + 2 + do n = 1,nslvd,5 + n1 = min( n+4,nslvd ) + m = m1 + do l = n,n1 + if( l /= nslvd ) then + if( l /= n1 ) then + write(line(m:),'("''",a16,"'',")') slvdsym(l) + else + write(line(m:),'("''",a16,"'', &")') slvdsym(l) + end if + else + write(line(m:),'("''",a16,"'' /)")') slvdsym(l) + end if + m = len_trim(line) + 2 + end do + write(30,'(a)') trim(line) + line = ' ' + end do + end if + +!------------------------------------------------------------------- +! ... reaction tags +!------------------------------------------------------------------- + i = count( rxt_has_tag(:rxntot) ) + if( i > 0 ) then + allocate( ndx(i) ) + l = 0 + do m = 1,rxntot + if( rxt_has_tag(m) ) then + l = l + 1 + ndx(l) = m + end if + end do + line = ' ' + write(30,100) trim(line) +!!$ write(line,'(" rxt_tag_cnt = ",i4)') i +!!$ write(30,100) trim(line) +!!$ line = ' ' + line(7:) = 'if( allocated( rxt_tag_lst ) ) then' + write(30,100) trim(line) + line(7:) = ' deallocate( rxt_tag_lst )' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line(7:) = 'allocate( rxt_tag_lst(rxt_tag_cnt),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate rxt_tag_lst; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line(7:) = 'if( allocated( rxt_tag_map ) ) then' + write(30,100) trim(line) + line(7:) = ' deallocate( rxt_tag_map )' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line(7:) = 'allocate( rxt_tag_map(rxt_tag_cnt),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate rxt_tag_map; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + + do begcnt = 1,i,200 + endcnt = min(begcnt+199,i) + write(line,'(a,i6,a,i6,a)') ' rxt_tag_lst(',begcnt,':',endcnt,') = (/ ' + m1 = len_trim(line) + 2 + do n = begcnt,endcnt,2 + n1 = min( n+1,endcnt ) + m = m1 + do l = n,n1 + rxt_string = rxt_tag(ndx(l)) + lpos = index( rxt_string, ',cph' ) + if( lpos > 0 ) then + rxt_string = trim( rxt_string(:lpos-1) ) + end if + if( l /= endcnt ) then + if( l /= n1 ) then + write(line(m:),'("''",a32,"'',")') rxt_string + else + write(line(m:),'("''",a32,"'', &")') rxt_string + end if + else + write(line(m:),'("''",a32,"'' /)")') rxt_string + end if + m = len_trim(line) + 2 + end do + write(30,'(a)') trim(line) + line = ' ' + end do + end do + + line = ' rxt_tag_map(:rxt_tag_cnt) = (/' + m = len_trim(line) + 2 + do n = 1,i,10 + n1 = min( n+9,i ) + if( n1 /= i ) then + write(line(m:),'(10(i4,",")," &")') ndx(n:n1) + else + if( n1 > n ) then + write(frmt,'("(",i1)') n1 - n + frmt(len_trim(frmt)+1:) = '(i4,","),i4," /)")' + else + frmt = '(i4," /)")' + end if + write(line(m:),trim(frmt)) ndx(n:n1) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + deallocate( ndx ) + end if + +!------------------------------------------------------------------- +! ... photoreactions alias +!------------------------------------------------------------------- + if( phtcnt > 0 ) then + line = ' ' + line(7:) = 'if( allocated( pht_alias_lst ) ) then' + write(30,100) trim(line) + line(7:) = ' deallocate( pht_alias_lst )' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line(7:) = 'allocate( pht_alias_lst(phtcnt,2),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate pht_alias_lst; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line = ' ' + line(7:) = 'if( allocated( pht_alias_mult ) ) then' + write(30,100) trim(line) + line(7:) = ' deallocate( pht_alias_mult )' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + line(7:) = 'allocate( pht_alias_mult(phtcnt,2),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate pht_alias_mult; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + do i = 1,2 + if( i == 1 ) then + line = ' pht_alias_lst(:,1) = (/ ' + else + line = ' pht_alias_lst(:,2) = (/ ' + end if + m1 = len_trim(line) + 2 + do n = 1,phtcnt,4 + n1 = min( n+3,phtcnt ) + m = m1 + do l = n,n1 + rxt_string = pht_alias(l,i) + if( l /= phtcnt ) then + if( l /= n1 ) then + write(line(m:),'("''",a16,"'',")') rxt_string + else + write(line(m:),'("''",a16,"'', &")') rxt_string + end if + else + write(line(m:),'("''",a16,"'' /)")') rxt_string + end if + m = len_trim(line) + 2 + end do + write(30,'(a)') trim(line) + line = ' ' + end do + end do + + do i = 1,2 + if( i == 1 ) then + line = ' pht_alias_mult(:,1) = (/ ' + else + line = ' pht_alias_mult(:,2) = (/ ' + end if + m = len_trim(line) + 2 + do n = 1,phtcnt + number = ' ' + write(number,'(a)') pht_alias_mult(n,i) + number = adjustl( number ) + lpos = scan( number, '0123456789', back=.true. ) + if( lpos == 1 ) then + lpos = lpos + 1 + number(lpos:lpos) = '.' + end if + lpos = lpos + 1 + if( n < phtcnt ) then + if( mod(n,5) /= 0 ) then + number(lpos:) = '_r8,' + flush = .false. + else + number(lpos:) = '_r8, &' + flush = .true. + end if + else + number(lpos:) = '_r8 /)' + flush = .true. + end if + line(m:) = trim( number ) + if( .not. flush ) then + m = len_trim(line) + 2 + else + write(30,'(a)') trim(line) + line = ' ' + m = lstrt + end if + end do + end do + end if + +!------------------------------------------------------------------- +! ... Enthalpy / Chem potential heating +!------------------------------------------------------------------- + enthalpy_cnt = count( cph_flg ) + + i = enthalpy_cnt + has_cph: if (i>0) then + + allocate( ndx(i) ) + l = 0 + do m = 1,rxntot + if( cph_flg(m) ) then + l = l + 1 + ndx(l) = m + end if + end do + line = ' ' + + line(7:) = 'allocate( cph_enthalpy(enthalpy_cnt),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate cph_enthalpy; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + + + line(7:) = 'allocate( cph_rid(enthalpy_cnt),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate cph_rid; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + + + line = ' cph_rid(:) = (/' + m = len_trim(line) + 2 + do n = 1,i,5 + n1 = min( n+4,i ) + if( n1 /= i ) then + write(line(m:),'(5(i15,",")," &")') ndx(n:n1) + else + if( n1 > n ) then + write(frmt,'("(",i2)') n1 - n + frmt(len_trim(frmt)+1:) = '(i15,","),i15," /)")' + else + frmt = '(i15," /)")' + end if + write(line(m:),trim(frmt)) ndx(n:n1) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + + + line = ' cph_enthalpy(:) = (/' + m = len_trim(line) + 2 + do n = 1,i,5 + n1 = min( n+4,i ) + if( n1 /= i ) then + write(line(m:),'(5(f12.6,"_r8,")," &")') enthalpy(ndx(n:n1)) + else + if( n1 > n ) then + write(frmt,'("(",i2)') n1 - n + frmt(len_trim(frmt)+1:) = '(f12.6,"_r8,"),f12.6,"_r8 /)")' + else + frmt = '(f12.6,"_r8 /)")' + end if + write(line(m:),trim(frmt)) enthalpy(ndx(n:n1)) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + + deallocate( ndx ) + endif has_cph + +!------------------------------------------------------------------- +! ... List number of reactants +!------------------------------------------------------------------- + + + i = rxntot-phtcnt + numrnts: if (i>0) then + + line = ' ' + + line(7:) = 'allocate( num_rnts(rxntot-phtcnt),stat=ios )' + write(30,100) trim(line) + line(7:) = 'if( ios /= 0 ) then' + write(30,100) trim(line) + line = ' ' + line(10:) = 'write(iulog,*) ''set_sim_dat: failed to allocate num_rnts; error = '',ios' + write(30,100) trim(line) + line(10:) = 'call endrun' + write(30,100) trim(line) + line(7:) = 'end if' + write(30,100) trim(line) + + + line = ' num_rnts(:) = (/' + m = len_trim(line) + 2 + do n = 1,i,10 + n1 = min( n+9, i ) + if( n1 /= i ) then + write(line(m:),'(10(i6,",")," &")') num_rnts(n+phtcnt:n1+phtcnt) + else + if( n1 > n ) then + write(frmt,'("(",i2)') n1 - n + frmt(len_trim(frmt)+1:) = '(i6,","),i6," /)")' + else + frmt = '(i6," /)")' + end if + write(line(m:),trim(frmt)) num_rnts(n+phtcnt:n1+phtcnt) + end if + write(30,'(a)') trim(line) + line = ' ' + end do + + endif numrnts + + line = ' ' + write(30,100) trim(line) + line(7:) = 'end subroutine set_sim_dat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'end module mo_sim_dat' + write(30,100) trim(line) + +100 format(a) + + close( unit = 30 ) + end subroutine make_sim_dat diff --git a/chem_proc/src/cam_chempp/mass_diags.f b/chem_proc/src/cam_chempp/mass_diags.f new file mode 100644 index 0000000000..1dbde63b10 --- /dev/null +++ b/chem_proc/src/cam_chempp/mass_diags.f @@ -0,0 +1,299 @@ + + module MASS_DIAGS +!-------------------------------------------------------------------- +! ... General purpose mozart2 diagnostic module +!-------------------------------------------------------------------- + + implicit none + + integer, parameter :: max_diags = 100 + + type CONSERVATION + integer, dimension(2) :: long_ind, lat_ind, lev_ind + real, dimension(2) :: longitudes, latitudes, levels + character(len=16) :: species + end type CONSERVATION + + integer :: ndiags = 0 + type(CONSERVATION) :: mdiags(max_diags) + real :: bigneg + + CONTAINS + + subroutine INIDIAGS( name, plon, plev, plat ) +!-------------------------------------------------------------------- +! ... Initialize the diagnostic variables +!-------------------------------------------------------------------- + + implicit none + +!-------------------------------------------------------------------- +! ... Dummy args +!-------------------------------------------------------------------- + integer, intent(in) :: plon, plev, plat + character(len=16), intent(in) :: name + + if( ndiags >= max_diags ) then + write(*,*) ' INIDIAGS: Exceeded diagnostic limit' + stop + end if + ndiags = ndiags + 1 + mdiags(ndiags)%species = name + mdiags(ndiags)%long_ind = (/ 1,plon /) + mdiags(ndiags)%lat_ind = (/ 1,plat /) + mdiags(ndiags)%lev_ind = (/ 1,plev /) + bigneg = -HUGE( bigneg ) + mdiags(ndiags)%longitudes = bigneg + mdiags(ndiags)%latitudes = bigneg + mdiags(ndiags)%levels = bigneg + + end subroutine INIDIAGS + + subroutine MASS_DIAGNOSTICS( spcsym, spccnt, plon, plev, plat ) +!-------------------------------------------------------------------- +! ... Process the mass diagnostics +!-------------------------------------------------------------------- + + use IO + + implicit none + +!-------------------------------------------------------------------- +! ... Dummy args +!-------------------------------------------------------------------- + integer, intent(in) :: plon, plev, plat + integer, intent(in) :: spccnt(:) + character(len=16), intent(in) :: spcsym(:,:) + +!-------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------- + integer, parameter :: symlen = 8 + integer, parameter :: numlen = 16 + integer :: tail, head + integer :: retcod, nchar + integer :: tokcnt, m, sep + integer :: toklen(20) + integer :: iind(2) + real :: rind(2) + character(len=numlen) :: tokens(20) + character(len=symlen) :: tstring + logical :: do_tokens, do_grid + + do_tokens = .true. + do_grid = .false. + tokcnt = 0 + head = 0 + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == 'ENDMASS_DIAGNOSTICS' ) then + return + end if + if( do_tokens ) then + call GETTOKENS( buff, & + nchar, & + ',', & + symlen, & + tokens, & + toklen, & + 20, & + tokcnt ) + if( tokcnt == 0 ) then + call ERRMES( 'Diagnostic spieces list error@', & + lout, & + buff, & + 1, & + buff ) + end if + tstring = tokens(1) + call UPCASE( tstring ) + if( tokcnt == 1 .and. tstring == 'ALL' ) then + do m = 1,spccnt(6) + call INIDIAGS( spcsym(m,6), plon, plev, plat ) + end do + else + do m = 1,tokcnt + call INIDIAGS( tokens(m), plon, plev, plat ) + end do + end if + do_grid = .true. + do_tokens = .false. + tail = head + 1 + head = ndiags + cycle + else if( do_grid ) then + if( buffh /= 'GRID' ) then + call ERRMES( '"GRID" keyword missing@', & + lout, & + buff, & + 1, & + buff ) + end if + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == 'ENDLST' ) then + do_grid = .false. + do_tokens = .true. + exit + end if + sep = INDEX( buffh, '=' ) + if( sep == 0 .or. sep == nchar ) then + call ERRMES( 'Grid keyword missing "=" separator@', & + lout, & + buff, & + 1, & + buff ) + end if + call GETTOKENS( buff(sep+1:), & + nchar-sep, & + ',', & + numlen, & + tokens, & + toklen, & + 20, & + tokcnt ) + if( tokcnt == 0 ) then + call ERRMES( 'Grid value format invalid@', & + lout, & + buff, & + 1, & + buff ) + end if + tokcnt = MIN(tokcnt,2) + select case( buffh(:sep-1) ) + case( 'LONGITUDES', 'LATITUDES', 'LEVELS' ) + do m = 1,tokcnt + call RELCON( tokens(m), & + toklen(m), & + rind(m), & + retcod ) + if( retcod /= 0 ) then + call ERRMES( '# is an invalid real number@', & + lout, & + tokens(m), & + toklen(m), & + buff ) + end if + end do + select case( buffh(:sep-1) ) + case( 'LONGITUDES' ) + do m = tail,head + mdiags(m)%longitudes(:tokcnt) = rind(:tokcnt) + end do + case( 'LATITUDES' ) + do m = tail,head + mdiags(m)%latitudes(:tokcnt) = rind(:tokcnt) + end do + case( 'LEVELS' ) + do m = tail,head + mdiags(m)%levels(:tokcnt) = rind(:tokcnt) + end do + end select + case( 'LONG_INDEX', 'LAT_INDEX', 'LEV_INDEX' ) + do m = 1,tokcnt + call INTCON( tokens(m), & + toklen(m), & + iind(m), & + retcod ) + if( retcod /= 0 ) then + call ERRMES( ' # is an invalid integer@', & + lout, & + tokens(m), & + toklen(m), & + buff ) + end if + end do + select case( buffh(:sep-1) ) + case( 'LONG_INDEX' ) + do m = tail,head + mdiags(m)%long_ind(:tokcnt) = iind(:tokcnt) + end do + case( 'LAT_INDEX' ) + do m = tail,head + mdiags(m)%lat_ind(:tokcnt) = iind(:tokcnt) + end do + case( 'LEV_INDEX' ) + do m = tail,head + mdiags(m)%lev_ind(:tokcnt) = iind(:tokcnt) + end do + end select + case default + call ERRMES( 'Grid keyword invalid@', & + lout, & + buff, & + 1, & + buff ) + end select + end do + end if + end do + call CHECK_RANGE() + + end subroutine MASS_DIAGNOSTICS + + subroutine CHECK_RANGE( ) +!-------------------------------------------------------------------- +! ... Check spatial domain ranges +!-------------------------------------------------------------------- + + implicit none + +!-------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------- + integer :: k, m + real :: value + real, parameter :: eps = 1.e-5 + + do m = 1,ndiags + do k = 1,2 + value = mdiags(m)%longitudes(k) + if( value /= bigneg ) then + if( value < 0. ) then + value = MOD( value,360. ) + 360. + else + value = MOD( value+eps,360. ) + end if + mdiags(m)%longitudes(k) = value + end if + value = mdiags(m)%latitudes(k) + if( value /= bigneg ) then + if( ABS( value) > 90. ) then + value = SIGN( 90.-eps,value ) + end if + mdiags(m)%latitudes(k) = value + end if + end do + end do + + end subroutine CHECK_RANGE + + subroutine MASS_DIAGS_SERIALIZE( unit ) +!-------------------------------------------------------------------- +! ... Write conservation info to output file +!-------------------------------------------------------------------- + + implicit none + +!-------------------------------------------------------------------- +! ... Dummy args +!-------------------------------------------------------------------- + integer, intent(in) :: unit + +!-------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------- + integer :: m + + write(unit,'(i3)') ndiags + do m = 1,ndiags + write(unit,*) mdiags(m) + end do + + end subroutine MASS_DIAGS_SERIALIZE + + end module MASS_DIAGS diff --git a/chem_proc/src/cam_chempp/mozpp.main.f b/chem_proc/src/cam_chempp/mozpp.main.f new file mode 100644 index 0000000000..f9a2e4c649 --- /dev/null +++ b/chem_proc/src/cam_chempp/mozpp.main.f @@ -0,0 +1,2309 @@ + + program mozart_pp +!----------------------------------------------------------------------- +! ... Mozart chemistry pre-processor +!----------------------------------------------------------------------- + + use io + use elements + use mass_diags + use var_mod + use rxt_mod + use lin_matrix + use nln_matrix + use lu_factor + use lu_solve + use prod_loss + use ind_prod + use set_rxt_rates + use mo_spat_dims + use mo_ver_hdr + use mo_files_hdr + use mo_hist_out + use mo_chem, only : chem + use sp_mods, only : sparsity + use mo_ver_opts, only : ver_opts + use rxt_equations_mod + use rxt_mod, only : cph_flg + use utils + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, target :: nind(200) + integer, pointer, dimension(:) :: nbeg, nend + integer :: dimensions(6) = (/ 128, 64, 18, 1, 1, 32 /) + + integer :: plon, plonl, plat, plev ! spatial dimensions of simulation + integer :: jintmx, nxpt ! slt parameters for bounds and array "padding" + integer :: sub_cnt = 0 ! count of user subroutines + + integer :: class, clsndx + integer :: grp_rows, rel_rows +!----------------------------------------------------------------------- +! ... Iteration counts are as follows: +! (1) == "hov" iteration count +! (2) == "implicit" iteration count +! (3) == "implicit" jacobian update count( first count iterations) +!----------------------------------------------------------------------- + character(len=1), parameter :: on = 'y' + character(len=1), parameter :: off = 'n' + + integer :: iter_counts(4) = (/ 7, 4, 2, 5 /) + + character(len=320) :: lib_src(350) + character(len=320) :: chem_src(50) + character(len=320) :: filename(100) + character(len=320) :: filepath(100) + character(len=320) :: sub_names(100) + character(len=80) :: iout(100) + character(len=320) :: mod_names(100) + character(len=320) :: mod_paths(100) + character(len=320) :: mod_src(100) + character(len=64) :: histinp(4) + character(len=64) :: histout(6) + character(len=16) :: jobctl(8) + character(len=16) :: wrk_rxt(10) + character(len=10) :: clshdr(5) + character(len=16) :: wrk_chr(10) + character(len=580) :: command, cpp_command + character(len=256) :: errcom, filout, filin + character(len=64) :: oper_flpth + character(len=64) :: cpp_dir, cpp_opts + character(len=64) :: wrk_dir + character(len=64) :: tar_flnm + character(len=64) :: subfile + character(len=64) :: filenm + character(len=64) :: tmp_filenm + character(len=16) :: param + character(len=16) :: hostname + character(len=16) :: jobname + + character(len=16) :: machine = 'IBM' + character(len=16) :: march = 'SCALAR' + character(len=16) :: model = 'CAM' + character(len=16) :: arch_type = 'HYBRID' + character(len=16) :: char + character(len=4) :: ftunit = 'ft' + character(len=1) :: errflg + + integer, allocatable :: mask(:) + integer :: entry(11) + integer :: filelines(5) + integer :: dyn_hst_fld_cnt(2) ! multi and single level field count + integer :: ratind(2) + integer :: additions(2) + integer :: multiplications(2) + integer :: nzcnt(2) = 0 ! number of nonzero entries in lu + integer :: file_cnt, hst_file_cnt + integer :: nchar, k, noff, m, j, l, il, iu + integer :: i, indx, ntab, ios, astat + integer :: spcno, counter, rxno, col, retcod, length, place + integer :: fixrows, rxmrows, pcelrows, pceprows + integer :: cpucnt = 1 ! number of cpu's + + logical, target :: options(20) + logical, allocatable :: lin_mat_pat(:) + logical, pointer :: usemods + logical :: null_flag + logical :: found + logical :: lexist + logical :: vec_ftns = .false. ! vector functions + logical :: radj_flag + logical :: ohstflag ! output history tape flag + logical :: diagprnt = .false. ! chktrc or negtrc diagnostics printout + logical :: tavgprnt = .false. ! time averaged printout + logical :: longnames = .false. ! do not use long names + integer :: veclen = 0 ! vector length in vectorized solver + integer :: rxt_tag_cnt + integer :: enthalpy_cnt + character(len=32) :: rxt_rates_conv_file = 'mo_rxt_rates_conv.F90' + + type(SPARSITY) :: sparse(2) + +!---------------------------------------------------------------------------------- +! ... Function declarations +!---------------------------------------------------------------------------------- + integer :: LENOF + integer :: STRLEN + +!---------------------------------------------------------------------------------- +! ... The options array has the following mapping: +! +! (1) Chemistry (on/off) (2) Target machine == cray (yes/no) +! (3) Diffusion (on/off) (4) Convection (on/off) +! (5) Iter norms (on/off) (6) Conservation (on/off) +! (7) Source code (yes/no) (8) Submission files (yes/no) +! (9) Execution (yes/no) (10) SLT fixer (on/off) +! (11) Multitasking (yes/no) (12) Rxt rate lookup table (on/off) +! (13) Relative humidity (yes/no) (14) New compiler (yes/no) +! (15) Height field (yes/no ) (16) User "hook" (yes/no) +! (17) Use f90 modules (yes/no) (18) Make and use f90 names module (yes/no) +! (19 - 20) Unused +! +! Iter norms, Execution, and Rxt rate lookup default to off +!---------------------------------------------------------------------------------- + data options / 4*.true., .false., 3*.true., .false., 2*.true., 2*.false., .true., 6*.false. / + data clshdr / 'Explicit', 'Ebi', 'Hov', 'Implicit', 'Rodas' / + +!----------------------------------------------------------------------- +! ... Initialize pointers and data +!----------------------------------------------------------------------- + usemods => options(17) + nbeg => nind(1:100) + nend => nind(101:200) + jobctl(:) = ' ' + histout(:) = ' ' + histinp(:) = ' ' + histinp(4) = 'LONG' + wrk_dir = '$TMPDIR' + subfile = ' ' + entry(:) = 0 + filelines(:) = 0 + src_dir = '../bkend/' + +!----------------------------------------------------------------------- +! ... Set default filenames/paths +!----------------------------------------------------------------------- + output_path = '../output/' + input_path = '../input/' + temp_path = '../tmp/' + sim_dat_path = output_path + procout_path = output_path + procfiles_path = '../procfiles/' + sim_dat_filename = 'sim.dat' + sim_dat_filespec = trim(sim_dat_path) // 'sim.dat' + cpp_dir = ' ' + cpp_opts = '-nostdinc -P -C -I.' + +!----------------------------------------------------------------------- +! ... Assign default input, output units +!----------------------------------------------------------------------- + lin = 5 + lout = 6 + +!----------------------------------------------------------------------- +! ... Get arguments +!----------------------------------------------------------------------- + filin = ' ' + filout = ' ' + call getarg( 1, filin ) + call getarg( 2, filout ) + +!----------------------------------------------------------------------- +! ... No input filespec on command line; request input +!----------------------------------------------------------------------- + if( filin == ' ' ) then + write(*,'('' Enter filespec of input file'')') + read(*,'(a80)') filin + if( filin == ' ' ) then + filin = './mozart2.inp' + end if + end if + open( unit = 5, & + file = trim( filin ), & + status = 'old', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file ',trim( filin ) + write(*,*) ' Error code = ',ios + stop + end if + + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + +!----------------------------------------------------------------------- +! ... Check for input overide and process if present +! if input unit 5 is overriden take +! all simulation input from lin +!----------------------------------------------------------------------- + if( buffh(:18) == 'INPUT_UNIT_NUMBER=' ) then + errflg = on + call intcon( buff(19:nchar), & + nchar - 18, & + lin, & + retcod ) + if( retcod /= 0 ) then + errcom = buff(19:nchar) // ' is an invalid unit number@' + else + if( lin <= 0 ) then + errcom = buff(19:nchar) // ' is an invalid unit number@' + else if( lin <= 3 ) then + errcom = buff(19:nchar) // ' is a reserved unit number@' + else if( lin == 6 ) then + errcom = buff(19:nchar) // ' is a reserved unit number@' + else if( lin >= 100 ) then + errcom = buff(19:nchar) // ' is an invalid unit number@' + else + errflg = off + end if + end if + + if( errflg == on ) then + call errmes( errcom, 6, param, 8, buff ) + end if + +!----------------------------------------------------------------------- +! ... Check for input file override and process if present +!----------------------------------------------------------------------- + call cardin ( 5, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh(:15) == 'INPUT_FILESPEC=' ) then + filin = buff(16:nchar) + if( lin <= 10 ) then + write (ftunit(3:4),'(''0'',i1)') lin + else + write (ftunit(3:4),'(i2)') lin + end if + close( unit = 5 ) + open( unit = lin, & + file = trim( filin ), & + status = 'old', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file ',trim( filin ) + write(*,*) ' Error code = ',ios + stop + end if + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + else + call errmes( ' ** Input reassignment requires both a unit number and filename@', & + lout, & + param, & + 8, & + buff ) + end if + end if + +!----------------------------------------------------------------------- +! ... Check for simulation start card (begsim) +!----------------------------------------------------------------------- + if( buffh /= 'BEGSIM' ) then + call errmes ( ' ** first card not begsim **@', & + lout, & + param, & + 8, & + buff ) + end if + + call cardin ( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + +!----------------------------------------------------------------------- +! ... Check for doc file overide and process if present +!----------------------------------------------------------------------- + if( buffh(:19) == 'OUTPUT_UNIT_NUMBER=' ) then + errflg = on + call intcon( buff(20:nchar), & + nchar - 19, & + lout, & + retcod ) + if( retcod /= 0 ) then + errcom = buff(20:nchar) // ' is an invalid unit number@' + else + if( lout <= 0 ) then + errcom = buff(20:nchar) // ' is an invalid unit number@' + else if( lout <= 3 ) then + errcom = buff(20:nchar) // ' is a reserved unit number@' + else if( lout == lin .or. lout == 6 ) then + errcom = buff(20:nchar) // ' is a reserved unit number@' + else if( lout >= 100 ) then + errcom = buff(20:nchar) // ' is an invalid unit number@' + else + errflg = off + end if + end if + +!----------------------------------------------------------------------- +! ... Error in assigning output unit number +!----------------------------------------------------------------------- + if( errflg == on ) then + call errmes ( errcom, 6, param, 8, buff ) + end if + +!----------------------------------------------------------------------- +! ... Set the output unit number +!----------------------------------------------------------------------- + if( lout <= 10 ) then + write (ftunit(3:4),'(''0'',i1)') lout + else + write (ftunit(3:4),'(i2)') lout + end if + + call cardin ( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + +!----------------------------------------------------------------------- +! ... get output_file +!----------------------------------------------------------------------- + if( buffh(:12) == 'OUTPUT_FILE=' ) then + filout = buff(13:nchar) + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + else + call errmes( ' ** Output reassignment requires both a unit number and filename@', & + lout, & + param, & + 8, & + buff ) + end if + else +!----------------------------------------------------------------------- +! ... Assign output unit +!----------------------------------------------------------------------- + if( filout == ' ' ) then + write(*,'('' Enter filename of output file'')') + read(*,'(a80)') filout + if( filout == ' ' ) then + filout = 'mozart2.doc' + end if + filout = trim(output_path) // trim( filout ) + end if + open( unit = lout, & + file = trim( filout ), & + status = 'new', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file ',trim(filout) + write(*,*) ' Error code = ',ios + stop + end if + end if + + do +!----------------------------------------------------------------------- +! ... Check for procout path override +!----------------------------------------------------------------------- + if( buffh(:13) == 'PROCOUT_PATH=' ) then + procout_path = buff(14:nchar) +!----------------------------------------------------------------------- +! ... Check for output path override +!----------------------------------------------------------------------- + else if( buffh(:15) == 'PROCFILES_PATH=' ) then + procfiles_path = buff(16:nchar) + else if( buffh(:12) == 'OUTPUT_PATH=' ) then + output_path = buff(13:nchar) +!----------------------------------------------------------------------- +! ... Check for tmp_path override +!----------------------------------------------------------------------- + else if( buffh(:10) == 'TEMP_PATH=' ) then + temp_path= buff(11:nchar) +!----------------------------------------------------------------------- +! ... Check for sim_dat_path override +!----------------------------------------------------------------------- + else if( buffh(:13) == 'SIM_DAT_PATH=' ) then + sim_dat_path = buff(14:nchar) +!----------------------------------------------------------------------- +! ... Check for src_path override +!----------------------------------------------------------------------- + else if( buffh(:9) == 'SRC_PATH=' ) then + src_dir = buff(10:nchar) +!----------------------------------------------------------------------- +! ... Check for sim_dat_filename override +!----------------------------------------------------------------------- + else if( buffh(:17) == 'SIM_DAT_FILENAME=' ) then + sim_dat_filename = buff(18:nchar) + sim_dat_filespec = trim( sim_dat_path ) // trim( sim_dat_filename ) + inquire( file = trim( sim_dat_filespec ), exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( sim_dat_filespec ) ) + end if + else + exit + end if + call cardin ( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + end do + +!----------------------------------------------------------------------- +! ... Find cpp preprocessor +!----------------------------------------------------------------------- + command = 'which cpp > ' // trim(temp_path) // 'cpp.path' + call system( trim( command ) ) + open( unit=20, file=trim(temp_path)//'cpp.path', iostat=ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to locate cpp path' + stop + end if + read(20,'(a)',iostat=ios) iout(1) + if( ios /= 0 ) then + write(*,*) ' Failed to read cpp path' + stop + end if + nend(1) = index( trim(iout(1)), 'cpp' ) + if( nend(1) > 0 ) then + cpp_dir = iout(1)(:nend(1)+2) + close( 20 ) + else + write(*,*) ' Failed to locate cpp path' + stop + end if + +!----------------------------------------------------------------------- +! ... Check for output file override and process if present +!----------------------------------------------------------------------- + filout = trim(output_path) // filout + open( unit = lout, & + file = trim( filout ), & + status = 'replace', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file ',trim(filout) + write(*,*) ' Error code = ',ios + stop + end if + +!----------------------------------------------------------------------- +! ... Check for comments and process if present +!----------------------------------------------------------------------- + if( trim(buffh) == 'COMMENTS' ) then + k = 1 + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( buffh == 'ENDCOMMENTS' ) then + exit + end if + iout(k) = buff + k = k + 1 + end do + + k = k - 1 + noff = 100 + + do m = 1,k + buff = iout(m) + do j = 1,80 + if( buff(j:j) /= ' ' ) then + exit + end if + end do + l = j + do j = 80,l,-1 + if( buff(j:j) /= ' ' ) then + nchar = j - l + 1 + nchar = 40 - nchar/2 + nbeg(m) = l + nend(m) = j + noff = MIN( nchar, noff ) + exit + end if + end do + end do + + do m = 1,k + buff = iout(m) + iout(m) = ' ' + il = nbeg(m) + if( il /= 0 ) then + iu = nend(m) + iout(m)(noff:) = buff(il:iu) + end if + end do + +!----------------------------------------------------------------------- +! ... Write out the comments +!----------------------------------------------------------------------- + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,1565) + write(lout,1571) + write(lout,1571) + write(lout,1567) (iout(m),m = 1,k) + write(lout,1571) + write(lout,1571) + write(lout,1565) + do m = 1,k + iout(m) = ' ' + end do + call cardin ( lin, & + buff, & + nchar ) + buffh = buff + call upcase( buffh ) + end if + +!----------------------------------------------------------------------- +! ... Clean the temp work directory +!----------------------------------------------------------------------- + call system( 'rm -f ' // trim( temp_path ) // '*' ) +!----------------------------------------------------------------------- +! ... Initialize the variables +!----------------------------------------------------------------------- + call var_ini +!----------------------------------------------------------------------- +! ... Initialize the reactions +!----------------------------------------------------------------------- + call rxt_ini +!----------------------------------------------------------------------- +! ... The species symbol list processing +!----------------------------------------------------------------------- + call symbol( iout ) + ntab = maxval( spccnt(1:5) ) + +!----------------------------------------------------------------------- +! ... Get variable mass +!----------------------------------------------------------------------- + call iniele + do i = 1,spccnt(1) + if( aliases(i) /= ' ' ) then + mass(i) = com_mass( aliases(i) ) + c_mass(i) = com_mass( aliases(i),carbmass=.true. ) + else + mass(i) = com_mass( solsym(i) ) + c_mass(i) = com_mass( solsym(i),carbmass=.true. ) + end if + end do + do i = spccnt(1)+1, spccnt(1)+spccnt(3) + if( aliases(i) /= ' ' ) then + mass(i) = com_mass( aliases(i) ) + c_mass(i) = com_mass( aliases(i),carbmass=.true. ) + else + mass(i) = com_mass( fixsym(i-spccnt(1)) ) + c_mass(i) = com_mass( fixsym(i-spccnt(1)),carbmass=.true. ) + end if + end do + +!----------------------------------------------------------------------- +! ... Form individual group members +!----------------------------------------------------------------------- + i = 0 + do l = 1,ngrp + do k = 1,grpcnt(l) + j = grpmap(k,l) + if( j <= 1999 ) then + j = j - 1000 + i = i + 1 + grp_mem_sym(i) = solsym(j) + end if + end do + end do + grp_mem_cnt = i + +!----------------------------------------------------------------------- +! ... Now begin group modification process by making +! new species numbering and group association tables +!----------------------------------------------------------------------- + counter = 0 + do i = 1,ngrp + do j = 1,grpcnt(i) + indx = mod( grpmap(j,i),1000 ) + grpflg(indx) = i + counter = counter + 1 + mem2grp_map(counter) = i + grp_rat_ind(indx) = counter + end do + new_solsym(i) = grpsym(i) + end do + + do i = 1,relcnt + indx = relmap(i,1) + rel_flg(indx) = i + end do + + indx = ngrp + do i = 1,nq + if( grpflg(i) /= 0 .or. rel_flg(i) /= 0 ) then + cycle + else + indx = indx + 1 + newind(i) = indx + new_solsym(indx) = solsym(i) + end if + end do + new_nq = indx + + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,230) + do j = 1,nq + if( aliases(j) == ' ' ) then + write(lout,231) j, solsym(j) + else + write(lout,'(6x,''('',i3,'')'',2x,a16,3x,''('',a,'')'')') j, solsym(j), trim( aliases(j) ) + end if + end do + if( relcnt /= 0 ) then + write(lout,235) + do j = 1,relcnt + length = STRLEN( solsym(relmap(j,1)) ) + buff = ' ' + write(buff,'(6x,''('',i2,'')'')') j + buff(STRLEN(buff)+2:) = solsym(relmap(j,1))(:length) // ' ~ ' // solsym(relmap(j,2)) + write(lout,'(a)') buff(:STRLEN(buff)) + end do + end if + if( nfs /= 0 ) then + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,232) + write(lout,231) (j, fixsym(j), j = 1,nfs) + end if + if( ncol /= 0 ) then + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,236) + write(lout,238) (j, colsym(j), colub(j), j = 1,ncol) + end if + if( ngrp /= 0 ) then + write(lout,*) ' ' + write(lout,*) ' ' + write (lout,237) + write (lout,'(2x,''('',i2,'')'',2x,a80)') ( j, iout(j), j = 1,ngrp ) + do j = 1,ngrp + iout(j) = ' ' + end do + end if + +!----------------------------------------------------------------------- +! ... Write out group modified species list +!----------------------------------------------------------------------- + if( ngrp /= 0 ) then + write(lout,*) ' ' + write(lout,*) ' ' + write(lout,*) 'Advected species' + write(lout,231) (j, new_solsym(j), j = 1,new_nq) + end if + +!----------------------------------------------------------------------- +! ... Define the solution classes +!----------------------------------------------------------------------- + call sol_cls( iout ) + +!----------------------------------------------------------------------- +! ... Write out class lists +!----------------------------------------------------------------------- + write(lout,*) ' ' + write(lout,'(''Class List'')') + write(lout,'(''=========='')') + do k = 1,5 + if( clscnt(k) /= 0 ) then + if( k > 1 ) then + write(lout,*) ' ' + end if + write(lout,'(1x,a10)') clshdr(k) + write(lout,'('' --------'')') + write(lout,231) (j, new_solsym(clsmap(j,k,2)), j = 1,clscnt(k) ) + end if + end do +!----------------------------------------------------------------------- +! End of the variable list processing +!------------------------------------------------------------------------ + +!======================================================================= +! ... Chemistry processing +!======================================================================= + call cardin( lin, buff, nchar ) + call upcase( buff ) + if( buff == 'CHEMISTRY' ) then +!----------------------------------------------------------------------- +! ... Set the reactions and rates +!----------------------------------------------------------------------- + call chem + options(1) = .true. + gascnt = rxntot - phtcnt + do i = 1,rxntot + if( rxt_tag(i) /= ' ' ) then + rxt_has_tag(i) = .true. + end if + end do + call cardin( lin, & + buff, & + nchar ) + call upcase( buff ) + else + options(1) = .false. + end if + +!----------------------------------------------------------------------- +! ... Transform the "hetero" reaction map +! The 1st column is the new species number +! if the species is a group member then the second column +! indicates the species number within the group ( the 1st col) +!----------------------------------------------------------------------- + do j = 1,hetcnt + spcno = hetmap(j,1) + if( grpflg(spcno) /= 0 ) then + hetmap(j,1) = grpflg(spcno) + hetmap(j,2) = grp_rat_ind(spcno) + else + hetmap(j,1) = newind(spcno) + hetmap(j,2) = 0 + end if + end do + +!----------------------------------------------------------------------- +! ... Then the "extraneous" reaction map +!----------------------------------------------------------------------- + do j = 1,usrcnt + spcno = usrmap(j) + if( grpflg(spcno) /= 0 ) then + usrmap(j) = grpflg(spcno) + else + usrmap(j) = newind(spcno) + end if + end do + +!======================================================================= +! ... The run parameters processing section +!======================================================================= + if( buff == 'ENDSIM' ) then + go to 292 + else if( buff == 'SIMULATIONPARAMETERS' ) then + do + call cardin( lin, & + buff, & + nchar ) + call upcase( buff ) + if( buff == 'SPATIALDIMENSIONS' ) then + if( entry(1) /= 0 ) then + call errmes( ' spatial dimensions already' & + // ' prescribed@', & + lout, & + char, & + 1, & + buff ) + else + entry(1) = 1 + call spat_dims( buff, dimensions ) + plon = dimensions(1) + plat = dimensions(2) + plev = dimensions(3) + nxpt = dimensions(4) + jintmx = dimensions(5) + plonl = dimensions(6) + end if + else if( buff == 'MASSDIAGNOSTICS' ) then + if( entry(11) /= 0 ) then + call errmes( ' Mass diagsnostics already prescribed@', & + lout, & + char, & + 1, & + buff ) + else if( entry(1) == 0 ) then + call errmes( ' Spatial dimensions must be done before mass diags@', & + lout, & + char, & + 1, & + buff ) + else + entry(11) = 1 + call mass_diagnostics( spcsym, & + spccnt, & + plon, plev, plat ) + end if + else if( buff == 'VERSIONOPTIONS' ) then + if( entry(2) /= 0 ) then + call errmes( ' Version options already prescribed@', & + lout, & + char, & + 1, & + buff ) + else + entry(2) = 1 + call ver_opts( options(2:), model, machine, march, arch_type, & + wrk_dir, cpp_dir, cpp_opts, subfile, diagprnt, & + tavgprnt, cpucnt, vec_ftns, veclen ) +!----------------------------------------------------------------------- +! ... Write out the species and reaction id files +!----------------------------------------------------------------------- + if( options(18) ) then + call make_name_mod + call make_rxt_name_mod + !call make_het_name_mod + end if + end if + else if( buff == 'EXECUTIONOPTIONS' ) then + if( entry(4) /= 0 ) then + call errmes( ' Exec options already prescribed@', & + lout, & + char, & + 1, & + buff ) + else + entry(4) = 1 + call exe_opts( options(8), & + lin, & + lout ) + end if + else if( buff == 'USERSUBROUTINES' ) then + if( entry(3) /= 0 ) then + call errmes( ' Subroutines already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(3) = 1 + call usrsubs( sub_names, & + sub_cnt ) +!----------------------------------------------------------------------- +! ... Parse user file pathnames +!----------------------------------------------------------------------- + if( sub_cnt /= 0 ) then + do i = 1,sub_cnt + call parse_flpth( sub_names(i), & + filename(i), & + filepath(i) ) + end do + do i = 1,sub_cnt + if( index( filename(i), '.mod', back = .true. ) /= 0 ) then + options(17) = .true. ! force fortran90 + usemods = .true. + exit + end if + end do + end if + end if + else if( buff == 'JOBCONTROL' ) then + if( entry(5) /= 0 ) then + call errmes( ' Job control already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(5) = 1 + call job_ctl( lin, & + lout, & + jobctl ) + end if + else if( buff == 'NUMERICALCONTROL' ) then + if( entry(10) /= 0 ) then + call errmes( ' Numerical control already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(10) = 1 + call num_ctl( iter_counts ) + end if + else if( buff == 'INPUTS' ) then + if( entry(6) /= 0 ) then + call errmes( ' Inputs already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(6) = 1 + call hist_inp( lin, & + lout, & + histinp, & + dyn_hst_fld_cnt ) + end if + else if( buff == 'OUTPUTS' ) then + if( entry(7) /= 0 ) then + call errmes( ' Outputs already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(6) = 1 + call hist_out( histout, longnames, hst_file_cnt ) + end if + else if( buff == 'SURFACEFLUX' ) then + if( entry(8) /= 0 ) then + call errmes( ' Surf flux already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(8) = 1 + call srfflx( lin, & + lout, & + new_nq, & + new_solsym, & + srf_flx_map, & + srf_flx_cnt, & + 1 ) + end if + else if( buff == 'SURFACEDEPOSITION' ) then + if( entry(9) /= 0 ) then + call errmes( ' Surf Dep already specified@', & + lout, & + char, & + 1, & + buff ) + else + entry(9) = 1 + call srfflx( lin, & + lout, & + new_nq, & + new_solsym, & + dvel_map, & + dvel_cnt, & + 2 ) + end if + else if( buff == 'ENDSIMULATIONPARAMETERS' ) then + exit + else if( buff /= 'ENDPAR' ) then + call errmes ( ' endsim card missing@', & + lout, & + char, & + 1, & + buff ) + end if + end do + else + call errmes ( ' endsim card missing@', & + lout, & + char, & + 1, & + buff ) + end if +292 continue + +Has_chemistry: & + if( options(1) ) then ! do only if there is chemistry +!======================================================================= +! ... Weed out the proportional products in all reaction maps +!======================================================================= + allocate( mask(max(7,prd_limp1)),stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the mask array; error = ',astat + stop 'abort' + end if +!----------------------------------------------------------------------- +! ... First the "independent" production map +!----------------------------------------------------------------------- + do j = 1,prdcnt + do k = 2,prd_limp1 + spcno = prdmap(j,k) + if( spcno == 0 ) then + mask(k) = -1 + exit + else if( rel_flg(spcno) == 0 ) then + mask(k) = 1 + else + mask(k) = 0 + end if + end do + place = 1 + do k = 2,prd_limp1 + if( mask(k) == -1 ) then + prdmap(j,place+1:prd_limp1) = 0 + exit + else if( mask(k) == 1 ) then + place = place + 1 + prdmap(j,place) = prdmap(j,k) + end if + end do + end do + +!----------------------------------------------------------------------- +! ... Then the "regular" reaction map +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + do k = i+2,i+prd_limp1 + spcno = rxmap(j,k,i) + if( spcno == 0 ) then + mask(k) = -1 + exit + else if( rel_flg(spcno) == 0 ) then + mask(k) = 1 + else + mask(k) = 0 + end if + end do + place = i + 1 + do k = i+2,i+prd_limp1 + if( mask(k) == -1 ) then + rxmap(j,place+1:i+prd_limp1,i) = 0 + exit + else if( mask(k) == 1 ) then + place = place + 1 + rxmap(j,place,i) = rxmap(j,k,i) + end if + end do + end do + end do + +!----------------------------------------------------------------------- +! ... Now xform all "proportional" reactants to proportional species +! NOTE! The proportional reactants are replaced by the NEGATIVE +! index of the species they are proportional to +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + counter = 0 + do k = 2,i+1 ! only do the reactants + spcno = rxmap(j,k,i) + if( rel_flg(spcno) /= 0 ) then + counter = counter + 1 + rxmap(j,k,i) = -relmap(rel_flg(spcno),2) + ratind(counter) = spcno + end if + end do + if( counter /= 0 ) then + rxno = rxmap(j,1,i) + rel_rxt_cnt(counter) = rel_rxt_cnt(counter) + 1 + indx = rel_rxt_cnt(counter) + rel_rxt_map(indx,1,counter) = rxno !the reaction number + do l = 1,counter + rel_rxt_map(indx,l+1,counter) = rel_flg(ratind(l)) + end do + rel_rxt_pntr(rxno,1) = counter + rel_rxt_pntr(rxno,2) = indx + end if + end do + end do + +!----------------------------------------------------------------------- +! Now do the actual reaction matrix transforms +! The first phase just does the basic x-form. +! The second phase scans resultant maps to "eliminate" +! matching product and reactant species in the +! same reaction. +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... First the "independent" production map +!----------------------------------------------------------------------- + do j = 1,prdcnt + do k = 2,prd_limp1 + spcno = prdmap(j,k) + if( spcno == 0 ) then + exit + else if( grpflg(spcno) /= 0 ) then + prdmap(j,k) = grpflg(spcno) + else + prdmap(j,k) = newind(spcno) + end if + end do + end do + +!----------------------------------------------------------------------- +! ... Then the "regular" reaction map +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + counter = 0 + do k = 2,i+prd_limp1 + spcno = abs( rxmap(j,k,i) ) + if( spcno == 0 ) then + exit + else if( grpflg(spcno) /= 0 ) then + rxmap(j,k,i) = SIGN( grpflg(spcno), rxmap(j,k,i) ) + if( i == 1 ) then + if( k == 2 ) then + counter = counter + 1 + ratind(counter) = spcno + end if + else + if( k <= 3 ) then + counter = counter + 1 + ratind(counter) = spcno + end if + end if + else + rxmap(j,k,i) = SIGN( newind(spcno), rxmap(j,k,i) ) + end if + end do + if( counter /= 0 ) then + rxno = rxmap(j,1,i) + grp_rat_cnt(counter) = grp_rat_cnt(counter) + 1 + indx = grp_rat_cnt(counter) + grp_rat_map(indx,1,counter) = rxno + do l = 1,counter + grp_rat_map(indx,l+1,counter) = grp_rat_ind(ratind(l)) + end do + rxt_to_grp_map(rxno,1) = counter + rxt_to_grp_map(rxno,2) = indx + end if + end do + end do + +!----------------------------------------------------------------------- +! Scan reaction matrix to eliminate equally weigthed reactants +! and products by setting the index = -index +!----------------------------------------------------------------------- + do i = 1,2 + do j = 1,rxmcnt(i) + do k = i+2,i+prd_limp1 + spcno = rxmap(j,k,i) + if( spcno == 0 ) then + exit + else + col = pcoeff_ind(rxmap(j,1,i)) + if( col /= 0 ) then + if( pcoeff(k-(i+1),col) /= 1. ) then + cycle + end if + end if + do l = 2,i+1 + if( spcno == rxmap(j,l,i) ) then + rxmap(j,l,i) = -rxmap(j,l,i) + rxmap(j,k,i) = -spcno + exit + end if + end do + end if + end do + end do + end do + +!----------------------------------------------------------------------- +! Scan reaction matrix to detect "null" reactions +! and eliminate such reactions from the following maps: +! 1. groups +! 2. relationships +! 3. reactions +!----------------------------------------------------------------------- + do i = 1,2 + place = 1 + do j = 1,rxmcnt(i) + null_flag = .true. ! assume a null reaction + do k = 2,i+prd_limp1 + if( rxmap(j,k,i) > 0 ) then + null_flag = .false. ! not a null reaction + exit + end if + end do + if( null_flag ) then ! remove from lists if null + rxno = rxmap(j,1,i) + rxt_to_grp_map(rxno,1:2) = 0 + rel_rxt_pntr(rxno,1:2) = 0 + else ! a non-null reaction; keep it + rxmap(place,1:i+prd_limp1,i) = rxmap(j,1:i+prd_limp1,i) + place = place + 1 + end if + end do + rxmcnt(i) = place - 1 + end do + +!----------------------------------------------------------------------- +! ... Form the solution class reaction maps +!----------------------------------------------------------------------- + call cls_maps + +!----------------------------------------------------------------------- +! ... Order class reaction map reactants for the nonlinear reactions +!----------------------------------------------------------------------- + do i = 1,5 + if( cls_rxt_cnt(3,i) /= 0 ) then + do k = sum( cls_rxt_cnt(1:2,i) )+1,sum( cls_rxt_cnt(1:3,i) ) + if( (abs(cls_rxt_map(k,2,i)) > abs(cls_rxt_map(k,3,i)) .and. & + cls_rxt_map(k,3,i) > 0 ) .or. cls_rxt_map(k,2,i) <= 0 ) then + m = cls_rxt_map(k,3,i) + cls_rxt_map(k,3,i) = cls_rxt_map(k,2,i) + cls_rxt_map(k,2,i) = m + end if + end do + end if + end do +!======================================================================= +! ... Call the code writing utilities +!======================================================================= +!----------------------------------------------------------------------- +! ... Force permutation for explicit method +!----------------------------------------------------------------------- + if( clscnt(1) /= 0 ) then + permute(:clscnt(1),1) = (/ (i,i=1,clscnt(1)) /) + end if +!----------------------------------------------------------------------- +! ... The iterated Euler backward and "Hov" methods +!----------------------------------------------------------------------- + do class = 2,3 + if( clscnt(class) /= 0 ) then + clsndx = class - 1 + allocate( sparse(clsndx)%mat_sp_pat(clscnt(class),clscnt(class)),stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the matrix sparsity pattern array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + allocate( sparse(clsndx)%lu_sp_pat(clscnt(class),clscnt(class)),stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the lu sparsity pattern array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + call sparsity_pat( clscnt(class), clsmap(1,class,2), cls_rxt_cnt(1,class), & + cls_rxt_map(1,1,class), sparse(clsndx)%mat_sp_pat ) + sparse(clsndx)%lu_sp_pat(:,:) = sparse(clsndx)%mat_sp_pat(:,:) + call diag_mark( clscnt(class), sparse(clsndx)%lu_sp_pat, permute(1,class) ) + permute_orig(:clscnt(class),class-1) = permute(:clscnt(class),class) + deallocate( sparse(clsndx)%mat_sp_pat ) + deallocate( sparse(clsndx)%lu_sp_pat ) + end if + end do +!----------------------------------------------------------------------- +! ... The sparse matrix backward Euler method +!----------------------------------------------------------------------- +sparse_matrix_loop : & + do class = 4,5 + k = max( 1,clscnt(class) ) + clsndx = class - 3 + allocate( sparse(clsndx)%mat_sp_pat(k,k), stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the matrix sparsity pattern array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + allocate( sparse(clsndx)%lu_sp_pat(k,k), stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the lu sparsity pattern array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + allocate( sparse(clsndx)%mat_sp_map(k,k), stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the matrix sparsity map array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + allocate( sparse(clsndx)%diag_map(k), stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the matrix diagonal map array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + if( clscnt(class) /= 0 ) then +!----------------------------------------------------------------------- +! ... Determine original jacobian sparsity +!----------------------------------------------------------------------- + call sparsity_pat( clscnt(class), & + clsmap(1,class,2), & + cls_rxt_cnt(1,class), & + cls_rxt_map(1,1,class), & + sparse(clsndx)%mat_sp_pat ) +! call draw_mat( clscnt(class), mat_sp_pat(1,1,class-3) ) + sparse(clsndx)%lu_sp_pat(:,:) = sparse(clsndx)%mat_sp_pat(:,:) +!----------------------------------------------------------------------- +! ... Reorder according to diagonal Markowitz +!----------------------------------------------------------------------- + call diag_mark( clscnt(class), sparse(clsndx)%lu_sp_pat, permute(1,class) ) +!----------------------------------------------------------------------- +! ... Permute the original sparsity pattern +!----------------------------------------------------------------------- + call perm_mat( clscnt(class), sparse(clsndx)%lu_sp_pat, permute(1,class) ) + sparse(clsndx)%mat_sp_pat(:,:) = sparse(clsndx)%lu_sp_pat(:,:) +! call draw_mat( clscnt(class), lu_sp_pat ) +!----------------------------------------------------------------------- +! ... Symbolic factorization; includes fillin +!----------------------------------------------------------------------- + call sym_fac( clscnt(class), sparse(clsndx)%lu_sp_pat, additions, multiplications ) +!----------------------------------------------------------------------- +! ... Make column oriented non-zero "map" +!----------------------------------------------------------------------- + nzcnt(class-3) = COUNT( sparse(clsndx)%lu_sp_pat(:,:) ) + sparse(clsndx)%mat_sp_map(:,:) = 0 + k = 0 + do j = 1,clscnt(class) + do i = 1,clscnt(class) + if( sparse(clsndx)%lu_sp_pat(i,j) ) then + k = k + 1 + sparse(clsndx)%mat_sp_map(i,j) = k + if( i == j ) then + sparse(clsndx)%diag_map(j) = k + end if + end if + end do + end do + end if +!----------------------------------------------------------------------- +! ... Write the factorization code +!----------------------------------------------------------------------- + if( class /= 5 .or. model == 'MOZART' ) then + call make_lu_fac( clscnt(class), class, sparse(clsndx)%lu_sp_pat, & + sparse(clsndx)%mat_sp_pat, sparse(clsndx)%mat_sp_map, march, model ) +!----------------------------------------------------------------------- +! ... Write the solver code +!----------------------------------------------------------------------- + call make_lu_slv( clscnt(class), class, sparse(clsndx)%lu_sp_pat, march, model ) + end if + if( associated( sparse(clsndx)%lu_sp_pat ) ) then + deallocate( sparse(clsndx)%lu_sp_pat ) + end if + end do sparse_matrix_loop +!----------------------------------------------------------------------- +! ... Make "from-to" permutation +!----------------------------------------------------------------------- + do class = 2,5 + do j = 1,clscnt(class) + do i = 1,clscnt(class) + if( permute(i,class) == j ) then + permutation(j) = i + end if + end do + end do + if( clscnt(class) /= 0 ) then + permute(:clscnt(class),class) = permutation(:clscnt(class)) + end if + end do +!----------------------------------------------------------------------- +! ... Make reaction scheme dependent prod & loss code +!----------------------------------------------------------------------- + call pl_code( new_nq, clscnt, clsmap, cls_rxt_cnt, cls_rxt_map, & + pcoeff_ind, pcoeff, permute, march, model ) + cls_ind_prdcnt = sum( cls_rxt_cnt(1,1:5) ) +!----------------------------------------------------------------------- +! ... Make reaction scheme independent prod & loss code +!----------------------------------------------------------------------- + call ipd_code( new_nq, clscnt, clsmap, cls_rxt_cnt, extcnt, & + cls_rxt_map, pcoeff_ind, pcoeff, permute, model, march ) +!----------------------------------------------------------------------- +! ... Make tabular reaction rates +!----------------------------------------------------------------------- + if( options(12) ) then + call make_rate_tab( rxparm, rxptab, rxpcnt ) + else + call make_rate( sym_rates, rxptab, rxpcnt, machine, vec_ftns, & + model, march ) + end if + if( rxmcnt(2) /= 0 .or. fixcnt(2) /= 0 ) then + radj_flag = .true. + else + radj_flag = .false. + do i = 1,fixcnt(1) + if( abs(fixmap(i,1,1)) > phtcnt ) then + radj_flag = .true. + end if + end do + end if +!----------------------------------------------------------------------- +! ... Make reaction rate adjustment routines +!----------------------------------------------------------------------- + call make_radj( fixmap, fixcnt, rxmap(1,1,2), rxmcnt(2), phtcnt, & + model, march ) + call make_padj( fixmap, fixcnt(1), phtcnt, model, march ) + call make_rmod( rel_rxt_pntr, rel_rxt_map, rxt_to_grp_map, grp_rat_map, hetmap(1,2), & + hetcnt, rxntot, model, march ) + do class = 4,5 + clsndx = class - 3 + allocate( lin_mat_pat(nzcnt(clsndx)), stat=astat ) + if( astat /= 0 ) then + write(lout,*) 'Failed to allocate the lin matrix map array' + write(lout,*) 'for class = ',class,' ; error = ',astat + stop 'abort' + end if + if( class /= 5 .or. model == 'MOZART' ) then + call make_lin( clscnt(class), clsmap, cls_rxt_cnt(1,class), cls_rxt_map(1,1,class), pcoeff_ind, & + pcoeff, permute(1,class), sparse(clsndx)%mat_sp_map, class, & + lin_mat_pat, march, model ) + call make_nln( clscnt(class), clsmap, cls_rxt_cnt(1,class), cls_rxt_map(1,1,class), pcoeff_ind, & + pcoeff, permute(1,class), sparse(clsndx)%mat_sp_map, class, & + lin_mat_pat, nzcnt(clsndx), sparse(clsndx)%diag_map, march, model ) + end if + if( associated( sparse(clsndx)%mat_sp_pat ) ) then + deallocate( sparse(clsndx)%mat_sp_pat ) + end if + if( allocated( lin_mat_pat ) ) then + deallocate( lin_mat_pat ) + end if + end do +!----------------------------------------------------------------------- +! ... Make group members vmr subroutine +!----------------------------------------------------------------------- + call mak_grp_vmr( grp_mem_cnt, mem2grp_map, model, march ) +!----------------------------------------------------------------------- +! ... Writeout the surface flux and depos vel info +!----------------------------------------------------------------------- + if( srf_flx_cnt /= 0 ) then + write(lout,*) ' ' + write(lout,'('' Species with non-zero surface emission'')') + do i = 1,srf_flx_cnt + write(lout,'(1x,''('',i2,'')'',3x,a8)') i, new_solsym(srf_flx_map(i)) + end do + end if + if( dvel_cnt /= 0 ) then + write(lout,*) ' ' + write(lout,'('' Species with non-zero dry deposition flux'')') + do i = 1,dvel_cnt + write(lout,'(1x,''('',i2,'')'',3x,a8)') i, new_solsym(dvel_map(i)) + end do + end if +!----------------------------------------------------------------------- +! ... Call the equation reporting utility +!----------------------------------------------------------------------- + call equation_rep( new_nq, new_solsym, nfs, fixsym, prdcnt, & + prdmap, rxntot, rxmcnt, rxmap, pcoeff_cnt, & + pcoeff_ind, pcoeff, fixcnt, fixmap, phtcnt ) + + call write_rxt_out_code ( & + rxmcnt, & + rxmap, & + fixmap, & + solsym, & + fixsym, & + prdcnt, & + prdmap, & + rxntot, & + phtcnt, & + rxt_rates_conv_file ) + + end if Has_chemistry + +!======================================================================= +! ... This is for the new CTM interface; the old driver +! data file can still be output for potential diagnostics +!======================================================================= + open( unit = 20, & + file = trim( sim_dat_filespec ), & + status = 'replace', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file '// trim( sim_dat_filespec ) + write(*,*) ' Error code = ',ios + stop + end if + if( model == 'MOZART' ) then + do class = 1,5 + if( class == 2 .or. class == 3 ) then + cycle + end if + if( clscnt(class) > 0 ) then + write(20,508) cls_rxt_cnt(:,class) + write(20,522) clsmap(:clscnt(class),class,2) + if( class >= 4 ) then + write(20,522) permute(:clscnt(class),class) + write(20,522) sparse(class-3)%diag_map(:clscnt(class)) + end if + end if + end do +!----------------------------------------------------------------------- +! ... Write the "class" maps & species symbols +!----------------------------------------------------------------------- + temp_mass(:) = 0. + if( nq > 0 ) then + do i = 1,nq + if( newind(i) /= 0 ) then + temp_mass(newind(i)) = mass(i) + end if + end do + write(20,*) temp_mass(:new_nq) + end if + if( ngrp > 0 ) then + do i = 1,nq + if( grp_rat_ind(i) /= 0 ) then + temp_mass(grp_rat_ind(i)) = mass(i) + end if + end do + write(20,*) temp_mass(:grp_mem_cnt) + end if + if( new_nq > 0 ) then + write(20,'(10a16)') new_solsym(:new_nq) + end if + if( grp_mem_cnt > 0 ) then + write(20,'(i4)') ngrp + write(20,'(20i4)') grpcnt(:ngrp) + write(20,'(10a16)') grpsym(:ngrp) + write(20,'(10a16)') grp_mem_sym(:grp_mem_cnt) + end if + write(20,'(i4)') srf_flx_cnt + if( srf_flx_cnt > 0 ) then + do m = 1,(srf_flx_cnt-1)/10+1 + wrk_chr(:) = ' ' + il = (m-1)*10 + 1 + iu = min( 10*m,srf_flx_cnt ) + do i = il,iu + wrk_chr(i-il+1) = new_solsym(srf_flx_map(i)) + end do + write(20,'(10a16)') wrk_chr + end do + end if + write(20,'(i4)') dvel_cnt + if( dvel_cnt > 0 ) then + do m = 1,(dvel_cnt-1)/10+1 + wrk_chr(:) = ' ' + il = (m-1)*10 + 1 + iu = min( 10*m,dvel_cnt ) + do i = il,iu + wrk_chr(i-il+1) = new_solsym(dvel_map(i)) + end do + write(20,'(10a16)') wrk_chr + end do + end if +!----------------------------------------------------------------------- +! ... Write the wet removal species +!----------------------------------------------------------------------- + if( hetcnt > 0 ) then + do m = 1,(hetcnt-1)/10+1 + wrk_chr(:) = ' ' + il = (m-1)*10 + 1 + iu = min( 10*m,hetcnt ) + do i = il,iu + wrk_chr(i-il+1) = new_solsym(hetmap(i,1)) + end do + write(20,'(10a16)') wrk_chr + end do + end if +!----------------------------------------------------------------------- +! ... Write the ext frcing species +!----------------------------------------------------------------------- + if( usrcnt > 0 ) then + do m = 1,(usrcnt-1)/10+1 + wrk_chr(:) = ' ' + il = (m-1)*10 + 1 + iu = min( 10*m,usrcnt ) + do i = il,iu + wrk_chr(i-il+1) = new_solsym(usrmap(i)) + end do + write(20,'(10a16)') wrk_chr + end do + end if +!----------------------------------------------------------------------- +! ... Write the rxt aliases +!----------------------------------------------------------------------- + k = count( rxt_has_alias(:rxntot) ) + write(20,'(i4)') k + if( k > 0 ) then + wrk_chr(:) = ' ' + i = 0 + do m = 1,rxntot + if( rxt_has_alias(m) ) then + i = i + 1 + wrk_rxt(i) = rxt_tag(m) + if( i == 5 ) then + write(20,'(5a16)') wrk_rxt(:5) + i = 0 + end if + end if + end do + if( i /= 0 ) then + write(20,'(5a16)') wrk_rxt(:i) + end if + i = 0 + do m = 1,rxntot + if( rxt_has_alias(m) ) then + i = i + 1 + nind(i) = m + if( i == 20 ) then + write(20,'(20i4)') nind(:20) + i = 0 + end if + end if + end do + if( i /= 0 ) then + write(20,'(20i4)') nind(:i) + end if + end if + else + write(20,510) clscnt(:) + write(20,508) cls_rxt_cnt(:,:) + do class = 1,5 + if( class == 2 .or. class == 3 ) then + cycle + end if + if( clscnt(class) > 0 ) then + write(20,522) clsmap(:clscnt(class),class,2) + end if + end do + temp_mass(:) = 0. + if( nq > 0 ) then + do i = 1,nq + if( newind(i) /= 0 ) then + temp_mass(newind(i)) = mass(i) + end if + end do + write(20,*) temp_mass(:new_nq) + end if + if( new_nq > 0 ) then + write(20,'(10a16)') new_solsym(:new_nq) + end if + do class = 2,5 + if( clscnt(class) > 0 ) then + write(20,522) permute(:clscnt(class),class) + if( class > 3 ) then + write(20,522) sparse(class-3)%diag_map(:clscnt(class)) + end if + end if + end do + call make_sim_dat( model, march, sparse ) + end if + close( 20) + + rxt_tag_cnt = count( rxt_has_tag ) + enthalpy_cnt = count( cph_flg ) + +!----------------------------------------------------------------------- +! ... Write the chemistry header file +!----------------------------------------------------------------------- + call chm_hdr( rxt_tag_cnt, enthalpy_cnt, hetcnt, usrcnt, cls_rxt_cnt, radj_flag, phtcnt, & + rxpcnt, rxparm, rxntot, ncol, nfs, nslvd, & + indexm, indexh2o, new_nq, relcnt, grp_mem_cnt, & + clscnt, iter_counts, nzcnt, vec_ftns, machine, options(1), veclen ) + +!----------------------------------------------------------------------- +! ... Write the resolution header file +!----------------------------------------------------------------------- +! call res_hdr( plon, plonl, plat, plev, jintmx, & +! nxpt, arch_type, cpucnt ) + +!----------------------------------------------------------------------- +! ... Write the version header file +!----------------------------------------------------------------------- + ptplen = histout_cnt(1,1,1) + histout_cnt(2,1,1) + histout_cnt(5,1,1) & + + histout_cnt(3,1,1) + histout_cnt(4,1,1) + histout_cnt(7,1,1) & + + histout_cnt(1,2,1) + histout_cnt(2,2,1) + histout_cnt(5,2,1) & + + histout_cnt(3,2,1) + histout_cnt(4,2,1) + histout_cnt(7,2,1) + if( ptplen /= 0 .and. histout(2) /= ' ' ) then + ohstflag = .true. + else + ohstflag = .false. + end if + call ver_hdr( options, plon, plonl, plev, machine, & + model, arch_type, ohstflag, diagprnt, tavgprnt, srf_flx_cnt, & + hetcnt, rxntot, clscnt, nzcnt, new_nq, dvel_cnt ) + +!----------------------------------------------------------------------- +! ... Write the slt header file +!----------------------------------------------------------------------- + call slt_hdr( options(2), options(11), cpucnt, machine ) + +!----------------------------------------------------------------------- +! ... Write the history tape header file +!----------------------------------------------------------------------- + call hist_hdr( hst_file_cnt, histout_cnt, histout_map, user_hst_names, histinp(4), & + dyn_hst_fld_cnt, spcsym, spccnt, hetmap, usrmap, & + ptplen, sim_dat_filespec, model ) + if( model == 'MOZART' ) then +!----------------------------------------------------------------------- +! ... Special section for invariants +!----------------------------------------------------------------------- + open( unit = 20, & + file = trim( sim_dat_filespec ), & + status = 'old', & + position = 'append', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open file '// trim( sim_dat_filespec ) + write(*,*) ' Error code = ',ios + stop + end if +!----------------------------------------------------------------------- +! ... Write the invariants +!----------------------------------------------------------------------- + if( nfs /= 0 ) then + do m = 1,(nfs-1)/10+1 + wrk_chr(:) = ' ' + il = (m-1)*10 + 1 + iu = min( 10*m,nfs ) + do i = il,iu + wrk_chr(i-il+1) = fixsym(i) + end do + write(20,'(10a16)') wrk_chr + end do + end if + close( 20 ) + end if + +!----------------------------------------------------------------------- +! ... Write the files.h file +!----------------------------------------------------------------------- + call files_hdr + +!----------------------------------------------------------------------- +! ... Form "include" files stub file +!----------------------------------------------------------------------- + inquire( file = trim( temp_path ) // 'wrk.stub.F', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( temp_path ) // 'wrk.stub.F' ) + end if + open( unit = 3, & + file = trim( temp_path ) // 'wrk.stub.F', & + iostat = ios ) + if( ios /= 0 ) then + write(*,*) ' Failed to open wrk file; terminating' + write(*,*) ' Error code = ',ios + stop + end if + write(3,'(''# include '')') +!!$ write(3,'(''# include '')') + write(3,'(''# include '')') + write(3,'(''# include '')') + write(3,'(''# include '')') + close( 3 ) + call system( 'rm -f wrk.F' ) + +!----------------------------------------------------------------------- +! ... Check for cpp utility +!----------------------------------------------------------------------- + cpp_command = trim( cpp_dir ) // ' ' // trim( cpp_opts ) + inquire( file = trim( cpp_dir ), exist = lexist ) + if( .not. lexist ) then + buff = ' ' + call errmes( ' ** cpp not in #', & + lout, & + trim( cpp_dir ), & + len_trim( cpp_dir ), & + buff ) + end if +!----------------------------------------------------------------------- +! ... Check for fortran 90 modules +!----------------------------------------------------------------------- + inquire( file = trim( temp_path ) // 'mod.src.files.PP', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( temp_path ) // 'mod.src.files.PP' ) + end if +!----------------------------------------------------------------------- +! ... Get mozart module files +!----------------------------------------------------------------------- + if( model == 'MOZART' ) then + inquire( file = trim( src_dir ) // 'mozart.mod.files.PP', exist = lexist ) + if( .not. lexist ) then + call errmes( ' ** Module source file missing@', 6, param, 8, buff ) + end if + call system( 'cat ' // trim( src_dir ) // 'mozart.mod.files.PP > ' & + // trim( temp_path ) // 'mod.src.files.PP' ) + else + inquire( file = trim( src_dir ) // 'cam.mod.files.PP', exist = lexist ) + if( .not. lexist ) then + call errmes( ' ** Module source file missing@', 6, param, 8, buff ) + end if + call system( 'cat ' // trim( src_dir ) // 'cam.mod.files.PP > ' & + // trim( temp_path ) // 'mod.src.files.PP' ) + end if + inquire( file = trim( temp_path ) // 'mod.src.files', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( temp_path ) // 'mod.src.files' ) + end if + call system( trim( cpp_command ) // ' ' // trim( temp_path ) // 'mod.src.files.PP > ' & + // trim( temp_path ) // 'mod.src.files' ) + close(2) + open( unit = 2, & + file = trim( temp_path ) // 'mod.src.files', & + status = 'old', & + position = 'rewind', & + iostat = ios ) + if( ios /= 0 ) then + write(lout,*) ' Failed to open mod.src.files file' + write(lout,*) ' Error code = ',ios + stop + end if + file_cnt = 1 + do k = 1,500 + read(2,'(a320)',end=1105) mod_src(file_cnt) + if( mod_src(file_cnt) /= ' ' ) then + filelines(5) = filelines(5) + 1 + file_cnt = file_cnt + 1 + end if + end do +1105 continue + close( 2 ) +!----------------------------------------------------------------------- +! ... Check for species names module +!----------------------------------------------------------------------- + if( options(18) ) then + k = 1 +!!$ mod_paths(k) = './' + mod_paths(k) = ' ' + mod_names(k) = trim( temp_path ) // 'spc_names.mod' + k = 2 +!!$ mod_paths(k) = './' + mod_paths(k) = ' ' + mod_names(k) = trim( temp_path ) // 'rxt_names.mod' +!!$ k = 3 +!!$ mod_paths(k) = './' +!!$ mod_paths(k) = ' ' +!!$ mod_names(k) = trim( temp_path ) // 'het_names.mod' + else + k = 0 + end if +!----------------------------------------------------------------------- +! ... Check user files for any module files +!----------------------------------------------------------------------- + do i = 1,sub_cnt + if( index( filename(i), 'mod', back = .true. ) == len_trim(filename(i))-2 ) then + k = k + 1 + mod_paths(k) = trim( filepath(i) ) + mod_names(k) = trim( filename(i) ) + nend(i) = 0 + else + nend(i) = 1 + end if + end do + filelines(2) = k +!----------------------------------------------------------------------- +! ... Remove .mod files from user subroutine lists +!----------------------------------------------------------------------- + k = 0 + do i = 1,sub_cnt + if( nend(i) == 1 ) then + k = k + 1 + filepath(k) = filepath(i) + filename(k) = filename(i) + end if + end do + sub_cnt = k +!----------------------------------------------------------------------- +! ... Check for user file "overrides" +!----------------------------------------------------------------------- + if( filelines(2) /= 0 ) then + call sub_scan( filelines(5), & + mod_src, & + mod_paths, & + mod_names, & + filelines(2) ) + end if +!----------------------------------------------------------------------- +! ... Form and preprocess the modules +!----------------------------------------------------------------------- + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + do i = 1,filelines(5) + command = 'cat ' // trim( mod_src(i) ) // ' >> wrk.F' + call system( trim( command ) ) + end do + if( filelines(2) > 0 ) then + do i = 1,filelines(2) + command = 'cat ' // trim( mod_paths(i) ) // trim( mod_names(i) ) // ' >> wrk.F' + call system( trim( command ) ) + end do + end if + inquire( file = trim(procout_path)//'moz.mods.F90', exist = lexist ) + if( lexist ) then + call system( 'rm -f '//trim(procout_path)//'moz.mods.F90' ) + end if + call system( trim( cpp_command ) // ' wrk.F > '//trim(procout_path)//'moz.mods.F90' ) + call system( 'rm -f wrk.F' ) + +!----------------------------------------------------------------------- +! ... for CAM,WRF remove tar file if it exists +!----------------------------------------------------------------------- + if( model /= 'MOZART' ) then + if( model == 'CAM' ) then + tar_flnm = 'cam.subs.tar' + else if( model == 'WRF' ) then + tar_flnm = 'wrf.subs.tar' + end if + inquire( file = trim( temp_path ) // trim(tar_flnm), exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim(temp_path ) // trim(tar_flnm) ) + end if +!----------------------------------------------------------------------- +! ... add module files to cam tar file +!----------------------------------------------------------------------- + if( filelines(5) /= 0 ) then + do i = 1,filelines(5) + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + call system( 'cat '// trim( mod_src(i) ) // ' >> wrk.F' ) +! write(*,*) 'cpp file ',trim(mod_src(i)) + il = index( mod_src(i), '/', back = .true. ) + 1 + iu = index( mod_src(i), '.mod', back = .true. ) - 1 + select case( mod_src(i)(il:iu) ) + case( 'mo_chem' ) + tmp_filenm = 'chem_mods' + case default + tmp_filenm = mod_src(i)(il:iu) + end select + filenm = trim(tmp_filenm) // '.F90' +! write(*,*) 'tar file ',trim(filenm) + call system( trim( cpp_command ) // ' wrk.F > '// trim(filenm) ) + if( i == 1 ) then + call system( 'tar -cf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + else + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + end if + call system( 'rm -f wrk.F' ) + call system( 'rm -f ' // trim(filenm) ) + end do + end if + if( filelines(2) > 0 ) then + do i = 1,filelines(2) + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + call system( 'cat '// trim( mod_paths(i) ) // trim(mod_names(i) ) // ' >> wrk.F' ) +! write(*,*) 'cpp file ',trim(mod_paths(i)) // trim(mod_names(i)) + il = index( mod_names(i), '/', back = .true. ) + 1 + iu = index( mod_names(i), '.mod', back = .true. ) - 1 + select case( mod_names(i)(il:iu) ) + case( 'spc_names' ) + tmp_filenm = 'm_spc_id' + case( 'rxt_names' ) + tmp_filenm = 'm_rxt_id' + case( 'het_names' ) + tmp_filenm = 'm_het_id' + case default + tmp_filenm = mod_src(i)(il:iu) + end select + filenm = trim(tmp_filenm) // '.F90' +! write(*,*) 'tar file ',trim(filenm) + call system( trim( cpp_command ) // ' wrk.F > '// trim(filenm) ) + if( filelines(5) == 0 .and. i == 1 ) then + call system( 'tar -cf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + else + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + end if + call system( 'rm -f wrk.F' ) + call system( 'rm -f ' // trim(filenm) ) + end do + end if + end if + +!----------------------------------------------------------------------- +! ... Get all source files +!----------------------------------------------------------------------- + if( options(7) ) then +!----------------------------------------------------------------------- +! ... Get "main" library files +!----------------------------------------------------------------------- + inquire( file = trim( temp_path ) // 'lib.src.files.PP', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim(temp_path ) // 'lib.src.files.PP' ) + end if +!----------------------------------------------------------------------- +! ... Get "chemistry" library files +!----------------------------------------------------------------------- + if( model == 'MOZART' ) then + inquire( file = trim( src_dir ) // 'mozart.src.files.PP', exist = lexist ) + else if( model == 'CAM' ) then + inquire( file = trim( src_dir ) // 'cam.src.files.PP', exist = lexist ) + end if + if( .not. lexist ) then + call errmes( ' ** Chem source file missing@', 6, param, 8, buff ) + end if + if( model == 'MOZART' ) then + call system( 'cat ' // trim( src_dir ) // 'mozart.src.files.PP ' // ' > ' // trim( temp_path ) // 'lib.src.files.PP' ) + else if( model == 'CAM' ) then + call system( 'cat ' // trim( src_dir ) // 'cam.src.files.PP ' // ' > ' // trim( temp_path ) // 'lib.src.files.PP' ) + end if + command = trim( cpp_command ) // ' ' // trim( temp_path ) // 'lib.src.files.PP > ' // trim( temp_path ) // 'lib.src.files' + inquire( file = trim( temp_path ) // 'lib.src.files', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim(temp_path ) // 'lib.src.files' ) + end if + call system( trim( command ) ) + close(2) + open( unit = 2, & + file = trim( temp_path ) // 'lib.src.files', & + status = 'old', & + iostat = ios ) + if( ios /= 0 ) then + write(lout,*) ' Failed to open lib.src.files file' + write(lout,*) ' Error code = ',ios + stop + end if + file_cnt = 1 + do k = 1,500 + read(2,'(a320)',end=1005) lib_src(file_cnt) + if( lib_src(file_cnt) /= ' ' ) then + filelines(1) = filelines(1) + 1 + file_cnt = file_cnt + 1 + end if + end do +1005 continue +!----------------------------------------------------------------------- +! ... set cam implicit solvers +!----------------------------------------------------------------------- + if( model == 'CAM' ) then + if( march == 'SCALAR' ) then + lib_src(file_cnt) = trim(procfiles_path) // 'mo_imp_sol_scalar.F90' + file_cnt = file_cnt + 1 + filelines(1) = filelines(1) + 1 + lib_src(file_cnt) = trim(procfiles_path) // 'mo_exp_sol_scalar.F90' + else if( march == 'CACHE' ) then + lib_src(file_cnt) = trim(procfiles_path) // 'mo_imp_sol_cache.F90' + else if( march == 'VECTOR' ) then + lib_src(file_cnt) = trim(procfiles_path) // 'mo_imp_sol_vector.F90' + file_cnt = file_cnt + 1 + filelines(1) = filelines(1) + 1 + lib_src(file_cnt) = trim(procfiles_path) // 'mo_exp_sol_vector.F90' + end if + file_cnt = file_cnt + 1 + filelines(1) = filelines(1) + 1 + end if +!----------------------------------------------------------------------- +! ... check for iterative convergence norms +!----------------------------------------------------------------------- + if( options(5) ) then + lib_src(file_cnt) = 'del_norm.F' + lib_src(file_cnt+1) = 'it_norm.F' + filelines(1) = filelines(1) + 2 + end if +!----------------------------------------------------------------------- +! ... Check for user file "overrides" +!----------------------------------------------------------------------- + if( sub_cnt /= 0 ) then + call sub_scan( filelines(1), lib_src, filepath, filename, sub_cnt ) + end if +!----------------------------------------------------------------------- +! ... Form main lib portion of ccmpp file +!----------------------------------------------------------------------- + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + if( filelines(1) /= 0 ) then + do i = 1,filelines(1) + command = 'cat '// trim( lib_src(i) ) // ' >> wrk.F' + call system( trim( command ) ) + end do + end if + +!----------------------------------------------------------------------- +! ... Get user specified files +!----------------------------------------------------------------------- + if( sub_cnt > 0 ) then + do i = 1,sub_cnt + command = 'cat ' // trim( filepath(i) ) // trim( filename(i) ) // ' >> wrk.F' + call system( trim( command ) ) + end do + end if + end if + inquire( file = trim( procout_path ) // 'moz.subs.F90', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim(procout_path ) // 'moz.subs.F90' ) + end if + call system( trim( cpp_command ) // ' wrk.F > '// trim(procout_path) // 'moz.subs.F90' ) + call system( 'rm -f wrk.F' ) + +!----------------------------------------------------------------------- +! ... add source files to cam tar file +!----------------------------------------------------------------------- + if( model /= 'MOZART' ) then + if( filelines(1) /= 0 ) then + do i = 1,filelines(1) + il = index( lib_src(i), '/', back = .true. ) + 1 + iu = index( lib_src(i), '.F', back = .true. ) - 1 + if( lib_src(i)(il:iu) /= 'mo_setrxt' .and. lib_src(i)(il:iu) /= 'mo_sim_dat' ) then + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) +! write(*,*) 'cpp file ',trim(lib_src(i)) + end if + call system( 'cat '// trim( lib_src(i) ) // ' >> wrk.F' ) + if( lib_src(i)(il:iu) == 'mo_imp_sol_scalar' .or. & + lib_src(i)(il:iu) == 'mo_imp_sol_cache' .or. & + lib_src(i)(il:iu) == 'mo_imp_sol_vector' ) then + filenm = 'mo_imp_sol.F90' + elseif( lib_src(i)(il:iu) == 'mo_exp_sol_scalar' .or. & + lib_src(i)(il:iu) == 'mo_exp_sol_cache' .or. & + lib_src(i)(il:iu) == 'mo_exp_sol_vector' ) then + filenm = 'mo_exp_sol.F90' + else + filenm = lib_src(i)(il:iu) // '.F90' + end if + if( lib_src(i)(il:iu) /= 'mo_setrxt' .and. lib_src(i)(il:iu) /= 'mo_sim_dat' ) then + call system( trim( cpp_command ) // ' wrk.F > '// trim(filenm) ) + else + call system( 'cp wrk.F ' // trim(filenm) ) + end if +! write(*,*) 'tar file ',trim(filenm) + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + call system( 'rm -f wrk.F' ) + call system( 'rm -f ' // trim(filenm) ) + end do + end if + if( sub_cnt > 0 ) then + do i = 1,sub_cnt + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + call system( 'cat '// trim( filepath(i) ) // trim(filename(i) ) // ' >> wrk.F' ) +! write(*,*) 'cpp file ',trim(filepath(i)) // trim(filename(i)) + il = index( filename(i), '/', back = .true. ) + 1 + iu = index( filename(i), '.F', back = .true. ) - 1 + filenm = filename(i)(il:iu) // '.F90' + write(*,*) 'tar file ',trim(filenm) + call system( trim( cpp_command ) // ' wrk.F > '// trim(filenm) ) + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + call system( 'rm -f wrk.F' ) + call system( 'rm -f ' // trim(filenm) ) + end do + end if + end if + +!----------------------------------------------------------------------- +! ... Get all matrix and production/loss files +!----------------------------------------------------------------------- + inquire( file = trim( temp_path ) // 'lib.mat.files.PP', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( temp_path ) // 'lib.mat.files.PP' ) + end if + inquire( file = trim( src_dir ) // 'mozart.mat.files.PP', exist = lexist ) + if( .not. lexist ) then + call errmes( ' ** Matrix source file missing@', 6, param, 8, buff ) + end if + call system( 'cat ' // trim( src_dir ) // 'mozart.mat.files.PP ' // ' > ' & + // trim( temp_path) // 'lib.mat.files.PP' ) + inquire( file = trim( temp_path ) // 'lib.mat.files', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim( temp_path ) // 'lib.mat.files' ) + end if + call system( trim( cpp_command ) // ' ' // trim( temp_path ) // 'lib.mat.files.PP > ' & + // trim( temp_path ) // 'lib.mat.files' ) + close(2) + open( unit = 2, & + file = trim( temp_path ) // 'lib.mat.files', & + status = 'old', & + iostat = ios ) + if( ios /= 0 ) then + write(lout,*) ' Failed to open ',trim(temp_path) // 'lib.mat.files file' + write(lout,*) ' Error code = ',ios + stop + end if + file_cnt = 1 + do k = 1,500 + read(2,'(a320)',end=1015) lib_src(file_cnt) + if( lib_src(file_cnt) /= ' ' ) then + lib_src(file_cnt) = trim( temp_path ) // trim( lib_src(file_cnt) ) + filelines(3) = filelines(3) + 1 + file_cnt = file_cnt + 1 + end if + end do +1015 continue +!----------------------------------------------------------------------- +! ... Form main lib portion of ccmpp file +!----------------------------------------------------------------------- + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + if( filelines(3) /= 0 ) then + do i = 1,filelines(3) + command = 'cat '// trim( lib_src(i) ) // ' >> wrk.F' + call system( trim( command ) ) + end do + end if + + inquire( file = trim( procout_path ) // 'moz.mat.F90', exist = lexist ) + if( lexist ) then + call system( 'rm -f ' // trim(procout_path ) // 'moz.mat.F90' ) + end if + call system( trim( cpp_command ) // ' wrk.F > '//trim(procout_path)//'moz.mat.F90' ) + call system( 'rm -f wrk.F' ) + +!----------------------------------------------------------------------- +! ... add matrix source files to cam tar file +!----------------------------------------------------------------------- + if( model /= 'MOZART' ) then + if( filelines(3) /= 0 ) then + do i = 1,filelines(3) + call system( 'cat ' // trim( temp_path ) // 'wrk.stub.F > wrk.F' ) + call system( 'cat '// trim( lib_src(i) ) // ' >> wrk.F' ) +! write(*,*) 'cpp file ',trim(lib_src(i)) + il = index( lib_src(i), '/', back = .true. ) + 1 + iu = index( lib_src(i), '.F', back = .true. ) - 1 + select case( lib_src(i)(il:iu) ) + case( 'prd_loss' ) + mod_src(1) = 'prod_loss' + case( 'lu_fac' ) + mod_src(1) = 'lu_factor' + case( 'lu_slv' ) + mod_src(1) = 'lu_solve' + case( 'linmat' ) + mod_src(1) = 'lin_matrix' + case( 'nlnmat' ) + mod_src(1) = 'nln_matrix' + case default + mod_src(1) = lib_src(i)(il:iu) + end select + filenm = 'mo_' // trim(mod_src(1)) // '.F90' +! write(*,*) 'tar file ',trim(filenm) + call system( trim( cpp_command ) // ' wrk.F > '// trim(filenm) ) + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(filenm) ) + call system( 'rm -f wrk.F' ) + call system( 'rm -f ' // trim(filenm) ) + end do + + call system( 'cp '// trim(temp_path) // trim(rxt_rates_conv_file) // ' .' ) + call system( 'tar -rf ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(rxt_rates_conv_file) ) + call system( 'rm -f ' // trim(rxt_rates_conv_file) ) + + call system( 'mv ' // trim(temp_path) // trim(tar_flnm) // ' ' // trim(output_path) // '.' ) + end if + end if + +!----------------------------------------------------------------------- +! ... Write the params.h file +!----------------------------------------------------------------------- + call params_hdr( plon, plonl, plat, plev, phtcnt, & + rxntot, new_nq, grp_mem_cnt, histout_cnt, options(1), & + options(3), options(4), arch_type, trim(procout_path)//'params.h' ) +!----------------------------------------------------------------------- +! ... Clean up this directory +!----------------------------------------------------------------------- + call system( 'mv *.h ' // trim( temp_path ) // '.' ) + + write(*,*) ' ' + write(*,*) '================================================' + write(*,*) 'CAM-Chem preprocessor has successfully completed' + write(*,*) '================================================' + write(*,*) ' ' + +!----------------------------------------------------------------------- +! ... Format statements +!----------------------------------------------------------------------- +101 format('0 *****Species header must be first card *****') +102 format('0 *****Solution must follow species card *****') + +202 format(6x,i3,2x,i3) +204 format(6x,i3,2x,i3,2x,i3) +206 format(6x,i3,2x,i3,2x,i3,2x,i3) +208 format(6x,i3,2x,i3,2x,i3,2x,i3,2x,i3) +201 format('0 the unimolecular fixed map'/6x,'rxn',2x,'fsn') +203 format('0 the bimolecular fixed map'/6x,'rxn',2(2x,'fsn')) +205 format('0 the production map'/6x,'rxn',2(2x,'psn')) +209 format('0 the unimolecular reaction map'/6x,'rxn',2x,'rsn',2(2x,'psn')) +210 format(6x,i3,2x,i3,2x,i3,2x,i3,2x,i3,2x,i3) +211 format('0 the bimolecualr reaction map'/6x,'rxn',2(2x,'rsn'),2(2x,'psn')) +213 format('0 the pce loss map'/6x,'pcn',2x,'rxn',2(2x,'psn')) +215 format('0 the pce,sol map'/6x,'pcn',2x,'rxn',2x,'rsn',2(2x,'psn')) +217 format('0 pure prod map for pces'/6x,'pcn',2x,'rxn',2x,'ind') +219 format('0 the linear prod map for pces'/6x,'pcn',2x,'rxn',2x,'rsn',2x,'ind') +221 format('0 the quadratic prod map for pces'/6x,'pcn',2x,'rxn',2x,'rsn',2x,'rsn',2x,'ind') +230 format(5x,'Solution species') +231 format(6x,'(',i3,')',2x,a16) +232 format(5x,'Invariant species') +235 format(5x,'Relationships') +236 format(5x,'Column integrals') +237 format(5x,'Groups') +238 format(3x,'(',i2,')',2x,a16,' - ',1pe10.3) + +502 format(10i4) +504 format(2i4) +506 format(3i4) +508 format(4i4) +510 format(5i4) +512 format(6i4) +514 format(i4) +516 format(1x,2e10.4) +519 format(5e16.8) +522 format(20i4) + +600 format('0 upper bndy conds'/2x,'species d n') +602 format(1x,a16,2i3) +604 format('0 lower bndy conds'/2x,'species d n') +606 format('0 upper bndy flux'/2x,'species day night ') +608 format(1x,a16,1p,2e12.4) +610 format('0 lower bndy flux'/2x,'species day night ') +612 format('0 upper bndy dir constants'/2x,'species',5x,'day',8x,'night ') +614 format('0 lower bndy dir constants'/2x,'species',5x,'day',8x,'night ') +616 format('0 aust coefficients'/2x,'species',5x,'day',8x,'night ') +618 format('0 the time increments') +620 format(1x,'(',i2,')',2x,1pe12.4) + +1565 format(11x,'|--------------------------------------------------------------------------------------------------|') +1571 format(11x,'| ',96x,' |') +1567 format(11x,'| ',8x,a80,8x,' |') +1569 format(11x,'|**************************************************************************************************|') + +2502 format('0 rxn a0 b0') +2504 format(3x,i3,1p,2e12.4) +2506 format('1',14x,'boundary conditions'/'+',14x,'________ __________' & + /'0',12x,'upper boundary',6x,'lower boundary'/'+',12x, & + '_____ ________',6x,'_____ ________'/' species',5x,'day',6x, & + 'night',6x,'day',6x,'night'/'+ _______',5x,'___',6x,'_____', & + 6x,'___',6x,'_____') +2508 format(1x,10a16) +2270 format('0',10a16) + +4000 format('0*** group table ***') +4002 format('0 group no',i4) +4004 format(1x,f3.1,i4) +4010 format('0*** column table ***') +4012 format(1x,2i4) +4020 format('0*** printout table ***') +4022 format('0 index',i4,' type',i4,' ic flag',i4) +4024 format('0 st fine prt',1pe12.4,' st course prt',e12.4) +4026 format('0 fine prt grid'/(1x,1pe12.4)) +4028 format('0 course prt grid'/(1x,1pe12.4)) +4030 format('0 column count'/(1x,i4)) +4032 format('0 print directory'/(1x,i4)) + + end program mozart_pp diff --git a/chem_proc/src/cam_chempp/mozpp.mods.f b/chem_proc/src/cam_chempp/mozpp.mods.f new file mode 100644 index 0000000000..9d9e5e4fa0 --- /dev/null +++ b/chem_proc/src/cam_chempp/mozpp.mods.f @@ -0,0 +1,790 @@ + + module io + + implicit none + + integer :: lin ! input unit number + integer :: lout ! output unit number + + character(len=320) :: buff ! primary line input buffer + character(len=320) :: buffh ! upcase xform of buff + character(len=320) :: procout_path = "../output/" + character(len=320) :: procfiles_path = "../procfiles/cam/" + character(len=320) :: output_path = "../output/" + character(len=320) :: input_path + character(len=320) :: temp_path + character(len=320) :: src_dir = "../bkend/" + character(len=320) :: sim_dat_path = "../output/" + character(len=320) :: sim_dat_filespec + character(len=320) :: sim_dat_filename + + end module io + +!----------------------------------------------------------- +! ... Table of the elements; symbol and amu +!----------------------------------------------------------- + module elements + + integer, private,parameter :: dp = selected_real_kind( 12 ) + + type element + character(len=2) :: sym + real(dp) :: wght + end type element + + integer, private :: tab_max = 100 + integer, private :: id_cnt = 1 + character(len=39), private :: id + type( element ), private :: e_table(100) + + contains + + subroutine iniele() +!----------------------------------------------------------- +! ... Initialize the element mass table and mass computation +!----------------------------------------------------------- + + implicit none + +!----------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------- + integer :: i + + e_table(:)%sym = ' ' + e_table(1) = ELEMENT( 'H ',1.0074_dp ) + e_table(2) = ELEMENT( 'He',4.0020602_dp ) + e_table(3) = ELEMENT( 'Li',6.941_dp ) + e_table(4) = ELEMENT( 'Be',9.012182_dp ) + e_table(5) = ELEMENT( 'B ',10.811_dp ) + e_table(6) = ELEMENT( 'C ',12.011_dp ) + e_table(7) = ELEMENT( 'N ',14.00674_dp ) + e_table(8) = ELEMENT( 'O ',15.9994_dp ) + e_table(9) = ELEMENT( 'F ',18.9984032_dp ) + e_table(10) = ELEMENT( 'Ne',20.1797_dp ) + e_table(11) = ELEMENT( 'Na',22.989768_dp ) + e_table(12) = ELEMENT( 'Mg',24.305_dp ) + e_table(13) = ELEMENT( 'Al',26.981539_dp ) + e_table(14) = ELEMENT( 'Si',28.0855_dp ) + e_table(15) = ELEMENT( 'P ',30.97362_dp ) + e_table(16) = ELEMENT( 'S ',32.066_dp ) + e_table(17) = ELEMENT( 'Cl',35.4527_dp ) + e_table(18) = ELEMENT( 'Ar',39.948_dp ) + e_table(19) = ELEMENT( 'K ',39.0983_dp ) + e_table(20) = ELEMENT( 'Ca',40.078_dp ) + e_table(21) = ELEMENT( 'Sc',44.95591_dp ) + e_table(22) = ELEMENT( 'Ti',47.867_dp ) + e_table(23) = ELEMENT( 'V ',50.9415_dp ) + e_table(24) = ELEMENT( 'Cr',51.9961_dp ) + e_table(25) = ELEMENT( 'Mn',54.93085_dp ) + e_table(26) = ELEMENT( 'Fe',55.845_dp ) + e_table(27) = ELEMENT( 'Co',58.9332_dp ) + e_table(28) = ELEMENT( 'Ni',58.6934_dp ) + e_table(29) = ELEMENT( 'Cu',63.546_dp ) + e_table(30) = ELEMENT( 'Zn',65.39_dp ) + e_table(31) = ELEMENT( 'Ga',69.723_dp ) + e_table(32) = ELEMENT( 'Ge',72.61_dp ) + e_table(33) = ELEMENT( 'As',74.92159_dp ) + e_table(34) = ELEMENT( 'Se',78.96_dp ) + e_table(35) = ELEMENT( 'Br',79.904_dp ) + e_table(36) = ELEMENT( 'Kr',83.8_dp ) + e_table(37) = ELEMENT( 'Rb',85.4678_dp ) + e_table(38) = ELEMENT( 'Sr',87.62_dp ) + e_table(39) = ELEMENT( 'Y ',88.90585_dp ) + e_table(40) = ELEMENT( 'Zr',91.224_dp ) + e_table(41) = ELEMENT( 'Nb',92.90638_dp ) + e_table(42) = ELEMENT( 'Mo',95.94_dp ) + e_table(43) = ELEMENT( 'Tc',98._dp ) + e_table(44) = ELEMENT( 'Ru',101.07_dp ) + e_table(45) = ELEMENT( 'Rh',102.9055_dp ) + e_table(46) = ELEMENT( 'Pd',106.42_dp ) + e_table(47) = ELEMENT( 'Ag',107.8682_dp ) + e_table(48) = ELEMENT( 'Cd',112.411_dp ) + e_table(49) = ELEMENT( 'In',114.818_dp ) + e_table(50) = ELEMENT( 'Sn',118.71_dp ) + e_table(51) = ELEMENT( 'Sb',121.76_dp ) + e_table(52) = ELEMENT( 'Te',127.6_dp ) + e_table(53) = ELEMENT( 'I ',126.90447_dp ) + e_table(54) = ELEMENT( 'Xe',131.29_dp ) + e_table(55) = ELEMENT( 'Cs',132.90543_dp ) + e_table(56) = ELEMENT( 'Ba',137.327_dp ) + e_table(57) = ELEMENT( 'La',138.9055_dp ) + e_table(58) = ELEMENT( 'Hf',178.49_dp ) + e_table(59) = ELEMENT( 'Ta',180.9479_dp ) + e_table(60) = ELEMENT( 'W ',183.84_dp ) + e_table(61) = ELEMENT( 'Re',186.207_dp ) + e_table(62) = ELEMENT( 'Os',190.23_dp ) + e_table(63) = ELEMENT( 'Ir',192.217_dp ) + e_table(64) = ELEMENT( 'Pt',195.08_dp ) + e_table(65) = ELEMENT( 'Au',196.96654_dp ) + e_table(66) = ELEMENT( 'Hg',200.59_dp ) + e_table(67) = ELEMENT( 'Tl',204.3833_dp ) + e_table(68) = ELEMENT( 'Pb',207.2_dp ) + e_table(69) = ELEMENT( 'Bi',208.98037_dp ) + e_table(70) = ELEMENT( 'Po',209._dp ) + e_table(71) = ELEMENT( 'At',210._dp ) + e_table(72) = ELEMENT( 'Rn',222._dp ) + e_table(73) = ELEMENT( 'Fr',223._dp ) + e_table(74) = ELEMENT( 'Ra',226.025_dp ) + e_table(75) = ELEMENT( 'Ac',227.028_dp ) + e_table(76) = ELEMENT( 'E ',.000548567_dp ) + + do i = 1,100 + if( e_table(i)%sym == ' ' ) then + exit + end if + end do + tab_max = i - 1 + + id(:1) = e_table(1)%sym(:1) + do i = 2,tab_max + if( scan( e_table(i)%sym(:1), id(:id_cnt) ) == 0 ) then + id_cnt = id_cnt + 1 + id(id_cnt:id_cnt) = e_table(i)%sym(:1) + end if + end do + + end subroutine iniele + + real(dp) function com_mass( compound, carbmass ) +!----------------------------------------------------------- +! ... Compute the mass of input compound +!----------------------------------------------------------- + + implicit none + +!----------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------- + character(len=*), intent(in) :: compound + logical, optional,intent(in) :: carbmass + +!----------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------- + integer :: beg, end, pos, nump, index + integer :: ios, el_cnt + real(dp) :: sum + logical :: carbon_only + + carbon_only = .false. + if (present(carbmass)) then + carbon_only = carbmass + endif + + end = len_trim( compound ) + sum = 0._dp + do + pos = scan( compound(:end), id(:id_cnt), back = .true. ) + if( pos == 0 ) then + exit + end if + nump = scan( compound(pos+1:end), '0123456789' ) + if( nump /= 0 ) then + nump = pos + nump + read(compound(nump:end),*,iostat=ios) el_cnt + if( ios /= 0 .or. el_cnt == 0 ) then + exit + end if + end = nump - 1 + else + el_cnt = 1 + end if + do index = 1,tab_max + if( e_table(index)%sym == compound(pos:end) ) then + exit + end if + end do +! if( index > 39 ) then +! COM_MASS = 0. +! exit +! end if + if (carbon_only) then + if( trim(e_table(index)%sym) == 'C') then + sum = sum + e_table(index)%wght * real( el_cnt,dp ) + endif + else + sum = sum + e_table(index)%wght * real( el_cnt,dp ) + endif + end = pos - 1 + if( end <= 0 ) then + exit + end if + end do + com_mass = sum + + end function com_mass + + end module elements + + module SP_MODS + integer :: n = 0 ! order of matrix + integer :: nz = 0 ! # of non=zero elements + integer :: sp = 0 ! stack pointer + integer :: nb = 0 ! search counter + integer :: pp = 0 ! perm vector position + integer :: blkcnt = 0 ! strongly connected blk count + integer, allocatable :: number(:) + integer, allocatable :: lowlink(:) + integer, allocatable :: vstack(:) + integer, allocatable :: perm(:) + integer, allocatable :: rp(:) + integer, allocatable :: ci(:) + integer, allocatable :: stcoblk(:) + integer, allocatable :: blkmemcnt(:) + logical, allocatable :: matrix(:,:) + + type SPARSITY + integer, pointer :: diag_map(:) ! map of jacobian diagonals + integer, pointer :: mat_sp_map(:,:) ! matrix sparsity "map" + logical, pointer, dimension(:,:) :: mat_sp_pat, lu_sp_pat + end type SPARSITY + end module SP_MODS + + module VAR_MOD +!----------------------------------------------------------------------- +! ... Mozart reaction variables +!----------------------------------------------------------------------- + + implicit none + + integer, parameter :: dp = selected_real_kind( 12 ) + + integer, parameter :: var_lim = 10000 + integer :: hst_file_lim + integer :: hst_map_lim + integer, pointer :: nq, relcnt, nfs, ngrp, & + ncol, new_nq, grp_mem_cnt + integer, target :: spccnt(7) = 0 + integer, allocatable :: & + grpflg(:), & + mem2grp_map(:), & + newind(:), & + grpmap(:,:), & + relmap(:,:), & + grpcnt(:), & + colmap(:), & + rel_flg(:), & + grp_rat_ind(:) + +!----------------------------------------------------------------------- +! ... The solution class variables +!----------------------------------------------------------------------- + integer, allocatable :: & + clsmap(:,:,:) + integer :: cls_ind_prdcnt + integer :: clscnt(5) = 0 ! count of solution species in each numerical "class" + + integer :: ptplen = 0 ! total hist tape fields + integer, allocatable :: & + histout_cnt(:,:,:), & + histout_map(:,:,:,:) + integer, dimension(5,2) :: & + class_prod_cnt = 0, & + class_loss_cnt = 0 + integer :: indexm = 0, & ! index for fixed species denoting total atm density + indexh2o = 0 ! index for fixed species denoting water vapor density + + integer :: extcnt(5) = 0 + integer, allocatable :: & + srf_flx_map(:) ! surface flux flag + integer :: srf_flx_cnt = 0 ! count of soln species with surface emissions + integer, allocatable :: & + dvel_map(:) ! deposition flux flag + integer :: dvel_cnt = 0 ! count of soln species with deposition flux + + real, allocatable :: & + colub(:), & ! upper boundary column integral + grpcof(:,:) ! multiplier for group members + + real(dp), allocatable :: & + mass(:), & ! molecular mass of the mechanism compound + c_mass(:), & ! carbon mass of the mechanism compound + temp_mass(:) ! original species masses and temp space + + character(len=64), allocatable :: aliases(:) + character(len=16), target, allocatable :: spcsym(:,:) + character(len=16), pointer :: pcesym(:), & + solsym(:), & + fixsym(:), & + grpsym(:), & + colsym(:), & + new_solsym(:), & + grp_mem_sym(:), & + slvdsym(:) + + integer :: nslvd + + character(len=16), allocatable :: & + user_hst_names(:,:) + + integer, allocatable :: permute(:,:) ! permutation vector + integer, allocatable :: permutation(:), permute_orig(:,:) + + contains + + subroutine VAR_INI() +!----------------------------------------------------------------------- +! ... Allocate and initialize reaction variables +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + + hst_file_lim = 10 + hst_map_lim = 1000 + allocate( grpflg(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate grpflg' + stop + end if + grpflg(:) = 0 + allocate( mem2grp_map(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate mem2grp' + stop + end if + mem2grp_map(:) = 0 + allocate( newind(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate newind' + stop + end if + newind(:) = 0 + allocate( relmap(var_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate relmap' + stop + end if + relmap(:,:) = 0 + allocate( grpcnt(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate grpcnt' + stop + end if + grpcnt(:) = 0 + allocate( grpmap(var_lim,var_lim/2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate grpmap' + stop + end if + grpmap(:,:) = 0 + allocate( colmap(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate colmap' + stop + end if + colmap(:) = 0 + allocate( rel_flg(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate rel_flg' + stop + end if + rel_flg(:) = 0 + allocate( grp_rat_ind(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate grp_rat_ind' + stop + end if + grp_rat_ind(:) = 0 + allocate( clsmap(var_lim,5,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate clsmap' + stop + end if + clsmap(:,:,:) = 0 + allocate( histout_cnt(20,2,hst_file_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate histout_cnt' + stop + end if + histout_cnt(:,:,:) = 0 + allocate( histout_map(hst_map_lim,20,2,hst_file_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate histout_map' + stop + end if + histout_map(:,:,:,:) = 0 + allocate( srf_flx_map(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate srf_flx_map' + stop + end if + srf_flx_map(:) = 0 + allocate( dvel_map(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate dvel_map' + stop + end if + dvel_map(:) = 0 + allocate( colub(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate colub' + stop + end if + colub(:) = 0. + allocate( grpcof(var_lim,var_lim/2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate grpcof' + stop + end if + grpcof(:,:) = 1. + allocate( mass(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate mass' + stop + end if + mass(:) = 0. + allocate( c_mass(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate c_mass' + stop + end if + c_mass(:) = 0. + allocate( temp_mass(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate temp_mass' + stop + end if + temp_mass(:) = 0. + allocate( aliases(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate aliases' + stop + end if + aliases(:) = ' ' + allocate( spcsym(var_lim,8),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate spcsym' + stop + end if + spcsym(:,:) = ' ' + allocate( user_hst_names(var_lim,4),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate usr_hst_names' + stop + end if + user_hst_names(:,:) = ' ' + allocate( permute(var_lim,5),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate permute' + stop + end if + permute(:,:) = 0 + allocate( permute_orig(var_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate permute_orig' + stop + end if + permute_orig(:,:) = 0 + allocate( permutation(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'VAR_INI: Failed to allocate permutation' + stop + end if + permutation(:) = 0 + + nq => spccnt(1) + relcnt => spccnt(2) + nfs => spccnt(3) + ngrp => spccnt(4) + ncol => spccnt(5) + new_nq => spccnt(6) + grp_mem_cnt => spccnt(7) + solsym => spcsym(:,1) + pcesym => spcsym(:,2) + fixsym => spcsym(:,3) + grpsym => spcsym(:,4) + colsym => spcsym(:,5) + new_solsym => spcsym(:,6) + grp_mem_sym => spcsym(:,7) + + slvdsym => spcsym(:,8) + + end subroutine VAR_INI + + end module VAR_MOD + + module RXT_MOD +!----------------------------------------------------------------------- +! ... Mozart reaction variables +!----------------------------------------------------------------------- + + implicit none + + integer, private,parameter :: dp = selected_real_kind( 12 ) + + integer :: rxt_lim + integer :: rxtnt_lim + integer :: prd_lim, prd_limp1 + integer :: phtcnt = 0, & ! count of photolysis reactions + hetcnt = 0, & ! count of heterogeneous processes + usrcnt = 0, & ! count of "extraneous" forcing processes + rxntot = 0, & ! count of photo and gas phase reactions + gascnt = 0 ! count of gas phase reactions + integer, allocatable :: & + fixmap(:,:,:), & + prdmap(:,:) + integer, dimension(2) :: & + fixcnt = 0, & ! count of reactions with fixed rxtnts + rxmcnt = 0, & ! count of reactions with sol rxtnts + ipcel = 0 ! not used + integer, dimension(3) :: & + ipcep = 0 ! not used + integer :: prdcnt = 0, & ! entries in prdmap matrix + rxpcnt = 0, & ! entries in rxparm matrix + troecnt = 0 ! count of troe rates + + integer, allocatable :: & + rxmap(:,:,:), & + pcel(:,:,:), & ! not used + pcep(:,:,:) ! not used + + integer, allocatable :: & + rxptab(:), & + troetab(:), & + hetmap(:,:), & + usrmap(:) + + integer, dimension(2) :: & + grp_rat_cnt = 0, & + rel_rxt_cnt = 0 + integer, allocatable :: & + grp_rat_map(:,:,:), & + rxt_to_grp_map(:,:), & + rel_rxt_pntr(:,:), & + rel_rxt_map(:,:,:) + + integer :: pcoeff_cnt = 0 + integer, allocatable :: & + pcoeff_ind(:) + real, allocatable :: & + pcoeff(:,:), & + rxparm(:,:), & + troe_rxparm(:,:) + character(len=16), allocatable :: & + sym_rates(:,:), & + troe_sym_rates(:,:), & + pht_alias(:,:), & + pht_alias_mult(:,:) + character(len=32), allocatable :: rxt_tag(:) + character(len=16), allocatable :: & + phtsym(:) + logical, allocatable :: & + rxt_has_tag(:), & + rxt_has_alias(:) + logical, allocatable :: & + cph_flg(:) + real(dp), allocatable :: & + enthalpy(:) + logical, allocatable :: & + frc_from_dataset(:) + + integer :: cls_rxt_cnt(4,5) = 0 + integer, allocatable :: & + cls_rxt_map(:,:,:) + integer, allocatable :: num_rnts(:) ! number of reactants + + contains + + subroutine RXT_INI() +!----------------------------------------------------------------------- +! ... Allocate and initialize reaction variables +!----------------------------------------------------------------------- + + use VAR_MOD, only : var_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: astat + +!----------------------------------------------------------------------- +! ... Set reaction limits +!----------------------------------------------------------------------- + rxt_lim = 5000 + rxtnt_lim = 3 + prd_lim = 64 + prd_limp1 = prd_lim + 1 + + allocate( fixmap(var_lim,3,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate fixmap' + stop + end if + fixmap(:,:,:) = 0 + allocate( prdmap(var_lim,prd_limp1),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate prdmap' + stop + end if + prdmap(:,:) = 0 + allocate( rxmap(rxt_lim,prd_lim+3,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxmap' + stop + end if + rxmap(:,:,:) = 0 + allocate( pcel(var_lim,6,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate pcel' + stop + end if + pcel(:,:,:) = 0 + allocate( pcep(var_lim,5,3),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate pcep' + stop + end if + pcep(:,:,:) = 0 + allocate( rxptab(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxptab' + stop + end if + rxptab(:) = 0 + allocate( troetab(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate troetab' + stop + end if + troetab(:) = 0 + allocate( hetmap(rxt_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate hetmap' + stop + end if + hetmap(:,:) = 0 + allocate( usrmap(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate usrmap' + stop + end if + usrmap(:) = 0 + allocate( grp_rat_map(rxt_lim,3,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate grp_rat_map' + stop + end if + grp_rat_map(:,:,:) = 0 + allocate( rxt_to_grp_map(rxt_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxt_to_grp_map' + stop + end if + rxt_to_grp_map(:,:) = 0 + allocate( rel_rxt_pntr(rxt_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rel_rxt_pntr' + stop + end if + rel_rxt_pntr(:,:) = 0 + allocate( rel_rxt_map(rxt_lim,3,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rel_rxt_map' + stop + end if + rel_rxt_map(:,:,:) = 0 + allocate( pcoeff_ind(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate pcoeff_ind' + stop + end if + pcoeff_ind(:) = 0 + allocate( pcoeff(prd_lim,rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate pcoeff' + stop + end if + pcoeff(:,:) = 0. + allocate( rxparm(2,rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxparm' + stop + end if + rxparm(:,:) = 0. + allocate( troe_rxparm(5,rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate troe_rxparm' + stop + end if + troe_rxparm(:,:) = 0. + allocate( sym_rates(2,rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate sym_rates' + stop + end if + sym_rates(:,:) = ' ' + allocate( troe_sym_rates(5,rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate troe_sym_rates' + stop + end if + troe_sym_rates(:,:) = ' ' + allocate( phtsym(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate phtsym' + stop + end if + phtsym(:) = ' ' + allocate( rxt_tag(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxt_tag' + stop + end if + rxt_tag(:) = ' ' + allocate( rxt_has_tag(rxt_lim),rxt_has_alias(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate rxt_has_tag,rxt_has_alias' + stop + end if + rxt_has_tag(:) = .false. + rxt_has_alias(:) = .false. + allocate( cph_flg(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate cph_flg' + stop + end if + cph_flg(:) = .false. + allocate( enthalpy(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate enthalpy' + stop + end if + enthalpy(:) = 0 + allocate( pht_alias(rxt_lim,2),pht_alias_mult(rxt_lim,2),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate pht_alias,pht_alias_mult' + stop + end if + pht_alias(:,:) = ' ' + pht_alias_mult(:,:) = '1.' + allocate( frc_from_dataset(var_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate frc_from_dataset' + stop + end if + frc_from_dataset(:) = .false. + allocate( cls_rxt_map(rxt_lim,prd_lim+3,5),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate cls_rxt_map' + stop + end if + cls_rxt_map(:,:,:) = 0 + + allocate( num_rnts(rxt_lim),stat=astat ) + if( astat /= 0 ) then + write(*,*) 'RXT_INI: Failed to allocate num_rnts' + stop + end if + num_rnts(:) = -1 + + end subroutine RXT_INI + + end module RXT_MOD diff --git a/chem_proc/src/cam_chempp/mozpp.subs.f b/chem_proc/src/cam_chempp/mozpp.subs.f new file mode 100644 index 0000000000..54cfd4e4b7 --- /dev/null +++ b/chem_proc/src/cam_chempp/mozpp.subs.f @@ -0,0 +1,978 @@ + + subroutine TIMCON ( buff, & + time, & + lout ) + + use IO, only : buffh + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: lout ! output unit number + character (len=*), intent(in) :: buff ! input time character string + real, intent(out) :: time ! converted time in seconds + + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: retcod, l, i, j, k, slen + integer :: mnth, tokcnt + integer :: toklen(6) + real :: units(6) + real :: days + real :: ndym(12) = (/ 31., 28., 31., 30., 31., 30., & + 31., 31., 30., 31., 30., 31. /) + character(len=16) :: tokens(6) + character(len=16) :: number + character(len=3) :: timsym(6) = & + (/ 'Y ', 'MON', 'D ', 'H ', 'MIN', 'S ' /) + + units(:) = 0. + slen = LEN_TRIM( buff ) + buffh = buff(:slen) + call UPCASE( buffh ) + call GETTOKENS( buffh, slen, ':', 16, tokens, toklen, 6, tokcnt ) + if( tokcnt == 0 ) then + write(*,*) ' TIMCON : Improper input time string' + stop + end if + do i = 1,tokcnt + l = VERIFY( tokens(i)(:toklen(i)), 'YMONDHIS', back = .true. ) + if( l == 0 ) then + write(*,*) ' TIMCON : Improper input time number' + stop + end if + if( l == toklen(i) ) then + j = 6 + else + l = l + 1 + do j = 1,6 + if( tokens(i)(l:toklen(i)) == timsym(j)(:LEN_TRIM(timsym(j))) ) then + l = l - 1 + exit + end if + end do + end if + + number = tokens(i)(:l) + if( j /= 2 ) then + call RELCON( number, l, units(j), retcod ) + if( retcod /= 0 ) then + call ERRMES( 'number format error in time input #@', & + lout, & + number(:l), & + l, & + buff ) + end if + else + call INTCON( number, l, mnth, retcod ) + if( retcod /= 0 ) then + call ERRMES( 'number format error in time input #@', & + lout, & + number(:l), & + l, & + buff ) + end if + units(2) = SUM( ndym(:mnth-1) ) + end if + end do + + time = 365.*units(1) + SUM( units(2:3) ) + time = time * 8.64e4 + time = time + 60.*(60.*units(4) + units(5)) + units(6) + + end subroutine TIMCON + + subroutine TIMCON_D ( buff, & + days0, & + secs ) + + use IO, only : lout, buffh + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + character (len=*), intent(in) :: buff ! input time character string + real, intent(out) :: days0 ! elapsed days since 0/0/0 + real, intent(out) :: secs ! elapsed secs + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: retcod, l, i, j, k, slen + integer :: mnth, tokcnt + integer :: toklen(6) + real :: units(6) + real :: days + real :: ndym(12) = (/ 31., 28., 31., 30., 31., 30., & + 31., 31., 30., 31., 30., 31. /) + character(len=16) :: tokens(6) + character(len=16) :: number + character(len=3) :: timsym(6) = & + (/ 'Y ', 'MON', 'D ', 'H ', 'MIN', 'S ' /) + + units(:) = 0. + slen = LEN_TRIM(buff) + buffh = buff(:slen) + call UPCASE( buffh ) + call GETTOKENS( buffh, slen, ':', 16, tokens, toklen, 6, tokcnt ) + if( tokcnt == 0 ) then + write(*,*) ' TIMCON_D : Improper input time string' + stop + end if + do i = 1,tokcnt + l = VERIFY( tokens(i)(:toklen(i)), 'YMONDHIS', back = .true. ) + if( l == 0 ) then + write(*,*) ' TIMCON_D : Improper input time number' + stop + end if + if( l == toklen(i) ) then + j = 6 + else + l = l + 1 + do j = 1,6 + if( tokens(i)(l:toklen(i)) == timsym(j)(:LEN_TRIM(timsym(j))) ) then + l = l - 1 + exit + end if + end do + end if + + number = tokens(i)(:l) + if( j /= 2 ) then + call RELCON( number, l, units(j), retcod ) + if( retcod /= 0 ) then + call ERRMES( 'number format error in time input #@', & + lout, & + number(:l), & + l, & + buff ) + end if + else + call INTCON( number, l, mnth, retcod ) + if( retcod /= 0 ) then + call ERRMES( 'number format error in time input #@', & + lout, & + number(:l), & + l, & + buff ) + end if + units(2) = SUM( ndym(:mnth-1) ) + end if + end do + + days0 = 365.*units(1) + SUM( units(2:3) ) + secs = 60.*(60.*units(4) + units(5)) + units(6) + + end subroutine TIMCON_D + + subroutine CARDIN( lin, card, chars ) +!----------------------------------------------------------------------- +! ... Cardin reads on logical input unit lin an 80 character +! card image right filled with blanks. +! The image has all imbedded whitespace removed and +! non whitespace character count returned in chars +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: lin + integer, intent(out) :: chars + character(len=*), intent(out) :: card + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: ht = 9 + integer :: i, ios, slen + character(len=6) :: format + logical :: compress + + + format = ' ' + slen = LEN( card ) + if( slen < 10 ) then + write(format,'(''(a'',i1,'')'')') slen + else if( slen < 100 ) then + write(format,'(''(a'',i2,'')'')') slen + else if( slen < 1000 ) then + write(format,'(''(a'',i3,'')'')') slen + end if + do + compress = .true. + card = ' ' + read(lin,format,iostat=ios) card + if( ios /= 0 ) then + write(*,*) ' CARDIN : Read error = ',ios + call ERRMES( 'Read Error in driver file@', 6, card, 1, card ) + end if +!----------------------------------------------------------------------- +! ... Remove blanks and horizontal tabs +!----------------------------------------------------------------------- + slen = LEN_TRIM( card ) + if( slen == 0 ) then + cycle + end if + chars = VERIFY( card(:slen), ' ' ) + if( card(chars:chars) == '*' ) then + cycle + end if +!----------------------------------------------------------------------- +! ... strip all characters following a '#' or '!' character +!----------------------------------------------------------------------- + i = index( card, '#' ) + if( i == 0 ) then + i = index( card, '!' ) + endif + if( i > 0 ) then + card(i:) = ' ' + endif + + chars = 0 + do i = 1,slen + if( compress ) then + if( card(i:i) /= ' ' .and. ICHAR( card(i:i) ) /= ht ) then + if( card(i:i) == '"' ) then + compress = .false. + cycle + end if + chars = chars + 1 + card(chars:chars) = card(i:i) + end if + else + if( card(i:i) == '"' ) then + compress = .true. + cycle + end if + chars = chars + 1 + card(chars:chars) = card(i:i) + end if + end do + if( card(chars:chars) == ',' ) then + card(chars:chars) = ' ' + chars = chars - 1 + if( chars == 0 ) then + cycle + end if + end if +!----------------------------------------------------------------------- +! ... Ignore "blank" or comment card +!----------------------------------------------------------------------- + if( card == ' ' ) then + cycle + else + card(chars+1:) = ' ' + exit + end if + end do + + end subroutine CARDIN + + subroutine ERRMES( string, & + lout, & + instng, & + count, & + card ) +!----------------------------------------------------------------------- +! ... Prints the input string error message; +! stops the pre-processor +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: count + integer, intent(in) :: lout + character(len=*), intent(in) :: string, instng, card + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: ls, i + character(len=320) :: copy + + copy = '0 *** ' + ls = 6 + + do i = 1,MIN( LEN(string),120 ) + if( string(i:i) == '@' ) then + exit + else if( string(i:i) == '#' ) then + copy(ls+1:ls+count) = instng(:count) + ls = ls + count + else + ls = ls + 1 + copy(ls:ls) = string(i:i) + end if + end do + + write(lout,'(a)') copy(:ls) + write( *,'(a)') copy(:ls) + if( card /= ' ' ) then + write(lout,'('' Input line:'')') + write( *,'('' Input line:'')') + write(lout,'(1x,a80)') card + write( *,'(1x,a80)') card + end if + + stop 'abort' + + end subroutine ERRMES + + subroutine ALTCON( string, & + ls, & + alt, & + retcod ) +!----------------------------------------------------------------------- +! altcon converts the input character string altcon +! to a real number returned in alt. The input string +! must have length ls and can be of the following forms: +! 1. %km +! 2. % +! where % is a generalized e format +! Successful conversion returns zero in retcod and -12 +! otherwise +! +! inputs: +! +! string = character string to convert +! ls = length of string (max value = 80) +! +! outputs: +! +! nout = integer value if retcod = 0 +! retcod = error flag; = 0 => proper format for string +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ls + integer, intent(out) :: retcod + real, intent(out) :: alt + character(len=*), intent(in) :: string + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: len + + if( string(ls:ls) == 'm' .or. string(ls:ls) == 'M' ) then + len = ls - 1 + else + len = ls + end if + + if( len /= 0 ) then + call RELCON( string, & + len, & + alt, & + retcod ) + if( retcod == 0 ) then + if( len == ls ) then + alt = alt*1.e5 + else + alt = alt*1.e2 + end if + retcod = 0 + return + end if + end if + + retcod = -12 + + end subroutine ALTCON + + subroutine INTCON( string, & + ls, & + nout, & + retcod ) +!----------------------------------------------------------------------- +! intcon converts a character string of length ls to an integer +! format errors are trapped and retcod is set to -12 +! +! inputs: +! +! string = character string to convert +! ls = length of string (max value = 80) +! +! outputs: +! +! nout = integer value if retcod = 0 +! retcod = error flag; = 0 => proper format for string +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ls + integer, intent(out) :: nout, retcod + character(len=*), intent(in) :: string + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: ios + + read (string(:ls),*,iostat=ios) nout + if( ios == 0 ) then + retcod = 0 + else + retcod = -12 + end if + + end subroutine INTCON + + subroutine RELCON( string, & + ls, & + flpout, & + retcod ) +!----------------------------------------------------------------------- +! relcon converts a character string of length ls to a real number +! format errors are trapped and retcod is set to -12 +! +! inputs: +! +! string = character string to convert +! ls = length of string (max value = 80) +! +! outputs: +! +! flpout = real value if retcod = 0 +! retcod = error flag; = 0 => proper format for string +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ls + integer, intent(out) :: retcod + real, intent(out) :: flpout + character(len=*), intent(in) :: string + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: ios, l + + l = LEN_TRIM( string(:ls) ) + if( l == 0 ) then + retcod = -12 + else + read(string(:l),*,iostat=ios) flpout + if( ios == 0 ) then + retcod = 0 + else + retcod = -12 + end if + end if + + end subroutine RELCON + + subroutine NUMCON( string, & + num, & + jus ) +!----------------------------------------------------------------------- +! numcon converts a real number to a generalized +! e format character string +! +! inputs: +! +! num = real number to convert +! jus = character code for output string justification +! 'l' = left justify +! 'c' = center +! 'r' = right justify +! +! outputs: +! +! string = converted character string +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real, intent(in) :: num + character(len=*), intent(out) :: string + character(len=1), intent(in) :: jus + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: wpart, il, i, iu + real :: frac + character(len=16) :: mask + character(len=8) :: copy(2) + + equivalence (mask,copy) + + if( num == 0. ) then + string = '0' + else + wpart = INT( num ) + if( wpart == 0 ) then + il = 9 + else + write(copy(1),'(i8)') wpart + do i = 1,8 + if( copy(1)(i:i) /= ' ') then + go to 12 + end if + end do +12 il = i + end if + frac = num - INT( num ) + if( frac == 0. ) then + iu = 8 + else + if( wpart == 0 .and. frac < 0.e0 ) then + write(copy(2),'(f8.6)') frac + else + write(copy(2),'(f8.7)') ABS( frac ) + end if + do i = 8,2,-1 + if( copy(2)(i:i) /= '0') then + go to 22 + end if + end do +22 iu = i + 8 + end if + string = mask(il:iu) + end if + if( jus == 'c' ) then + call CENTER( string, 16 ) + end if + + end subroutine NUMCON + + subroutine CENTER( string, ls ) +!----------------------------------------------------------------------- +! ... Center a character string of length ls +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ls + character(len=*), intent(inout) :: string + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: offset, i, il, iu, len, j + character(len=320) :: copy + + len = MIN( ls,120 ) + copy(:len) = string(:len) + il = VERIFY( string(:len), ' ' ) + if( il /= 0) then + iu = VERIFY( string(:len), ' ', back = .true. ) + len = iu - il + 1 + offset = MAX( 0,(ls - len)/2 + 1) + string(:ls) = ' ' + string(offset:offset+len) = copy(il:iu) + end if + + end subroutine CENTER + + integer function LENOF( ls, string ) +!----------------------------------------------------------------------- +! ... Returns the length of a string by finding +! the first non-blank character from the right side +! of the input string. +! This function will not scan beyond ls characters +! in the input string. If the string consists of only +! blanks then an "error" value of zero is returned. +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: ls + character(len=*), intent(in) :: string + + LENOF = LEN_TRIM( string(:ls) ) + + end function LENOF + + integer function ALTCHK( alt, sptgrd, np ) + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: np + real, intent(in) :: alt + real, intent(in) :: sptgrd(np) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i + + ALTCHK = 0 + do i = 1,np + if( sptgrd(i) == alt ) then + ALTCHK = 1 + exit + end if + end do + + end function ALTCHK + + subroutine UPCASE( lstring ) +!---------------------------------------------------------------------- +! ... Convert character string lstring to upper case +!---------------------------------------------------------------------- + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + character(len=*), intent(inout) :: lstring + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i + + do i = 1,LEN_TRIM( lstring ) + if( ICHAR(lstring(i:i)) >= 97 .and. ICHAR(lstring(i:i)) <= 122 ) then + lstring(i:i) = CHAR(ICHAR(lstring(i:i)) - 32) + end if + end do + + end subroutine UPCASE + + integer function STRLEN ( string ) +!----------------------------------------------------------------------- +! ... Returns the length of a string by finding +! the first non-blank character from the right side +! of the input string. +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + character(len=*), intent(in) :: string + + STRLEN = LEN_TRIM( string ) + + end function STRLEN + + subroutine PARSE_FLPTH( fullpath, filename, filepath ) + + implicit none + +!------------------------------------------------------- +! ... Dummy args +!------------------------------------------------------- + character(len=*), intent(in) :: fullpath ! incoming full pathname + character(len=*), intent(out) :: filename ! the file name + character(len=*), intent(out) :: filepath ! the file path + +!------------------------------------------------------- +! ... Local variables +!------------------------------------------------------- + integer :: i + + i = INDEX( fullpath(:LEN_TRIM(fullpath)), '/', back = .true. ) + filename = fullpath(i+1:) + if( i /= 0 ) then + filepath = fullpath(:i) + else + filepath = ' ' + end if + + end subroutine PARSE_FLPTH + + logical function ISNUM( char ) + + implicit none + + character(len=1), intent(in) :: char + + if( char <= '9' .and. char >= '0' ) then + ISNUM = .true. + else + ISNUM = .false. + end if + + end function ISNUM + + subroutine MKDATE( time, date ) + + implicit none + +!------------------------------------------------------- +! ... Dummy args +!------------------------------------------------------- + real, intent(in) :: time ! time to convert in days + character(len=6), intent(out) :: date ! date in form yymmdd + +!------------------------------------------------------- +! ... Local variables +!------------------------------------------------------- + integer :: years, days + integer :: mnth + integer :: mdys(0:12) = (/ 0, 31, 59, 90, 120, 151, & + 181, 212, 243, 273, 304, 334, 365 /) + + years = INT( time/365. ) + if( years > 1900 ) then + years = years - 1900 + end if + write(date(1:2),'(i2)') years + + days = INT( time - REAL(years)*365. ) + do mnth = 1,12 + if( days <= mdys(mnth) ) then + exit + end if + end do + + mnth = MAX( 1,MIN( 12, mnth ) ) + if( mnth < 10 ) then + write(date(3:4),'(''0'',i1)') mnth + else + write(date(3:4),'(i2)') mnth + end if + + days = days - mdys(mnth-1) + if( days < 10 ) then + write(date(5:6),'(''0'',i1)') days + else + write(date(5:6),'(i2)') days + end if + + end subroutine MKDATE + + integer function INCLIST( target, list, cnt ) +!------------------------------------------------------- +! ... Check for match in character list +!------------------------------------------------------- + + implicit none + +!------------------------------------------------------- +! ... Input arguments +!------------------------------------------------------- + integer, intent(in) :: cnt ! no elements in list + character(len=*), intent(in) :: target ! match string + character(len=*), intent(in) :: list(*) ! list to search + +!------------------------------------------------------- +! ... Local variables +!------------------------------------------------------- + integer :: i + + INCLIST = 0 + do i = 1,cnt + if( target == list(i) ) then + INCLIST = i + exit + end if + end do + + end function INCLIST + + integer function INILIST( target, list, cnt ) +!------------------------------------------------------- +! ... Check for match in integer list +!------------------------------------------------------- + + implicit none + +!------------------------------------------------------- +! ... Input arguments +!------------------------------------------------------- + integer, intent(in) :: cnt ! no elements in list + integer, intent(in) :: target ! match integer + integer, intent(in) :: list(*) ! list to search + +!------------------------------------------------------- +! ... Local variables +!------------------------------------------------------- + integer :: i + + INILIST = 0 + do i = 1,cnt + if( target == list(i) ) then + INILIST = i + exit + end if + end do + + end function INILIST + + subroutine r2c( string, num, jus ) +!----------------------------------------------------------------------- +! r2c converts a real number to a generalized e format character string +! +! inputs: +! +! num = real number to convert +! jus = character code for output string justification +! 'l' = left justify +! 'c' = center +! 'r' = right justify +! +! outputs: +! +! char = converted character string +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real, intent(in) :: num + character(len=*), intent(out) :: string + character(len=1) :: jus + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + real, parameter :: epsilon = .0000005 + + integer :: wpart, il, i, iu + integer :: power + real :: frac + real :: wrk_num + character(len=24) :: mask + character(len=8) :: copy(3) + + equivalence (mask,copy) + + if( num == 0. ) then + string = '0' + else + wrk_num = num + power = 0 + if( abs(wrk_num) < 1.e-4 ) then + power = 1 + wrk_num = wrk_num + do while( power < 40 ) + wrk_num = 10.*wrk_num + if( abs(wrk_num) >= 1. ) then + go to 100 + end if + power = power + 1 + end do + string = '0' + return + end if + +100 wrk_num = wrk_num + epsilon + wpart = int( wrk_num ) + if( wpart == 0 ) then + il = 9 + else + write(copy(1),'(i8)') wpart + do i = 1,8 + if( copy(1)(i:i) /= ' ') then + exit + end if + end do + il = i + end if + frac = wrk_num - int(wrk_num) + if( frac == 0. ) then + mask(9:9) = '.' + iu = 9 + else + if( wpart == 0 .and. frac < 0.e0 ) then + write(copy(2),'(f8.6)') frac + else + write(copy(2),'(f8.7)') abs(frac) + end if + do i = 8,2,-1 + if( copy(2)(i:i) /= '0') then + exit + end if + end do + iu = i + 8 + end if + if( frac /= 0. ) then + if( mask(iu-3:iu-1) == '000') then + iu = iu - 4 + else if( mask(iu-4:iu-2) == '000' ) then + iu = iu - 5 + end if + end if + if( power /= 0 ) then + if( power < 10 ) then + write(mask(iu+1:),'(''e'',i2)') -power + iu = iu + 3 + else + write(mask(iu+1:),'(''e'',i3)') -power + iu = iu + 4 + end if + end if + if( num > 0. ) then + string = mask(il:iu) + else + string = '(' // mask(il:iu) // ')' + end if + end if + + if( jus == 'c' ) then + call center( string, 16 ) + end if + + end subroutine r2c + + integer function XLATE( match ) +!------------------------------------------------------------------------ +! ... Translate between overall indexing and method indexing +!------------------------------------------------------------------------ + + use VAR_MOD, only : var_lim, clsmap + + implicit none + +!------------------------------------------------------------------------ +! ... Dummy args +!------------------------------------------------------------------------ + integer, intent(inout) :: match + +!------------------------------------------------------------------------ +! ... Local variables +!------------------------------------------------------------------------ + integer :: class + + do class = 1,5 + if( clsmap(match,class,1) /= 0 ) then + match = clsmap(match,class,1) + XLATE = class + return + end if + end do + + XLATE = 0 + + end function XLATE diff --git a/chem_proc/src/cam_chempp/nln_code.f b/chem_proc/src/cam_chempp/nln_code.f new file mode 100644 index 0000000000..18f76ba7bc --- /dev/null +++ b/chem_proc/src/cam_chempp/nln_code.f @@ -0,0 +1,990 @@ + + module nln_matrix + + use io, only : temp_path + + implicit none + + character(len=9) :: spc_cnt + character(len=4) :: hdr, up_hdr + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + + contains + + subroutine make_nln( clscnt, clsmap, cls_rxt_cnt, cls_rxt_map, pcoeff_ind, & + pcoeff, permute, mat_map, class, & + lin_mat_pat, nzcnt, diag_map, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran code for the non-linear components +! of the Jacobian matrix +!----------------------------------------------------------------------- + + use var_mod, only : var_lim + use rxt_mod, only : rxt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: clscnt ! count of class members + integer, intent(in) :: class ! class index + integer, intent(in) :: nzcnt ! matrix non-zero count + integer, intent(in) :: clsmap(var_lim,5,2) + integer, intent(in) :: cls_rxt_map(rxt_lim,prd_lim+3) + integer, intent(in) :: cls_rxt_cnt(4) ! class rxtns count + integer, intent(in) :: permute(clscnt) + integer, intent(in) :: mat_map(clscnt,clscnt) + integer, intent(in) :: diag_map(:) + integer, intent(in) :: pcoeff_ind(*) ! map for nonunity prod + real, intent(in) :: pcoeff(prd_lim,*) + character(len=16), intent(in) :: march ! target architecture + character(len=16), intent(in) :: model ! target model + logical, intent(in) :: lin_mat_pat(:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_len = 90 + integer, parameter :: max_lines = 200 + integer :: i, j, k, l, m, m2, n, r1, r2 + integer :: length, index, pindx, mat_ind + integer :: row, col, sub_cnt + integer :: line_pos, buf_pos, rxno, target, line_cnt + integer :: base + integer :: species + integer :: match_cnt + integer :: list_cnt + integer :: rxtnt_cnt, rxtnt1, rxtnt2 + integer :: other_ind + integer :: match_ind(rxt_lim) + integer :: rxt_match_ind(rxt_lim) + integer :: scan(rxt_lim,4) + integer :: rxtnt(2) + real :: rate + character(len=max_len+10) :: line + character(len=max_len) :: buff + character(len= 6) :: mat_piece, rxt_piece + character(len= 4) :: sol_piece, num, num1 + logical :: beg_line + logical :: lexist + logical, allocatable :: nln_mat_pat(:) + logical :: hdr_made = .false. + + allocate( nln_mat_pat(nzcnt),stat=pindx ) + if( pindx /= 0 ) then + stop + end if + nln_mat_pat(:) = .false. + + if( class == 4 ) then + inquire( file = trim( temp_path ) // 'nlnmat.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'nlnmat.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'nlnmat.F' ) + if( model /= 'CAM' ) then + up_hdr = 'imp_' + hdr = 'imp_' + else + up_hdr = ' ' + hdr = ' ' + end if + else + open( unit = 30, file = trim( temp_path ) // 'nlnmat.F', position='append' ) + up_hdr = 'rod_' + hdr = 'rod_' + end if + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + spc_cnt = 'gas_pcnst' + else + num_suffix = ' ' + dec_suffix = ' ' + spc_cnt = 'pcnstm1' + end if + + line_cnt = 0 + line = ' ' + write(30,100) trim(line) + line = ' module mo_' // trim(up_hdr) // 'nln_matrix' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'CAM' ) then + line = ' use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if ( march == 'VECTOR' ) then + line = ' use chem_mods, only: veclen' + write(30,100) trim(line) + end if + end if + line = ' private' + write(30,100) trim(line) + line = ' public :: nlnmat' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' contains' + write(30,100) trim(line) + if( clscnt == 0 .or. cls_rxt_cnt(3) == 0 ) then + sub_cnt = 0 + else + sub_cnt = 1 + end if + call make_nln_hdr( sub_cnt, march, model ) + if (sub_cnt>0) hdr_made = .true. + + select case ( march ) + case( 'SCALAR' ) + mat_piece = 'mat(' + rxt_piece = 'rxt(' + sol_piece = 'y(' + case default + mat_piece = 'mat(k,' + rxt_piece = 'rxt(k,' + sol_piece = 'y(k,' + end select + + base = sum( cls_rxt_cnt(:2) ) +Species_loop : & + do species = 1,clscnt + target = clsmap(species,class,2) + line = ' ' +!----------------------------------------------------------------------- +! ... Write code for nonlinear loss entries +!----------------------------------------------------------------------- + match_cnt = 0 + do k = base+1,base+cls_rxt_cnt(3) +!----------------------------------------------------------------------- +! ... Find all reactions with target reactant +!----------------------------------------------------------------------- + other_ind = 0 + do l = 2,3 + if( cls_rxt_map(k,l) == target ) then + if( other_ind == 0 ) then + match_cnt = match_cnt + 1 + scan(match_cnt,1) = k + if( l == 2 ) then + scan(match_cnt,2) = abs(cls_rxt_map(k,3)) + else + scan(match_cnt,2) = abs(cls_rxt_map(k,2)) + end if + scan(match_cnt,4) = l + end if + other_ind = other_ind + 1 + end if + end do + end do +!----------------------------------------------------------------------- +! ... Write the diagonal loss entry +!----------------------------------------------------------------------- + if( match_cnt > 0 ) then + scan(:match_cnt,3) = scan(:match_cnt,2) + pindx = permute(species) + mat_ind = mat_map(pindx,pindx) + write(num,'(i4)') mat_map(pindx,pindx) + num = adjustl( num ) + n = len_trim( num ) + line = ' ' + line(10:) = trim( mat_piece ) // num(:n) // ') = -(' + line_pos = len_trim( line ) + 1 + beg_line = .true. + end if + list_cnt = match_cnt + do while( list_cnt > 0 ) + do j = 1,match_cnt + if( scan(j,2) /= 0 ) then + index = scan(j,2) + exit + end if + end do + m = 0 + do j = 1,match_cnt + if( scan(j,2) == index ) then + m = m + 1 + match_ind(m) = j + scan(j,2) = 0 + list_cnt = list_cnt - 1 + end if + end do + do j = 1,m + l = match_ind(j) + rxno = cls_rxt_map(scan(l,1),1) + buff = ' ' + buf_pos = 1 + if( j == 1 .and. m > 1 ) then + if( scan(l,3) == target ) then + buff(buf_pos:) = '(4.' // trim(num_suffix) // '*' + else + buff(buf_pos:) = '(' + end if + else if( scan(l,3) == target ) then + buff(buf_pos:) = '4.' // trim(num_suffix) // '*' + end if + write(num,'(i4)') rxno + num = adjustl( num ) + n = len_trim( num ) + buff(len_trim(buff)+1:) = trim( rxt_piece ) // num(:n) // ')' + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + if( beg_line ) then + line(line_pos:) = buff(:length) + beg_line = .false. + else + line(line_pos:) = ' + ' // buff(:length) + end if + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end do + write(num,'(i4)') scan(l,3) + num = adjustl( num ) + if( m > 1 ) then + buff = ') * ' // trim( sol_piece ) // num(:len_trim(num)) // ')' + else + buff = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + end if + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + line(line_pos:) = buff(:length) + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = buff(:length) + end if + line_pos = len_trim( line ) + 1 + nln_mat_pat(mat_ind) = .true. + end do + if( match_cnt /= 0 ) then + line(len_trim(line)+1:) = ')' + end if + if( line /= ' ' ) then + write(30,100) trim(line) + line_cnt = line_cnt + 1 + end if + +!----------------------------------------------------------------------- +! ... Write nondiagonal loss entries +!----------------------------------------------------------------------- + list_cnt = match_cnt + do j = 1,match_cnt + if( scan(j,3) == target ) then + scan(j,2) = 0 + list_cnt = list_cnt - 1 + else + scan(j,2) = scan(j,3) + end if + end do + do while( list_cnt > 0 ) + do j = 1,match_cnt + if( scan(j,2) /= 0 ) then + index = scan(j,2) + exit + end if + end do + m = 0 + do j = 1,match_cnt + if( scan(j,2) == index ) then + m = m + 1 + match_ind(m) = j + scan(j,2) = 0 + list_cnt = list_cnt - 1 + end if + end do + pindx = permute(clsmap(index,class,1)) + mat_ind = mat_map(permute(species),pindx) + write(num,'(i4)') mat_map(permute(species),pindx) + num = adjustl( num ) + n = len_trim( num ) + line = ' ' + line(10:) = trim( mat_piece ) // num(:n) // ') = -' + line_pos = len_trim( line ) + 1 + if( m > 0 ) then + beg_line = .true. + nln_mat_pat(mat_ind) = .true. + else + if( model /= 'CAM' ) then + line(line_pos:) = '0.' + else + line(line_pos:) = '0._r8' + end if + end if + do j = 1,m + l = match_ind(j) + rxno = cls_rxt_map(scan(l,1),1) + buff = ' ' + if( j == 1 .and. m > 1 ) then + buff = '(' + buf_pos = 2 + else + buf_pos = 1 + end if + write(num,'(i4)') rxno + num = adjustl( num ) + n = len_trim( num ) + buff(buf_pos:) = trim( rxt_piece ) // num(:n) // ')' + if( j == 1 ) then + if ( scan(l,4) == 2 ) then + index = 3 + else + index = 2 + end if + end if + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + if( beg_line ) then + line(line_pos:) = buff(:length) + beg_line = .false. + else + line(line_pos:) = ' + ' // buff(:length) + end if + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end do + write(num,'(i4)') target + num = adjustl( num ) + if( m > 1 ) then + buff = ') * '// trim( sol_piece ) // num(:len_trim(num)) // ')' + else + buff = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + end if + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + line(line_pos:) = buff(:length) + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = buff(:length) + end if + write(30,100) trim(line) + line_cnt = line_cnt + 1 + end do + line = ' ' + write(30,100) trim(line) + +!----------------------------------------------------------------------- +! ... Scan for production matches +!----------------------------------------------------------------------- + match_cnt = 0 +Product_match : & + do k = base+1,base+cls_rxt_cnt(3) + other_ind = 0 + do l = 4,prd_lim+3 + if( cls_rxt_map(k,l) == species ) then + if( other_ind == 0 ) then + match_cnt = match_cnt + 1 + scan(match_cnt,1) = k + scan(match_cnt,2) = abs(cls_rxt_map(k,2)) + scan(match_cnt,4) = abs(cls_rxt_map(k,3)) + end if + other_ind = other_ind + 1 + end if + end do + if( other_ind /= 0 ) then + scan(match_cnt,3) = other_ind + end if + end do Product_match + if( match_cnt == 0 ) then + cycle + end if +!----------------------------------------------------------------------- +! ... "Order" the match list reactants +!----------------------------------------------------------------------- + do j = 1,match_cnt + if( scan(j,2) > scan(j,4) ) then + l = scan(j,2) + scan(j,2) = scan(j,4) + scan(j,4) = l + end if + end do +!----------------------------------------------------------------------- +! ... Search matching reactions for reactant match +!----------------------------------------------------------------------- +Reactant_match : & + do r1 = 1,clscnt + m = 0 + rxtnt1 = clsmap(r1,class,2) + do j = 1,match_cnt + if( scan(j,2) == rxtnt1 .or. scan(j,4) == rxtnt1 ) then + m = m + 1 + match_ind(m) = j + end if + end do + if( m == 0 ) then + cycle + end if + pindx = permute(clsmap(rxtnt1,class,1)) + mat_ind = mat_map(permute(species),pindx) + write(num,'(i4)') mat_ind + num = adjustl( num ) + line = ' ' + line(10:) = trim( mat_piece ) // num(:len_trim(num)) // ') =' + beg_line = .true. + if( nln_mat_pat(mat_ind) ) then + line_pos = len_trim(line) + 2 + line(line_pos:) = trim( mat_piece ) // num(:len_trim(num)) // ')' + beg_line = .false. + end if + nln_mat_pat(mat_ind) = .true. +Second_reactant_match : & + do r2 = 1,clscnt + m2 = 0 + rxtnt2 = clsmap(r2,class,2) + do n = 1,m + j = match_ind(n) + if( rxtnt2 /= rxtnt1 ) then + if( scan(j,2) == rxtnt2 .or. scan(j,4) == rxtnt2 ) then + m2 = m2 + 1 + rxt_match_ind(m2) = j + end if + else if( scan(j,2) == rxtnt2 .and. scan(j,4) == rxtnt2 ) then + m2 = m2 + 1 + rxt_match_ind(m2) = j + end if + end do + if( m2 == 0 ) then + cycle + end if + if( .not. beg_line ) then + line(len_trim(line)+2:) = '+' + else + beg_line = .false. + end if + if( m2 > 1 ) then + line(len_trim(line)+2:) = '(' + line_pos = len_trim( line ) + 1 + else + line_pos = len_trim( line ) + 2 + end if +Rates_loop : & + do n = 1,m2 +!----------------------------------------------------------------------- +! ... The reaction rate +!----------------------------------------------------------------------- + l = rxt_match_ind(n) + rxno = cls_rxt_map(scan(l,1),1) + index = pcoeff_ind(rxno) + rate = 0. + if( index /= 0 ) then + do i = 4,prd_lim+3 + if( cls_rxt_map(scan(l,1),i) == species ) then + rate = rate + pcoeff(i-3,index) + end if + end do + else if( scan(l,3) /= 1 ) then + rate = REAL(scan(l,3)) + end if + if( rxtnt1 == rxtnt2 ) then + if( rate == 0. ) then + rate = 2. + else + rate = 2.*rate + end if + end if + buff = ' ' + if( n > 1 .and. m2 > 1 ) then + buff = '+' + end if + if( rate /= 0. .and. rate /= 1. ) then + call r2c( buff(len_trim(buff)+1:), rate, 'l' ) + buff(len_trim(buff)+1:) = trim(num_suffix) // '*' + end if + write(num,'(i4)') rxno + num = adjustl( num ) + buff(len_trim(buff)+1:) = trim( rxt_piece ) // num(:len_trim(num)) // ')' + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + line(line_pos:) = buff(:length) + else + if( line(len_trim(line):len_trim(line)) /= '+' ) then + line(len_trim(line)+1:) = ' &' + else + line(len_trim(line):) = ' &' + end if + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + if( buff(1:1) /= '+' ) then + line(23:) = '+ ' // buff(:length) + else + line(23:) = ' ' // buff(:length) + end if +! line(23:) = '+ ' // buff(:length) + end if + line_pos = len_trim( line ) + 1 + end do Rates_loop +!----------------------------------------------------------------------- +! ... The reactant +!----------------------------------------------------------------------- + if( m2 > 1 ) then + line(len_trim(line)+1:) = ')' + line_pos = len_trim( line ) + 1 + end if + write(num,'(i4)') rxtnt2 + num = adjustl( num ) + buff = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + length = len_trim(buff) + if( (line_pos + length) <= max_len-3 ) then + line(line_pos:) = buff(:length) + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line_cnt = line_cnt + 1 + line = ' ' + line(23:) = buff(:length) + end if + end do Second_Reactant_match + write(30,100) trim(line) + line_cnt = line_cnt + 1 + end do Reactant_match + line = ' ' + write(30,100) trim(line) + if( line_cnt > max_lines ) then + if( march /= 'SCALAR' ) then + line = ' end do' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + write(num,'(i3)') 100+sub_cnt + write(line,'('' end subroutine '',a,''nlnmat'',a)') up_hdr,num(2:3) + write(30,100) trim(line) + hdr_made = .false. + line_cnt = 0 + if( species /= clscnt ) then + sub_cnt = sub_cnt + 1 + call make_nln_hdr( sub_cnt, march, model ) + hdr_made = .true. + end if + end if + end do Species_loop + if ( hdr_made ) then + if( march /= 'SCALAR' ) then + line = ' end do' + write(30,100) trim(line) + end if + + line = ' ' + write(30,100) trim(line) + write(num,'(i3)') 100+sub_cnt + write(line,'('' end subroutine '',a,''nlnmat'',a)') up_hdr,num(2:3) + write(30,100) trim(line) + end if +!----------------------------------------------------------------------- +! ... Make the inclusion routine +!----------------------------------------------------------------------- + if( clscnt > 0 ) then + if( cls_rxt_cnt(3) == 0 ) then + if( model == 'MOZART' ) then + select case( march ) + case ( 'VECTOR' ) + write(line,'('' call '',a,''nlnmat_finit( avec_len, mat, lmat, dti )'')') up_hdr + case default + write(line,'('' call '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + end select + else + if ( march == 'VECTOR' ) then + write(line,'('' call '',a,''nlnmat_finit( avec_len, mat, lmat, dti )'')') up_hdr + else + write(line,'('' call '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + endif + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' end subroutine ' // trim(up_hdr) // 'nlnmat' + write(30,100) trim(line) + end if + call make_nln_hdr( -1, march, model ) + line = ' ' + do n = 1,size(lin_mat_pat) + if( lin_mat_pat(n) ) then + write(num,'(i4)') n + m = len_trim( num ) + if( nln_mat_pat(n) ) then + line(10:) = trim( mat_piece ) // num(:m) // ') = ' // trim(mat_piece) // num(:m) // ') + l' & + // trim(mat_piece) // num(:m) // ')' + else + line(10:) = trim( mat_piece ) // num(:m) // ') = l' // trim(mat_piece) // num(:m) // ')' + end if + write(30,100) trim(line) + end if + end do + line = ' ' + do n = 1,size(lin_mat_pat) + if( .not. lin_mat_pat(n) .and. .not. nln_mat_pat(n) ) then + write(num,'(i4)') n + m = len_trim( num ) + if( model /= 'CAM' ) then + line(10:) = trim( mat_piece ) // num(:m) // ') = 0.' + else + line(10:) = trim( mat_piece ) // num(:m) // ') = 0._r8' + end if + write(30,100) trim(line) + end if + end do + do n = 1,size(diag_map) + l = diag_map(n) + if( lin_mat_pat(l) .or. nln_mat_pat(l) ) then + write(num,'(i4)') l + m = len_trim( num ) + if( model == 'CAM' .and. march == 'VECTOR' ) then + line(10:) = trim( mat_piece ) // num(:m) // ') = ' // trim(mat_piece) // num(:m) // ') - dti(k)' + else + line(10:) = trim( mat_piece ) // num(:m) // ') = ' // trim(mat_piece) // num(:m) // ') - dti' + endif + else + write(num,'(i4)') l + m = len_trim( num ) + if( model == 'CAM' .and. march == 'VECTOR' ) then + line(10:) = trim( mat_piece ) // num(:m) // ') = -dti(k)' + else + line(10:) = trim( mat_piece ) // num(:m) // ') = -dti' + endif + end if + write(30,100) trim(line) + end do + if( march /= 'SCALAR' ) then + line = ' end do' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line = ' end subroutine ' // trim(up_hdr) // 'nlnmat_finit' + write(30,100) trim(line) + end if +!----------------------------------------------------------------------- +! ... Now make the driver routine +!----------------------------------------------------------------------- + if( clscnt > 0 .and. cls_rxt_cnt(3) > 0 ) then + call make_nln_hdr( 0, march, model ) + end if + do n = 1,sub_cnt + write(num,'(i3)') 100+n + select case( march ) + case ( 'SCALAR' ) + write(line,'('' call '',a,''nlnmat'',a,''( mat, y, rxt )'')') up_hdr,num(2:3) + case ( 'VECTOR' ) + write(line,'('' call '',a,''nlnmat'',a,''( avec_len, mat, y, rxt )'')') & + up_hdr,num(2:3) + case default + if( model /= 'CAM' ) then + write(line,'('' call '',a,''nlnmat'',a,''( mat, y, rxt )'')') up_hdr,num(2:3) + else + write(line,'('' call '',a,''nlnmat'',a,''( mat, y, rxt, cols )'')') up_hdr,num(2:3) + end if + end select + write(30,100) trim(line) + end do + if( clscnt > 0 .and. cls_rxt_cnt(3) > 0 ) then + select case( march ) + case ( 'SCALAR' ) + write(line,'('' call '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + case ( 'VECTOR' ) + write(line,'('' call '',a,''nlnmat_finit( avec_len, mat, lmat, dti )'')') up_hdr + case default + if( model /= 'CAM' ) then + write(line,'('' call '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + else + write(line,'('' call '',a,''nlnmat_finit( mat, lmat, dti, cols )'')') up_hdr + end if + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' end subroutine ' // trim(up_hdr) // 'nlnmat' + write(30,100) trim(line) + end if + if( clscnt == 0 ) then + line = ' ' + write(30,100) trim(line) + line = ' end subroutine ' // trim(up_hdr) // 'nlnmat' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line = ' end module mo_' // trim(up_hdr) // 'nln_matrix' + write(30,100) trim(line) + + if( allocated( nln_mat_pat ) ) then + deallocate( nln_mat_pat ) + end if + + close( 30 ) + +100 format(a) + + end subroutine make_nln + + subroutine make_nln_hdr( sub_cnt, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran header code for the non-linear components +! of the Jacobian matrix +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: sub_cnt ! subroutine counter + character(len=16), intent(in) :: march ! targe architecture + character(len=16), intent(in) :: model ! target model + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: length + character(len=132) :: line + character(len=3) :: num + + line = ' ' + write(30,100) trim(line) + write(num,'(i3)') 100+sub_cnt + select case( march ) + case ( 'SCALAR' ) + if( sub_cnt > 0 ) then + write(line,'('' subroutine '',a,''nlnmat'',a,''( mat, y, rxt )'')') up_hdr,num(2:3) + else if( sub_cnt < 0 ) then + write(line,'('' subroutine '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + else + write(line,'('' subroutine '',a,''nlnmat( mat, y, rxt, lmat, dti )'')') up_hdr + end if + case ( 'VECTOR' ) + if( sub_cnt > 0 ) then + write(line,'('' subroutine '',a,''nlnmat'',a,''( avec_len, mat, y, rxt )'')') up_hdr,num(2:3) + else if( sub_cnt < 0 ) then + write(line,'('' subroutine '',a,''nlnmat_finit( avec_len, mat, lmat, dti )'')') up_hdr + else + write(line,'('' subroutine '',a,''nlnmat( avec_len, mat, y, rxt, lmat, dti )'')') up_hdr + end if + case default + if( model /= 'CAM' ) then + if( sub_cnt > 0 ) then + write(line,'('' subroutine '',a,''nlnmat'',a,''( mat, y, rxt )'')') up_hdr,num(2:3) + else if( sub_cnt < 0 ) then + write(line,'('' subroutine '',a,''nlnmat_finit( mat, lmat, dti )'')') up_hdr + else + write(line,'('' subroutine '',a,''nlnmat( mat, y, rxt, lmat, dti )'')') up_hdr + end if + else + if( sub_cnt > 0 ) then + write(line,'('' subroutine '',a,''nlnmat'',a,''( mat, y, rxt, cols )'')') up_hdr,num(2:3) + else if( sub_cnt < 0 ) then + write(line,'('' subroutine '',a,''nlnmat_finit( mat, lmat, dti, cols )'')') up_hdr + else + write(line,'('' subroutine '',a,''nlnmat( mat, y, rxt, lmat, dti, cols )'')') up_hdr + end if + end if + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + select case( march ) + case( 'SCALAR' ) + if( model /= 'WRF' ) then + if( model == 'MOZART' ) then + line = ' use mo_grid, only : ' // trim(spc_cnt) + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt' + else + line = ' use chem_mods, only : gas_pcnst, rxntot, ' // hdr // 'nzcnt' + end if + else + line = ' ' + end if + case ( 'VECTOR' ) + if( model == 'MOZART' ) then + line = ' use mo_grid, only : plnplv, ' // trim(spc_cnt) + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt' + elseif( march == 'VECTOR' ) then + line = ' use chem_mods, only : gas_pcnst, rxntot, nzcnt' + end if + case default + if( model == 'MOZART' ) then + line = ' use mo_grid, only : ' // trim(spc_cnt) + write(30,100) trim(line) + line = ' use chem_mods, only : rxntot, ' // hdr // 'nzcnt, clsze' + else if( model == 'CAM' ) then + line = ' use chem_mods, only : gas_pcnst, rxntot, nzcnt, clsze' + write(30,100) trim(line) + line = ' ' + end if + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + if( model == 'CAM' .and. march == 'CACHE' ) then + line = ' integer, intent(in) :: cols' + write(30,100) trim(line) + end if + select case( march ) + case( 'SCALAR' ) + if( sub_cnt <= 0 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: dti' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: lmat(' // trim(hdr) // 'nzcnt)' + write(30,100) trim(line) + else + line = ' real, intent(in) :: lmat(:)' + write(30,100) trim(line) + end if + end if + if( sub_cnt >= 0 ) then + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(' // trim(spc_cnt) // ')' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(rxntot)' + write(30,100) trim(line) + else + line = ' real, intent(in) :: y(:)' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(:)' + write(30,100) trim(line) + end if + end if + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(inout) :: mat(' // trim(hdr) // 'nzcnt)' + else + line = ' real, intent(inout) :: mat(:)' + end if + case ( 'VECTOR' ) + line = ' integer, intent(in) :: avec_len' + write(30,100) trim(line) + if( sub_cnt <= 0 ) then + if( model /= 'CAM' ) then + line = ' real, intent(in) :: dti' + write(30,100) trim(line) + line = ' real, intent(in) :: lmat(plnplv,' // trim(hdr) // 'nzcnt)' + else + line = ' real(r8), intent(in) :: dti(veclen)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: lmat(veclen,nzcnt)' + end if + write(30,100) trim(line) + end if + if( sub_cnt >= 0 ) then + if( model /= 'CAM' ) then + line = ' real, intent(in) :: y(plnplv,' // trim(spc_cnt) // ')' + write(30,100) trim(line) + line = ' real, intent(in) :: rxt(plnplv,rxntot)' + else + line = ' real(r8), intent(in) :: y(veclen,gas_pcnst)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: rxt(veclen,rxntot)' + end if + write(30,100) trim(line) + end if + if( model /= 'CAM' ) then + line = ' real, intent(inout) :: mat(plnplv,' // hdr // 'nzcnt)' + else + line = ' real(r8), intent(inout) :: mat(veclen,nzcnt)' + end if + case ( 'CACHE' ) + if( sub_cnt <= 0 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: dti' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: lmat(clsze,' // trim(hdr) // 'nzcnt)' + write(30,100) trim(line) + end if + if( sub_cnt >= 0 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(clsze,' // trim(spc_cnt) // ')' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(clsze,rxntot)' + write(30,100) trim(line) + end if + line = ' real' // trim(dec_suffix) // ', intent(inout) :: mat(clsze,' // trim(hdr) // 'nzcnt)' + case default + if( sub_cnt <= 0 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: dti' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: lmat(plnplv,' // trim(hdr) // 'nzcnt)' + write(30,100) trim(line) + end if + if( sub_cnt >= 0 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(plnplv,' // trim(spc_cnt) // ')' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(plnplv,rxntot)' + write(30,100) trim(line) + end if + line = ' real' // trim(dec_suffix) // ', intent(inout) :: mat(plnplv,' // trim(hdr) // 'nzcnt)' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( sub_cnt /= 0 ) then + line = ' ' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + if( march /= 'SCALAR' ) then + line = ' integer :: k' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + + line = '!----------------------------------------------' + write(30,100) trim(line) + line = '! ... complete matrix entries' + length = len_trim( line ) + 2 + line(length:) = 'implicit species' + write(30,100) trim(line) + line = '!----------------------------------------------' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( march == 'VECTOR' ) then + line(7:) = 'do k = 1,avec_len' + else if( march == 'CACHE' ) then + if( model == 'MOZART' ) then + line(7:) = 'do k = 1,clsze' + else if( model == 'CAM' ) then + line(7:) = 'do k = 1,cols' + end if + end if + write(30,100) trim(line) + end if + +100 format(a) + + end subroutine make_nln_hdr + + end module nln_matrix diff --git a/chem_proc/src/cam_chempp/num_ctl.f b/chem_proc/src/cam_chempp/num_ctl.f new file mode 100644 index 0000000000..c3c46b0ab2 --- /dev/null +++ b/chem_proc/src/cam_chempp/num_ctl.f @@ -0,0 +1,96 @@ + + subroutine NUM_CTL( iter_counts ) + + use IO + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(inout) :: iter_counts(4) ! iteration counts + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_parm = 4 + integer :: kpar, nchar, k + integer :: parsw(max_parm) + integer :: retcod + character(len=20) :: keywrd + character(len=20) :: parkey(max_parm) + logical :: found + + parkey(1) = 'HOVITERATIONS' + parkey(2) = 'IMPLICITITERATIONS' + parkey(3) = 'JACOBIANITERATIONS' + parkey(4) = 'EBIITERATIONS' + + parsw = 0 + +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE ( buffh ) + if( buffh == 'ENDNUMERICALCONTROL' ) then + exit + end if + k = INDEX( buffh(:nchar), '=' ) + if( k /= 0 ) then + found = .false. + keywrd = buffh(:k-1) + do kpar = 1,max_parm + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + else +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call ERRMES ( ' Num ctl specification has no = operator@', lout, buff, 1, buff ) + end if +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + if( .not. found ) then + call ERRMES ( ' # is an invalid Num control parameter keyword@', & + lout, & + keywrd, & + LEN_TRIM(keywrd), & + buffh ) +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + else if( parsw(kpar) /= 0 ) then + call ERRMES( '0 *** # has already been specified@', lout, parkey(kpar), k, ' ' ) + end if + +!----------------------------------------------------------------------- +! ... Set individual iteration counts +!----------------------------------------------------------------------- + call INTCON( buff(k+1:nchar), nchar - k, iter_counts(kpar), retcod ) +!----------------------------------------------------------------------- +! ... Check itertion limit for validity +!----------------------------------------------------------------------- + if( retcod /= 0 ) then + call ERRMES ( ' # is an invalid iteration count@', & + lout, & + buff(k+1:nchar), & + nchar - k, & + buffh ) + else if( iter_counts(kpar) <= 0 ) then + call ERRMES ( ' # is an invalid iteration count@', & + lout, & + buff(k+1:nchar), & + nchar - k, & + buffh ) + end if + parsw(kpar) = 1 + end do + + end subroutine NUM_CTL diff --git a/chem_proc/src/cam_chempp/outp.f b/chem_proc/src/cam_chempp/outp.f new file mode 100644 index 0000000000..bf626d2f88 --- /dev/null +++ b/chem_proc/src/cam_chempp/outp.f @@ -0,0 +1,222 @@ + + subroutine OUTP( rxparms, & + nr, & + np, & + rxtsym, & + prdsym, & + sym_rate, & + irxn, & + rate, & + loc_rxt_alias, & + lout ) + + use RXT_MOD, only : rxtnt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! OUTP OUTPuts a single reaction and rate +! +! Inputs: +! nr - number of reactants +! np - number of products +! rxparms - vector of "full" product terms (including +! multipliers) +! rxtsym - reactant symbol(s) +! prdsym - product symbol(s) +! irxn - reaction number +! rate - vector of reaction rate parameters +! lout - logical OUTPut unit number +! Outputs: +! NONE +!----------------------------------------------------------------------- + + integer, intent(in) :: nr, np, irxn, lout + real, intent(in) :: rate(:) + character(len=16), intent(in) :: rxparms(prd_lim) + character(len=16), intent(in) :: sym_rate(5) + character(len=16), intent(in) :: loc_rxt_alias + character(len=16), intent(in) :: rxtsym(rxtnt_lim), prdsym(prd_lim) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, j, k, kl, length, retcod, line_cnt + integer :: buff_pos, arrow_pos + real :: coeff + character(len=320) :: buff + character(len=64) :: rx_piece + + buff = ' ' + j = 1 + +!----------------------------------------------------------------------- +! ... Form the reactants +!----------------------------------------------------------------------- + do i = 1,nr + length = LEN_TRIM( rxtsym(i) ) + buff(j:length+j-1) = rxtsym(i)(:length) + j = length + j + 1 + if( i == nr ) then + buff(j:) = '->' + j = j + 3 + else + buff(j:) = '+' + j = j + 2 + end if + end do + buff_pos = j ; arrow_pos = j - 1 + +!----------------------------------------------------------------------- +! ... Form the products +!----------------------------------------------------------------------- + line_cnt = 1 + if( np /= 0 ) then + do i = 1,np + rx_piece = ' ' + j = 1 + length = INDEX( rxparms(i), '*' ) + if( length /= 0 ) then + read(rxparms(i)(:length-1),*,iostat=retcod) coeff + if( retcod /= 0 ) then + call ERRMES( ' # is not a valid real number@', & + lout, & + rxparms(i), & + length-1, & + buff ) + end if + if( coeff /= 1. ) then + length = length + 1 + rx_piece(:length) = rxparms(i)(:length-1) // '*' + j = length + end if + end if + length = LEN_TRIM( prdsym(i) ) + rx_piece(j:length+j-1) = prdsym(i)(:length) + length = LEN_TRIM( rx_piece ) + if( (buff_pos + length) <= 69 ) then + buff(buff_pos:) = TRIM( rx_piece ) + buff_pos = buff_pos + length + 1 + if( i /= np ) then + buff(buff_pos:buff_pos) = '+' + buff_pos = buff_pos + 2 + else + kl = line_cnt + do k = kl,3 + call WRITE_RXT( buff, sym_rate, rate, loc_rxt_alias, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + else + call WRITE_RXT( buff, sym_rate, rate, loc_rxt_alias, irxn, line_cnt ) + line_cnt = line_cnt + 1 + if( i /= np ) then + buff(arrow_pos:arrow_pos) = '+' + buff_pos = arrow_pos + 2 + else + kl = line_cnt + do k = kl,3 + call WRITE_RXT( buff, sym_rate, rate, loc_rxt_alias, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + end if + end do + else + buff(j:) = '(No products)' + do k = 1,3 + call WRITE_RXT( buff, sym_rate, rate, loc_rxt_alias, irxn, line_cnt ) + line_cnt = line_cnt + 1 + end do + end if + + end subroutine OUTP + + subroutine WRITE_RXT( buff, sym_rate, rate, loc_rxt_alias, irxn, line_cnt ) +!----------------------------------------------------------------------- +! ... Print the reaction rate +!----------------------------------------------------------------------- + + use IO, only : lout + use RXT_MOD, only : phtcnt + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: line_cnt, irxn + real, intent(in) :: rate(:) + character(len=320), intent(inout) :: buff + character(len=16), intent(in) :: sym_rate(:) + character(len=16), intent(in) :: loc_rxt_alias + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + logical :: troe_rate + + if( line_cnt <= 3 ) then + if( sym_rate(1) /= ' ' ) then + troe_rate = rate(1) /= 0. .and. rate(3) /= 0. + if( line_cnt == 1 ) then + if( rate(1) == 0. ) then + buff(69:) = ' rate = 0.' + write(lout,100) loc_rxt_alias, irxn, buff, irxn+phtcnt + else if( .not. troe_rate ) then + buff(69:) = ' rate = ' + write(buff(77:),'(1pe8.2)') rate(1) + if( rate(2) /= 0. ) then + buff(85:) = '*EXP(' + write(buff(90:),'(f8.0)') rate(2) + buff(98:) = '/t)' + end if + write(lout,100) loc_rxt_alias, irxn, buff, irxn+phtcnt + else + buff(69:) = ' troe : ko=' + write(buff(80:),'(1pe8.2)') rate(1) + if( rate(2) /= 0. ) then + buff(88:) = '*(300/t)**' + write(buff(98:),'(f4.2)') rate(2) + end if + write(lout,110) loc_rxt_alias, irxn, buff, irxn+phtcnt + end if + else if( troe_rate ) then + if( line_cnt == 2 ) then + buff(69:) = ' ki=' + write(buff(80:),'(1pe8.2)') rate(3) + if( rate(4) /= 0. ) then + if( rate(4) /= 1. ) then + buff(88:) = '*(300/t)**' + write(buff(98:),'(f4.2)') rate(4) + else + buff(88:) = '*(300/t)' + end if + end if + else if( line_cnt == 3 ) then + buff(69:) = ' f=' + write(buff(80:),'(f4.2)') rate(5) + end if + write(lout,120) buff + else if( buff /= ' ' ) then + write(lout,120) buff + end if + else + if( line_cnt == 1 ) then + buff(69:) = ' rate = ** User defined **' + write(lout,100) loc_rxt_alias, irxn, buff, irxn+phtcnt + end if + end if + else if( buff /= ' ' ) then + write(lout,120) buff + end if + buff = ' ' + +!----------------------------------------------------------------------- +! ... Formats +!----------------------------------------------------------------------- +100 format(2x,a8,1x,'(',i3,')',3x,a100,3x,'(',i3,')') +110 format(2x,a8,1x,'(',i3,')',3x,a101,2x,'(',i3,')') +120 format(19x,a101) + + end subroutine WRITE_RXT diff --git a/chem_proc/src/cam_chempp/padj_code.f b/chem_proc/src/cam_chempp/padj_code.f new file mode 100644 index 0000000000..9867923f9e --- /dev/null +++ b/chem_proc/src/cam_chempp/padj_code.f @@ -0,0 +1,191 @@ + + subroutine make_padj( fixmap, fixcnt, phtcnt, model, march ) +!----------------------------------------------------------------------- +! ... Write the photorate adjustment code +!----------------------------------------------------------------------- + + use var_mod, only : var_lim + use io, only : temp_path + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +!----------------------------------------------------------------------- + integer, intent(in) :: fixcnt + integer, intent(in) :: phtcnt + integer, intent(in) :: fixmap(var_lim,2) + character(len=*), intent(in) :: model + character(len=*), intent(in) :: march + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + integer :: k, rxno + character(len=72) :: line + logical :: first + logical :: lexist + + + inquire( file = trim( temp_path ) // 'mo_phtadj.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_phtadj.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_phtadj.F' ) + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_phtadj' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: phtadj' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line(7:) = 'subroutine phtadj( p_rate, inv, m, plnplv )' + case ( 'CAM' ) + line(7:) = 'subroutine phtadj( p_rate, inv, m, ncol, nlev )' + case ( 'WRF' ) + line(7:) = 'subroutine phtadj( p_rate, inv, m, n )' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line(7:) = 'use chem_mods, only : nfs, phtcnt' + write(30,100) trim(line) + end if + if( model == 'CAM' ) then + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line(7:) = 'implicit none' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line = ' integer, intent(in) :: plnplv' + case ( 'CAM' ) + line = ' integer, intent(in) :: ncol, nlev' + case ( 'WRF' ) + line = ' integer, intent(in) :: n' + end select + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line = ' real, intent(in) :: inv(plnplv,nfs)' + write(30,100) trim(line) + line = ' real, intent(in) :: m(plnplv)' + write(30,100) trim(line) + line = ' real, intent(inout) :: p_rate(plnplv,phtcnt)' + case( 'CAM' ) + line = ' real(r8), intent(in) :: inv(ncol,nlev,max(1,nfs))' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: m(ncol,nlev)' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: p_rate(ncol,nlev,max(1,phtcnt))' + case( 'WRF' ) + line = ' real, intent(in) :: inv(:,:)' + write(30,100) trim(line) + line = ' real, intent(in) :: m(:)' + write(30,100) trim(line) + line = ' real, intent(inout) :: p_rate(:,:)' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line = ' real :: im(plnplv)' + case( 'CAM' ) + line = ' integer :: k' + write(30,100) trim(line) + line = ' real(r8) :: im(ncol,nlev)' + case( 'WRF' ) + line = ' real :: im(n)' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + + if( model == 'CAM' ) then + line = ' do k = 1,nlev' + write(30,100) trim(line) + end if + + first = .true. + do k = 1,fixcnt + rxno = abs( fixmap(k,1) ) + if( fixmap(k,1) < 0 .and. rxno <= phtcnt ) then + if( first ) then + select case( model ) + case( 'CAM' ) + line(7:) = ' im(:ncol,k) = 1._r8 / m(:ncol,k)' + case default + line(7:) = 'im(:) = 1. / m(:)' + end select + write(30,100) trim(line) + line = ' ' + first = .false. + end if + select case( model ) + case( 'CAM' ) + write(line(7:),'('' p_rate(:,k,'',i3,'') = p_rate(:,k,'',i3,'')'')') rxno,rxno + line(len_trim(line)+2:) = ' * inv(:,k,' + write(line(len_trim(line)+1:),'(i2)') fixmap(k,2) + line(len_trim(line)+1:) = ') * im(:,k)' + case default + line(7:) = 'p_rate(:, ) = p_rate(:, )' + write(line(16:18),'(i3)') rxno + write(line(32:34),'(i3)') rxno + line(len_trim(line)+2:) = ' * inv(:,' + write(line(len_trim(line)+1:),'(i2)') fixmap(k,2) + line(len_trim(line)+1:) = ') * im(:)' + end select + write(30,100) trim(line) + end if + end do + + if( model == 'CAM') then + line = ' end do' + write(30,100) trim(line) + end if + + line = ' ' + write(30,100) trim(line) + line(7:) = 'end subroutine phtadj' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'end module mo_phtadj' + write(30,100) trim(line) + + close(30) + +100 format(a) + + end subroutine make_padj diff --git a/chem_proc/src/cam_chempp/params_hdr.f b/chem_proc/src/cam_chempp/params_hdr.f new file mode 100644 index 0000000000..9e21738700 --- /dev/null +++ b/chem_proc/src/cam_chempp/params_hdr.f @@ -0,0 +1,62 @@ + + subroutine PARAMS_HDR( plon, plonl, plat, plev, & + phtcnt, rxntot, & + adv_cnt, nadv_cnt, histout_cnt, & + chemistry, diffusion, convection, arch_type, & + filespec ) +!----------------------------------------------------------------------- +! ... Make the params.h file +!----------------------------------------------------------------------- + + use IO, only : lout + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: plon, plonl, plat, plev + integer, intent(in) :: phtcnt, rxntot + integer, intent(in) :: adv_cnt, nadv_cnt + integer, intent(in) :: histout_cnt(20,2) + logical, intent(in) :: chemistry, diffusion, convection + character(len=16), intent(in) :: arch_type + character(len=*), intent(in) :: filespec + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + integer :: ios + logical :: lexist + + INQUIRE( file = TRIM(filespec), exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm '//TRIM(filespec) ) + end if + OPEN( unit = 30, file = TRIM(filespec), iostat=ios ) + if( ios /= 0 ) then + write(lout,*) 'PARAMS_HDR: Failed to open simulation datafile ',TRIM(filespec),' ;error = ',ios + stop + end if + write(30,'(a)') '# ifndef PARAMS_H' + write(30,'(a)') '# define PARAMS_H' + write(30,'('' '')') + write(30,'(a)') '# define CALC_ETADOT' + if( diffusion ) then + write(30,'(a)') '# define DI_VDIFF' + else + write(30,'(a)') '# define AR_VDIFF' + end if + if( convection ) then + write(30,'(a)') '# define DI_CONV_CCM' + else + write(30,'(a)') '# define AR_CONV_CCM' + end if + write(30,'(a)') '# define DI_CLOUD_PHYS' + if( chemistry ) then + write(30,'(a)') '# define TROP_CHEM' + end if + write(30,'('' '')') + write(30,'(a)') '# endif' + + end subroutine PARAMS_HDR diff --git a/chem_proc/src/cam_chempp/pl_code.f b/chem_proc/src/cam_chempp/pl_code.f new file mode 100644 index 0000000000..f9dcb78d19 --- /dev/null +++ b/chem_proc/src/cam_chempp/pl_code.f @@ -0,0 +1,919 @@ + + module prod_loss + + use io, only : temp_path + + contains + + subroutine pl_code( spccnt, clscnt, clsmap, cls_rxt_cnt, cls_rxt_map, & + pcoeff_ind, pcoeff, permute, march, model ) +!----------------------------------------------------------------------- +! ... Write the fortran production and loss code +!----------------------------------------------------------------------- + + use var_mod, only : var_lim + use rxt_mod, only : rxt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +! +! The columns of the cls_rxt_cnt represent the reaction count +! for each class with the following row conontation: +! (1) - independent reactions +! (2) - linear reactions +! (3) - nonlinear reactions +! (4) - heterogeneous processes +!----------------------------------------------------------------------- + integer, intent(in) :: spccnt + integer, intent(in) :: clscnt(5), & + clsmap(var_lim,5,2), & + cls_rxt_map(rxt_lim,prd_lim+3,5), & + cls_rxt_cnt(4,5) + integer, intent(in) :: pcoeff_ind(rxt_lim) + integer, intent(in) :: permute(var_lim,5) + real, intent(in) :: pcoeff(prd_lim,rxt_lim) + character(len=16), intent(in) :: march + character(len=16), intent(in) :: model + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_len = 90 + integer, parameter :: explicit = 1 + integer, parameter :: ebi = 2 + integer, parameter :: hov = 3 + integer, parameter :: implicit = 4 + integer, parameter :: rodas = 5 + integer :: i, k, kl, ku, l, m, ml + integer :: length, index, cnt + integer :: line_pos, target + integer :: class + integer :: base + integer :: species + integer :: match_cnt + integer :: other_ind + integer :: match_ind(4) + integer :: max_loc(1) + integer :: freq(spccnt) + integer, allocatable :: indexer(:) + real :: rate + character(len=max_len) :: line + character(len=72) :: buff + character(len=14) :: het_piece + character(len= 9) :: l_piece + character(len= 9) :: p_piece + character(len= 8) :: rxt_piece + character(len= 6) :: sol_piece + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + character(len= 3) :: num + logical, allocatable :: match_mask(:,:) + logical, allocatable :: pmask(:,:) + logical :: beg_line + logical :: lexist, first + + inquire( file = trim( temp_path ) // 'prd_loss.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'prd_loss.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'prd_loss.F' ) + + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + line = ' module mo_prod_loss' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'CAM' ) then + line = ' use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( march == 'VECTOR' ) then + line = ' use chem_mods, only : veclen' + write(30,100) trim(line) + endif + line = ' private' + write(30,100) trim(line) + end if + do class = 1,5 + select case( class ) + case( 1 ) + line = ' public :: exp_prod_loss' + write(30,100) trim(line) + case( 4 ) + line = ' public :: imp_prod_loss' + write(30,100) trim(line) + end select + end do + line = ' ' + write(30,100) trim(line) + line = ' contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + +Class_loop : & + do class = 1,5 + if( class == ebi .or. class == hov ) then + cycle + else if( class == rodas .and. model /= 'MOZART' ) then + cycle + end if + if( march == 'SCALAR' ) then + select case( class ) + case( explicit ) + line = ' subroutine exp_prod_loss( prod, loss, y, rxt, het_rates )' + case( ebi ) + line = ' subroutine ebi_prod_loss( prod, loss, y, rxt, het_rates )' + case( hov ) + line = ' subroutine hov_prod_loss( prod, loss, y, rxt, het_rates )' + case( implicit ) + line = ' subroutine imp_prod_loss( prod, loss, y, rxt, het_rates )' + case( rodas ) + line = ' subroutine rodas_prod_loss( prod, loss, y, rxt, het_rates )' + end select + else if( march == 'VECTOR' ) then + select case( class ) + case( explicit ) + if( model /= 'CAM' ) then + line = ' subroutine exp_prod_loss( prod, loss, y, rxt, het_rates )' + else + line = ' subroutine exp_prod_loss( ofl, ofu, prod, loss, y, &' + write(30,100) trim(line) + line = ' rxt, het_rates, chnkpnts )' + end if + case( ebi ) + line = ' subroutine ebi_prod_loss( prod, loss, y, rxt, het_rates )' + case( hov ) + line = ' subroutine hov_prod_loss( prod, loss, y, rxt, het_rates )' + case( implicit ) + line = ' subroutine imp_prod_loss( avec_len, prod, loss, y, &' + write(30,100) trim(line) + line = ' rxt, het_rates )' + case( rodas ) + line = ' subroutine rodas_prod_loss( avec_len, prod, loss, y, &' + write(30,100) trim(line) + line = ' rxt, het_rates )' + end select + else + if( model == 'MOZART' ) then + select case( class ) + case( explicit ) + line = ' subroutine exp_prod_loss( prod, loss, y, rxt, het_rates )' + case( ebi ) + line = ' subroutine ebi_prod_loss( prod, loss, y, rxt, het_rates )' + case( hov ) + line = ' subroutine hov_prod_loss( prod, loss, y, rxt, het_rates )' + case( implicit ) + line = ' subroutine imp_prod_loss( prod, loss, y, rxt, het_rates )' + case( rodas ) + line = ' subroutine rodas_prod_loss( prod, loss, y, rxt, het_rates )' + end select + else if( model == 'CAM' ) then + select case( class ) + case( explicit ) + line = ' subroutine exp_prod_loss( prod, loss, y, rxt, het_rates )' + case( ebi ) + line = ' subroutine ebi_prod_loss( prod, loss, y, rxt, het_rates, cols )' + case( hov ) + line = ' subroutine hov_prod_loss( prod, loss, y, rxt, het_rates, cols )' + case( implicit ) + line = ' subroutine imp_prod_loss( prod, loss, y, rxt, het_rates, cols )' + case( rodas ) + line = ' subroutine rodas_prod_loss( prod, loss, y, rxt, het_rates, cols )' + end select + else if( model == 'WRF' ) then + select case( class ) + case( explicit ) + line = ' subroutine exp_prod_loss( prod, loss, y, rxt )' + case( ebi ) + line = ' subroutine ebi_prod_loss( prod, loss, y, rxt )' + case( hov ) + line = ' subroutine hov_prod_loss( prod, loss, y, rxt )' + case( implicit ) + line = ' subroutine imp_prod_loss( prod, loss, y, rxt )' + case( rodas ) + line = ' subroutine rodas_prod_loss( prod, loss, y, rxt )' + end select + end if + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + line = ' use ppgrid, only : pver' + elseif( class == explicit ) then + line = ' use chem_mods, only : gas_pcnst,rxntot,clscnt1' + elseif( class == implicit ) then + line = ' use chem_mods, only : gas_pcnst,rxntot,clscnt4' + end if + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line = ' implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy args' + write(30,100) line + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + if( model == 'CAM' ) then + if( class == implicit ) then + if( march == 'CACHE' ) then + line = ' integer :: cols' + write(30,100) trim(line) + elseif( march == 'VECTOR' ) then + line = ' integer, intent(in) :: avec_len' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', dimension(veclen,clscnt4), intent(out) :: &' + else + line = ' real' // trim(dec_suffix) // ', dimension(:,:), intent(out) :: &' + endif + else + if( march /= 'VECTOR' ) then + line = ' real' // trim(dec_suffix) // ', dimension(:,:,:), intent(out) :: &' + elseif( class == explicit ) then + line = ' integer, intent(in) :: ofl, ofu, chnkpnts' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', dimension(chnkpnts,max(1,clscnt1)), intent(out) :: &' + else + line = ' real' // trim(dec_suffix) // ', dimension(:,:), intent(out) :: &' + end if + end if + else + line = ' real' // trim(dec_suffix) // ', dimension(:,:), intent(out) :: &' + end if + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + if( march == 'SCALAR' .and. class /= explicit ) then + line = ' real' // trim(dec_suffix) // ', dimension(:), intent(out) :: &' + p_piece = 'prod(' + l_piece = 'loss(' + rxt_piece = 'rxt(' + het_piece = 'het_rates(' + sol_piece = 'y(' + else if( march == 'VECTOR' ) then + p_piece = 'prod(k,' + l_piece = 'loss(k,' + rxt_piece = 'rxt(k,' + het_piece = 'het_rates(k,' + sol_piece = 'y(k,' + else + if( class == explicit ) then + p_piece = 'prod(:,:,' + l_piece = 'loss(:,:,' + rxt_piece = 'rxt(:,:,' + het_piece = 'het_rates(:,:,' + sol_piece = 'y(:,:,' + else + p_piece = 'prod(k,' + l_piece = 'loss(k,' + rxt_piece = 'rxt(k,' + het_piece = 'het_rates(k,' + sol_piece = 'y(k,' + end if + end if + end if + write(30,100) trim(line) + line = ' prod, &' + write(30,100) trim(line) + line = ' loss' + write(30,100) trim(line) + if( class == explicit ) then + if( model /= 'CAM' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:,:)' + write(30,100) trim(line) + end if + else + if( march /= 'VECTOR' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:,:,:)' + else + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(chnkpnts,gas_pcnst)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(chnkpnts,rxntot)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(chnkpnts,gas_pcnst)' + end if + write(30,100) trim(line) + end if + else + if( march == 'SCALAR' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:)' + end if + else if( march == 'VECTOR' ) then +! line = ' integer, intent(in) :: ofl' +! write(30,100) trim(line) +! line = ' integer, intent(in) :: ofu' +! write(30,100) trim(line) +! line = ' integer, intent(in) :: chnkpnts' +! write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(veclen,gas_pcnst)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(veclen,rxntot)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(veclen,gas_pcnst)' + end if + else + if( model /= 'CAM' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:)' + write(30,100) trim(line) + if( model /= 'WRF' ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:,:)' + end if + else + select case( class ) + case( explicit ) + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:,:,:)' + case( implicit ) + line = ' real' // trim(dec_suffix) // ', intent(in) :: y(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: rxt(:,:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: het_rates(:,:)' + end select + end if + end if + if( model /= 'WRF' ) then + write(30,100) trim(line) + end if + end if + line = ' ' + write(30,100) trim(line) + if( clscnt(class) /= 0 ) then + line = ' ' + write(30,100) trim(line) + buff = ' ' + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then +! if( march /= 'SCALAR' .and. class /= explicit ) then + if( march == 'VECTOR' ) then + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) line + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = ' ' + line(7:) = 'integer :: k' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line = ' ' + end if + if( allocated( match_mask ) ) then + deallocate( match_mask ) + end if + if( allocated( pmask ) ) then + deallocate( pmask ) + end if + if( allocated( indexer ) ) then + deallocate( indexer ) + end if + k = sum( cls_rxt_cnt(:,class) ) + if( k == 0 ) then + if( class == implicit .or. class == rodas ) then + line(10:) = trim( l_piece ) // ':) = 0.' // trim(num_suffix) + else + if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + line(10:) = 'loss(:,:,:) = 0.' // trim(num_suffix) + end if + else + line(7:) = 'loss(:,:) = 0.' // trim(num_suffix) + end if + end if + write(30,100) trim(line) + + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + line(10:) = trim( p_piece ) // ':) = 0.' // trim(num_suffix) + else + line(7:) = 'prod(:,:) = 0.' // trim(num_suffix) + end if + write(30,100) trim(line) + + call terminate_subroutine + cycle Class_loop + end if + allocate( match_mask(k,3) ) + allocate( indexer(k) ) + if( sum( cls_rxt_cnt(2:3,class) ) /= 0 ) then + allocate( pmask(k,prd_lim) ) + end if + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... loss and production for' + length = len_trim( line ) + 2 + select case( class ) + case( 1 ) + line(length:) = 'Explicit method' + case( 2 ) + line(length:) = 'Ebi-gs method' + case( 3 ) + line(length:) = 'Hov-gs method' + case( 4 ) + line(length:) = 'Implicit method' + case( 5 ) + line(length:) = 'Rodas3 method' + end select + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) +100 format(a) + if( class == ebi ) then + line = ' ' + line(10:) = 'select case( index )' + write(30,100) trim(line) + line = ' ' + else if( model == 'CAM' .or. class == 4 .or. class == 5 ) then + line = ' ' + if( march /= 'SCALAR' ) then + if( march == 'VECTOR' ) then + if( class == implicit ) then + line(7:) = 'do k = 1,avec_len' + else + line(7:) = 'do k = ofl,ofu' + end if + else + if( model == 'MOZART' ) then + line(7:) = 'do k = 1,clsze' + else if( model == 'CAM' .and. class /= explicit ) then + line(7:) = 'do k = 1,cols' + end if + end if + end if + write(30,100) trim(line) + line = ' ' + end if +Species_loop : & + do species = 1,clscnt(class) + if( class == ebi .or. class == hov ) then + write(num,'(i3)') permute(species,2) + line = ' ' + line(13:) = 'case( ' // num(:len_trim(num)) // ' )' + write(30,100) trim(line) + line = ' ' + end if +!----------------------------------------------------------------------- +! ...Write code for loss processes; linear, nonlinear, and heterogeneous +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... Setup indicies and check whether species is in any loss reactions +!----------------------------------------------------------------------- + target = clsmap(species,class,2) + kl = cls_rxt_cnt(1,class) + 1 + ku = sum( cls_rxt_cnt(:3,class) ) + do i = 1,2 + match_mask(kl:ku,i) = cls_rxt_map(kl:ku,i+1,class) == target + where( match_mask(kl:ku,i) ) + indexer(kl:ku) = 6/(i+1) + endwhere + end do + match_mask(kl:ku,1) = match_mask(kl:ku,1) .or. match_mask(kl:ku,2) + kl = ku + 1 ; ku = sum(cls_rxt_cnt(:,class)) + match_mask(kl:ku,1) = cls_rxt_map(kl:ku,2,class) == species + kl = cls_rxt_cnt(1,class) + 1 + if( class == ebi .or. class == hov ) then + num = '1' + else + write(num,'(i3)') permute(species,class) + num = adjustl( num ) + end if + if( count( match_mask(kl:ku,1) ) == 0 ) then +!----------------------------------------------------------------------- +! ... no loss for this species +!----------------------------------------------------------------------- + if( class == implicit .or. class == rodas ) then + line(10:) = trim( l_piece ) // num(:len_trim(num)) // ') = 0.' // trim(num_suffix) + else + if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + line(10:) = 'loss(:,:,' // num(:len_trim(num)) // ') = 0.' // trim(num_suffix) + end if + else + line(7:) = 'loss(:,' // num(:len_trim(num)) // ') = 0.' // trim(num_suffix) + end if + end if + write(30,100) trim(line) + else + line = ' ' + if( class == explicit .or. class >= implicit ) then + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + line(10:) = trim( l_piece ) // num(:len_trim(num)) // ') = (' + else + line(7:) = 'loss(:,' // num(:len_trim(num)) // ') = (' + end if + line_pos = len_trim( line ) + 1 + else + line(7:) = 'loss(:,' // num(:len_trim(num)) // ') =' + line_pos = len_trim( line ) + 2 + end if +!----------------------------------------------------------------------- +! ... Scan loss reactions for common terms +!----------------------------------------------------------------------- + ku = ku - cls_rxt_cnt(4,class) + first = .true. + do m = 1,spccnt + match_mask(kl:ku,2) = .false. + do k = kl,ku + if( match_mask(k,1) ) then + if( abs( cls_rxt_map(k,indexer(k),class) ) == m ) then + match_mask(k,2) = .true. + end if + end if + end do + cnt = count( match_mask(kl:ku,2) ) + if( cnt == 0 ) then + cycle + end if + if( m == target ) then + if( cnt > 1 ) then + if( first ) then + buff = '2.' // trim(num_suffix) // '*(' + else + buff = ' + 2.' // trim(num_suffix) // '*(' + end if + else + if( first ) then + buff = '2.' // trim(num_suffix) // '*' + else + buff = ' + 2.' // trim(num_suffix) // '*' + end if + end if + else + if( cnt > 1 ) then + if( first ) then + buff = '(' + else + buff = ' + (' + end if + else + if( first ) then + buff = ' ' + else + buff = ' + ' + end if + end if + end if + if( first ) then + first = .false. + end if + l = 0 + do k = kl,ku + if( match_mask(k,2) ) then + l = l + 1 + write(num,'(i3)') cls_rxt_map(k,1,class) + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = trim( rxt_piece ) // num(:len_trim(num)) // ') +' + else + buff(len_trim(buff)+1:) = 'rxt(:,' // num(:len_trim(num)) // ') +' + end if + if( l == cnt ) then + if( cnt > 1 ) then + buff(len_trim(buff)-1:) = ')' + else + buff(len_trim(buff)-1:) = ' ' + end if + call put_in_line + write(num,'(i3)') m + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = '* ' // trim( sol_piece ) // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = '* y(:,' // num(:len_trim(num)) // ')' + end if + end if + call put_in_line + end if + end do + where( match_mask(kl:ku,2) ) + match_mask(kl:ku,1) = .false. + endwhere + end do +!----------------------------------------------------------------------- +! ... Strictly unimolecular losses +!----------------------------------------------------------------------- + ku = sum( cls_rxt_cnt(:,class) ) + cnt = count( match_mask(kl:ku,1) ) + if( cnt > 0 ) then + do k = kl,ku + if( match_mask(k,1) ) then + cnt = cnt - 1 + write(num,'(i3)') cls_rxt_map(k,1,class) + num = adjustl( num ) + if( k <= sum(cls_rxt_cnt(1:3,class)) ) then + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = ' + ' // trim( rxt_piece ) // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = ' + rxt(:,' // num(:len_trim(num)) // ')' + end if + else + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = ' + ' // trim( het_piece ) // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = ' + het_rates(:,' // num(:len_trim(num)) // ')' + end if + end if + if( cnt == 0 .and. (class == explicit .or. class >= implicit) ) then + buff(len_trim(buff)+1:) = ')' + end if + call put_in_line + end if + end do + else if( class == explicit .or. class >= implicit ) then + buff(len_trim(buff)+1:) = ')' + call put_in_line + end if + if( class == explicit .or. class >= implicit ) then + write(num,'(i3)') target + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = '* ' // trim( sol_piece ) // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = '* y(:,' // num(:len_trim(num)) // ')' + end if + call put_in_line + end if + if( line(7:) /= ' ' ) then + write(30,100) trim(line) + end if + end if +!----------------------------------------------------------------------- +! ...Write code for production from linear and nonlinear reactions +!----------------------------------------------------------------------- + ku = sum( cls_rxt_cnt(:3,class) ) + do k = kl,ku + pmask(k,:) = cls_rxt_map(k,4:prd_lim+3,class) == species + match_mask(k,1) = ANY( pmask(k,:) ) + end do + if( class == ebi .or. class == hov ) then + num = '1' + else + write(num,'(i3)') permute(species,class) + num = adjustl( num ) + end if + line = ' ' +!----------------------------------------------------------------------- +! ... No species products +!----------------------------------------------------------------------- + if( count( match_mask(kl:ku,1) ) == 0 ) then + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + line(10:) = trim( p_piece ) // num(:len_trim(num)) // ') = 0.' // trim(num_suffix) + else + line(7:) = 'prod(:,' // num(:len_trim(num)) // ') = 0.' // trim(num_suffix) + end if + write(30,100) trim(line) + cycle Species_loop + else + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + line(10:) = trim( p_piece ) // num(:len_trim(num)) // ') = ' + else + line(7:) = 'prod(:,' // num(:len_trim(num)) // ') = ' + end if + end if + first = .true. + do + do m = 1,spccnt + match_mask(kl:ku,3) = (abs(cls_rxt_map(kl:ku,2,class)) == m .or. & + abs(cls_rxt_map(kl:ku,3,class)) == m) .and.& + match_mask(kl:ku,1) + freq(m) = count( match_mask(kl:ku,3) ) + end do + max_loc = MAXLOC( freq(:spccnt) ) + cnt = MAXVAL( freq(:spccnt) ) + match_mask(kl:ku,3) = (abs(cls_rxt_map(kl:ku,2,class)) == max_loc(1) .or. & + abs(cls_rxt_map(kl:ku,3,class)) == max_loc(1)) .and. & + match_mask(kl:ku,1) + do k = kl,ku + if( match_mask(k,3) ) then + if( abs( cls_rxt_map(k,2,class) ) == max_loc(1) ) then + indexer(k) = 3 + else + indexer(k) = 2 + end if + end if + end do + if( cnt > 1 ) then + if( first ) then + buff = ' (' + else + buff = ' + (' + end if + else if( first ) then + buff = ' ' + else + buff = ' +' + end if + if( first ) then + first = .false. + end if + m = cnt + do k = kl,ku + if( match_mask(k,3) ) then + index = pcoeff_ind(cls_rxt_map(k,1,class)) + if( index /= 0 ) then + rate = 0. + do ml = 1,prd_lim + if( pmask(k,ml) ) then + rate = rate + pcoeff(ml,index) + end if + end do + else + rate = REAL( count( abs( cls_rxt_map(k,4:prd_lim+3,class) ) == species ) ) + end if + if( rate /= 0. .and. rate /= 1. ) then + call r2c( buff(len_trim(buff)+1:), rate, 'l' ) + buff(len_trim( buff )+1:) = trim(num_suffix) // '*' + end if + write(num,'(i3)') cls_rxt_map(k,1,class) + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff(len_trim(buff)+1:) = trim( rxt_piece ) // num(:len_trim(num)) // ')' + else + buff(len_trim(buff)+1:) = 'rxt(:,' // num(:len_trim(num)) // ')' + end if + if( abs( cls_rxt_map(k,indexer(k),class) ) /= 0 ) then + write(num,'(i3)') abs( cls_rxt_map(k,indexer(k),class) ) + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + if( m > 1 ) then + buff(len_trim(buff)+1:) = '*' // trim( sol_piece ) // num(:len_trim(num)) // ') +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = '*' // trim( sol_piece ) // num(:len_trim(num)) // '))' + else + buff(len_trim(buff)+1:) = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + end if + else + if( m > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ') +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // '))' + else + buff(len_trim(buff)+1:) = '*y(:,' // num(:len_trim(num)) // ')' + end if + end if + else + if( m > 1 ) then + buff(len_trim(buff)+1:) = ' +' + else if( cnt > 1 ) then + buff(len_trim(buff)+1:) = ')' + end if + end if + call put_in_line + if( m == 1 ) then + write(num,'(i3)') max_loc(1) + num = adjustl( num ) + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then + buff = '*' // trim( sol_piece ) // num(:len_trim(num)) // ')' + else + buff = '*y(:,' // num(:len_trim(num)) // ')' + end if + call put_in_line + exit + end if + m = m - 1 + end if + end do + where( match_mask(kl:ku,3) ) + match_mask(kl:ku,1) = .false. + endwhere + if( count( match_mask(kl:ku,1) ) == 0 ) then + exit + end if + end do + if( line(7:) /= ' ' ) then + write(30,100) trim(line) + line = ' ' + end if + end do Species_loop + if( class == ebi ) then + line = ' ' + line(10:) = 'end select' + write(30,100) trim(line) + line = ' ' + end if + if( model == 'CAM' .or. class == implicit .or. class == rodas ) then +! if( march /= 'SCALAR' .and. class /= explicit ) then + if( march == 'VECTOR' ) then + line = ' end do' + write(30,100) trim(line) + end if + end if + end if +!----------------------------------------------------------------------- +! ... Terminate the subroutine +!----------------------------------------------------------------------- + call terminate_subroutine + end do Class_loop + + line = ' end module mo_prod_loss' + write(30,100) trim(line) + + + CLOSE( 30 ) + if( allocated( match_mask ) ) then + deallocate( match_mask ) + end if + if( allocated( pmask ) ) then + deallocate( pmask ) + end if + if( allocated( indexer ) ) then + deallocate( indexer ) + end if + + contains + + subroutine put_in_line +!----------------------------------------------------------------------- +! ... Put line piece in buff into the line +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: blen, llen + + blen = len_trim( buff ) + llen = len_trim( line ) + 1 + if( blen + llen < max_len-2 ) then + line(llen:) = buff(:blen) + else + line(len_trim(line)+1:) = ' &' + write(30,'(a)') trim(line) + line = ' ' + line(18:) = buff(:blen) + end if + buff = ' ' + + end subroutine put_in_line + + subroutine terminate_subroutine +!----------------------------------------------------------------------- +! ... Terminate the subroutine +!----------------------------------------------------------------------- + + implicit none + + line = ' ' + write(30,100) trim(line) + select case( class ) + case( 1 ) + line = ' end subroutine exp_prod_loss' + case( 2 ) + line = ' end subroutine ebi_prod_loss' + case( 3 ) + line = ' end subroutine hov_prod_loss' + case( 4 ) + line = ' end subroutine imp_prod_loss' + case( 5 ) + line = ' end subroutine rodas_prod_loss' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + +100 format(a) + + end subroutine terminate_subroutine + + end subroutine pl_code + + end module prod_loss diff --git a/chem_proc/src/cam_chempp/prd_map.f b/chem_proc/src/cam_chempp/prd_map.f new file mode 100644 index 0000000000..24eea19c30 --- /dev/null +++ b/chem_proc/src/cam_chempp/prd_map.f @@ -0,0 +1,44 @@ + + module MO_PRD_MAP + + CONTAINS + + subroutine PRD_MAP( template ) +!----------------------------------------------------------------------- +! ... Form production indicies +!----------------------------------------------------------------------- + + use VAR_MOD, only : var_lim + use RXT_MOD, only : prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(inout) :: template(:,:) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, clsno + + integer :: XLATE + + template(:,:2) = 0 + + do i = 1,prd_lim + if( template(i,3) < 0 ) then + cycle + else if( template(i,3) == 0 ) then + exit + else + clsno = XLATE( template(i,3) ) + template(i,2) = clsno + template(clsno,1) = template(clsno,1) + 1 + end if + end do + + end subroutine PRD_MAP + + end module MO_PRD_MAP diff --git a/chem_proc/src/cam_chempp/radj_code.f b/chem_proc/src/cam_chempp/radj_code.f new file mode 100644 index 0000000000..bf41b4d8a4 --- /dev/null +++ b/chem_proc/src/cam_chempp/radj_code.f @@ -0,0 +1,254 @@ + + subroutine make_radj( fixmap, fixcnt, rxmap, rxmcnt, phtcnt, & + model, march ) +!----------------------------------------------------------------------- +! ... Make the reaction rate "adjustment" code +!----------------------------------------------------------------------- + + use var_mod, only : var_lim + use rxt_mod, only : rxt_lim + use io, only : temp_path + + implicit none + +!----------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: phtcnt + integer, intent(in) :: rxmcnt + integer, intent(in) :: fixcnt(2) + integer, intent(in) :: fixmap(var_lim,3,2) + integer, intent(in) :: rxmap(rxt_lim) + character(len=*), intent(in) :: model + character(len=*), intent(in) :: march + +!----------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------- + integer :: j, k, l, rxno + character(len=128):: line + character(len=4) :: dec_suffix + logical :: first + logical :: divide + logical :: doloop + logical :: lexist + + integer :: strlen + + inquire( file = trim( temp_path ) // 'mo_adjrxt.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_adjrxt.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_adjrxt.F' ) + + if( model == 'CAM' ) then + dec_suffix = '(r8)' + else + dec_suffix = ' ' + end if + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_adjrxt' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: adjrxt' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( model == 'MOZART' ) then + line(7:) = 'subroutine adjrxt( rate, inv, m, plnplv )' + else if( trim(model) == 'CAM' ) then + line(7:) = 'subroutine adjrxt( rate, inv, m, ncol, nlev )' + else if( trim(model) == 'WRF' ) then + line(7:) = 'subroutine adjrxt( rate, inv, m )' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( trim(model) == 'CAM' ) then + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line(7:) = 'use chem_mods, only : nfs, rxntot' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line(7:) = 'implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + if( trim(model) == 'MOZART' ) then + line = ' integer, intent(in) :: plnplv' + write(30,100) trim(line) + line = ' real, intent(in) :: inv(plnplv,nfs)' + write(30,100) trim(line) + line = ' real, intent(in) :: m(plnplv)' + write(30,100) trim(line) + line = ' real, intent(inout) :: rate(plnplv,rxntot)' + else if( trim(model) == 'CAM' ) then + line = ' integer, intent(in) :: ncol, nlev' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: inv(ncol,nlev,nfs)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: m(ncol,nlev)' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: rate(ncol,nlev,rxntot)' + else if( trim(model) == 'WRF' ) then + line = ' real, intent(in) :: inv(:,:)' + write(30,100) trim(line) + line = ' real, intent(in) :: m(:)' + write(30,100) trim(line) + line = ' real, intent(inout) :: rate(:,:)' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + + divide = .false. + if( any( fixmap(:fixcnt(2),1,2) < 0 ) ) then + divide = .true. + endif + if( .not. divide ) then + do k = 1,fixcnt(1) + if( fixmap(k,1,1) < 0 .and. abs( fixmap(k,1,1) ) > phtcnt ) then + divide = .true. + exit + endif + end do + endif + + if( divide ) then + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!--------------------------------------------------------------------' + write(30,100) trim(line) + if( trim(model) == 'MOZART' ) then + line = ' real :: im(plnplv)' + else if( trim(model) == 'CAM' ) then + line = ' real(r8) :: im(ncol,nlev)' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + write(30,100) trim(line) + end if + + first = .true. + doloop = .false. + + if( divide ) then + if( trim(model) /= 'CAM' ) then + line(10:) = 'im(:) = 1. / m(:)' + else + line(7:) = 'im(:,:) = 1._r8 / m(:,:)' + end if + write(30,100) trim(line) + endif + +!--------------------------------------------------------- +! ... First check reactions with invariants for +! potential modification +!--------------------------------------------------------- + do j = 1,2 + do k = 1,fixcnt(j) + rxno = abs( fixmap(k,1,j) ) + if( j == 2 .or. rxno > phtcnt ) then + if( first ) then + first = .false. + doloop = .true. + if( trim(model) == 'CAM' ) then + line = ' ' + end if + end if + if( trim(model) /= 'CAM' ) then + line(10:) = 'rate(:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') = rate(:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ')' + do l = 2,j+1 + line(strlen(line)+1:) = ' * inv(:,' + write(line(strlen(line)+1:),'(i2)') fixmap(k,l,j) + line(strlen(line)+1:) = ')' + end do + else + line(7:) = 'rate(:,:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') = rate(:,:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ')' + do l = 2,j+1 + line(strlen(line)+1:) = ' * inv(:,:,' + write(line(strlen(line)+1:),'(i2)') fixmap(k,l,j) + line(strlen(line)+1:) = ')' + end do + end if + if( fixmap(k,1,j) < 0 ) then + if( trim(model) /= 'CAM' ) then + line(strlen(line)+1:) = ' * im(:)' + else + line(strlen(line)+1:) = ' * im(:,:)' + end if + end if + write(30,100) trim(line) + end if + end do + end do + +!--------------------------------------------------------- +! ... Now do all nonlinear reactions +!--------------------------------------------------------- + first = .true. + do k = 1,rxmcnt + rxno = rxmap(k) + line = ' ' + if( model /= 'CAM' ) then + line(10:) = 'rate(:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') = rate(:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') * m(:)' + else + line(7:) = 'rate(:,:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') = rate(:,:,' + write(line(len_trim(line)+1:),'(i3)') rxno + line(len_trim(line)+1:) = ') * m(:,:)' + end if + write(30,100) trim(line) + end do + + if( model == 'CAM' ) then + if ( rxmcnt > 0 .or. fixcnt(1) > 0 .or. fixcnt(2) > 0 ) then + endif + end if + line = ' ' + write(30,100) trim(line) + line(7:) = 'end subroutine adjrxt' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'end module mo_adjrxt' + write(30,100) trim(line) + + close(30) + +100 format(a) + + end subroutine make_radj diff --git a/chem_proc/src/cam_chempp/rate_code.f b/chem_proc/src/cam_chempp/rate_code.f new file mode 100644 index 0000000000..1a3b447160 --- /dev/null +++ b/chem_proc/src/cam_chempp/rate_code.f @@ -0,0 +1,845 @@ +module set_rxt_rates + + use rxt_mod, only : rxntot, cph_flg + use io, only : temp_path + + private + public :: make_rate + +contains + + subroutine make_rate( sym_rates, rxptab, rxpcnt, machine, vec_ftns, & + model, march ) + !----------------------------------------------------------------------- + ! ... write fortran "internal" reaction rates + !----------------------------------------------------------------------- + + use rxt_mod, only : troecnt, troetab, troe_sym_rates, rxparm + + implicit none + + !----------------------------------------------------------------------- + ! ... dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: rxpcnt + integer, intent(in) :: rxptab(*) + character(len=16), intent(in) :: sym_rates(2,*) + character(len=16), intent(in) :: machine + character(len=16), intent(in) :: march + character(len=16), intent(in) :: model + logical, intent(in) :: vec_ftns + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: i, cnt, indp, inde, l, m, m1, pos + integer :: ftn_lim + integer :: ftn_mode + integer :: cph_cnt + integer :: match_cnt + integer :: subs_lim + integer :: subs + integer :: match_ind(rxpcnt) + real :: rate + character(len=132) :: line + character(len=32) :: wrk, buff + character(len=16) :: vec_dim + character(len=4) :: num_suffix + character(len=4) :: dec_suffix + character(len=3) :: num + character(len=3) :: numa + logical :: lexist + logical :: vftns + logical :: do_tmp + logical :: do_rxt + logical :: t_dependent(rxpcnt) + + + + inquire( file = trim( temp_path ) // 'mo_setrxt.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_setrxt.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_setrxt.F' ) + + vec_dim = 'plnplv' + if( model == 'CAM' ) then + num_suffix = '_r8' + dec_suffix = '(r8)' + if( march == 'VECTOR' ) then + vec_dim = 'chnkpnts' + end if + else + num_suffix = ' ' + dec_suffix = ' ' + end if + + if( model == 'CAM' ) then + subs_lim = 2 + else + subs_lim = 1 + end if + cph_cnt = count( cph_flg(:) ) + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_setrxt' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: setrxt' + write(30,100) trim(line) + line(7:) = 'public :: setrxt_hrates' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + subs_loop : do subs = 1,subs_lim + write(30,100) trim(line) + if( march == 'VECTOR' ) then + if( subs == 1 ) then +! line(7:) = 'subroutine setrxt( rate, temp, m, ' // trim(vec_dim) // ' )' + line(7:) = 'subroutine setrxt( rate, temp, m, ncol )' + write(30,100) trim(line) + write(30,100) ' ' + line(7:) = 'use ppgrid, only : pcols, pver' + else + line(7:) = 'subroutine setrxt_hrates( rate, temp, m, ncol, kbot )' + write(30,100) trim(line) + write(30,100) ' ' + line(7:) = 'use ppgrid, only : pcols, pver' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + else + select case( model ) + case( 'MOZART' ) + line(7:) = 'subroutine setrxt( rate, temp, m, plonl )' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + line(7:) = 'use mo_grid, only : plev, plnplv' + case( 'CAM' ) + if( subs == 1 ) then + line(7:) = 'subroutine setrxt( rate, temp, m, ncol )' + else + line(7:) = 'subroutine setrxt_hrates( rate, temp, m, ncol, kbot )' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = ' ' + line(7:) = 'use ppgrid, only : pver, pcols' + write(30,100) trim(line) + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + case( 'WRF' ) + line(7:) = 'subroutine setrxt( rate, temp, m, n )' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'use mo_jpl, only : jpl' + end select + end if + write(30,100) trim(line) + if( model /= 'WRF' ) then + line(7:) = 'use chem_mods, only : rxntot' + write(30,100) trim(line) + line(7:) = 'use mo_jpl, only : jpl' + write(30,100) trim(line) + end if + line = ' ' + write(30,100) trim(line) + line(7:) = 'implicit none ' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line = '!-------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!-------------------------------------------------------' + write(30,100) trim(line) + if( machine == 'NEC' .or. machine == 'FUJITSU' ) then +! if( subs == 1 ) then +! line = ' integer, intent(in) :: ' // trim(vec_dim) +! else + line = ' integer, intent(in) :: ncol' +! endif + write(30,100) trim(line) + if( subs == 1 ) then + line = ' real' // trim(dec_suffix) // ', intent(in) :: temp(pcols,pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: m(ncol*pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: rate(ncol*pver,max(1,rxntot))' + else + line = ' integer, intent(in) :: kbot' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: temp(pcols,pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: m(ncol*pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: rate(ncol*pver,max(1,rxntot))' + endif + else + select case( model ) + case( 'MOZART' ) + line = ' integer, intent(in) :: plonl' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: temp(plonl,plev)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: m(plonl,plev)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: rate(plonl,plev,rxntot)' + case( 'CAM' ) + line = ' integer, intent(in) :: ncol' + write(30,100) trim(line) + if( subs == 2 ) then + line = ' integer, intent(in) :: kbot' + write(30,100) trim(line) + end if + line = ' real' // trim(dec_suffix) // ', intent(in) :: temp(pcols,pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: m(ncol,pver)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: rate(ncol,pver,rxntot)' + case( 'WRF' ) + line = ' integer, intent(in) :: n' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: temp(:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(in) :: m(:)' + write(30,100) trim(line) + line = ' real' // trim(dec_suffix) // ', intent(inout) :: rate(:,:)' + end select + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + + if( rxpcnt == 0 ) then + if( subs == 1 ) then + line(7:) = 'end subroutine setrxt' + else + line(7:) = 'end subroutine setrxt_hrates' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( subs == 2 ) then + line(7:) = 'end module mo_setrxt' + write(30,100) trim(line) + end if + cnt = 0 + cycle subs_loop + else + t_dependent(:rxpcnt) = sym_rates(2,:rxpcnt) /= ' ' + cnt = count( t_dependent(:rxpcnt) ) + end if + + + !----------------------------------------------------------------------- + ! ... check for temp dependent rates + !----------------------------------------------------------------------- + temp_dep_rxts : if( cnt /= 0 .or. troecnt /= 0 ) then + line = '!-------------------------------------------------------' + write(30,100) trim(line) + line = '! ... local variables' + write(30,100) trim(line) + line = '!-------------------------------------------------------' + write(30,100) trim(line) + line = ' ' + if( model /= 'WRF' ) then + line(7:) = 'integer :: n' + write(30,100) trim(line) + if( model == 'CAM' .and. march == 'VECTOR' ) then + line(7:) = 'integer :: offset' + write(30,100) trim(line) + if( subs > 1 ) then + line(7:) = 'integer :: k' + write(30,100) trim(line) + endif + endif + end if + if( machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(ncol*pver)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(ncol*pver)' + else + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(ncol*kbot)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(ncol*kbot)' + endif + else + select case( model ) + case( 'MOZART' ) + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(plonl,plev)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(plonl,plev)' + case( 'CAM' ) + if( subs == 1 ) then + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(ncol,pver)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(ncol,pver)' + else + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(ncol,kbot)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(ncol,kbot)' + end if + case( 'WRF' ) + line(7:) = 'real' // trim(dec_suffix) // ' :: itemp(n)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: exp_fac(n)' + end select + end if + write(30,100) trim(line) + end if temp_dep_rxts + troe_rxts : if( troecnt /= 0 ) then + if( machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(ncol*pver)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(ncol*pver)' + if( subs > 1 ) then + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: wrk(ncol*pver)' + endif + else + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(ncol*kbot)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(ncol*kbot)' + if( subs > 1 ) then + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: wrk(ncol*kbot)' + endif + endif + else + select case( model ) + case( 'MOZART' ) + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(plonl,plev)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(plonl,plev)' + case( 'CAM' ) + if( subs == 1 ) then + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(ncol,pver)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(ncol,pver)' + else + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(ncol,kbot)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(ncol,kbot)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: wrk(ncol,kbot)' + end if + case( 'WRF' ) + line(7:) = 'real' // trim(dec_suffix) // ' :: ko(n)' + write(30,100) trim(line) + line(7:) = 'real' // trim(dec_suffix) // ' :: kinf(n)' + end select + end if + write(30,100) trim(line) + end if troe_rxts + + if( model == 'CAM' .and. march == 'VECTOR' .and. subs > 1 ) then + write(30,100) ' ' + line(7:) = 'n = ncol*kbot' + write(30,100) trim(line) + endif + line = ' ' + write(30,100) trim(line) + + !----------------------------------------------------------------------- + ! ... first do all temperature independent rates + !----------------------------------------------------------------------- + const_rxts : if( rxpcnt > 0 .and. cnt /= rxpcnt ) then + line = ' ' + do i = 1,rxpcnt + if( sym_rates(2,i) == ' ' ) then + if( subs == 2 ) then + if( .not. cph_flg(rxptab(i)) ) then + cycle + end if + end if + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + line(7:) = 'rate(:,' + else + line(7:) = 'rate(:n,' + endif + else + if( subs == 1 ) then + line(7:) = 'rate(:,:,' + else + line(7:) = 'rate(:,:kbot,' + end if + end if + write(num,'(i3)') rxptab(i) + num = adjustl( num ) + l = len_trim( sym_rates(1,i) ) + wrk = sym_rates(1,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // trim(num_suffix) + write(30,100) trim(line) + end if + end do + end if const_rxts + + !----------------------------------------------------------------------- + ! ... now do temp dependent rxts + !----------------------------------------------------------------------- + do_tmp = cnt /= 0 .and. (subs == 1 .or. cph_cnt > 0) + any_temp_dep : if( do_tmp ) then + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + write(30,100) ' ' + line(7:) = 'do n = 1,pver' + write(30,100) trim(line) + line(7:) = ' offset = (n-1)*ncol' + write(30,100) trim(line) + line(7:) = ' itemp(offset+1:offset+ncol) = 1.' // trim(num_suffix)// ' / temp(:ncol,n)' + write(30,100) trim(line) + line(7:) = 'end do' + else +! line(7:) = 'itemp(:) = 1.' // trim(num_suffix)// ' / temp(:n)' + write(30,100) ' ' + line(7:) = 'do k = 1,kbot' + write(30,100) trim(line) + line(7:) = ' offset = (k-1)*ncol' + write(30,100) trim(line) + line(7:) = ' itemp(offset+1:offset+ncol) = 1.' // trim(num_suffix)// ' / temp(:ncol,k)' + write(30,100) trim(line) + line(7:) = 'end do' + endif + else if( model == 'MOZART' ) then + line(7:) = 'itemp(:,:) = 1.' // trim(num_suffix)// ' / temp(:,:)' + else if( model == 'CAM' ) then + if( subs == 1 ) then + line(7:) = 'itemp(:ncol,:) = 1.' // trim(num_suffix)// ' / temp(:ncol,:)' + else + line(7:) = 'itemp(:ncol,:kbot) = 1.' // trim(num_suffix)// ' / temp(:ncol,:kbot)' + end if + end if + write(30,100) trim(line) + if( vec_ftns ) then + if( model == 'MOZART' ) then + line(7:) = 'n = plonl*plev' + else if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + if( subs == 1 ) then + line(7:) = 'n = ncol*pver' + else + line(7:) = 'n = ncol*kbot' + end if + else + line(7:) = 'n = ' // trim(vec_dim) + end if + end if + write(30,100) trim(line) + else if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + if( subs == 1 ) then + line(7:) = 'n = ncol*pver' + else + line(7:) = 'n = ncol*kbot' + end if + else +! line(7:) = 'n = ' // trim(vec_dim) + line(7:) = ' ' + end if + write(30,100) trim(line) + end if + line = ' ' + if( model == 'CAM' .and. machine == 'IBM' ) then + ftn_lim = 2 + else + ftn_lim = 1 + end if + ftn_mode_loop : do ftn_mode = 1,ftn_lim + if( model == 'CAM' .and. machine == 'IBM' ) then + vftns = ftn_mode == 2 + if( ftn_mode == 1 ) then + ! line = '#ifndef AIX' + line = '#if ( !defined AIX || defined NO_VEXP )' + else if( ftn_mode == 2 ) then + line = '#else' + end if + write(30,100) trim(line) + line = ' ' + else + vftns = vec_ftns + end if + if( ftn_mode == 2 ) then + t_dependent(:rxpcnt) = sym_rates(2,:rxpcnt) /= ' ' + end if + rxt_loop : do i = 1,rxpcnt + do_rxt = t_dependent(i) + if( subs == 2 ) then + if( do_rxt ) then + do_rxt = cph_flg(rxptab(i)) + end if + end if + is_temp_dep : if( do_rxt ) then + match_cnt = 0 + do m = i,rxpcnt + if( rxparm(2,i) == rxparm(2,m) ) then + if( subs == 1 ) then + match_cnt = match_cnt + 1 + match_ind(match_cnt) = m + t_dependent(m) = .false. + else if( cph_flg(rxptab(m)) ) then + match_cnt = match_cnt + 1 + match_ind(match_cnt) = m + t_dependent(m) = .false. + end if + end if + end do + multiple_matches : if( match_cnt > 1 ) then + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(7:) = 'exp_fac(:) = ' + else if( .not. vftns ) then + line(7:) = 'exp_fac(:,:) = ' + end if + l = len_trim( sym_rates(2,i) ) + wrk = sym_rates(2,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + pos = len_trim( line ) + if( .not. vftns ) then + line(pos+1:) = ' exp( ' // wrk(:l) // trim(num_suffix) + else + line(7:) = 'call vexp( exp_fac, ' // wrk(:l) // trim(num_suffix) + end if + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(len_trim(line)+1:) = ' * itemp(:) )' + else if( .not. vftns ) then + line(len_trim(line)+1:) = ' * itemp(:,:) )' + else if( vftns ) then + line(len_trim(line)+1:) = ' * itemp, n )' + end if + write(30,100) trim(line) + do m = 1,match_cnt + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + line(7:) = 'rate(:,' + else + line(7:) = 'rate(:n,' + endif + else + if( subs == 1 ) then + line(7:) = 'rate(:,:,' + else + line(7:) = 'rate(:,:kbot,' + end if + end if + m1 = match_ind(m) + write(num,'(i3)') rxptab(m1) + num = adjustl( num ) + l = len_trim( sym_rates(1,m1) ) + wrk = sym_rates(1,m1)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // & + trim(num_suffix) // ' * exp_fac(:)' + else + line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // & + trim(num_suffix) // ' * exp_fac(:,:)' + end if + write(30,100) trim(line) + end do + else multiple_matches + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( subs == 1 ) then + line(7:) = 'rate(:,' + else + line(7:) = 'rate(:n,' + endif + else if( .not. vftns ) then + if( subs == 1 ) then + line(7:) = 'rate(:,:,' + else + line(7:) = 'rate(:,:kbot,' + end if + end if + write(num,'(i3)') rxptab(i) + num = adjustl( num ) + l = len_trim( sym_rates(1,i) ) + wrk = sym_rates(1,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + if( .not. vftns ) then + line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // trim(num_suffix) + else + buff = wrk + end if + l = len_trim( sym_rates(2,i) ) + wrk = sym_rates(2,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + if( vftns ) then + line(7:) = 'call vexp( exp_fac, ' // wrk(:l) // trim(num_suffix) // '*itemp, n )' + write(30,100) trim(line) + if( subs == 1 ) then + line(7:) = 'rate(:,:,' // trim(num) // ') = ' // trim(buff) // trim(num_suffix) // ' * exp_fac(:,:)' + else + line(7:) = 'rate(:,:kbot,' // trim(num) // ') = ' // trim(buff) // trim(num_suffix) // ' * exp_fac(:,:)' + end if + end if + if( .not. vftns ) then + pos = len_trim( line ) + line(pos+1:) = ' * exp( ' // wrk(:l) // trim(num_suffix) + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(len_trim(line)+1:) = ' * itemp(:) )' + else + line(len_trim(line)+1:) = ' * itemp(:,:) )' + end if + end if + write(30,100) trim(line) + end if multiple_matches + end if is_temp_dep + end do rxt_loop + if( model == 'CAM' .and. machine == 'IBM' .and. ftn_mode == 2 ) then + line = '#endif' + write(30,100) trim(line) + line = ' ' + end if + end do ftn_mode_loop + end if any_temp_dep + + !----------------------------------------------------------------------- + ! ... troe rates + !----------------------------------------------------------------------- + do_tmp = troecnt /= 0 .and. (subs == 1 .or. cph_cnt > 0) + any_troe_rxts : if( do_tmp ) then + line = ' ' + write(30,100) trim(line) + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(7:) = 'itemp(:) = 300.' // trim(num_suffix) // ' * itemp(:)' + else + line(7:) = 'itemp(:,:) = 300.' // trim(num_suffix) // ' * itemp(:,:)' + end if + if( subs == 1 .and. model == 'CAM' .and. march == 'VECTOR' ) then + write(30,100) trim(line) + write(30,100) ' ' + line(7:) = 'n = ncol*pver' + endif + write(30,100) trim(line) + troe_rxt_loop : do i = 1,troecnt + if( subs == 2 ) then + m1 = troetab(i) + do_rxt = cph_flg(m1) + else + do_rxt = .true. + end if + line = ' ' + write(30,100) trim(line) + do_troe_rate : if( do_rxt ) then + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(7:) = 'ko(:)' + else + line(7:) = 'ko(:,:)' + end if + l = len_trim( troe_sym_rates(1,i) ) + wrk = troe_sym_rates(1,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + line(len_trim(line)+1:) = ' = ' // wrk(:l) // trim(num_suffix) + if( troe_sym_rates(2,i) /= ' ' ) then + l = len_trim( troe_sym_rates(2,i) ) + read(troe_sym_rates(2,i)(:l),*) rate + wrk = troe_sym_rates(2,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( rate /= 0. ) then + if ( rate < 0. ) then + line(len_trim(line)+1:) = ' * itemp(:)**(' // wrk(:l) // trim(num_suffix)//')' + else + line(len_trim(line)+1:) = ' * itemp(:)**' // wrk(:l) // trim(num_suffix) + endif + end if + else + if( rate /= 0. ) then + if ( rate < 0. ) then + line(len_trim(line)+1:) = ' * itemp(:,:)**(' // wrk(:l) // trim(num_suffix)//')' + else + line(len_trim(line)+1:) = ' * itemp(:,:)**' // wrk(:l) // trim(num_suffix) + endif + end if + end if + end if + write(30,100) trim(line) + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + line(7:) = 'kinf(:)' + else + line(7:) = 'kinf(:,:)' + end if + l = len_trim( troe_sym_rates(3,i) ) + wrk = troe_sym_rates(3,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + line(len_trim(line)+1:) = ' = ' // wrk(:l) // trim(num_suffix) + if( troe_sym_rates(4,i) /= ' ' ) then + l = len_trim( troe_sym_rates(4,i) ) + read(troe_sym_rates(4,i)(:l),*) rate + wrk = troe_sym_rates(4,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( rate /= 0. ) then + if( rate /= 1. ) then + if ( rate < 0. ) then + line(len_trim(line)+1:) = ' * itemp(:)**(' // wrk(:l) // trim(num_suffix)//')' + else + line(len_trim(line)+1:) = ' * itemp(:)**' // wrk(:l) // trim(num_suffix) + endif + else + line(len_trim(line)+1:) = ' * itemp(:)' + end if + end if + else + if( rate /= 0. ) then + if( rate /= 1. ) then + if ( rate < 0. ) then + line(len_trim(line)+1:) = ' * itemp(:,:)**(' // wrk(:l) // trim(num_suffix)//')' + else + line(len_trim(line)+1:) = ' * itemp(:,:)**' // wrk(:l) // trim(num_suffix) + endif + else + line(len_trim(line)+1:) = ' * itemp(:,:)' + end if + end if + end if + end if + write(30,100) trim(line) + if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then + if( march /= 'VECTOR' ) then + line(7:) = 'call jpl( rate(1,' + else + if( subs == 1 ) then + line(7:) = 'call jpl( rate(:,' + else + line(7:) = 'call jpl( wrk' + endif + end if + else + if( subs == 1 ) then + line(7:) = 'call jpl( rate(1,1,' + else + line(7:) = 'call jpl( wrk' + end if + end if + write(numa,'(i3)') troetab(i) + if( subs == 1 ) then + num = numa + else + num = ' ' + end if + num = adjustl( num ) + l = len_trim( troe_sym_rates(5,i) ) + wrk = troe_sym_rates(5,i)(:l) + indp = scan( wrk(:l), '.' ) + inde = scan( wrk(:l), 'eE' ) + if( indp == 0 .and. inde == 0 ) then + l = l + 1 + wrk(l:l) = '.' + end if + select case( model ) + case( 'MOZART' ) + line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // & + trim(num_suffix) // ', ko, kinf, plnplv )' + case( 'CAM' ) + if( subs == 1 ) then + line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // & + trim(num_suffix) // ', ko, kinf, n )' + else + line(len_trim(line)+1:) = num(:len_trim(num)) // ', m, ' // wrk(:l) // & + trim(num_suffix) // ', ko, kinf, n )' + write(30,100) trim(line) + if( march /= 'VECTOR' ) then + line = ' rate(:,:kbot,' // numa(:len_trim(numa)) // ') = wrk(:,:)' + else +! line = ' rate(:,:kbot,' // numa(:len_trim(numa)) // ') = wrk(:)' + line = ' rate(:n,' // numa(:len_trim(numa)) // ') = wrk(:)' + endif + end if + case( 'WRF' ) + line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // & + trim(num_suffix) // ', ko, kinf, n )' + end select + write(30,100) trim(line) + end if do_troe_rate + end do troe_rxt_loop + end if any_troe_rxts + + line = ' ' + write(30,100) trim(line) + if( subs == 1 ) then + line(7:) = 'end subroutine setrxt' + else + line(7:) = 'end subroutine setrxt_hrates' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + if( subs == 2 ) then + line(7:) = 'end module mo_setrxt' + write(30,100) trim(line) + end if + end do subs_loop + + close(30) + +100 format(a) + + end subroutine make_rate + +end module set_rxt_rates diff --git a/chem_proc/src/cam_chempp/rate_tab.f b/chem_proc/src/cam_chempp/rate_tab.f new file mode 100644 index 0000000000..38f05c07fc --- /dev/null +++ b/chem_proc/src/cam_chempp/rate_tab.f @@ -0,0 +1,232 @@ + + subroutine MAKE_RATE_TAB( rxparm, & + rxptab, & + rxpcnt ) +!----------------------------------------------------------------------- +! ... Make the code to setup the rate table +!----------------------------------------------------------------------- + + use IO, only : temp_path + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------- + integer, intent(in) :: rxpcnt + integer, intent(in) :: rxptab(*) + + real, intent(in) :: rxparm(2,*) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, j, k, cnt, pos + character(len=72) :: line + logical :: lexist + + if( rxpcnt == 0 ) then + return + else +!----------------------------------------------------------------------- +! ... Check for temp dependent rates +!----------------------------------------------------------------------- + cnt = COUNT( rxparm(2,1:rxpcnt) /= 0. ) + if( cnt == 0 ) then + return + end if + end if + +!----------------------------------------------------------------------- +! ... First write the table setup routine +!----------------------------------------------------------------------- + INQUIRE( file = TRIM( temp_path ) // 'rxttab.F', exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm ' // TRIM( temp_path ) // 'rxttab.F' ) + end if + OPEN( unit = 30, file = TRIM( temp_path ) // 'rxttab.F' ) + + line = ' ' + write(30,100) line + line(7:) = 'subroutine RXTTAB( )' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'implicit none ' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'real rates' + write(30,100) line + line(7:) = 'common / RXTTAB / rates(126,' + write(line(LEN_TRIM(line)+1:),'(i3,'')'')') cnt + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'real temp(126)' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'integer j' + write(30,100) line + line = ' ' + write(30,100) line + line = '# if defined(EXPHF)' + write(30,100) line + line = ' ' + line(7:) = 'real EXPHF' + write(30,100) line + line = 'CDIR$ VFUNCTION EXPHF' + write(30,100) line + line = '# endif' + write(30,100) line + line = ' ' + write(30,100) line + + line(7:) = 'do j = 1,126' + write(30,100) line + line = ' ' + line(10:) = 'temp(j) = 1. / (180. + REAL(j-1))' + write(30,100) line + line = ' ' + line(7:) = 'end do' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'do j = 1,126' + write(30,100) line + line = ' ' + line(10:) = 'rates(j, ) =' + k = 0 + do i = 1,rxpcnt + if( rxparm(2,i) /= 0.e0 ) then + k = k + 1 + write(line(18:20),'(i3)') k + call R2C( line(25:), rxparm(1,i), 'l' ) + pos = LEN_TRIM(line) + write(30,*) '# if defined(EXPHF)' + line(pos+1:) = '*EXPHF(' + call R2C( line(LEN_TRIM(line)+1:), rxparm(2,i), 'l' ) + line(LEN_TRIM(line)+1:) = ' * temp(j) )' + write(30,100) line + write(30,*) '# else' + line(pos+1:) = '*EXP(' + call R2C( line(LEN_TRIM(line)+1:), rxparm(2,i), 'l' ) + line(LEN_TRIM(line)+1:) = ' * temp(j) )' + write(30,100) line + write(30,*) '# endif' + end if + end do + + line = ' ' + line(7:) = 'end do' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'end' + write(30,100) line + + CLOSE(30) +!----------------------------------------------------------------------- +! ... Finally write the table interpolation routine +!----------------------------------------------------------------------- + INQUIRE( file = 'setrxt.F', exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm setrxt.F' ) + end if + OPEN( unit = 30, file = 'setrxt.F' ) + + line = ' ' + write(30,100) line + line(7:) = 'subroutine SETRXT( rate,' + write(30,100) line + line(6:) = '$ temp )' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'implicit none ' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'real rate(PLNPLV,RXNCNT)' + write(30,100) line + line(7:) = 'real temp(PLNPLV)' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'real rates' + write(30,100) line + line(7:) = 'common / RXTTAB / rates(126,' + write(line(LEN_TRIM(line)+1:),'(i3,'')'')') cnt + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'integer i, ip1, j' + write(30,100) line + line(7:) = 'real del_temp' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'do j = 1,PLNPLV' + write(30,100) line + + if( cnt /= rxpcnt ) then + line = ' ' + line(10:) = 'rate(j, ) =' + do i = 1,rxpcnt + if( rxparm(2,i) == 0.e0 ) then + write(line(17:19),'(i3)') rxptab(i) + call R2C( line(24:), rxparm(1,i), 'l' ) + write(30,100) line + end if + end do + end if + line = ' ' + line(7:) = 'end do' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'do j = 1,PLNPLV' + write(30,100) line + line = ' ' + line(10:) = 'i = INT( temp(j) ) - 179' + write(30,100) line + line(10:) = 'i = MAX( 1,MIN( 125,i) )' + write(30,100) line + line(10:) = 'ip1 = i + 1' + write(30,100) line + line(10:) = 'del_temp = temp(j) - AINT(temp(j))' + write(30,100) line + line = ' ' + k = 0 + do i = 1,rxpcnt + if( rxparm(2,i) /= 0.e0 ) then + line = ' ' + line(10:) = 'rate(j,' + k = k + 1 + write(line(LEN_TRIM(line)+1:),'(i3,'') ='')') rxptab(i) + line(LEN_TRIM(line)+2:) = 'rates(i,' + write(line(LEN_TRIM(line)+1:),'(i3,'')'')') k + write(30,100) line + j = INDEX( line,'=' ) + 2 + line(6:) = '$' + line(j:) = '+ del_temp * (rates(ip1,' + write(line(LEN_TRIM(line)+1:),'(i3,'')'')') k + line(LEN_TRIM(line)+2:) = '- rates(i,' + write(line(LEN_TRIM(line)+1:),'(i3,''))'')') k + write(30,100) line + end if + end do + + line = ' ' + line(7:) = 'end do' + write(30,100) line + line = ' ' + write(30,100) line + line(7:) = 'end' + write(30,100) line + CLOSE(30) + +100 format(a72) + + end subroutine MAKE_RATE_TAB diff --git a/chem_proc/src/cam_chempp/res_hdr.f b/chem_proc/src/cam_chempp/res_hdr.f new file mode 100644 index 0000000000..feaa813ee4 --- /dev/null +++ b/chem_proc/src/cam_chempp/res_hdr.f @@ -0,0 +1,59 @@ + + subroutine RES_HDR( plon, & + plonl, & + plat, & + plev, & + jintmx, & + nxpt, & + arch_type, & + cpucnt ) + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +!----------------------------------------------------------------------- + integer, intent(in) :: plon + integer, intent(in) :: plonl + integer, intent(in) :: plat + integer, intent(in) :: plev + integer, intent(in) :: jintmx + integer, intent(in) :: nxpt + integer, intent(in) :: cpucnt + character(len=16), intent(in) :: arch_type + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + character(len=72) :: comment + logical :: lexist + + INQUIRE( file = 'res.h', exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm res.h' ) + end if + OPEN( unit = 30, file = 'res.h' ) + + write(30,'(''# define PLON '',i3)') plon + write(30,'(''# define PLONP2 '',i3)') plon + 2 + if( arch_type == 'HYBRID' ) then + write(30,'(''# define PLONL '',i3)') plonl + end if + write(30,'(''# define NXPT '',i3)') nxpt + write(30,'(''# define JINTMX '',i3)') jintmx + write(30,'(''# define NXPTJ '',i3)') nxpt + jintmx + write(30,'(''# define PLOND '',i3)') plon + 1 + 2*nxpt + write(30,'(''# define PLAT '',i3)') plat + write(30,'(''# define PLEV '',i3)') plev + write(30,'(''# define PLEVP '',i3)') plev + 1 + write(30,'(''# define PLEVM '',i3)') plev - 1 + write(30,'(''# define PLNPLV '',i6)') plon*plev + write(30,'(''# define I1 '',i3)') 1 + nxpt + write(30,'(''# define I1M '',i3)') nxpt + write(30,'(''# define J1 '',i3)') 1 + nxpt + jintmx + write(30,'(''# define J1M '',i3)') nxpt + jintmx + write(30,'(''# define PTIML 2 '')') + + CLOSE(30) + + end subroutine RES_HDR diff --git a/chem_proc/src/cam_chempp/rmod_code.f b/chem_proc/src/cam_chempp/rmod_code.f new file mode 100644 index 0000000000..fd09352da7 --- /dev/null +++ b/chem_proc/src/cam_chempp/rmod_code.f @@ -0,0 +1,193 @@ + + subroutine make_rmod( rxt2rel_pntr, rel_rxt_map, rxt2grp_pntr, & + grp_rxt_map, hetmap, hetcnt, rxntot, model, march ) +!----------------------------------------------------------------------- +! ... Make the group ratios reaction rate adjustment code +!----------------------------------------------------------------------- + + use rxt_mod, only : rxt_lim + use io, only : temp_path + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: rxt2rel_pntr(rxt_lim,2) + integer, intent(in) :: rel_rxt_map(rxt_lim,3,2) + integer, intent(in) :: rxt2grp_pntr(rxt_lim,2) + integer, intent(in) :: grp_rxt_map(rxt_lim,3,2) + integer, intent(in) :: hetmap(rxt_lim) + integer, intent(in) :: rxntot + integer, intent(in) :: hetcnt + character(len=*), intent(in) :: model + character(len=*), intent(in) :: march + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: max_len = 90 + integer :: k, l, rxno, row, index + character(len=max_len) :: line + logical :: first + logical :: found + logical :: lexist + + integer :: strlen + + inquire( file = trim( temp_path ) // 'mo_rxtmod.F', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'mo_rxt_mod.F' ) + end if + open( unit = 30, file = trim( temp_path ) // 'mo_rxt_mod.F' ) + + line = ' ' + write(30,100) trim(line) + line(7:) = 'module mo_rxt_mod' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'private' + write(30,100) trim(line) + line(7:) = 'public :: rxt_mod' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'contains' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + select case( model ) + case( 'MOZART' ) + line(7:) = 'subroutine rxt_mod( rate, het_rates, grp_ratios, plnplv )' + case( 'CAM' ) + line(7:) = 'subroutine rxt_mod( rate, het_rates, grp_ratios, chnkpnts )' + case( 'WRF' ) + line(7:) = 'subroutine rxt_mod( rate, grp_ratios )' + end select + write(30,100) trim(line) + line = ' ' + write(30,100) trim( line ) + if( model /= 'WRF' ) then + line(7:) = 'use chem_mods, only : rxntot, hetcnt, grpcnt' + write(30,100) trim( line ) + end if + if( model == 'CAM' ) then + line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(30,100) trim( line ) + end if + line = ' ' + write(30,100) trim( line ) + line(7:) = 'implicit none ' + write(30,100) trim( line ) + line = ' ' + write(30,100) trim( line ) + line = '!---------------------------------------------------------------------------' + write(30,100) trim(line) + line = '! ... dummy arguments' + write(30,100) trim(line) + line = '!---------------------------------------------------------------------------' + write(30,100) trim(line) + if( model == 'CAM' .and. march == 'VECTOR' ) then + line = ' integer, intent(in) :: chnkpnts' + write(30,100) trim(line) + else if( model /= 'WRF' ) then + line = ' integer, intent(in) :: plnplv' + write(30,100) trim(line) + end if + if( model == 'MOZART' ) then + line = ' real, intent(inout) :: rate(plnplv,rxntot)' + write(30,100) trim(line) + line = ' real, intent(inout) :: het_rates(plnplv,hetcnt)' + write(30,100) trim(line) + line = ' real, intent(in) :: grp_ratios(plnplv,grpcnt)' + else if( model == 'CAM' ) then + if( march /= 'VECTOR' ) then + line = ' real(r8), intent(inout) :: rate(:,:)' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: het_rates(:,:)' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: grp_ratios(:,:)' + else + line = ' real(r8), intent(inout) :: rate(chnkpnts,max(1,rxntot))' + write(30,100) trim(line) + line = ' real(r8), intent(inout) :: het_rates(chnkpnts,max(1,hetcnt))' + write(30,100) trim(line) + line = ' real(r8), intent(in) :: grp_ratios(chnkpnts,max(1,grpcnt))' + end if + else if( model == 'WRF' ) then + line = ' real, intent(in) :: grp_ratios(:,:)' + write(30,100) trim(line) + line = ' real, intent(inout) :: rate(:,:)' + end if + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + + first = .true. + do k = 1,rxntot +!----------------------------------------------------------------------- +! ... Scan the group map +!----------------------------------------------------------------------- + found = .false. + index = rxt2grp_pntr(k,1) + row = rxt2grp_pntr(k,2) + do l = 1,index + found = .true. + if( first ) then + line = ' ' + first = .false. + end if + rxno = grp_rxt_map(row,1,index) + if( l == 1 ) then + line = ' ' + line(7:) = 'rate(:, ) = rate(:, )' + write(line(14:16),'(i3)') rxno + write(line(28:30),'(i3)') rxno + line(strlen(line)+2:) = ' * grp_ratios(:,' + write(line(strlen(line)+1:),'(i2)') grp_rxt_map(row,l+1,index) + line(strlen(line)+1:) = ')' + else + line(len_trim(line)+1:) = ' &' + write(30,100) trim(line) + line(6:) = ' ' + line(33:) = ' * grp_ratios(:,' + write(line(strlen(line)+1:),'(i2)') grp_rxt_map(row,l+1,index) + line(strlen(line)+1:) = ')' + end if + end do + if( found ) then + write(30,100) trim(line) + end if + end do + + do k = 1,hetcnt + if( hetmap(k) /= 0 ) then + line = ' ' + if( first ) then + first = .false. + end if + line(7:) = ' het_rates(j, ) = het_rates(j, )' + write(line(19:21),'(i3)') k + write(line(38:40),'(i3)') k + line(strlen(line)+2:) = ' * grp_ratios(:,' + write(line(strlen(line)+1:),'(i2)') hetmap(k) + line(strlen(line)+1:) = ')' + write(30,100) trim(line) + end if + end do + + line = ' ' + write(30,100) trim(line) + line = ' end subroutine rxt_mod' + write(30,100) trim(line) + line = ' ' + write(30,100) trim(line) + line(7:) = 'end module mo_rxt_mod' + write(30,100) trim(line) + + close(30) + +100 format(a) + + end subroutine make_rmod diff --git a/chem_proc/src/cam_chempp/rxt_equations.f b/chem_proc/src/cam_chempp/rxt_equations.f new file mode 100644 index 0000000000..a90fe4b833 --- /dev/null +++ b/chem_proc/src/cam_chempp/rxt_equations.f @@ -0,0 +1,284 @@ +module rxt_equations_mod + use VAR_MOD, only : var_lim + use RXT_MOD, only : rxt_lim, prd_lim, prd_limp1 + use utils, only: get_index + + implicit none + + private + + public :: write_rxt_out_code + +contains + + subroutine write_rxt_out_code ( & + rxmcnt, & + rxmap, & + fixmap, & + solsym, & + fixsym, & + prdcnt, & + prdmap, & + rxntot, & + phtcnt, & + outfile ) + + use io, only : temp_path + + implicit none + + integer, intent(in) :: rxmcnt(2) + integer, intent(in) :: rxmap(rxt_lim,prd_lim+3,2) + integer, intent(in) :: fixmap(var_lim,3,2) + character(len=16), intent(in) :: solsym(var_lim) + character(len=16), intent(in) :: fixsym(var_lim) + integer, intent(in) :: phtcnt + integer, intent(in) :: prdcnt + integer, intent(in) :: rxntot + integer, intent(in) :: prdmap(var_lim,prd_limp1) + character(len=*), intent(in) :: outfile + + integer, parameter :: unitno = 33 + character(len=128) :: line + character(len=64) :: mod_name + logical :: lexist + integer :: pos + + inquire( file = trim( temp_path ) // outfile, exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // trim(outfile) ) + end if + open( unit = unitno, file = trim( temp_path ) // trim(outfile) ) + + pos = index(trim(outfile),'.F') + mod_name = outfile(1:pos-1) + + line = ' ' + line(1:) = 'module '//trim(mod_name) + write(unitno,100) trim(line) + + line = ' ' + line(3:) = 'use shr_kind_mod, only : r8 => shr_kind_r8' + write(unitno,100) trim(line) + + line = ' ' + line(3:) = 'implicit none' + write(unitno,100) trim(line) + + line = ' ' + line(3:) = 'private' + write(unitno,100) trim(line) + + line = ' ' + line(3:) = 'public :: set_rates' + write(unitno,100) trim(line) + + line = ' ' + line(1:) = 'contains' + write(unitno,100) trim(line) + + line = ' ' + line(4:) = 'subroutine set_rates( rxt_rates, sol, ncol )' + write(unitno,100) trim(line) + + line = ' ' + line(7:) = 'real(r8), intent(inout) :: rxt_rates(:,:,:)' + write(unitno,100) trim(line) + line = ' ' + line(7:) = 'real(r8), intent(in) :: sol(:,:,:)' + write(unitno,100) trim(line) + line = ' ' + line(7:) = 'integer, intent(in) :: ncol' + write(unitno,100) trim(line) + + call write_rxt_equations ( & + rxmcnt, & + rxmap, & + fixmap, & + solsym, & + fixsym, & + prdcnt, & + prdmap, & + rxntot, & + phtcnt, & + unitno ) + + line = ' ' + line(3:) = 'end subroutine set_rates' + write(unitno,100) trim(line) + + line = ' ' + line(1:) = 'end module '//trim(mod_name) + write(unitno,100) trim(line) + + close(unitno) + +100 format(a) + + end subroutine write_rxt_out_code + + subroutine write_rxt_equations ( & + rxmcnt, & + rxmap, & + fixmap, & + solsym, & + fixsym, & + prdcnt, & + prdmap, & + rxntot, & + phtcnt, unitno ) + + implicit none + + integer, intent(in) :: rxmcnt(2) + integer, intent(in) :: rxmap(rxt_lim,prd_lim+3,2) + integer, intent(in) :: fixmap(var_lim,3,2) + character(len=16), intent(in) :: solsym(var_lim) + character(len=16), intent(in) :: fixsym(var_lim) + integer, intent(in) :: phtcnt + integer, intent(in) :: prdcnt + integer, intent(in) :: rxntot + integer, intent(in) :: prdmap(var_lim,prd_limp1) + integer, intent(in) :: unitno + + character(len=80) :: eq_piece + character(len=80) :: doc_piece + character(len=6) :: num + character(len=120) :: eqline + character(len=120) :: docline + character(len=16) :: symbol + + character(len=120) :: equations(rxntot) + character(len=120) :: docs(rxntot) + + integer :: i,j,l + integer :: rxno + logical :: debug = .false. + + equations(:) = ' ' + docs(:) = ' ' + + ! this is for case where all reactants are invariants + do i = 1,prdcnt + + rxno = prdmap(i,1) + write( num, '(i6)' ) rxno + docline = 'rate_const' +!!$ eqline = 'rxt_rates(:ncol,:,'//trim(num)//') = rxt_rates(:ncol,:,'//trim(num)//')' + + call get_fixed_reactants( fixmap, var_lim, 3, phtcnt, rxno, fixsym, doc_piece ) + + docline = trim(docline)//trim(doc_piece) + +!!$ equations(rxno) = trim(eqline) + docs(rxno) = trim(docline) + + enddo + + do i = 1,2 + do j = 1,rxmcnt(i) + + rxno = rxmap(j,1,i) + + write(num, '(i6)' ) rxno + docline = 'rate_const' + eqline = 'rxt_rates(:ncol,:,'//trim(num)//') = rxt_rates(:ncol,:,'//trim(num)//')' + eq_piece = ' ' + doc_piece = ' ' + + call get_fixed_reactants( fixmap, var_lim, 3, phtcnt, rxno, fixsym, doc_piece ) + + do l = 2,i+1 + if( rxmap(j,l,i) == 0 ) then + exit + end if + symbol = solsym(ABS(rxmap(j,l,i))) + + write(num,'(i6)') ABS(rxmap(j,l,i)) + eq_piece = trim(eq_piece)//'*sol(:ncol,:,' // trim(num) //')' + doc_piece = trim(doc_piece)//'*' // trim(symbol) + + end do + + eqline = trim(eqline)//trim(eq_piece) + docline = trim(docline)//trim(doc_piece) + + equations(rxno) = trim(eqline) + docs(rxno) = trim(docline) + + enddo + enddo + + do i = 1,rxntot + write(unitno,'(a6,a120,a)') ' ',equations(i), ' ! '//trim(docs(i)) + enddo + + if (debug) then + write(*,*) ' EQUATIONS : ' + do i = 1,rxntot + write(*,'(i4,a120,a)') i, ' '//equations(i), ' ! '//trim(docs(i)) + enddo + endif + + end subroutine write_rxt_equations + + subroutine get_fixed_reactants( & + fixmap, & + rowdim, & + coldim, & + phtcnt, & + rxno, & + fixsym, & + doc_piece ) + + use VAR_MOD, only : var_lim + + implicit none + + !----------------------------------------------------------------------- + ! ... Dummy args + !----------------------------------------------------------------------- + integer, intent(in) :: rowdim, coldim, phtcnt + integer, intent(in) :: fixmap(rowdim,coldim,2) + integer, intent(in) :: rxno + character(len=*), intent(in) :: fixsym(:) + + character(len=*), intent(out) :: doc_piece + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: j, l, index + character(len=16) :: symbol + character(len=6) :: num + + integer :: irx + + doc_piece = ' ' + + irx = rxno + if( rxno < phtcnt ) then + irx = - rxno + end if + do j = 1,2 + index = get_index( fixmap(1,1,j), var_lim, 3, 1, irx ) + if( index /= 0 ) then + do l = 2,3 + + if( fixmap(index,l,j) == 0 ) then + return + end if + + symbol = fixsym(fixmap(index,l,j)) + write(num,'(i6)') fixmap(index,l,j) + + doc_piece = trim(doc_piece)//'*' // trim(symbol) + + end do + exit + end if + end do + + end subroutine get_fixed_reactants + +end module rxt_equations_mod diff --git a/chem_proc/src/cam_chempp/rxt_names.f b/chem_proc/src/cam_chempp/rxt_names.f new file mode 100644 index 0000000000..63e7ad3638 --- /dev/null +++ b/chem_proc/src/cam_chempp/rxt_names.f @@ -0,0 +1,76 @@ + + subroutine make_rxt_name_mod +!-------------------------------------------------------------------------------- +! ... Makes a module of parameter reaction names +!-------------------------------------------------------------------------------- + + use rxt_mod, only : rxtcnt => rxntot, gascnt, phtcnt, rxt_tag, rxt_has_tag + use io, only : temp_path + + implicit none + +!-------------------------------------------------------------------------------- +! ... Local variables +!-------------------------------------------------------------------------------- + integer :: i + character(len=80) :: buff + character(len=5) :: num + logical :: lexist + +!-------------------------------------------------------------------------------- +! ... Check mod file existence; remove if found +!-------------------------------------------------------------------------------- + inquire( file = trim( temp_path ) // 'rxt_names.mod', exist = lexist ) + if( lexist ) then + call system( 'rm ' // trim( temp_path ) // 'rxt_names.mod' ) + end if + open( unit = 30, file = trim( temp_path ) // 'rxt_names.mod' ) + + buff = '' + write(30,'(a)') buff + buff(7:) = 'module m_rxt_id' + write(30,'(a)') buff + buff = '' + write(30,'(a)') buff + buff(7:) = 'implicit none' + write(30,'(a)') buff + buff = '' + write(30,'(a)') buff + + do i = 1,rxtcnt + if( rxt_tag(i) /= ' ' ) then + rxt_has_tag(i) = .true. + write(buff(7:),'(''integer, parameter :: rid_'',a,1x,''='',1x,i4)') & + rxt_tag(i)(:len_trim(rxt_tag(i))), i + write(30,'(a)') buff + end if + end do + + if( any( rxt_has_tag(:rxtcnt) ) ) then + buff = '' + write(30,'(a)') buff + end if + + do i = 1,rxtcnt + if( .not. rxt_has_tag(i) ) then + write(num,'(i5)') i+10000 + if( i <= phtcnt ) then + write(buff(7:),'(''integer, parameter :: rid_j'',a,1x,''='',1x,i4)') & + num(2:5), i + write(rxt_tag(i)(:5),'(''j'',a)') num(2:5) + else + write(buff(7:),'(''integer, parameter :: rid_r'',a,1x,''='',1x,i4)') & + num(2:5), i + write(rxt_tag(i)(:5),'(''r'',a)') num(2:5) + end if + write(30,'(a)') buff + end if + end do + + buff = '' + write(30,'(a)') buff + buff(7:) = 'end module m_rxt_id' + write(30,'(a)') buff + close( 30 ) + + end subroutine make_rxt_name_mod diff --git a/chem_proc/src/cam_chempp/slt_hdr.f b/chem_proc/src/cam_chempp/slt_hdr.f new file mode 100644 index 0000000000..b20f1050c0 --- /dev/null +++ b/chem_proc/src/cam_chempp/slt_hdr.f @@ -0,0 +1,41 @@ + subroutine SLT_HDR( cray, & + multitask, & + cpucnt, & + machine ) + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +!----------------------------------------------------------------------- + integer, intent(in) :: cpucnt + logical, intent(in) :: cray + logical, intent(in) :: multitask + character(len=16), intent(in) :: machine + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + logical :: lexist + + INQUIRE( file = 'slt.h', exist = lexist ) + if( lexist ) then + call SYSTEM( 'rm slt.h' ) + end if + OPEN( unit = 30, file = 'slt.h' ) + + if( cray .and. multitask ) then + write(30,'(''# define MT'')') + else if( .not. cray ) then + write(30,'(''# define NOCRAY'')') + write(30,'(''# define PORT'')') + if( multitask ) then + write(30,'(''# define MPP'')') + write(30,'(''# define NCPUS '',i3)') cpucnt + end if + end if + write(30,'(''# define '',a8)') machine + + CLOSE(30) + + end subroutine SLT_HDR diff --git a/chem_proc/src/cam_chempp/sol_cls.f b/chem_proc/src/cam_chempp/sol_cls.f new file mode 100644 index 0000000000..fdea0e13d4 --- /dev/null +++ b/chem_proc/src/cam_chempp/sol_cls.f @@ -0,0 +1,182 @@ + + subroutine SOL_CLS( iout ) +!----------------------------------------------------------------------- +! ... Map solution species to solution method groups +!----------------------------------------------------------------------- + + use IO + use VAR_MOD, only : spccnt => new_nq, spcsym => new_solsym, clscnt, clsmap + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + character(len=80), intent(inout) :: iout(*) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: symlen = 16 + + integer :: kpar, i, parsw(5), nchar + integer :: toklen(20) + integer :: j, l + integer :: no_tokens + integer :: class + character(len=16) :: tokens(20) + character(len=10) :: clshdr(5) = (/ 'EXPLICIT ', 'EBI ', & + 'HOV ', 'IMPLICIT ', & + 'RODAS ' /) + character(len=11) :: clsend(5) = (/ 'ENDEXPLICIT', 'ENDEBI ', & + 'ENDHOV ', 'ENDIMPLICIT', & + 'ENDRODAS ' /) + character(len=1) :: char + logical :: found + + integer :: INILIST + +!----------------------------------------------------------------------- +! ... Initialization +!----------------------------------------------------------------------- + parsw(:) = 0 ; clscnt(:) = 0 ; clsmap(:,:,:) = 0 + + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh /= 'SOLUTIONCLASSES' ) then + call ERRMES( '"Solution classes" card missing; run terminated@', & + lout, char, 1, buff ) + end if + + do + call CARDIN(lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == 'ENDSOLUTIONCLASSES' ) then +!----------------------------------------------------------------------- +! ... Check for all species in class +!----------------------------------------------------------------------- + if( sum( clscnt(:) ) /= spccnt ) then + write(lout,*) ' ' + write(lout,*) 'Following species not in a class' + write(lout,*) ' ' + do l = 1,spccnt + found = .false. + do class = 1,5 + if( clscnt(class) /= 0 ) then + j = INILIST( l, clsmap(1,class,2), clscnt(class) ) + if( j /= 0 ) then + found = .true. + exit + end if + end if + end do + if( .not. found ) then + write(lout,*) trim(spcsym(l)) + end if + end do + stop 'abort' + end if + exit + end if + + found = .false. + do kpar = 1,5 + if( buffh == clshdr(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES( '# is an invalid class header@', & + lout, & + buff(:8), & + 8, & + buff ) + else if( parsw(kpar) /= 0 ) then + call ERRMES( '# solution class already declared@', & + lout, & + clshdr(kpar), & + LEN_TRIM(clshdr(kpar)), & + buff ) + else + parsw(kpar) = 1 + end if + +!----------------------------------------------------------------------- +! ... Read the solution class members +!----------------------------------------------------------------------- +Methods : & + do + call CARDIN(lin, buff, nchar) + buffh = buff + call UPCASE( buffh ) + if( buffh /= clsend(kpar) ) then + if( buffh(:nchar) == 'ALL' ) then + clscnt(:5) = 0 + clscnt(kpar) = spccnt + clsmap(:,:,:) = 0 + do j = 1,spccnt + clsmap(j,kpar,1) = j + clsmap(j,kpar,2) = j + end do + cycle + else if( buffh(:nchar) == 'ALLOTHERS' ) then + clscnt(kpar) = 0 + clsmap(:,kpar,:) = 0 + do j = 1,spccnt + if( SUM( clsmap(j,:5,1) ) == 0 ) then + clscnt(kpar) = clscnt(kpar) + 1 + clsmap(j,kpar,1) = clscnt(kpar) + clsmap(clscnt(kpar),kpar,2) = j + end if + end do + cycle + end if + call GETTOKENS( buff, & + nchar, & + ',', & + symlen, & + tokens, & + toklen, & + 20, & + no_tokens ) + if( no_tokens == 0 ) then + call ERRMES( ' Species input line in error@', lout, buff, 1, ' ' ) + end if + +Tok_loop: do j = 1,no_tokens + do l = 1,spccnt + if( trim(tokens(j)) == trim(spcsym(l)) ) then + clscnt(kpar) = clscnt(kpar) + 1 + if( clscnt(kpar) > spccnt ) then + call ERRMES( ' Species count exceeds limit@', & + lout, & + buff, 1, buff ) + end if + if( SUM( clsmap(l,:5,1) ) /= 0 ) then + call ERRMES( ' # in two or more classes@', & + lout, & + tokens(j), & + toklen(j), & + buff ) + end if + clsmap(l,kpar,1) = clscnt(kpar) + clsmap(clscnt(kpar),kpar,2) = l + cycle tok_loop + end if + end do + call ERRMES( ' Class member # not in solution list@', & + lout, & + tokens(j), & + toklen(j), & + buff ) + end do Tok_loop + else + exit + end if + end do Methods + end do + + end subroutine SOL_CLS diff --git a/chem_proc/src/cam_chempp/sp_utils.f b/chem_proc/src/cam_chempp/sp_utils.f new file mode 100644 index 0000000000..c18c101bed --- /dev/null +++ b/chem_proc/src/cam_chempp/sp_utils.f @@ -0,0 +1,356 @@ + + recursive subroutine STCO( vertex ) +!---------------------------------------------------------------- +! ... Permutate sparse matrix in order to find the +! the strongly connected blocks in a lower triangular +! block form (LTBF) +!---------------------------------------------------------------- + + use SP_MODS + + implicit none + +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: vertex + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i, j, vn + integer :: adj_vertex + + nb = nb + 1 + lowlink(vertex) = nb + number(vertex) = nb + sp = sp + 1 + vstack(sp) = vertex + do vn = rp(vertex),rp(vertex+1)-1 + adj_vertex = ci(vn) + if( number(adj_vertex) == 0 ) then + call STCO( adj_vertex ) + lowlink(vertex) = MIN( lowlink(vertex),lowlink(adj_vertex) ) + else if( number(adj_vertex) < number(vertex) ) then + do j = 1,sp + if( vstack(j) == adj_vertex ) then + lowlink(vertex) = MIN( lowlink(vertex),number(adj_vertex) ) + exit + end if + end do + end if + end do + + if( lowlink(vertex) == number(vertex) ) then + blkcnt = blkcnt + 1 + stcoblk(blkcnt) = pp + 1 + do + if( sp == 0 ) then + exit + end if + vn = vstack(sp) + if( number(vn) >= number(vertex) ) then + sp = sp - 1 + pp = pp + 1 + perm(pp) = vn + blkmemcnt(blkcnt) = blkmemcnt(blkcnt) + 1 + else + exit + end if + end do + end if + + end subroutine STCO + + recursive subroutine STCO_PAT( vertex, order ) +!---------------------------------------------------------------- +! ... Permutate sparse matrix in order to find the +! the strongly connected blocks in a lower triangular +! block form (LTBF) +!---------------------------------------------------------------- + + use SP_MODS + + implicit none + +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: vertex, order + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i, j, vn + integer :: adj_vertex + + nb = nb + 1 + lowlink(vertex) = nb + number(vertex) = nb + sp = sp + 1 + vstack(sp) = vertex + do vn = 1,order + if( matrix(vertex,vn) ) then + adj_vertex = vn + if( number(adj_vertex) == 0 ) then + call STCO_PAT( adj_vertex, order ) + lowlink(vertex) = MIN( lowlink(vertex),lowlink(adj_vertex) ) + else if( number(adj_vertex) < number(vertex) ) then + do j = 1,sp + if( vstack(j) == adj_vertex ) then + lowlink(vertex) = MIN( lowlink(vertex),number(adj_vertex) ) + exit + end if + end do + end if + end if + end do + + if( lowlink(vertex) == number(vertex) ) then + blkcnt = blkcnt + 1 + stcoblk(blkcnt) = pp + 1 + do + if( sp == 0 ) then + exit + end if + vn = vstack(sp) + if( number(vn) >= number(vertex) ) then + sp = sp - 1 + pp = pp + 1 + perm(pp) = vn + blkmemcnt(blkcnt) = blkmemcnt(blkcnt) + 1 + else + exit + end if + end do + end if + + end subroutine STCO_PAT + + subroutine DIAG_MARK( order, matrix, perm ) +!--------------------------------------------------------------------------- +! ... Find permuatation via diagonal markowitz to produce +! near optimal LU fillin +!--------------------------------------------------------------------------- + + implicit none + +!--------------------------------------------------------------------------- +! ... Dummy args +!--------------------------------------------------------------------------- + integer, intent(in) :: order + integer, intent(out) :: perm(order) + logical, intent(in) :: matrix(order,order) + +!--------------------------------------------------------------------------- +! ... Local variables +!--------------------------------------------------------------------------- + integer :: row, rowp1, col, maxrow + integer :: beta, cnt + integer :: i, j + logical :: holder(order) + logical :: pattern(order,order) + + cnt = COUNT( matrix ) + perm(:order) = (/ (row,row=1,order) /) ! no permutations + pattern = matrix + do row = 1,order-1 + rowp1 = row + 1 + beta = (order - 1)**2 + maxrow = row + do col = row,order + cnt = (COUNT(pattern(col,row:order)) - 1) * & + (COUNT(pattern(row:order,col)) - 1) + if( cnt < beta ) then + beta = cnt + maxrow = col + end if + end do + if( maxrow /= row ) then +!---------------------------------------------------------------- +! ... Row and column permuatation +!---------------------------------------------------------------- + holder(row:order) = pattern(row,row:order) + pattern(row,row:order) = pattern(maxrow,row:order) + pattern(maxrow,row:order) = holder(row:order) + holder(row:order) = pattern(row:order,row) + pattern(row:order,row) = pattern(row:order,maxrow) + pattern(row:order,maxrow) = holder(row:order) + beta = perm(row) + perm(row) = perm(maxrow) + perm(maxrow) = beta + end if +!---------------------------------------------------------------- +! ... Now do "symbolic" decomposition on sub-matrix +!---------------------------------------------------------------- + do col = rowp1,order + if( pattern(row,col) ) then + pattern(rowp1:order,col) = pattern(rowp1:order,row) .or. & + pattern(rowp1:order,col) + end if + end do + end do + + end subroutine DIAG_MARK + + subroutine SYM_FAC( order, matrix, adds, mults ) +!---------------------------------------------------------------- +! ... Do a symbolic LU decomposition on sparse matrix +!---------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: order ! matrix order + logical, intent(inout) :: matrix(order,order) ! sparse matrix + integer, intent(out) :: adds(2), mults(2) ! operation counts + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i, im1, j, rcnt, ccnt + + adds = 0; mults = 0; + do i = 2,order + im1 = i - 1 + ccnt = COUNT( matrix(i:order,im1) ) + rcnt = COUNT( matrix(im1,i:order) ) + mults(1) = mults(1) + ccnt * (1 + rcnt) + mults(2) = mults(2) + ccnt + do j = i,order + if( matrix(im1,j) ) then + adds(1) = adds(1) + COUNT( matrix(i:order,j) .and. matrix(i:order,im1) ) + matrix(i:order,j) = matrix(i:order,j) .or. matrix(i:order,im1) + end if + end do + end do + + do i = order,2,-1 + ccnt = COUNT( matrix(1:i-1,i) ) + mults(2) = mults(2) + ccnt + end do + adds(2) = mults(2) + + end subroutine SYM_FAC + + subroutine GEN_PAT( order, pattern, rp, ci ) +!---------------------------------------------------------------- +! ... Generate sparsity pattern from row storage +!---------------------------------------------------------------- + + implicit none +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: order + integer, intent(in) :: rp(order+1) + integer, intent(in) :: ci(*) + logical, intent(out) :: pattern(order,order) + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i, row + + pattern = .false. + do i = 1,order + do row = rp(i),rp(i+1)-1 + pattern(i,ci(row)) = .true. + end do + end do + + end subroutine GEN_PAT + + subroutine PERM_MAT( order, matrix, perm) +!---------------------------------------------------------------- +! ... Matrix row and column permutation +!---------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: order + integer, intent(in) :: perm(order) + logical, intent(inout) :: matrix(order,order) + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i + logical :: copy(order,order) + + copy = matrix +!---------------------------------------------------------------- +! ... Row permutation +!---------------------------------------------------------------- + do i = 1,order + if( perm(i) /= i ) then + copy(i,:order) = matrix(perm(i),:order) + end if + end do + matrix = copy +!---------------------------------------------------------------- +! ... Col permutation +!---------------------------------------------------------------- + do i = 1,order + if( perm(i) /= i ) then + matrix(:order,i) = copy(:order,perm(i)) + end if + end do + + end subroutine PERM_MAT + + subroutine DRAW_MAT( order, matrix ) +!---------------------------------------------------------------- +! ... Draw matrix sparsity +!---------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------- +! ... Dummy args +!---------------------------------------------------------------- + integer, intent(in) :: order + logical, intent(in) :: matrix(order,order) + +!---------------------------------------------------------------- +! ... Local variables +!---------------------------------------------------------------- + integer :: i, row + character(len=1) :: matrow(order) + character(len=32) :: frmt + character(len=132) :: line + + write(*,*) ' ' + line = ' ' + do i = 10,order,10 + write(line(5+i*2:5+i*2),'(i1)') i/10 + end do + write(*,'(a)') line(:LEN_TRIM(line)) + line = ' ' + do i = 1,order + write(line(5+i*2:5+i*2),'(i1)') MOD( i,10 ) + end do + write(*,'(a)') line(:LEN_TRIM(line)) + write(*,*) ' ' + frmt = '(1x,i2,2x,' + i = LEN_TRIM( frmt ) + 1 + if( order < 10 ) then + write(frmt(i:i),'(i1)') order + else + write(frmt(i:i+1),'(i2)') order + end if + frmt(LEN_TRIM(frmt)+1:) = '(1x,a))' + do row = 1,order + matrow = ' ' + where( matrix(row,:order) ) + matrow(:order) = 'X' + endwhere + write(*,frmt) row, matrow + end do + + end subroutine DRAW_MAT diff --git a/chem_proc/src/cam_chempp/sparse_pat.f b/chem_proc/src/cam_chempp/sparse_pat.f new file mode 100644 index 0000000000..304bcff887 --- /dev/null +++ b/chem_proc/src/cam_chempp/sparse_pat.f @@ -0,0 +1,129 @@ + + subroutine SPARSITY_PAT( clscnt, & + clsmap, & + cls_rxt_cnt, & + cls_rxt_map, & + sparse_pat ) +!----------------------------------------------------------------------- +! ... Set the jacobian matrix sparsity pattern +!----------------------------------------------------------------------- + + use VAR_MOD, only : var_lim + use RXT_MOD, only : rxt_lim, prd_lim + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +! +! The columns of the cls_rxt_cnt represent the reaction count +! for each class with the following row conontation: +! (1) - independent reactions +! (2) - linear reactions +! (3) - nonlinear reactions +! (4) - heterogeneous processes +!----------------------------------------------------------------------- + integer, intent(in) :: clscnt, & + clsmap(var_lim), & + cls_rxt_map(rxt_lim,prd_lim+3), & + cls_rxt_cnt(4) + logical, intent(out):: sparse_pat(clscnt,clscnt) + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: i, k, kl, ku, l, m + integer :: target + integer :: species + integer, allocatable :: indexer(:) + logical, allocatable :: match_mask(:,:) + logical, allocatable :: pmask(:,:) + + if( ALLOCATED( match_mask ) ) then + DEALLOCATE( match_mask ) + end if + if( ALLOCATED( pmask ) ) then + DEALLOCATE( pmask ) + end if + if( ALLOCATED( indexer ) ) then + DEALLOCATE( indexer ) + end if + k = SUM( cls_rxt_cnt(:) ) + ALLOCATE( match_mask(k,3) ) + ALLOCATE( indexer(k) ) + if( SUM( cls_rxt_cnt(2:3) ) /= 0 ) then + ALLOCATE( pmask(k,prd_lim) ) + end if + sparse_pat = .false. + do i = 1,clscnt + sparse_pat(i,i) = .true. ! assume only diagonal entries + end do + +Species_loop : & + do species = 1,clscnt +!----------------------------------------------------------------------- +! ... Check for non-linear losses +!----------------------------------------------------------------------- + target = clsmap(species) + kl = SUM( cls_rxt_cnt(:2) ) + 1 + ku = SUM( cls_rxt_cnt(:3) ) + do i = 1,2 + match_mask(kl:ku,i) = cls_rxt_map(kl:ku,i+1) == target + where( match_mask(kl:ku,i) ) + indexer(kl:ku) = 6/(i+1) + endwhere + end do + match_mask(kl:ku,1) = match_mask(kl:ku,1) .or. match_mask(kl:ku,2) + if( COUNT( match_mask(kl:ku,1) ) /= 0 ) then + do k = kl,ku + if( match_mask(k,1) ) then + m = ABS( cls_rxt_map(k,indexer(k)) ) + if( m /= target ) then + do i = 1,clscnt + if( clsmap(i) == m ) then + sparse_pat(species,i) = .true. + exit + end if + end do + end if + end if + end do + end if +!----------------------------------------------------------------------- +! ... Check for production from linear and nonlinear reactions +!----------------------------------------------------------------------- + kl = cls_rxt_cnt(1) + 1 + do k = kl,ku + pmask(k,:) = cls_rxt_map(k,4:prd_lim+3) == species + match_mask(k,1) = ANY( pmask(k,:) ) + end do + if( COUNT( match_mask(kl:ku,1) ) /= 0 ) then + do k = kl,ku + if( match_mask(k,1) ) then + do i = 2,3 + m = ABS( cls_rxt_map(k,i) ) + if( m /= 0 ) then + do l = 1,clscnt + if( clsmap(l) == m ) then + sparse_pat(species,l) = .true. + exit + end if + end do + end if + end do + end if + end do + end if + end do Species_loop + + if( ALLOCATED( match_mask ) ) then + DEALLOCATE( match_mask ) + end if + if( ALLOCATED( pmask ) ) then + DEALLOCATE( pmask ) + end if + if( ALLOCATED( indexer ) ) then + DEALLOCATE( indexer ) + end if + + end subroutine SPARSITY_PAT diff --git a/chem_proc/src/cam_chempp/spat_dim.f b/chem_proc/src/cam_chempp/spat_dim.f new file mode 100644 index 0000000000..87fba079fb --- /dev/null +++ b/chem_proc/src/cam_chempp/spat_dim.f @@ -0,0 +1,99 @@ + + module MO_SPAT_DIMS + + CONTAINS + + subroutine SPAT_DIMS( buff, dimensions ) +!----------------------------------------------------------------------- +! ... Set the simulation spatial dimensions +!----------------------------------------------------------------------- + + use IO, only : lin, lout + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(inout) :: dimensions(6) + character(len=80), intent(inout) :: buff + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: maxparms = 6 + integer :: kpar, nchar, retcod, i, k + character(len=20) :: parkey(maxparms), keywrd + logical :: found + logical :: processed(maxparms) + +!----------------------------------------------------------------------- +! ... Function declarations +!----------------------------------------------------------------------- + integer :: LENOF + + parkey(1) = 'LONGITUDEPOINTS' + parkey(2) = 'LATITUDEPOINTS' + parkey(3) = 'VERTICALPOINTS' + parkey(4) = 'NXPT' + parkey(5) = 'JINTMX' + parkey(6) = 'PLONL' + + processed = .false. +!----------------------------------------------------------------------- +! ... Scan for valid numerical control parameter keyword +!----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + call UPCASE( buff ) + if( buff == 'ENDSPATIALDIMENSIONS' ) then + exit + end if + k = INDEX( buff(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buff(:k-1) + found = .false. + do kpar = 1,maxparms + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES ( ' # is an invalid numerical control' & + // ' parameter keyword@', lout, keywrd, & + LENOF(20,keywrd), buff ) + end if + else +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call ERRMES ( ' numerical specification has no = operator@', & + lout, buff, 1, buff ) + end if + +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( processed(kpar) ) then + call ERRMES( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + call INTCON ( buff(k+1:), & + nchar-k, & + dimensions(kpar), & + retcod ) +!----------------------------------------------------------------------- +! ... Check for numeric parameter syntax error +!----------------------------------------------------------------------- + if( retcod /= 0 ) then + call ERRMES ( ' # is an invalid real or integer in ' & + // 'numeric controls@', lout, buff(k+1:), & + LENOF( nchar-k, buff(k+1:)), buff ) + end if + processed(kpar) = .true. + end do + + end subroutine SPAT_DIMS + + end module MO_SPAT_DIMS diff --git a/chem_proc/src/cam_chempp/srfflx.f b/chem_proc/src/cam_chempp/srfflx.f new file mode 100644 index 0000000000..ced4e401c3 --- /dev/null +++ b/chem_proc/src/cam_chempp/srfflx.f @@ -0,0 +1,86 @@ + + subroutine srfflx( lin, & + lout, & + new_nq, & + new_solsym, & + srf_flx_map, & + srf_flx_cnt, & + tag ) + + use var_mod, only : var_lim + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(in) :: lin, & ! input unit number + lout, & ! output unit number + new_nq, & ! species count + tag ! emission or deposition tag ( 1,2 ) + integer, intent(inout) :: srf_flx_cnt ! count of species with srf flux + integer, intent(out) :: srf_flx_map(*) ! srf flux "map" + character(len=16), intent(in) :: new_solsym(*) ! species names + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: nchar + integer :: toklen(20) + integer :: j, k + integer :: no_tokens + + character(len=320) :: buff + character(len=320) :: buffh + character(len=16) :: tokens(20) + + logical :: found + + integer, parameter :: symlen = 8 + +!----------------------------------------------------------------------- +! ... Read the surface flux species +!----------------------------------------------------------------------- + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase( buffh ) + if( tag == 1 .and. buffh == 'ENDSURFACEFLUX' ) then + exit + else if( tag == 2 .and. buffh == 'ENDSURFACEDEPOSITION' ) then + exit + end if + call gettokens( buff, nchar, ',', symlen, & + tokens, toklen, 20, no_tokens ) + if( no_tokens == 0 ) then + call errmes( ' SRFFLX: Species input line in error@', lout, buff, 1, buff ) + end if + do j = 1,no_tokens + srf_flx_cnt = srf_flx_cnt + 1 + if( srf_flx_cnt > var_lim ) then + call errmes( ' SRFFLX: Species count exceeds limit@', lout, buff, 1, buff ) + end if + found = .false. + do k = 1,new_nq + if( tokens(j) == new_solsym(k) ) then + if( srf_flx_cnt > 1 ) then + if( any( srf_flx_map(:srf_flx_cnt) == k ) ) then + if( tag == 1 ) then + call errmes( '# is already in srf emis list@', lout, tokens(j), toklen(j), buff ) + else if( tag == 2 ) then + call errmes( '# is already in dry dep list@', lout, tokens(j), toklen(j), buff ) + end if + end if + end if + srf_flx_map(srf_flx_cnt) = k + found = .true. + exit + end if + end do + if( .not. found ) then + call errmes( '# is not in solution species list@', lout, tokens(j), toklen(j), buff ) + end if + end do + end do + + end subroutine srfflx diff --git a/chem_proc/src/cam_chempp/sub_scan.f b/chem_proc/src/cam_chempp/sub_scan.f new file mode 100644 index 0000000000..9620e093bf --- /dev/null +++ b/chem_proc/src/cam_chempp/sub_scan.f @@ -0,0 +1,76 @@ + + subroutine SUB_SCAN( filecnt, & + lib_files, & + usr_paths, & + usr_files, & + sub_cnt ) +!--------------------------------------------------------------------- +! ... This subroutine scans a "standard" library routine for +! matching user routines which will override the library +! routine. +!--------------------------------------------------------------------- + + implicit none + +!--------------------------------------------------------------------- +! ... Dummy args +!--------------------------------------------------------------------- + integer, intent(in) :: filecnt ! count of library subroutines + integer, intent(inout) :: sub_cnt ! count of "user" subroutines + character(len=*), intent(inout) :: lib_files(*) ! library filenames + character(len=*), intent(inout) :: usr_files(*) ! user filenames + character(len=*), intent(inout) :: usr_paths(*) ! user filepaths + +!--------------------------------------------------------------------- +! ... Local variables +!--------------------------------------------------------------------- + integer :: i, j, alls, cnt + integer, allocatable :: mark(:) + character(len=128), allocatable :: wrk_files(:) ! work space + character(len=128), allocatable :: wrk_paths(:) ! work space + logical, allocatable :: keep(:) + + if( filecnt > 0 .and. sub_cnt > 0 ) then + ALLOCATE( wrk_files(sub_cnt), wrk_paths(sub_cnt), keep(sub_cnt), stat = alls ) + if( alls /= 0 ) then + write(*,*) ' SUB_SCAN : Failed to allocated wrk array' + stop 'Alloc err' + end if + ALLOCATE( mark(filecnt), stat = alls ) + if( alls /= 0 ) then + write(*,*) ' SUB_SCAN : Failed to allocated wrk array' + stop 'Alloc err' + end if + wrk_files(:sub_cnt) = usr_files(:sub_cnt) + wrk_paths(:sub_cnt) = usr_paths(:sub_cnt) + do i = 1,filecnt + mark(i) = INDEX( lib_files(i)(:LEN_TRIM(lib_files(i))), & + '/', back = .true. ) + 1 + end do + keep(:sub_cnt) = .true. + do i = 1,filecnt + do j = 1,sub_cnt + if( keep(j) .and. & + lib_files(i)(mark(i):LEN_TRIM(lib_files(i))) == & + wrk_files(j)(:LEN_TRIM(wrk_files(j))) ) then + lib_files(i) = wrk_paths(j)(:LEN_TRIM(usr_paths(j))) & + // wrk_files(j)(:LEN_TRIM(wrk_files(j))) + keep(j) = .false. + exit + end if + end do + end do + + cnt = COUNT( keep(:sub_cnt) ) + if( cnt /= sub_cnt ) then + usr_files(:cnt) = PACK( wrk_files(:sub_cnt), mask = keep(:sub_cnt) ) + usr_paths(:cnt) = PACK( wrk_paths(:sub_cnt), mask = keep(:sub_cnt) ) + sub_cnt = cnt + end if + DEALLOCATE( wrk_files ) + DEALLOCATE( wrk_paths ) + DEALLOCATE( keep ) + DEALLOCATE( mark ) + end if + + end subroutine SUB_SCAN diff --git a/chem_proc/src/cam_chempp/symbol.f b/chem_proc/src/cam_chempp/symbol.f new file mode 100644 index 0000000000..1c8c99804b --- /dev/null +++ b/chem_proc/src/cam_chempp/symbol.f @@ -0,0 +1,379 @@ + +subroutine SYMBOL( iout ) + !----------------------------------------------------------------------- + ! ... Parse out the solution, pce, fixed, column, and group variables + !----------------------------------------------------------------------- + + use IO + use VAR_MOD, only : indexh2o, spccnt, indexm, grpsym, grpcof, & + grpmap, grpcnt, colsym, colmap, spcsym, slvdsym, nslvd, & + colub, relmap, aliases, var_lim + + implicit none + + !----------------------------------------------------------------------- + ! ... Dummy args + !----------------------------------------------------------------------- + character(len=80), intent(out) :: iout(*) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer, parameter :: symlen = 16 + + integer :: retcod, parsw(6), nchar + integer :: spclim(5) + integer :: kpar, i + integer :: symbol_len + + integer, allocatable :: toklen(:) + integer :: j,jj, k, jl, l, ic, m, count,acount + integer :: jeq, no_tokens, relcnt + + character(len=80), allocatable :: tokens(:) + character(len=16) :: param + character(len=16) :: spchdr(6) = (/ 'SOLUTION ', & + 'PCE ', & + 'FIXED ', & + 'GROUPS ', & + 'COL-INT ', & + 'NOT-TRANSPORTED ' /) + character(len=20) :: spcend(6) = (/ 'ENDSOLUTION ', & + 'ENDPCE ', & + 'ENDFIXED ', & + 'ENDGROUPS ', & + 'ENDCOL-INT ', & + 'ENDNOT-TRANSPORTED ' /) + character(len=16) :: upname + character(len=1) :: char + + logical :: found + spclim(:) = var_lim + parsw(:) = 0 + buffh = buff + call UPCASE( buffh ) + if( buffh /= 'SPECIES' ) then + call ERRMES( '"Species" card missing; run terminated@', lout, char, 1, buff ) + end if + kpar = 0 + ALLOCATE( tokens(64) ) + ALLOCATE( toklen(64) ) + acount = 0 + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == 'ENDSPECIES' ) then + DEALLOCATE( tokens ) + DEALLOCATE( toklen ) + exit + end if + count = 0 + found = .false. + do kpar = 1,6 + if( buffh == spchdr(kpar) ) then + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES( '# is an invalid species header@', lout, buff(:16), 16, buff ) + else if( parsw(kpar) /= 0 ) then + call ERRMES( '# species class already declared@', lout, spchdr(kpar), LEN_TRIM(spchdr(kpar)), buff ) + else if( kpar >= 4 .and. MAXVAL( spccnt(1:3) ) == 0 ) then + call ERRMES( 'There are no sol,pce,fixed species; cannot declare # species class@', lout, & + spchdr(kpar), LEN_TRIM(spchdr(kpar)), buff ) + else if( kpar == 2 .and. parsw(1) /= 1 ) then + call ERRMES( ' Solution species must be specified BEFORE pce species@', lout, buff, 1, ' ' ) + end if + parsw(kpar) = 1 + + if( kpar <= 3 ) then + !----------------------------------------------------------------------- + ! ... Read the solution, fixed, and/or "relationship" variables + !----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == spcend(kpar) ) then +!!$ if( kpar == 1 .and. count == 0 ) then +!!$ call ERRMES( 'No # variables declared; terminating@', lout, spchdr(1), & +!!$ LEN_TRIM(spchdr(1)), & +!!$ buff ) +!!$ end if + spccnt(kpar) = count + exit + end if + if( kpar == 1 .or. kpar == 3 ) then + symbol_len = 80 + else if( kpar /= 2 ) then + symbol_len = symlen + else + symbol_len = 2*symlen+1 + end if + call GETTOKENS( buff, nchar, ',', symbol_len, & + tokens, toklen, 64, no_tokens ) + if( no_tokens <= 0 ) then + call ERRMES( ' Species input line in error@', lout, buff, 1, ' ' ) + end if + if( (count + no_tokens) > spclim(kpar) ) then + call ERRMES( ' Species count exceeds limit@', lout, buff, 1, buff ) + end if + do j = 1,no_tokens + count = count + 1 + acount = acount + 1 + if( kpar == 1 .or. kpar == 3 ) then + l = INDEX( tokens(j)(:toklen(j)), '->' ) + if( l == 0 ) then + if( toklen(j) <= symlen ) then + spcsym(count,kpar) = tokens(j)(:toklen(j)) + else + call ERRMES( ' Species input line in error@', lout, buff, 1, ' ' ) + end if + else + l = l - 1 + if( l <= symlen ) then + spcsym(count,kpar) = tokens(j)(:l) + else + call ERRMES( ' Species input line in error@', lout, buff, 1, ' ' ) + end if + l = l + 3 + if( toklen(j) - l + 1 <= 64 ) then + aliases(acount) = tokens(j)(l:toklen(j)) + else + call ERRMES( ' Species input line in error@', lout, buff, 1, ' ' ) + end if + end if + else if( kpar == 2 ) then + call GETTOKENS( tokens(j), toklen(j), '/', & + symlen, tokens(19), toklen(19), & + 2, relcnt ) + if( relcnt /= 2 ) then + call ERRMES( ' Relationship syntax error@', lout, buff, 1, ' ' ) + end if + match_loop : do m = 1,2 + do l = 1,spccnt(1) + if( tokens(18+m) == spcsym(l,1)) then + relmap(count,m) = l + cycle match_loop + end if + end do + if( relmap(count,m) == 0 ) then + call ERRMES( ' Relation member # not in solution list@', lout, & + tokens(18+m), toklen(18+m), & + buff ) + end if + end do match_loop + else + spcsym(count,kpar) = tokens(j)(:toklen(j)) + end if + end do + end do + !----------------------------------------------------------------------- + ! ... Check fixed species for atmospheric total density symbol "M" + ! and see if water vapor is declard + !----------------------------------------------------------------------- + if( kpar == 3 ) then + found = .false. + do i = 1,spccnt(3) + upname = spcsym(i,3) + call UPCASE( upname ) + if( upname == 'M' ) then + indexm = i + found = .true. + exit + end if + end do + if( .not. found ) then + call ERRMES( 'There must be a fixed symbol "m"; run terminated@', lout, char, 1, buff ) + end if + do i = 1,spccnt(3) + upname = spcsym(i,3) + call UPCASE( upname ) + if( upname == 'H2O' ) then + indexh2o = i + exit + end if + end do + end if + else if( kpar == 4 ) then + !----------------------------------------------------------------------- + ! ... The group section + !----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == spcend(kpar) ) then + spccnt(4) = count + exit + end if + count = count + 1 + if( count > spclim(kpar) ) then + call ERRMES( 'Group count exceeds limit@', lout, buff, 1, buff ) + end if + jeq = INDEX( buff(:symlen+1),'=' ) + if( jeq == 0 ) then + call ERRMES( 'Group name exceeds char limit@', lout, buff, 1, buff ) + else if( jeq == 1 ) then + call ERRMES( 'Group name missing@', lout, buff, 1, buff ) + else if( jeq == nchar ) then + call ERRMES( 'Group list missing@', lout, buff, 1, buff ) + end if + grpsym(count) = buff(:jeq-1) + jl = jeq + 1 + call GETTOKENS( buff(jl:nchar), nchar - jl + 1, '+', 16, & + tokens, toklen, 20, no_tokens ) + if( no_tokens <= 1 ) then + call ERRMES( 'One or fewer group members@', lout, buff, 1, buff ) + end if + l = 0 + do j = 1,no_tokens + k = INDEX( tokens(j)(:toklen(j)),'*' ) + if( k == 1 ) then + call ERRMES( 'No group member multiplier specified@', lout, buff, 1, buff ) + else if( k == toklen(j) ) then + call ERRMES( 'No group member specified@', lout, buff, 1, buff ) + end if + param = tokens(j)(k+1:toklen(j)) + found = .false. + grp_srch_loop : do ic = 1,2 + do m = 1,spccnt(ic) + if( param == spcsym(m,ic) ) then + found = .true. + exit grp_srch_loop + end if + end do + end do grp_srch_loop + if( .not. found ) then + call ERRMES( 'Group member # not in sol,pce lists@', lout, param, k, buff ) + end if + l = l + 1 + if( l > 20 ) then + call ERRMES( 'Group member count exceeds limit@', lout, buff, 1, buff ) + end if + if( k /= 0 ) then + param = tokens(j)(:k-1) + call RELCON( param, k-1, grpcof(l,count), retcod ) + if( retcod /= 0 ) then + call ERRMES( '# is an invalid group member coefficient@', lout, param, k-1, buff ) + end if + end if + grpmap(l,count) = 1000*ic + m + end do + + if( l == 0 ) then + call ERRMES( 'Group has no members@', lout, buff, 1, buff ) + end if + grpcnt(count) = l + iout(count) = ' ' + iout(count) = buff(:jeq-1) // ' = ' + do j = 1,no_tokens + jl = LEN_TRIM(iout(count)) + 1 + if( j == 1 ) then + iout(count)(jl+1:) = tokens(j)(:toklen(j)) + else + iout(count)(jl:) = ' + ' // tokens(j)(:toklen(j)) + end if + end do + end do + else if( kpar == 5 ) then + !----------------------------------------------------------------------- + ! ... The column integrals + !----------------------------------------------------------------------- + do + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == spcend(kpar) ) then + spccnt(5) = count + exit + end if + call GETTOKENS( buff(:nchar), nchar, ',', 32, & + tokens, toklen, 20, no_tokens ) + if( no_tokens <= 0 ) then +! call ERRMES( 'Column integral list improperly specified@', lout, buff, 1, buff ) + end if + do j = 1,no_tokens + jeq = INDEX( tokens(j)(:toklen(j)),'=' ) +!!$ if( jeq == 0 ) then +!!$ call ERRMES( 'No assignment operator in column integral list@', lout, tokens(j), toklen(j), buff ) +!!$ else if( jeq == 1 ) then +!!$ call ERRMES( 'No member in column integral list@', lout, tokens(j), toklen(j), buff ) +!!$ else if( jeq == toklen(j) ) then +!!$ call ERRMES( 'No value in column integral list@', lout, tokens(j), toklen(j), buff ) +!!$ else if( jeq > (symlen+1) ) then +!!$ call ERRMES( 'Column name exceeds char limit@', lout, buff, 1, buff ) +!!$ end if + param = tokens(j)(:jeq-1) + found = .false. + colub_srch_loop : do ic = 1,3 + do m = 1,spccnt(ic) + if( param == spcsym(m,ic) ) then + found = .true. + exit colub_srch_loop + end if + end do + end do colub_srch_loop +!!$ if( .not. found ) then +!!$ call ERRMES( 'Column member # not in sol,pce, or fixed lists@', lout, param, k, buff ) +!!$ end if + count = count + 1 + if( count > spclim(kpar) ) then + call ERRMES( 'Column count exceeds limit@', lout, buff, 1, buff ) + end if + param = tokens(j)(jeq+1:toklen(j)) + call RELCON( param, toklen(j)-jeq, colub(count), retcod ) + if( retcod /= 0 ) then + call ERRMES( '# is an invalid upper bndy column density@', lout, param, toklen(j)-jeq, buff ) + end if + colsym(count) = tokens(j)(:jeq-1) + end do + end do + else if( kpar == 6 ) then + !----------------------------------------------------------------------- + ! ... The Short Lived Species + !----------------------------------------------------------------------- + jj=0 + do + + call CARDIN( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh == spcend(kpar) ) then + exit + end if + call GETTOKENS( buff(:nchar), nchar, ',', 32, & + tokens, toklen, 20, no_tokens ) +!!$ if( no_tokens <= 0 ) then +!!$! call ERRMES( 'Column integral list improperly specified@', lout, buff, 1, buff ) +!!$ end if + + do j=1,no_tokens + + found = .false. + slvd_srch_loop : do ic = 1,2 + do m = 1,spccnt(ic) + if( tokens(j) == spcsym(m,ic) ) then + found = .true. + exit slvd_srch_loop + end if + end do + end do slvd_srch_loop + if( .not. found ) then + call ERRMES( 'Short Lived Species # not in sol,pce lists@', lout, tokens(j), toklen(j), buff ) + end if + jj=jj+1 + slvdsym(jj) = trim(tokens(j)) + enddo + + nslvd = jj + + end do + + end if + + end do + +end subroutine SYMBOL diff --git a/chem_proc/src/cam_chempp/tokens.f b/chem_proc/src/cam_chempp/tokens.f new file mode 100644 index 0000000000..6f10f186d7 --- /dev/null +++ b/chem_proc/src/cam_chempp/tokens.f @@ -0,0 +1,71 @@ + subroutine GETTOKENS( string, & + ls, & + delim, & + maxlen, & + tokens, & + toklen, & + maxtok, & + tokcnt ) + + implicit none + +!----------------------------------------------------------------------- +! Input arguments: +! string - character string to crack into tokens +! ls - length of string +! delim - token delimiter character +! maxlen - maximum length of any single token +! maxtok - maximum number of tokens +! Output arguments: +! tokcnt - number of actual tokens +! < 0 => hit maxtok before end of string +! = 0 => error in input string +! toklen - array containing length of each token +! tokens - character array of tokens +!----------------------------------------------------------------------- + + integer, intent(in) :: ls, maxlen, maxtok + integer, intent(out) :: tokcnt + integer, intent(out) :: toklen(*) + + character(len=*), intent(in) :: string + character(len=*), intent(out) :: tokens(*) + character(len=1), intent(in) :: delim + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer :: marker, i, length, endpos + + tokcnt = 0 + marker = 1 + do i = 1,ls + if( string(i:i) == delim .or. i == ls ) then + if( i == ls ) then + if( string(i:i) == delim ) then + tokcnt = 0 + exit + end if + length = i - marker + 1 + endpos = i + else + length = i - marker + endpos = i - 1 + end if + if( length < 1 .or. length > maxlen ) then + tokcnt = 0 + exit + end if + tokcnt = tokcnt + 1 + if( tokcnt > maxtok ) then + tokcnt = -tokcnt + exit + end if + tokens(tokcnt) = ' ' + tokens(tokcnt)(:length) = string(marker:endpos) + toklen(tokcnt) = length + marker = i + 1 + end if + end do + + end subroutine GETTOKENS diff --git a/chem_proc/src/cam_chempp/usrsubs.f b/chem_proc/src/cam_chempp/usrsubs.f new file mode 100644 index 0000000000..b136cbd66f --- /dev/null +++ b/chem_proc/src/cam_chempp/usrsubs.f @@ -0,0 +1,98 @@ + + subroutine USRSUBS ( sub_names, sub_cnt ) + + use IO + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(out) :: sub_cnt ! count of user subroutines + character(len=128), intent(out) :: sub_names(*) ! user filenames + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: symlen = 64 + + integer :: sublim = 100 + integer :: nchar, pos + integer :: toklen(20) + integer :: j, count + integer :: no_tokens + + character(len=64) :: filepath + character(len=128) :: filespec + character(len=64) :: tokens(20) + + logical :: lexist + + sub_cnt = 0 + count = 0 + filepath = ' ' + filespec = ' ' +!----------------------------------------------------------------------- +! ... Read the subroutine pathnames +!----------------------------------------------------------------------- + do + call CARDIN ( lin, buff, nchar ) + buffh = buff + call UPCASE( buffh ) + if( buffh /= 'ENDUSERSUBROUTINES' ) then + call GETTOKENS( buff, nchar, ',', symlen, & + tokens, toklen, 20, no_tokens ) + if( no_tokens == 0 ) then + call ERRMES( ' Files input line in error@', lout, buff, 1, ' ' ) +!----------------------------------------------------------------------- +! ... Check for filepath setting +!----------------------------------------------------------------------- + else if( no_tokens == 1 .and. tokens(1)(9:9) == '=' ) then + filepath = tokens(1)(:8) + call UPCASE( filepath ) + if( filepath == 'FILEPATH' ) then + filepath = tokens(1)(10:) + filepath = TRIM( filepath ) + else + call ERRMES( ' # is not FILEPATH keyword@', lout, tokens(1)(:8), 8, buff ) + end if + cycle + end if +!----------------------------------------------------------------------- +! ... Process the user subroutine filespec +!----------------------------------------------------------------------- + do j = 1,no_tokens + count = count + 1 + if( count > sublim ) then + call ERRMES( ' Files count exceeds limit@', lout, buff, 1, buff ) + end if + if( tokens(j)(1:1) == '/' ) then + filespec = tokens(j)(:toklen(j)) + else + if( filepath /= ' ' ) then + pos = LEN_TRIM(filepath) + if( filepath(pos:pos) /= '/' ) then + filepath(pos+1:pos+1) = '/' + end if + filespec = TRIM( filepath) // tokens(j)(:toklen(j)) + else + filespec = tokens(j)(:toklen(j)) + end if + end if +!----------------------------------------------------------------------- +! ... Check for file existence +!----------------------------------------------------------------------- + INQUIRE( file = TRIM( filespec ), exist = lexist ) + if( .not. lexist ) then + call ERRMES( ' File # does NOT exist@', lout, filespec, LEN_TRIM(filespec), buff ) + end if + sub_names(count) = filespec + end do + cycle + else + sub_cnt = count + exit + end if + end do + + end subroutine USRSUBS diff --git a/chem_proc/src/cam_chempp/ver_hdr.f b/chem_proc/src/cam_chempp/ver_hdr.f new file mode 100644 index 0000000000..00487b06e4 --- /dev/null +++ b/chem_proc/src/cam_chempp/ver_hdr.f @@ -0,0 +1,144 @@ + + module mo_ver_hdr + + contains + + subroutine ver_hdr( options, & + plon, plonl, plev, & + machine, & + model, & + arch_type, & + ohstflag, & + diagprnt, & + tavgprnt, & + srf_flx_cnt, & + hetcnt, rxntot, clscnt, nzcnt, spcno, & + dvel_cnt ) + + implicit none + +!----------------------------------------------------------------------- +! ... The arguments +!----------------------------------------------------------------------- + integer, intent(in) :: srf_flx_cnt ! species with srf flux + integer, intent(in) :: dvel_cnt ! species with dep vel + integer, intent(in) :: plon, plonl, plev + integer, intent(in) :: hetcnt, rxntot, spcno + integer, intent(in) :: nzcnt(2) + integer, intent(in) :: clscnt(5) + character(len=16), intent(in) :: machine ! target machine + character(len=16), intent(in) :: model ! target model + character(len=16), intent(in) :: arch_type ! architecture + logical, intent(in) :: options(*) ! options array + logical, intent(in) :: ohstflag ! hist tape write flag + logical, intent(in) :: diagprnt ! chktrc, negtrc diag printout flag + logical, intent(in) :: tavgprnt ! time averaged printout flag + +!----------------------------------------------------------------------- +! ... The local variables +!----------------------------------------------------------------------- + integer :: i, cache_factor + integer :: up_bound(2) + logical :: lexist + + inquire( file = 'version.h', exist = lexist ) + if( lexist ) then + call system( 'rm version.h' ) + end if + open( unit = 30, file = 'version.h' ) + + if( options(1) ) then + write(30,'(''# define CHEM'')') + end if + + if( options(2) ) then + write(30,'(''# define CRAY'')') + end if + + if( ohstflag ) then + write(30,'(''# define HISTTAPE'')') + end if + + if( diagprnt ) then + write(30,'(''# define DIAGPRNT'')') + end if + + if( tavgprnt ) then + write(30,'(''# define TAVGPRNT'')') + end if + + if( options(12) ) then + write(30,'(''# define RXTNLOOKUP'')') + end if + + if( options(14) ) then + write(30,'(''# define F90'')') + end if + + if( options(16) ) then + write(30,'(''# define USRHOOK'')') + end if + + if( options(17) ) then + write(30,'(''# define MODULES'')') + end if + + if( srf_flx_cnt /= 0 ) then + write(30,'(''# define SFLUX'')') + end if + + if( dvel_cnt /= 0 ) then + write(30,'(''# define DVEL'')') + end if + + select case( machine ) + case( 'INTEL' ) + write(30,'(''# define CLSZE 1'')') + write(30,'(''# define MACHINE_INTEL'')') + case( 'ALPHA', 'IBM' ) + do i = 1,2 + up_bound(i) = 2*nzcnt(i) + rxntot + hetcnt + 6*clscnt(i+3) + spcno + up_bound(i) = CEILING( 8.*1024./REAL(up_bound(i)) ) + end do + i = MINVAL( up_bound(:) ) + up_bound(1) = i + do i = 2,up_bound(1) + if( MOD( plonl,i) == 0 ) then + cache_factor = i + end if + end do + write(30,'(''# define CLSZE '',i3)') MAX( 1,cache_factor ) + if( machine == 'IBM' ) then + write(30,'(''# define MACHINE_IBM'')') + else + write(30,'(''# define MACHINE_ALPHA'')') + end if + case( 'CRAY': 'CRAYYMP', 'J90', 'C90' ) + write(30,'(''# define CLSZE '',i3)') plon + write(30,'(''# define MACHINE CRAY'')') + case( 'NEC', 'FUJITSU' ) +! write(30,'(''# define CLSZE '',i5)') plon*plev + write(30,'(''# define CLSZE 1'')') + if( machine == 'NEC' ) then + write(30,'(''# define MACHINE_NEC'')') + else + write(30,'(''# define MACHINE_FUJITSU'')') + end if + case default + if( arch_type == 'HYBRID' ) then + write(30,'(''# define CLSZE 4'')') + else + write(30,'(''# define CLSZE '',i3)') plon + end if + end select + if( model == 'MOZART' ) then + write(30,'(''# define MOZART '')') + else if( model == 'MOZART' ) then + write(30,'(''# define CAM '')') + end if + + close(30) + + end subroutine ver_hdr + + end module mo_ver_hdr diff --git a/chem_proc/src/cam_chempp/ver_opts.f b/chem_proc/src/cam_chempp/ver_opts.f new file mode 100644 index 0000000000..7a5158386d --- /dev/null +++ b/chem_proc/src/cam_chempp/ver_opts.f @@ -0,0 +1,243 @@ + + module mo_ver_opts + + private + public :: ver_opts + + contains + + subroutine ver_opts( options, model, machine, march, arch_type, & + wrk_dir, cpp_dir, cpp_opts, subfile, diagprnt, & + tavgprnt, cpucnt, vec_ftns, vctr_len ) +!----------------------------------------------------------------------- +! ... Set the simulation options +!----------------------------------------------------------------------- + + use io + + implicit none + +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + integer, intent(inout) :: cpucnt + character(len=16), intent(inout) :: machine + character(len=16), intent(inout) :: model + character(len=16), intent(inout) :: march + character(len=16), intent(inout) :: arch_type + character(len=64), intent(out) :: wrk_dir + character(len=64), intent(inout) :: cpp_dir, cpp_opts + character(len=64), intent(out) :: subfile + logical, intent(inout) :: diagprnt + logical, intent(inout) :: tavgprnt + logical, intent(inout) :: vec_ftns + logical, intent(inout) :: options(:) + integer, intent(inout) :: vctr_len + +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- + integer, parameter :: maxparm = 27 + + integer :: kpar, nchar, k + integer :: err + logical :: entered(maxparm) + + character(len=20) :: keywrd + character(len=20) :: parkey(maxparm) + + logical :: found + + integer :: lenof + + parkey(1) = 'MACHINE' + parkey(2) = 'DIFFUSION' + parkey(3) = 'CONVECTION' + parkey(4) = 'NORMS' + parkey(5) = 'CONSERVATION' + parkey(6) = 'SOURCECODE' + parkey(7) = 'CPUS' + parkey(8) = 'MULTITASK' + parkey(9) = 'FIXER' + parkey(10) = 'DIAGPRNT' + parkey(11) = 'RXTNLOOKUP' + parkey(12) = 'RELHUM' + parkey(13) = 'F90' + parkey(14) = 'GEOHEIGHT' + parkey(15) = 'USERHOOK' + parkey(16) = 'MODULES' + parkey(17) = 'WORKDIR' + parkey(18) = 'NAMEMOD' + parkey(19) = 'SUBFILE' + parkey(20) = 'TAVGPRNT' + parkey(21) = 'VEC_FTNS' + parkey(22) = 'ARCHITECTURE' + parkey(23) = 'CPP_DIR' + parkey(24) = 'CPP_OPTS' + parkey(25) = 'MODEL' + parkey(26) = 'MODEL_ARCHITECTURE' + parkey(27) = 'VECTOR_LENGTH' + + entered = .false. + +!----------------------------------------------------------------------- +! ... Scan for valid option keyword +!----------------------------------------------------------------------- + do + call cardin( lin, buff, nchar ) + buffh = buff + call upcase ( buffh ) + if( buffh == 'ENDVERSIONOPTIONS' ) then + if( .not. options(1) ) then ! not a cray target + if( cpucnt > 1 ) then + options(10) = .true. ! "distributed" processing + else + options(10) = .false. ! no dist processing + end if + end if + if( .not. options(13) ) then ! if not fortran90 then no modules + options(16) = .false. + options(17) = .false. + end if + if( machine /= 'IBM' ) then + vec_ftns = .false. + end if + if( machine == 'NEC' ) then + march = 'VECTOR' + else if( machine == 'INTEL' ) then + march = 'SCALAR' + end if + if( model == 'WRF' ) then + march = 'SCALAR' + end if + exit + end if + k = index( buffh(:nchar), '=' ) + if( k /= 0 ) then + keywrd = buffh(:k-1) + found = .false. + do kpar = 1,maxparm + if( keywrd == parkey(kpar) ) then + found = .true. + exit + end if + end do + else + call errmes ( ' option specification has no = operator@', lout, buff, 1, buff ) + end if + if( .not. found ) then +!----------------------------------------------------------------------- +! ... Invalid parameter keyword; terminate the program +!----------------------------------------------------------------------- + call errmes ( ' # is an invalid options' & + // ' parameter keyword@', lout, keywrd, & + LENOF(20,keywrd), buff ) + end if + +!----------------------------------------------------------------------- +! ... Valid parameter keyword; now check for duplicate keyword +!----------------------------------------------------------------------- + if( entered(kpar) ) then + call errmes( '0 *** # has already been specified@', & + lout, parkey(kpar), k, ' ' ) + end if + +!----------------------------------------------------------------------- +! ... Set individual options +!----------------------------------------------------------------------- + if( kpar == 1 ) then + machine = buffh(k+1:nchar) + if( machine /= 'CRAYYMP' .and. machine /= 'CRAY2' .and. machine /= 'CRAY3' & + .and. machine /= 'J90' .and. machine /= 'C90' ) then + options(1) = .false. + end if + else if( kpar == 6 ) then + if( buffh(k+1:nchar) /= 'FULL' ) then + options(6) = .false. + end if + else if( kpar == 7 ) then + call intcon( buffh(k+1:), & + nchar - k, & + cpucnt, & + err ) + if( err /= 0 ) then + call errmes( ' # is not a valid number@', & + lout, & + buffh(k+1:), & + nchar - k, & + buff ) + end if + else if( kpar == 21 ) then + if( buffh(k+1:nchar) == 'ON' .or. buffh(k+1:nchar) == 'YES' ) then + vec_ftns = .true. + end if + else if( kpar == 22 ) then + arch_type = buffh(k+1:nchar) + if( arch_type /= 'OMP' .and. arch_type /= 'MPI' .and. arch_type /= 'HYBRID' ) then + call errmes( '0 *** # is not a valid architecture type@', lout, arch_type, 8, ' ' ) + end if + else if( kpar == 25 ) then + model = buffh(k+1:nchar) + if( model /= 'MOZART' .and. model /= 'CAM' .and. model /= 'WRF' ) then + call errmes( '# is not a valid model type@', lout, buff(k+1:), nchar-k , ' ' ) + end if + else if( kpar == 26 ) then + march = buffh(k+1:nchar) + if( march /= 'SCALAR' .and. march /= 'CACHE' .and. march /= 'VECTOR' ) then + call errmes( '# is not a valid model architecture type@', lout, buff(k+1:), nchar-k , ' ' ) + end if + else if( kpar == 27 ) then + call intcon( buffh(k+1:), & + nchar - k, & + vctr_len, & + err ) + if( err /= 0 ) then + call errmes( ' # is not a valid number@', & + lout, & + buffh(k+1:), & + nchar - k, & + buff ) + end if + else + if( buffh(k+1:nchar) == 'ON' .or. buffh(k+1:nchar) == 'YES' ) then + if( kpar == 10) then + diagprnt = .true. + else if( kpar == 20) then + tavgprnt = .true. + else if( kpar == 18 ) then + options(17) = .true. + else if( kpar /= 8 .and. kpar /= 9 ) then + options(kpar) = .true. + else if( kpar == 8 ) then + options(10) = .true. + else if( kpar == 9 ) then + options(9) = .true. + end if + else + if( kpar == 17) then + wrk_dir = buff(k+1:nchar) + else if( kpar == 23) then + cpp_dir = buff(k+1:nchar) + else if( kpar == 24) then + cpp_opts = buff(k+1:nchar) + else if( kpar == 19) then + subfile = buff(k+1:nchar) + else if( kpar == 10) then + diagprnt = .false. + else if( kpar == 20) then + tavgprnt = .false. + else if( kpar /= 8 .and. kpar /= 9 ) then + options(kpar) = .false. + else if( kpar == 8 ) then + options(10) = .false. + else if( kpar == 9 ) then + options(9) = .false. + end if + end if + end if + entered(kpar) = .true. + end do + + end subroutine ver_opts + + end module mo_ver_opts diff --git a/chem_proc/src/make_chempp b/chem_proc/src/make_chempp new file mode 100755 index 0000000000..3c1871b251 --- /dev/null +++ b/chem_proc/src/make_chempp @@ -0,0 +1,9 @@ +#!/bin/csh + +set exenam=../campp +set objdir=OBJ + +rm -f $exenam +rm -f $objdir/* + +gmake USER_FC=pgf95 DEBUG=TRUE EXENAME=$exenam diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 7b8f9a8d53..6fe4700825 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -104,10 +104,7 @@ def buildcpp(case): os.makedirs(camconf) # Construct the command itself. - testpath = os.path.join(srcroot, "components", "cam") - if os.path.exists(testpath): - srcroot = testpath - cmd = os.path.join(srcroot, "bld", "configure") + \ + cmd = os.path.join(srcroot, "components", "cam", "bld", "configure") + \ " " + " ".join(config_opts) run_cmd_no_fail(cmd, from_dir=camconf) diff --git a/cime_config/buildlib b/cime_config/buildlib index 84cd406f1c..8c60595d1e 100755 --- a/cime_config/buildlib +++ b/cime_config/buildlib @@ -39,11 +39,7 @@ def _build_cam(): #------------------------------------------------------- # Call cam's buildcpp #------------------------------------------------------- - testpath = os.path.join(srcroot, "components", "cam") - if os.path.exists(testpath): - srcroot = testpath - - cmd = os.path.join(os.path.join(srcroot, + cmd = os.path.join(os.path.join(srcroot, "components", "cam", "cime_config", "buildcpp")) logger.info(" ...calling cam buildcpp to set build time options") try: diff --git a/cime_config/buildnml b/cime_config/buildnml index b12f690263..bf9e2ea298 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -44,11 +44,7 @@ def buildnml(case, caseroot, compname): RUN_REFCASE = case.get_value("RUN_REFCASE") RUN_REFDATE = case.get_value("RUN_REFDATE") RUN_REFTOD = case.get_value("RUN_REFTOD") - - testsrc = os.path.join(srcroot, "components", "cam") - if os.path.exists(testsrc): - srcroot = testsrc - + DMS_MODE = case.get_value("CCSM_BGC") #-------------------------------------------------------------------- # call buildcpp to set both cppdefs and config_cache.xml file for generating namelist #-------------------------------------------------------------------- @@ -61,7 +57,7 @@ def buildnml(case, caseroot, compname): if not filecmp.cmp(file1, file2): call_buildcpp = True if call_buildcpp: - cmd = os.path.join(os.path.join(srcroot,"cime_config","buildcpp")) + cmd = os.path.join(os.path.join(srcroot,"components","cam","cime_config","buildcpp")) logger.info(" ...calling cam buildcpp to set build time options") try: mod = imp.load_source("buildcpp", cmd) @@ -169,7 +165,7 @@ def buildnml(case, caseroot, compname): buildnl_opts += ["-namelist", '" &atmexp ' + CAM_NAMELIST_OPTS + '/" '] - cmd = os.path.join(srcroot, "bld", "build-namelist") + cmd = os.path.join(srcroot, "components", "cam", "bld", "build-namelist") cmd += " " + " ".join(buildnl_opts) rc, out, err = run_cmd(cmd, from_dir=camconf) diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index dfbba10270..33a9a21022 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -8,7 +8,7 @@ CAM =============== --> - CAM cam6 physics: + CAM cam6 physics: CAM cam5 physics: CAM cam4 physics: CAM simplified and non-versioned physics : @@ -19,8 +19,17 @@ =============== --> abrupt quadrupling of CO2 with other forcings maintained at 1850 piControl levels (CMIP6 DECK abrupt4xCO2 experiment) : + abrupt doubling of CO2 with other forcings maintained at 1850 piControl levels : ramped CO2 increasing by 1% per year with other forcings maintained at 1850 piControl levels (CMIP6 DECK 1pctCO2 experiment) : + cam 5 physics and Production tagged aerosols (OSLO_AERO) + cam 6 and Production tagged aerosols (OSLO_AERO) + cam 6 and general NorESM changes + Production tagged aerosols (OSLO_AERO) + cam 5.4+Production tagged aerosols (OSLO_AERO)+clm5 + cam 5 physics and Production tagged aerosols (OSLO_AERO) + cam 6 (no clubb) physics and Production tagged aerosols (OSLO_AERO) + cam 6 physics and Production tagged aerosols (OSLO_AERO) + -offline_drv rad + + -phys cam5 -chem trop_mam_oslo + -chem trop_mam_oslo + -chem trop_mam_oslo + -chem trop_mam_oslo -cosp + -chem trop_mam_oslo -cosp + -chem trop_mam_oslo -cosp + -chem trop_mam_oslo -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 build_component_cam env_build.xml @@ -228,6 +250,15 @@ 1850-PD_cam5 + ssp126_cam6 + ssp245_cam6 + ssp370_cam6 + ssp585_cam6 + waccm_tsmlt_ssp126_cam6 + waccm_tsmlt_ssp245_cam6 + waccm_tsmlt_ssp370_cam6 + waccm_tsmlt_ssp534_cam6 + waccm_tsmlt_ssp585_cam6 2005-2100_cam4_rcp26 2005-2100_cam4_rcp45 2005-2100_cam4_rcp45_bgc @@ -256,6 +287,72 @@ scam_arm97 + 2000_cam6_noclb + 1850_cam54_ptaero + 2000_cam6_noclb_oslo + 2000_cam6_oslo + 1850_cam6_oslo + 1850_cam6_noresm + 1850_cam6_noresm_frc2 + + 1850_cam6_noresm_ghgonly + 1850_cam6_noresm_natonly + 1850_cam6_noresm_aeroxidonly + + ssp245_cam6_noresm_ghgonly_frc2 + ssp245_cam6_noresm_natonly_frc2 + ssp245_cam6_noresm_aeroxidonly_frc2 + + + 1850_cam6_noresm_ghgonly + 1850_cam6_noresm_natonly + 1850_cam6_noresm_aeroxidonly + 1850_cam6_noresm_ozoneonly + + 1850_cam6_noresm_ghg2014 + 1850_cam6_noresm_ghgnoh2o2014 + 1850_cam6_noresm_n2o2014 + 1850_cam6_noresm_ch42014 + 1850_cam6_noresm_ch4noh2o2014 + 1850_cam6_noresm_bc2014 + 1850_cam6_noresm_oc2014 + 1850_cam6_noresm_so22014 + 1850_cam6_noresm_aer2014 + 1850_cam6_noresm_aeroxid2014 + 1850_cam6_noresm_so2oxid2014 + 1850_cam6_noresm_ntcf2014 + 1850_cam6_noresm_anthro2014 + 1850_cam6_noresm_ghgozone2014 + 1850_cam6_noresm_ozone2014 + 1850_cam6_noresm_h2o2014 + 1850_cam6_noresm_oxid2014 + + hist_cam6_oslo + hist_cam6_noresm + hist_cam6_noresm_frc2 + hist_cam6_noresm_frc2 + hist_cam6_noresm_frc2 + + sd_hist_cam6_noresm + + hist_cam6_noresm_pintcf + hist_cam6_noresm_piaer + hist_cam6_noresm_piaeroxid + + hist_cam6_noresm_pintcf + hist_cam6_noresm_piaer + + ssp126_cam6_noresm_frc2 + ssp245_cam6_noresm_frc2 + ssp370_cam6_noresm_frc2 + ssp585_cam6_noresm_frc2 + + 2000_cam5_oslonudge + cam5_nudge_ptaero_up1 + 2000_cam6_noclb_oslonudge + 2000_cam6_oslonudge + 2000_cam5_oslonudge + cam5_ptaero_up1 run_component_cam env_run.xml @@ -265,7 +362,7 @@ leverages groups of namelist options (use cases) that are often paired with the CAM configure options. These use cases are xml files located in - $CIMEROOT/../components/cam/bld/namelist_files/use_cases. + $CIMEROOT/../components/atm/cam/bld/namelist_files/use_cases. In general, this variable should not be modified for supported component sets (compsets). Recommendation: If you want to modify this value for your experiment, use your own user-defined @@ -279,6 +376,7 @@ scenario_ghg='RAMP_CO2_ONLY'ramp_co2_annual_rate=1 co2vmr=1138.8e-6 + co2vmr=568.64e-6 flbc_cycle_yr=1 flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6abrupt4xCO2_cyclicalYear1_0p5degLat_c180929.nc' ncdata='$DIN_LOC_ROOT/atm/waccm/ic/b.e21.BW1850.f09_g17.CMIP6-piControl.001.cam.i.0070-01-01.abrupt4xCO2_c181003.nc' @@ -291,6 +389,45 @@ flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2ramp_y1-165_0p5degLat_c180930.nc' nlte_limit_co2=.true. co2_cycle_rad_passive=.true. + dms_source='ocean_flux' + co2_cycle_rad_passive=.true.,dms_source='ocean_flux' + dms_source='ocean_flux' + co2vmr=1138.8e-6 + co2vmr=1138.8e-6 + co2vmr=568.64e-6 + flbc_type='SERIAL' + flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' + flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' + flbc_type='SERIAL' + flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' + flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' + + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.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_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.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' + dms_source_type='INTERP_MISSING_MONTHS' + opom_source_type='INTERP_MISSING_MONTHS' + + 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=568.64e-6 run_component_cam env_run.xml @@ -306,10 +443,10 @@ - $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/aquap - $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/aquap - $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/waccmx - $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/scam_mandatory + $SRCROOT/components/cam/cime_config/usermods_dirs/aquap + $SRCROOT/components/cam/cime_config/usermods_dirs/aquap + $SRCROOT/components/cam/cime_config/usermods_dirs/waccmx + $SRCROOT/components/cam/cime_config/usermods_dirs/scam_mandatory run_component_cam env_case.xml diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index b93b3da8fe..5e941a2184 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -58,6 +58,208 @@ + + + + NF1850 + 1850_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NFHIST + HIST_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTfsst + HIST_CAM60%NORESM%FSST_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTfsstfrc2 + HIST_CAM60%NORESM%FSST%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + + NFHISTnorpddmsbc + HIST_CAM60%NORESM%NORPDDMSBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + + NFHISTnorpddmsbcsdyn + HIST_CAM60%NORESM%NORPDDMSBC%SDYN_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTfrc2norpddmsbc + HIST_CAM60%NORESM%NORPDDMSBC%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + + NFHISTnorbc + HIST_CAM60%NORESM%NORBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorbc_pintcf + HIST_CAM60%NORESM%NORBC%PINTCF_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorbc_piaer + HIST_CAM60%NORESM%NORBC%PIAER_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + + NFHISTnorpibc + HIST_CAM60%NORESM%NORPIBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorpibc_ghgonly + 1850_CAM60%NORESM%NORPIBC%GHGONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorpibc_natonly + 1850_CAM60%NORESM%NORPIBC%NATONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorpibc_aeroxidonly + 1850_CAM60%NORESM%NORPIBC%AEROXIDONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NFHISTnorpibc_ozoneonly + 1850_CAM60%NORESM%NORPIBC%OZONEONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + NF2000climo + 2000_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + + + NF1850norbc + 1850_CAM60%NORESM%NORBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_4xco2 + 1850_CAM60%NORESM%NORBC%4xCO2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_2xco2 + 1850_CAM60%NORESM%NORBC%2xCO2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ghg2014 + 1850_CAM60%NORESM%NORBC%GHG2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ghgnoh2o2014 + 1850_CAM60%NORESM%NORBC%GHGNOH2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_n2o2014 + 1850_CAM60%NORESM%NORBC%N2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ch42014 + 1850_CAM60%NORESM%NORBC%CH42014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ch4noh2o2014 + 1850_CAM60%NORESM%NORBC%CH4NOH2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_bc2014 + 1850_CAM60%NORESM%NORBC%BC2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_oc2014 + 1850_CAM60%NORESM%NORBC%OC2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_so22014 + 1850_CAM60%NORESM%NORBC%SO22014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_aer2014 + 1850_CAM60%NORESM%NORBC%AER2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_aeroxid2014 + 1850_CAM60%NORESM%NORBC%AEROXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ntcf2014 + 1850_CAM60%NORESM%NORBC%NTCF2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_anthro2014 + 1850_CAM60%NORESM%NORBC%ANTHRO2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ghgozonelu2014 + 1850_CAM60%NORESM%NORBC%GHGOZONELU2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_so2oxid2014 + 1850_CAM60%NORESM%NORBC%SO2OXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_ozone2014 + 1850_CAM60%NORESM%NORBC%OZONE2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_h2o2014 + 1850_CAM60%NORESM%NORBC%H2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + + + NF1850norbc_oxid2014 + 1850_CAM60%NORESM%NORBC%OXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + + @@ -68,13 +270,6 @@ - - FKESSLER - 2000_CAM%KESSLER_SLND_SICE_SOCN_SROF_SGLC_SWAV - - - - FSCAM 2000_CAM60%SCAM_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV @@ -157,6 +352,10 @@ 2000_CAM%TJ16_SLND_SICE_SOCN_SROF_SGLC_SWAV + + FKESSLER + 2000_CAM%KESSLER_SLND_SICE_SOCN_SROF_SGLC_SWAV + @@ -253,7 +452,40 @@ 2000_CAM50_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV - + + QSC6O + 2000_CAM60%PTAERO_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV + + + + NFPTAERO + 2000_CAM5%PTAEROUPD1_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + NFPTAERO60 + + 2000_CAM60%PTAERO_CLM50%BGC_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + + + NFPTAERO60NC + 2000_CAM54%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + NFAMIPNUDGEPTAEROUPD1 + 2000_CAM5%NUDGEPTAEROUPD1_CLM45%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + NFAMIPNUDGEPTAERONCLB + 2000_CAM54%NUDGEPTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + NFAMIPNUDGEPTAEROCLB + 2000_CAM60%NUDGEPTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + + + @@ -269,36 +501,40 @@ - - FW1850 - 1850_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - - - - - - - FWsc2010climo 2010_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + FWsc2000climo 2000_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + FWsc1850 1850_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + FWscHIST HIST_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + + + + + FW1850 + 1850_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + + + + + FW2000climo 2000_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV @@ -341,11 +577,11 @@ FW4madHIST - HIST_CAM40%WCMD_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WCMD_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV FW4madSD - HIST_CAM40%WCMD%SDYN_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WCMD%SDYN_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV @@ -354,33 +590,68 @@ FX2000 - 2000_CAM40%WXIE_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + 2000_CAM40%WXIE_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV FXHIST - HIST_CAM40%WXIE_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WXIE_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV FXmadHIST - HIST_CAM40%WXIED_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WXIED_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV FXSD - HIST_CAM40%WXIE%SDYN_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WXIE%SDYN_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV FXmadSD - HIST_CAM40%WXIED%SDYN_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + HIST_CAM40%WXIED%SDYN_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + + + domain.lnd.fv1.9x2.5_tnx1v4.170609.nc + domain.lnd.fv1.9x2.5_tnx1v4.170609.nc + + + + + + domain.lnd.fv1.9x2.5_tnx1v4.170609.nc + domain.lnd.fv1.9x2.5_tnx1v4.170609.nc + + + + + + domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + + + + + + domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + + + + + + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + + + 1997-06-18 @@ -392,6 +663,7 @@ 1995-01-01 1995-01-01 2005-01-01 + 2015-01-01 2005-01-01 2010-01-01 2000-01-01 @@ -442,12 +714,19 @@ $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 + + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NHIST_f19_tn14_20190625_1849-2015_series_version20190726_ts.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_clim_pi_c101029.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_pi_c101028.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_pi_c101028.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_pi_c101028.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_pi_c101028.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_pi_c101028.nc + + + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2000climo_c180511.nc $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2000climo_c180511.nc @@ -494,7 +773,8 @@ - 2016 + 0 + 2016 @@ -502,6 +782,7 @@ hybrid hybrid + hybrid hybrid hybrid @@ -515,6 +796,7 @@ b.e20.BHIST.f09_g17.20thC.297_01_v2 b.e20.BHIST.f09_g17.20thC.297_01_v2 + b.e20.BHIST.f09_g17.20thC.297_01_v2 b.e16.B1850_WW3.f09_g16.lang_redi_2hr_frz_chl.003 b.e20.B1850.f09_g16.pi_control.all.123 @@ -528,6 +810,7 @@ 1979-01-01 2000-01-01 + 2000-01-01 0097-01-01 0010-01-01 0097-01-01 @@ -540,6 +823,7 @@ cesm2_init cesm2_init + cesm2_init cesm2_init diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index d4e7ae45c8..2d51b135c9 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -1289,6 +1289,43 @@ + + + + none + + 256 + 256 + 256 + 256 + 256 + 256 + 256 + 256 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + diff --git a/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h new file mode 100755 index 0000000000..3803258bdf --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h @@ -0,0 +1,2 @@ +#define AEROCOM +#define AEROFFL diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h new file mode 100755 index 0000000000..3803258bdf --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h @@ -0,0 +1,2 @@ +#define AEROCOM +#define AEROFFL diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_cam b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_cam new file mode 100644 index 0000000000..273a1320e0 --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_cam @@ -0,0 +1,35 @@ + +history_aerosol=.true. + +nhtfrq = 0, -24, -6, -6, -3, -3 , -1, 1, -24 + +mfilt = 1, 73, 292, 292, 584, 584, 584, 240, 365 + +ndens = 2, 2, 2, 2, 2, 2, 2, 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 = 'ABSVIS ','ACTNL:A', 'ACTREL:A', 'AOD_VIS:A', 'cb_BC:A', 'cb_DMS:A', 'cb_DUST:A', 'cb_OM:A', 'cb_SALT:A', 'cb_SO2:A', 'cb_SULFATE:A','CDNUMC:A', 'CLDICE:A', 'CLDLIQ:A', 'CLDTOT:A', 'CLOUD:A', 'CMFMC:A', 'CMFMCDZM:A', 'DAYFOC:A', 'FCTL:A', 'FLDS:A', 'FLDSC:A', 'FLNR:A', 'FLNS:A', 'FLNSC:A','FLNT:A', 'FLNTC:A', 'FLUT:A', 'FLUTC:A', 'FSDS:A', 'FSDSC:A', 'FSNR:A', 'FSNS:A', 'FSNSC:A', 'FSNTOA:A', 'FSNTOAC:A', 'ICEFRAC:A' ,'LHFLX:A', 'MASS:A', 'OMEGA:A','OMEGA500:A', 'PBLH:A', 'PDELDRY:A', 'PRECC:A', 'PRECT:A', 'PS:A', 'PSL:A', 'Q:A', 'QREFHT:A', 'QSNOW:A', 'RELHUM:A', 'RHREFHT:A', 'SHFLX:A', 'SOLIN:A', 'SOLLD:A', 'SOLSD:A','SST:A', 'T:A', 'T500:A', 'T700:A', 'T850:A', 'TAUBLJX:A', 'TAUBLJY:A', 'TAUGWX:A', 'TAUGWY:A', 'TAUX:A', 'TAUY:A', 'TGCLDIWP:A', 'TGCLDLWP:A', 'TMQ:A', 'TREFHT:A', 'TREFHTMN:M', 'TREFHTMX:X', 'TS:A', 'TSMN:M', 'TSMX:X', 'U:A', 'U10:A', 'UTGWORO:A','V:A', 'Z3:A', 'Z500:A','PRECL:A','FREQZM:A','PCONVB:A','PCONVT:A','PRECCDZM:A','Z700:A','Z200:A', 'Z300:A','Z100:A','Z050:A','U200:A','U850:A','V200:A','V850:A','T200:A','T1000:A','OMEGA850:A','VTHzm:A','WTHzm:A','UVzm:A','UWzm:A','Uzm:A','Vzm:A','THzm:A','Wzm:A','dUzm:A','dVzm:A','dUazm:A','dVazm:A','dUfzm:A','EFLX:A','TFIX:A','EFIX:A', +'TOT_CLD_VISTAU:A','PBLHMX:X','PBLHMN:M','DOD550:A','UA010:A','Z010:A','Z1000:A', +'TAUTMODIS:A','CLTMODIS:A' + +fincl3 ='CLOUD:A','PBLH:A','RHREFHT:A','PRECT:A','PRECC:A','PRECL:A','PSL:A','U10:A','TREFHT:A','OMEGA:A','UBOT:A','VBOT:A','Z1000:A','Q:A','OMEGA:A','TS:A','SST:A','ICEFRAC:A','PRECCDZM:A','PRECSH:A','PRECTMX:X','BS550AER:A' + +fincl4= 'CLDICE:I','CLDLIQ:I','TOT_CLD_VISTAU:I','Q:I','QREFHT:I','Q850:I','PSL:I','U10:I','SNOWHLND:I','SNOWHICE:I','QRAIN:I','QSNOW:I', 'PS:I','PHIS:I','T:I','TREFHT:I','TS:I','T850:I','U:I','UBOT:I','V:I','VBOT:I','Z3:I','ZM_ORG:I','CMFMC:I','CMFMCDZM:I','FREQSH:I','FREQZM:I','PCONVB:I','PCONVT:I','Z700:I','Z500:I','Z200:I','Z300:I','Z100:I','Z050:I','U200:I','U850:I','V200:I','V850:I','T200:I','T500:I','T700:I','T1000:I','OMEGA500:I','OMEGA850:I','PTTEND:I','LHFLX:I','SHFLX:I','EFLX:I', +'EC550AER:I' + + +fincl5='PRECC:A','PRECL:A','PRECT:A','LHFLX:A','SHFLX:A','FLDS:A', 'FLDSC:A', 'FLNR:A', 'FLNS:A', 'FLNSC:A','FLNT:A', 'FLNTC:A', 'FLUT:A', 'FLUTC:A', 'FSDS:A', 'FSDSC:A', 'FSNR:A', 'FSNS:A', 'FSNSC:A', 'FSNTOA:A', 'FSNTOAC:A', 'LWCF','SWCF:A','CLDTOT:A','SOLLD:A','SOLSD:A', +'PRECSC:A','PRECSL:A' + +fincl6='UBOT:I','VBOT:I','TREFHT:I','QREFHT:I','TS:I','SST:I','PS:I','ICEFRAC:I', +'U10:I' + +fincl7='PS:A','TREFHT:A','MMRPM2P5_SRF:A' + + +do_circulation_diags = .true. + + diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_clm b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_clm new file mode 100644 index 0000000000..6028a6a170 --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/user_nl_clm @@ -0,0 +1,36 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig .true. setting +! Set co2_ppmv with CCSM_CO2_PPMV option +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! or with CLM_FORCE_COLDSTART to do a cold start +! or set it with an explicit filename here. +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- + + +hist_nhtfrq = 0, -24, -3,-8760 + +hist_mfilt = 12, 365, 2920,1 + +hist_fincl1 = 'FERT_TO_SMINN','NFIX_TO_SMINN','LITFIRE','LITR1C_TO_SOIL1C','LITR2C_TO_SOIL1C','LITR3C_TO_SOIL2C','M_LEAFC_TO_LITTER','M_FROOTC_TO_LITTER','M_LIVESTEMC_TO_LITTER','M_DEADSTEMC_TO_LITTER','M_LIVECROOTC_TO_LITTER','M_DEADCROOTC_TO_LITTER' + +hist_fincl2 = 'ALT','H2OCAN','H2OSFC','QVEGE','QVEGT','QSOIL','QSNOEVAP','QRUNOFF','QOVER','QDRAI','QINTR','QCHARGE','RAM1','SOILLIQ','SOILICE','SOILWATER_10CM','SNOFSRVD','SNOFSRVI','SNOFSRND','SNOFSRNI','SNOFSDSVD','SNOFSDSVI','SNOFSDSND','SNOFSDSNI','TLAI','TG','TSA','TSOI','TV','TOTSOILLIQ','TOTSOILICE','TWS','VOLR','ZWT' + + + hist_fincl3 = 'QRUNOFF', 'SOILLIQ', 'SOILICE', 'SOILWATER_10CM', 'TSA', 'TSL', 'GPP', 'AR', 'HR' + + +hist_fincl4 = 'TOTVEGC','TOTSOMC','TOTLITC' diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h new file mode 100755 index 0000000000..3803258bdf --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h @@ -0,0 +1,2 @@ +#define AEROCOM +#define AEROFFL diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_cam b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_cam new file mode 100644 index 0000000000..ed04ce6ad4 --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_cam @@ -0,0 +1,23 @@ + +history_aerosol=.true. + +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 = 'ABSVIS:A', 'ACTNL:A', 'ACTREL:A', 'AOD_VIS:A', 'cb_BC:A', 'cb_DMS:A', 'cb_DUST:A', 'cb_OM:A', 'cb_SALT:A', 'cb_SO2:A', 'cb_SULFATE:A', + 'CDNUMC:A', 'CLDICE:A', 'CLDLIQ:A', 'CLDTOT:A', 'CLOUD:A', 'CMFMC:A', 'CMFMCDZM:A', 'DAYFOC:A', 'FCTL:A', 'FLDS:A', 'FLDSC:A', 'FLNR:A', 'FLNS:A', 'FLNSC:A', + 'FLNT:A', 'FLNTC:A', 'FLUT:A', 'FLUTC:A', 'FSDS:A', 'FSDSC:A', 'FSNR:A', 'FSNS:A', 'FSNSC:A', 'FSNTOA:A', 'FSNTOAC:A', 'ICEFRAC:A' , 'LHFLX:A', 'MASS:A', 'OMEGA:A', + 'OMEGA500:A', 'PBLH:A', 'PDELDRY:A', 'PRECC:A', 'PRECT:A', 'PS:A', 'PSL:A', 'Q:A', 'QREFHT:A', 'QSNOW:A', 'RHREFHT:A', 'SHFLX:A', + 'SOLIN:A', 'SOLLD:A', 'SOLSD:A', 'SST:A' ,'T:A', 'T500:A', 'T700:A', 'T850:A', 'TAUBLJX:A', 'TAUBLJY:A', 'TAUGWX:A', 'TAUGWY:A', 'TAUX:A', 'TAUY:A', + 'TGCLDIWP:A', 'TGCLDLWP:A', 'TMQ:A', 'TREFHT:A', 'TREFHTMN:M', 'TREFHTMX:X', 'TS:A', 'TSMN:M', 'TSMX:X', 'U10:A', 'UTGWORO:A', + 'Z500:A', + 'Z100:A','Z1000:A','DOD550:A','TAUTMODIS:A','CLTMODIS:A' + + diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_clm b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_clm new file mode 100644 index 0000000000..f483209066 --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/user_nl_clm @@ -0,0 +1,30 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig .true. setting +! Set co2_ppmv with CCSM_CO2_PPMV option +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! or with CLM_FORCE_COLDSTART to do a cold start +! or set it with an explicit filename here. +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- + + +hist_nhtfrq = 0, -24, -6, -3 + +hist_mfilt = 1, 5, 20, 40 + +hist_fincl1 = 'FERT_TO_SMINN','NFIX_TO_SMINN','LITFIRE','LITR1C_TO_SOIL1C','LITR2C_TO_SOIL1C','LITR3C_TO_SOIL2C','M_LEAFC_TO_LITTER','M_FROOTC_TO_LITTER','M_LIVESTEMC_TO_LITTER','M_DEADSTEMC_TO_LITTER','M_LIVECROOTC_TO_LITTER','M_DEADCROOTC_TO_LITTER' + + hist_fincl2 = 'QRUNOFF', 'SOILLIQ', 'SOILICE', 'SOILWATER_10CM', 'TSA', 'TSL', 'GPP', 'AR', 'HR' diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 new file mode 100644 index 0000000000..e8dff42def --- /dev/null +++ b/src/NorESM/cam_diagnostics.F90 @@ -0,0 +1,3047 @@ +module cam_diagnostics + +!--------------------------------------------------------------------------------- +! Module to compute a variety of diagnostics quantities for history files +!--------------------------------------------------------------------------------- + +#ifdef OSLO_AERO +#include +#endif + +use shr_kind_mod, only: r8 => shr_kind_r8 +use camsrfexch, only: cam_in_t, cam_out_t +use cam_control_mod, only: moist_physics +use physics_types, only: physics_state, physics_tend +use ppgrid, only: pcols, pver, begchunk, endchunk +use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dtype_r8 +use physics_buffer, only: dyn_time_lvls, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx + +use cam_history, only: outfld, write_inithist, hist_fld_active, inithist_all +use constituents, only: pcnst, cnst_name, cnst_longname, cnst_cam_outfld +use constituents, only: ptendnam, dmetendnam, apcnst, bpcnst, cnst_get_ind +use dycore, only: dycore_is +use phys_control, only: phys_getopts +use wv_saturation, only: qsat, qsat_water, svp_ice +use time_manager, only: is_first_step + +use scamMod, only: single_column, wfld +use cam_abortutils, only: endrun + +#ifdef OSLO_AERO +use opttab, only: RF +#endif + +implicit none +private +save + +! Public interfaces + +public :: & + diag_readnl, &! read namelist options + diag_register, &! register pbuf space + diag_init, &! initialization + diag_allocate, &! allocate memory for module variables + diag_deallocate, &! deallocate memory for module variables + diag_conv_tend_ini, &! initialize convective tendency calcs + diag_phys_writeout, &! output diagnostics of the dynamics + diag_phys_tend_writeout, &! output physics tendencies + diag_state_b4_phys_write, &! output state before physics execution + diag_conv, &! output diagnostics of convective processes + diag_surf, &! output diagnostics of the surface + diag_export, &! output export state + diag_physvar_ic, & + diag_phys_writeout_dry, &! output diagnostics of the dynamics + nsurf + + +! Private data + +integer :: dqcond_num ! number of constituents to compute convective +character(len=16) :: dcconnam(pcnst) ! names of convection tendencies + ! tendencies for +real(r8), allocatable :: dtcond(:,:,:) ! temperature tendency due to convection +type dqcond_t + real(r8), allocatable :: cnst(:,:,:) ! constituent tendency due to convection +end type dqcond_t +type(dqcond_t), allocatable :: dqcond(:) + +character(len=8) :: diag_cnst_conv_tend = 'q_only' ! output constituent tendencies due to convection + ! 'none', 'q_only' or 'all' + +integer, parameter :: surf_100000 = 1 +integer, parameter :: surf_092500 = 2 +integer, parameter :: surf_085000 = 3 +integer, parameter :: surf_070000 = 4 +integer, parameter :: nsurf = 4 + +logical :: history_amwg ! output the variables used by the AMWG diag package +logical :: history_vdiag ! output the variables used by the AMWG variability diag package +logical :: history_eddy ! output the eddy variables +logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. +integer :: history_budget_histfile_num ! output history file number for budget fields +logical :: history_waccm ! outputs typically used for WACCM + +! Physics buffer indices + +integer :: psl_idx = 0 +integer :: relhum_idx = 0 +integer :: qcwat_idx = 0 +integer :: tcwat_idx = 0 +integer :: lcwat_idx = 0 +integer :: cld_idx = 0 +integer :: concld_idx = 0 +integer :: tke_idx = 0 +integer :: kvm_idx = 0 +integer :: kvh_idx = 0 +integer :: cush_idx = 0 +integer :: t_ttend_idx = 0 + +integer :: prec_dp_idx = 0 +integer :: snow_dp_idx = 0 +integer :: prec_sh_idx = 0 +integer :: snow_sh_idx = 0 +integer :: prec_sed_idx = 0 +integer :: snow_sed_idx = 0 +integer :: prec_pcw_idx = 0 +integer :: snow_pcw_idx = 0 + + +integer :: tpert_idx=-1, qpert_idx=-1, pblh_idx=-1 + +integer :: trefmxav_idx = -1, trefmnav_idx = -1 + +contains + +!============================================================================== + + subroutine diag_readnl(nlfile) + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_character, mpicom + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'diag_readnl' + + namelist /cam_diag_opts/ diag_cnst_conv_tend + !-------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'cam_diag_opts', status=ierr) + if (ierr == 0) then + read(unitn, cam_diag_opts, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(diag_cnst_conv_tend, len(diag_cnst_conv_tend), mpi_character, masterprocid, mpicom, ierr) + + end subroutine diag_readnl + +!============================================================================== + + subroutine diag_register_dry() + + call pbuf_add_field('PSL', 'physpkg', dtype_r8, (/pcols/), psl_idx) + + ! Request physics buffer space for fields that persist across timesteps. + call pbuf_add_field('T_TTEND', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), t_ttend_idx) + end subroutine diag_register_dry + + subroutine diag_register_moist() + ! Request physics buffer space for fields that persist across timesteps. + call pbuf_add_field('TREFMXAV', 'global', dtype_r8, (/pcols/), trefmxav_idx) + call pbuf_add_field('TREFMNAV', 'global', dtype_r8, (/pcols/), trefmnav_idx) + end subroutine diag_register_moist + + subroutine diag_register() + call diag_register_dry() + if (moist_physics) then + call diag_register_moist() + end if + end subroutine diag_register + +!============================================================================== + + subroutine diag_init_dry(pbuf2d) + ! Declare the history fields for which this module contains outfld calls. + + use cam_history, only: addfld, add_default, horiz_only + use cam_history, only: register_vector_field + use constituent_burden, only: constituent_burden_init + use physics_buffer, only: pbuf_set_field + use tidal_diag, only: tidal_diag_init +!+ +#ifdef AEROCOM + use commondefinitions, only: nbmodes +!#ifdef RFMIPIRF +! use radconstants, only: nswbands, nlwbands +!#endif +#endif +!- + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + integer :: k, m + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. +!AL + integer :: ixcldni, ixcldnc ! constituent indices for cloud liquid and ice water. +!AL + integer :: ierr + +!+ +#ifdef AEROCOM + character(len=10) :: modeString + character(len=20) :: varname + integer :: i, irh +!#ifdef RFMIPIRF +! character(len=2) :: c2 +! integer :: ib +!#endif +#endif +!- + + ! outfld calls in diag_phys_writeout + call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) + call addfld ('NSTEP', horiz_only, 'A', 'timestep', 'Model timestep') + call addfld ('PHIS', horiz_only, 'I', 'm2/s2', 'Surface geopotential') + + call addfld ('PS', horiz_only, 'A', 'Pa', 'Surface pressure') + call addfld ('T', (/ 'lev' /), 'A', 'K', 'Temperature') + call addfld ('U', (/ 'lev' /), 'A', 'm/s', 'Zonal wind') + call addfld ('UA010', horiz_only, 'A', 'm/s', 'Zonal wind U at 10 mbar pressure surface') + call addfld ('V', (/ 'lev' /), 'A', 'm/s', 'Meridional wind') + + call register_vector_field('U','V') + + ! State before physics + call addfld ('TBP', (/ 'lev' /), 'A','K', 'Temperature (before physics)') + call addfld (bpcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (before physics)') + ! State after physics + call addfld ('TAP', (/ 'lev' /), 'A','K', 'Temperature (after physics)' ) + call addfld ('UAP', (/ 'lev' /), 'A','m/s', 'Zonal wind (after physics)' ) + call addfld ('VAP', (/ 'lev' /), 'A','m/s', 'Meridional wind (after physics)' ) + + call register_vector_field('UAP','VAP') + + call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') + if ( dycore_is('LR') .or. dycore_is('SE') ) then + call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') +!+tht + call addfld ('EBREAK', horiz_only, 'A','W/m2', 'Global-mean energy-nonconservation (W/m2)') + call addfld ('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & + 'T-tendency due to dry mass adjustment at the end of tphysac' ) + call addfld ('IETEND_DME', horiz_only, 'A','W/m2 ', & + 'Column DSE tendency due to mass adjustment at end of tphysac' ) + call addfld ('EFLX ' , horiz_only, 'A','W/m2 ', & + 'Material enthalpy flux due to mass adjustment at end of tphysac') +!-tht + end if + call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') + + call addfld ('Z3', (/ 'lev' /), 'A', 'm', 'Geopotential Height (above sea level)') + call addfld ('Z1000', horiz_only, 'A', 'm', 'Geopotential Z at 1000 mbar pressure surface') + call addfld ('Z700', horiz_only, 'A', 'm', 'Geopotential Z at 700 mbar pressure surface') + call addfld ('Z500', horiz_only, 'A', 'm', 'Geopotential Z at 500 mbar pressure surface') + call addfld ('Z300', horiz_only, 'A', 'm', 'Geopotential Z at 300 mbar pressure surface') + call addfld ('Z200', horiz_only, 'A', 'm', 'Geopotential Z at 200 mbar pressure surface') + call addfld ('Z100', horiz_only, 'A', 'm', 'Geopotential Z at 100 mbar pressure surface') + call addfld ('Z050', horiz_only, 'A', 'm', 'Geopotential Z at 50 mbar pressure surface') + call addfld ('Z010', horiz_only, 'A', 'm', 'Geopotential Z at 10 mbar pressure surface') + + call addfld ('ZZ', (/ 'lev' /), 'A', 'm2', 'Eddy height variance' ) + call addfld ('VZ', (/ 'lev' /), 'A', 'm2/s', 'Meridional transport of geopotential height') + call addfld ('VT', (/ 'lev' /), 'A', 'K m/s ', 'Meridional heat transport') + call addfld ('VT100', horiz_only, 'A', 'K m/s ', 'Meridional heat transport at 100 mbar pressure level') + call addfld ('VU', (/ 'lev' /), 'A', 'm2/s2', 'Meridional flux of zonal momentum' ) + call addfld ('VV', (/ 'lev' /), 'A', 'm2/s2', 'Meridional velocity squared' ) + call addfld ('OMEGAV', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of meridional momentum' ) + call addfld ('OMGAOMGA', (/ 'lev' /), 'A', 'Pa2/s2', 'Vertical flux of vertical momentum' ) + + call addfld ('UU', (/ 'lev' /), 'A', 'm2/s2', 'Zonal velocity squared' ) + call addfld ('WSPEED', (/ 'lev' /), 'X', 'm/s', 'Horizontal total wind speed maximum' ) + call addfld ('WSPDSRFMX', horiz_only, 'X', 'm/s', 'Horizontal total wind speed maximum at the surface' ) + call addfld ('WSPDSRFAV', horiz_only, 'A', 'm/s', 'Horizontal total wind speed average at the surface' ) + + call addfld ('OMEGA', (/ 'lev' /), 'A', 'Pa/s', 'Vertical velocity (pressure)') + call addfld ('OMEGAT', (/ 'lev' /), 'A', 'K Pa/s ', 'Vertical heat flux' ) + call addfld ('OMEGAU', (/ 'lev' /), 'A', 'm Pa/s2 ', 'Vertical flux of zonal momentum' ) + call addfld ('OMEGA850', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 850 mbar pressure surface') + call addfld ('OMEGA500', horiz_only, 'A', 'Pa/s', 'Vertical velocity at 500 mbar pressure surface') + + call addfld ('PSL', horiz_only, 'A', 'Pa','Sea level pressure') + + call addfld ('T1000', horiz_only, 'A', 'K','Temperature at 1000 mbar pressure surface') + call addfld ('T925', horiz_only, 'A', 'K','Temperature at 925 mbar pressure surface') + call addfld ('T850', horiz_only, 'A', 'K','Temperature at 850 mbar pressure surface') + call addfld ('T700', horiz_only, 'A', 'K','Temperature at 700 mbar pressure surface') + call addfld ('T500', horiz_only, 'A', 'K','Temperature at 500 mbar pressure surface') + call addfld ('T400', horiz_only, 'A', 'K','Temperature at 400 mbar pressure surface') + call addfld ('T300', horiz_only, 'A', 'K','Temperature at 300 mbar pressure surface') + call addfld ('T200', horiz_only, 'A', 'K','Temperature at 200 mbar pressure surface') + call addfld ('T010', horiz_only, 'A', 'K','Temperature at 10 mbar pressure surface') + + call addfld ('T7001000', horiz_only, 'A', 'K','Temperature difference 700 mb - 1000 mb') + call addfld ('TH7001000', horiz_only, 'A', 'K','Theta difference 700 mb - 1000 mb') + call addfld ('THE7001000', horiz_only, 'A', 'K','ThetaE difference 700 mb - 1000 mb') + + call addfld ('T8501000', horiz_only, 'A', 'K','Temperature difference 850 mb - 1000 mb') + call addfld ('TH8501000', horiz_only, 'A', 'K','Theta difference 850 mb - 1000 mb') + call addfld ('T9251000', horiz_only, 'A', 'K','Temperature difference 925 mb - 1000 mb') + call addfld ('TH9251000', horiz_only, 'A', 'K','Theta difference 925 mb - 1000 mb') + + call addfld ('TT', (/ 'lev' /), 'A', 'K2','Eddy temperature variance' ) + + call addfld ('U850', horiz_only, 'A', 'm/s','Zonal wind at 850 mbar pressure surface') + call addfld ('U500', horiz_only, 'A', 'm/s','Zonal wind at 500 mbar pressure surface') + call addfld ('U250', horiz_only, 'A', 'm/s','Zonal wind at 250 mbar pressure surface') + call addfld ('U200', horiz_only, 'A', 'm/s','Zonal wind at 200 mbar pressure surface') + call addfld ('U010', horiz_only, 'A', 'm/s','Zonal wind at 10 mbar pressure surface') + call addfld ('V850', horiz_only, 'A', 'm/s','Meridional wind at 850 mbar pressure surface') + call addfld ('V500', horiz_only, 'A', 'm/s','Meridional wind at 500 mbar pressure surface') + call addfld ('V250', horiz_only, 'A', 'm/s','Meridional wind at 250 mbar pressure surface') + call addfld ('V200', horiz_only, 'A', 'm/s','Meridional wind at 200 mbar pressure surface') + + call register_vector_field('U850', 'V850') + call register_vector_field('U500', 'V500') + call register_vector_field('U250', 'V250') + call register_vector_field('U200', 'V200') + + call addfld ('UBOT', horiz_only, 'A', 'm/s','Lowest model level zonal wind') + call addfld ('VBOT', horiz_only, 'A', 'm/s','Lowest model level meridional wind') + call register_vector_field('UBOT', 'VBOT') + + call addfld ('ZBOT', horiz_only, 'A', 'm','Lowest model level height') + + call addfld ('ATMEINT', horiz_only, 'A', 'J/m2','Vertically integrated total atmospheric energy ') + +!akc6+ CNVCLD is zero... +! call addfld ('CNVCLD', horiz_only, 'A', 'fraction', 'Vertically integrated convective cloud cover') +!akc6- + + +#ifdef OSLO_AERO + +#ifdef DIRIND + call addfld ('AOD_VIS ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('ABSVIS ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('AODVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('ABSVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('CAODVIS ',horiz_only, 'A','unitless','Clear air aerosol optical depth') + call addfld ('CABSVIS ',horiz_only, 'A','unitless','Clear air aerosol absorptive optical depth') + call addfld ('CLDFREE ',horiz_only, 'A','unitless','Cloud free fraction wrt CAODVIS and CABSVIS') + call addfld ('DAYFOC ',horiz_only, 'A','unitless','Daylight fraction') + call addfld ('N_AER ',(/'lev'/), 'A', 'unitless','Aerosol number concentration') +!- call addfld ('N_AERORG','unitless',pver, 'A','Aerosol number concentration',phys_decomp) + call addfld ('SSAVIS ',(/'lev'/), 'A','unitless','Aerosol single scattering albedo in visible wavelength band') + call addfld ('ASYMMVIS',(/'lev'/), 'A','unitless','Aerosol assymetry factor in visible wavelength band') + call addfld ('EXTVIS ',(/'lev'/), 'A','1/km ','Aerosol extinction') +!=0 call addfld ('RELH ',(/'lev'/), 'A', 'unitless','Fictive relative humidity') +!akc6+ + call addfld ('BVISVOLC ',(/'lev'/), 'A','1/km ','CMIP6 volcanic aerosol extinction at 0.442-0.625um') +!akc6- +!#ifdef SPAERO +! call addfld ('AODVISSP',horiz_only, 'A','unitless' ,'Simple plumes aerosol optical depth at 0.35-0.64um') +! call addfld ('ABSVISSP',horiz_only, 'A','unitless' ,'Simple plumes aerosol absorptive optical depth at 0.35-0.64um') +! call addfld ('XCDNC_SP',horiz_only, 'A','unitless' ,'CDNC modification factor for simple plume aerosols') +! call addfld ('AODV3DSP',(/'lev'/), 'A','unitless','Simple plumes 3D aerosol optical depth at 0.35-0.64um') +! call addfld ('ABSV3DSP',(/'lev'/), 'A','unitless','Simple plumes 3D absorption AOD at 0.35-0.64um') +!#endif +#ifdef COLTST4INTCONS +! optical depth for each mode/mixture: + call addfld ('TAUKC0 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 0') + call addfld ('TAUKC1 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 1') + call addfld ('TAUKC2 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 2') + call addfld ('TAUKC4 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 4') + call addfld ('TAUKC5 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 5') + call addfld ('TAUKC6 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 6') + call addfld ('TAUKC7 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 7') + call addfld ('TAUKC8 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 8') + call addfld ('TAUKC9 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 9') + call addfld ('TAUKC10',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 10') + call addfld ('TAUKC12',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 12') + call addfld ('TAUKC14',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 14') +! mass specific extinction (including condensed water) for each mode/mixture: + call addfld ('MECKC0 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 0') + call addfld ('MECKC1 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 1') + call addfld ('MECKC2 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 2') + call addfld ('MECKC4 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 4') + call addfld ('MECKC5 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 5') + call addfld ('MECKC6 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 6') + call addfld ('MECKC7 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 7') + call addfld ('MECKC8 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 8') + call addfld ('MECKC9 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 9') + call addfld ('MECKC10',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 10') + call addfld ('MECKC12',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 12') + call addfld ('MECKC14',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 14') +#ifdef AEROCOM +! dry mass for each mode/mixture (for calculation of specific extinction without condensed water): + call addfld ('CMDRY0 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 0') + call addfld ('CMDRY1 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 1') + call addfld ('CMDRY2 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 2') + call addfld ('CMDRY4 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 4') + call addfld ('CMDRY5 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 5') + call addfld ('CMDRY6 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 6') + call addfld ('CMDRY7 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 7') + call addfld ('CMDRY8 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 8') + call addfld ('CMDRY9 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 9') + call addfld ('CMDRY10',horiz_only, 'A','unitless','Total dry mass load for kcomp 10') + call addfld ('CMDRY12',horiz_only, 'A','unitless','Total dry mass load for kcomp 12') + call addfld ('CMDRY14',horiz_only, 'A','unitless','Total dry mass load for kcomp 14') +#endif !aerocom +#endif !extra tests +#ifdef AEROFFL + call addfld ('FSNT_DRF',horiz_only, 'A','W/m^2','Total column absorbed solar flux (DIRind)') + call addfld ('FSNTCDRF',horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (DIRind)' ) + call addfld ('FSNS_DRF',horiz_only, 'A','W/m^2 ','Surface absorbed solar flux (DIRind)' ) + call addfld ('FSNSCDRF',horiz_only, 'A','W/m^2 ','Clear sky surface absorbed solar flux (DIRind)' ) + call addfld ('QRS_DRF ',(/'lev'/), 'A','K/s ','Solar heating rate (DIRind)') + call addfld ('QRSC_DRF',(/'lev'/), 'A','K/s ','Clearsky solar heating rate (DIRind)' ) + call addfld ('FLNT_DRF',horiz_only, 'A','W/m^2 ','Total column longwave flux (DIRind)' ) + call addfld ('FLNTCDRF',horiz_only, 'A','W/m^2 ','Clear sky total column longwave flux (DIRind)' ) + call addfld ('FSUTADRF',horiz_only, 'A','W/m^2 ','SW upwelling flux at TOA') + call addfld ('FSDS_DRF',horiz_only, 'A','W/m^2 ','SW downelling flux at surface') + call addfld ('FSUS_DRF',horiz_only, 'A','W/m^2 ','SW upwelling flux at surface') + call addfld ('FSDSCDRF',horiz_only, 'A','W/m^2 ','SW downwelling clear sky flux at surface') + call addfld ('FLUS ',horiz_only, 'A','W/m^2 ','LW surface upwelling flux') +!->ut call addfld ('FLNT_ORG',horiz_only, 'A','W/m^2 ','Total column longwave flux (CAM5)' ) +#endif ! aeroffl +#ifdef AEROCOM + call addfld ('AKCXS ',horiz_only, 'A','mg/m2 ','Scheme excess aerosol mass burden') + call addfld ('PMTOT ',horiz_only, 'A','ug/m3 ','Aerosol PM, all sizes') + call addfld ('PM25 ',horiz_only, 'A','ug/m3 ','Aerosol PM2.5') +!akc6+ + call addfld ('PM2P5 ',(/'lev'/), 'A','ug/m3 ','3D aerosol PM2.5') + call addfld ('MMRPM2P5',(/'lev'/), 'A','kg/kg ','3D aerosol PM2.5 mass mixing ratio') + call addfld ('MMRPM1 ',(/'lev'/), 'A','kg/kg ','3D aerosol PM1.0 mass mixing ratio') + call addfld ('MMRPM2P5_SRF',horiz_only, 'A','kg/kg ','Aerosol PM2.5 mass mixing ratio in bottom layer') +!akc6- + call addfld ('GRIDAREA',horiz_only, 'A','m2 ','Grid area for 1.9x2.5 horizontal resolution') + call addfld ('DAERH2O ',horiz_only, 'A', 'mg/m2 ','Aerosol water load') + call addfld ('MMR_AH2O',(/'lev'/), 'A', 'kg/kg ','Aerosol water mmr') + call addfld ('ECDRYAER',(/'lev'/), 'A', 'kg/kg ','Dry aerosol extinction at 550nm') + call addfld ('ABSDRYAE',(/'lev'/), 'A','m-1 ','Dry aerosol absorption at 550nm') + call addfld ('ECDRY440',(/'lev'/), 'A','m-1 ','Dry aerosol extinction at 440nm') + call addfld ('ABSDR440',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 440nm') + call addfld ('ECDRY870',(/'lev'/),'A','m-1 ','Dry aerosol extinction at 870nm') + call addfld ('ABSDR870',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 870nm') + call addfld ('ASYMMDRY',(/'lev'/),'A','unitless','Dry asymmetry factor in visible wavelength band') + call addfld ('ECDRYLT1',(/'lev'/),'A','m-1 ','Dry aerosol extinction at 550nm lt05') + call addfld ('ABSDRYBC',(/'lev'/),'A','m-1 ','Dry BC absorption at 550nm') + call addfld ('ABSDRYOC',(/'lev'/),'A','m-1 ','Dry OC absorption at 550nm') + call addfld ('ABSDRYSU',(/'lev'/),'A','m-1 ','Dry sulfate absorption at 550nm') + call addfld ('ABSDRYSS',(/'lev'/),'A','m-1 ','Dry sea-salt absorption at 550nm') + call addfld ('ABSDRYDU',(/'lev'/),'A','m-1 ','Dry dust absorption at 550nm') + call addfld ('OD550DRY',horiz_only,'A','unitless','Dry aerosol optical depth at 550nm') + call addfld ('AB550DRY',horiz_only, 'A','unitless','Dry aerosol absorptive optical depth at 550nm') + call addfld ('DERLT05 ',horiz_only, 'A','um ','Effective aerosol dry radius<0.5um') + call addfld ('DERGT05 ',horiz_only, 'A','um ','Effective aerosol dry radius>0.5um') + call addfld ('DER ',horiz_only, 'A','um ','Effective aerosol dry radius') + call addfld ('DOD440 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 440nm') + call addfld ('ABS440 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 440nm') + call addfld ('DOD500 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 500nm') + call addfld ('ABS500 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 500nm') + call addfld ('DOD550 ',horiz_only, 'A','unitless','Aerosol optical depth at 550nm') +!tst +! call addfld ('DOD5503D',(/'lev'/),'A','unitless','3D aerosol optical depth at 550 nm') +! call addfld ('AODVIS3D',(/'lev'/),'A','unitless','3D aerosol optical depth in visible wavelength band') +!tst + call addfld ('ABS550 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 550nm') + call addfld ('ABS550AL',horiz_only, 'A','unitless','Alt. aerosol absorptive optical depth at 550nm') + call addfld ('DOD670 ',horiz_only, 'A','unitless','Aerosol optical depth at 670nm') + call addfld ('ABS670 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 670nm') + call addfld ('DOD870 ',horiz_only, 'A','unitless','Aerosol optical depth at 870nm') + call addfld ('ABS870 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 870nm') + call addfld ('DLOAD_MI',horiz_only, 'A','mg/m2 ','mineral aerosol load') + call addfld ('DLOAD_SS',horiz_only, 'A','mg/m2 ','sea-salt aerosol load') + call addfld ('DLOAD_S4',horiz_only, 'A','mg/m2 ','sulfate aerosol load') + call addfld ('DLOAD_OC',horiz_only, 'A','mg/m2 ','OC aerosol load') + call addfld ('DLOAD_BC',horiz_only, 'A','mg/m2 ','BC aerosol load') + + call addfld ('LOADBCAC',horiz_only, 'A','mg/m2 ','BC aerosol coag load') + call addfld ('LOADBC0 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 0 load') + call addfld ('LOADBC2 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 2 load') + call addfld ('LOADBC4 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 4 load') + call addfld ('LOADBC12',horiz_only, 'A','mg/m2 ','BC aerosol mode 12 load') + call addfld ('LOADBC14',horiz_only, 'A','mg/m2 ','BC aerosol mode 14 load') + call addfld ('LOADOCAC',horiz_only, 'A','mg/m2 ','OC aerosol coag load') + call addfld ('LOADOC3 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 3 load') + call addfld ('LOADOC4 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 4 load') + call addfld ('LOADOC13',horiz_only, 'A','mg/m2 ','OC aerosol mode 13 load') + call addfld ('LOADOC14',horiz_only, 'A','mg/m2 ','OC aerosol mode 14 load') +#ifdef COLTST4INTCONS + call addfld ('COLRBC0 ',horiz_only, 'A','unitless','COLRAT BC mode 0 load ratio') + call addfld ('COLRBC2 ',horiz_only, 'A','unitless','COLRAT BC mode 2 load ratio') + call addfld ('COLRBC4 ',horiz_only, 'A','unitless','COLRAT BC mode 4 load ratio') + call addfld ('COLRBC12',horiz_only, 'A','unitless','COLRAT BC mode 12 load ratio') + call addfld ('COLRBC14',horiz_only, 'A','unitless','COLRAT BC mode 14 load ratio') + call addfld ('COLRBCAC',horiz_only, 'A','unitless','COLRAT BC mode AC load ratio') + call addfld ('COLROC4 ',horiz_only, 'A','unitless','COLRAT OC mode 4 load ratio') + call addfld ('COLROC14',horiz_only, 'A','unitless','COLRAT OC mode 14 load ratio') + call addfld ('COLROCAC',horiz_only, 'A','unitless','COLRAT OC mode AC load ratio') + call addfld ('COLRSULA',horiz_only, 'A','unitless','COLRAT Sulfate mode A load ratio') + call addfld ('COLRSUL1',horiz_only, 'A','unitless','COLRAT Sulfate mode 1 load ratio') + call addfld ('COLRSUL5',horiz_only, 'A','unitless','COLRAT Sulfate mode 5 load ratio') +#endif ! COLTST4INTCONS + +! + call addfld ('EC550AER',(/'lev'/),'A','m-1 ','aerosol extinction coefficient') + call addfld ('ABS550_A',(/'lev'/),'A','m-1 ','aerosol absorption coefficient') + call addfld ('BS550AER',(/'lev'/),'A','m-1 sr-1','aerosol backscatter coefficient') +! + call addfld ('EC550SO4',(/'lev'/),'A','m-1 ','SO4 aerosol extinction coefficient') + call addfld ('EC550BC ',(/'lev'/),'A','m-1 ','BC aerosol extinction coefficient') + call addfld ('EC550POM',(/'lev'/), 'A','m-1 ','POM aerosol extinction coefficient') + call addfld ('EC550SS ',(/'lev'/), 'A','m-1 ','SS aerosol extinction coefficient') + call addfld ('EC550DU ',(/'lev'/), 'A','m-1 ','DU aerosol extinction coefficient') +! + call addfld ('CDOD440 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 440nm') + call addfld ('CDOD550 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 550nm') + call addfld ('CABS550 ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') + call addfld ('CABS550A ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') + call addfld ('CDOD870 ' ,horiz_only, 'A','unitless','Clear air Aerosol optical depth at 870nm') + call addfld ('A550_DU ' ,horiz_only, 'A','unitless', 'mineral abs. aerosol optical depth 550nm') + call addfld ('A550_SS ' ,horiz_only, 'A','unitless','sea-salt abs aerosol optical depth 550nm') + call addfld ('A550_SO4' ,horiz_only, 'A','unitless','SO4 aerosol abs. optical depth 550nm') + call addfld ('A550_POM' ,horiz_only, 'A','unitless', 'OC abs. aerosol optical depth 550nm') + call addfld ('A550_BC ' ,horiz_only, 'A','unitless', 'BC abs. aerosol optical depth 550nm') + call addfld ('D440_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 440nm') + call addfld ('D440_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 440nm') + call addfld ('D440_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 440nm') + call addfld ('D440_POM',horiz_only, 'A','unitless','OC aerosol optical depth 440nm') + call addfld ('D440_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 440nm') + call addfld ('D500_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 500nm') + call addfld ('D500_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 500nm') + call addfld ('D500_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 500nm') + call addfld ('D500_POM',horiz_only, 'A','unitless','OC aerosol optical depth 500nm') + call addfld ('D500_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 500nm') + call addfld ('D550_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm') + call addfld ('D550_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm') + call addfld ('D550_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm') + call addfld ('D550_POM',horiz_only, 'A','unitless','OC aerosol optical depth 550nm') + call addfld ('D550_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm') + call addfld ('D670_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 670nm') + call addfld ('D670_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 670nm') + call addfld ('D670_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 670nm') + call addfld ('D670_POM',horiz_only, 'A','unitless','OC aerosol optical depth 670nm') + call addfld ('D670_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 670nm') + call addfld ('D870_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 870nm') + call addfld ('D870_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 870nm') + call addfld ('D870_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 870nm') + call addfld ('D870_POM',horiz_only, 'A','unitless','OC aerosol optical depth 870nm') + call addfld ('D870_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 870nm') + call addfld ('DLT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm lt05') + call addfld ('DLT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm lt05') + call addfld ('DLT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm lt05') + call addfld ('DLT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm lt05') + call addfld ('DLT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm lt05') + call addfld ('DGT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm gt05') + call addfld ('DGT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm gt05') + call addfld ('DGT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm gt05') + call addfld ('DGT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm gt05') + call addfld ('DGT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm gt05') + call addfld ('AIRMASS ',horiz_only, 'A','kg/m2 ','Vertically integrated airmass') !akc6 + call addfld ('NNAT_0 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 0 number concentration') + call addfld ('NNAT_1 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 1 number concentration') + call addfld ('NNAT_2 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 2 number concentration') + call addfld ('NNAT_4 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 4 number concentration') + call addfld ('NNAT_5 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 5 number concentration') + call addfld ('NNAT_6 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 6 number concentration') + call addfld ('NNAT_7 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 7 number concentration') + call addfld ('NNAT_8 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 8 number concentration') + call addfld ('NNAT_9 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 9 number concentration') + call addfld ('NNAT_10 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 10 number concentration') + call addfld ('NNAT_12 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 12 number concentration') + call addfld ('NNAT_14 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 14 number concentration') +!ak call addfld ('AIRMASS ',(/'lev'/),'A','kg/m3 ','Layer airmass') + call addfld ('AIRMASSL',(/'lev'/),'A','kg/m2 ','Layer airmass') + call addfld ('BETOTVIS',(/'lev'/),'A','1/km','Aerosol 3d extinction at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um + call addfld ('BATOTVIS',(/'lev'/),'A','1/km','Aerosol 3d absorption at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um + call addfld ('BATSW13 ',(/'lev'/),'A','1/km','Aerosol 3d SW absorption at 3.077-3.846um') + call addfld ('BATLW01 ',(/'lev'/),'A','1/km','Aerosol 3d LW absorption depth at 3.077-3.846um') +!akc6 call addfld ('AERLWA01',(/'lev'/),'A','unitless','CAM5 3d LW absorptive optical depth at 3.077-3.846um') +!+ + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call addfld(varName, (/'lev'/),'A','unitless', 'relative added mass for mode'//modeString) + enddo + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call addfld(varName, horiz_only, 'A', 'unitless', 'relative exessive added mass column for mode'//modeString) + enddo + +!#ifdef RFMIPIRF +! do ib=1,nswbands +! write(c2,'(I2)') ib +! call addfld('AERTAUBND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol extinction optical depth for wavelength band '//trim(adjustl(c2))) +! call addfld('AERSSABND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol single scattering albedo for wavelength band '//c2) +! call addfld('AERASYBND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol asymmetry parameter for wavelength band '//c2) +! +! call addfld('SDBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'shortwave spectral flux down for wavelength band '//c2) +! call addfld('SUBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'shortwave spectral flux up for wavelength band '//c2) +! enddo +! do ib=1,nlwbands +! write(c2,'(I2)') ib +! call addfld('LDBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'longwave spectral flux down for wavelength band '//c2) +! call addfld('LUBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'longwave spectral flux up for wavelength band '//c2) +! enddo +!#endif + +#ifdef AEROCOM_INSITU ! Note that this code has not yet been updated to CESM2 standard + + do i=2,6 + + irh=RF(i) + modeString=" " + write(modeString,"(I2)"),irh + if(RF(i).eq.0) modeString="00" + +!- varName = "EC44RH"//trim(modeString) +!- call addfld(varName, 'unitless', pver, 'A', '3D EC440 at RH ='//modeString//'%', phys_decomp) + varName = "EC55RH"//trim(modeString) + call addfld(varName, 'unitless', pver, 'A', '3D EC550 at RH ='//modeString//'%', phys_decomp) +!- varName = "EC87RH"//trim(modeString) +!- call addfld(varName, 'unitless', pver, 'A', '3D EC870 at RH ='//modeString//'%', phys_decomp) + +!- varName = "AB44RH"//trim(modeString) +!- call addfld(varName, 'unitless', pver, 'A', '3D ABS440 at RH ='//modeString//'%', phys_decomp) + varName = "AB55RH"//trim(modeString) + call addfld(varName, 'unitless', pver, 'A', '3D ABS550 at RH ='//modeString//'%', phys_decomp) +!- varName = "AB87RH"//trim(modeString) +!- call addfld(varName, 'unitless', pver, 'A', '3D ABS870 at RH ='//modeString//'%', phys_decomp) + + enddo + +#endif ! AEROCOM_INSITU + +#endif ! aerocom +#endif ! dirind + +#endif ! OSLO_AERO + + + if (history_amwg) then + call add_default ('PHIS ' , 1, ' ') + call add_default ('PS ' , 1, ' ') + call add_default ('T ' , 1, ' ') + call add_default ('U ' , 1, ' ') + call add_default ('V ' , 1, ' ') + call add_default ('Z3 ' , 1, ' ') + call add_default ('OMEGA ' , 1, ' ') + call add_default ('VT ', 1, ' ') + call add_default ('VU ', 1, ' ') + call add_default ('VV ', 1, ' ') + call add_default ('UU ', 1, ' ') + call add_default ('OMEGAT ', 1, ' ') + call add_default ('PSL ', 1, ' ') + end if + + if (history_vdiag) then + call add_default ('U200', 2, ' ') + call add_default ('V200', 2, ' ') + call add_default ('U850', 2, ' ') + call add_default ('U200', 3, ' ') + call add_default ('U850', 3, ' ') + call add_default ('OMEGA500', 3, ' ') + end if + + if (history_eddy) then + call add_default ('VT ', 1, ' ') + call add_default ('VU ', 1, ' ') + call add_default ('VV ', 1, ' ') + call add_default ('UU ', 1, ' ') + call add_default ('OMEGAT ', 1, ' ') + call add_default ('OMEGAU ', 1, ' ') + call add_default ('OMEGAV ', 1, ' ') + endif + + if ( history_budget ) then + call add_default ('PHIS ' , history_budget_histfile_num, ' ') + call add_default ('PS ' , history_budget_histfile_num, ' ') + call add_default ('T ' , history_budget_histfile_num, ' ') + call add_default ('U ' , history_budget_histfile_num, ' ') + call add_default ('V ' , history_budget_histfile_num, ' ') + call add_default ('TTEND_TOT' , history_budget_histfile_num, ' ') + + ! State before physics (FV) + call add_default ('TBP ' , history_budget_histfile_num, ' ') + call add_default (bpcnst(1) , history_budget_histfile_num, ' ') + ! State after physics (FV) + call add_default ('TAP ' , history_budget_histfile_num, ' ') + call add_default ('UAP ' , history_budget_histfile_num, ' ') + call add_default ('VAP ' , history_budget_histfile_num, ' ') + call add_default (apcnst(1) , history_budget_histfile_num, ' ') + if ( dycore_is('LR') .or. dycore_is('SE') ) then + call add_default ('TFIX ' , history_budget_histfile_num, ' ') +!+tht + call add_default ('EBREAK ' , history_budget_histfile_num, ' ') + call add_default ('PTTEND_DME', history_budget_histfile_num, ' ') + call add_default ('IETEND_DME', history_budget_histfile_num, ' ') + call add_default ('EFLX ' , history_budget_histfile_num, ' ') +!-tht + end if + end if + + if (history_waccm) then + call add_default ('PHIS', 7, ' ') + call add_default ('PS', 7, ' ') + call add_default ('PSL', 7, ' ') + end if + + ! outfld calls in diag_phys_tend_writeout + call addfld ('PTTEND', (/ 'lev' /), 'A', 'K/s','T total physics tendency' ) + if ( history_budget ) then + call add_default ('PTTEND' , history_budget_histfile_num, ' ') + end if + +!akc6+ CNVCLD is zero +! call add_default ('CNVCLD ', 1, ' ') +!akc6- + + ! create history variables for fourier coefficients of the diurnal + ! and semidiurnal tide in T, U, V, and Z3 + call tidal_diag_init() + + ! + ! energy diagnostics + ! + call addfld ('SE_pBF', horiz_only, 'A', 'J/m2','Dry Static Energy before energy fixer') + call addfld ('SE_pBP', horiz_only, 'A', 'J/m2','Dry Static Energy before parameterizations') + call addfld ('SE_pAP', horiz_only, 'A', 'J/m2','Dry Static Energy after parameterizations') + call addfld ('SE_pAM', horiz_only, 'A', 'J/m2','Dry Static Energy after dry mass correction') + + call addfld ('KE_pBF', horiz_only, 'A', 'J/m2','Kinetic Energy before energy fixer') + call addfld ('KE_pBP', horiz_only, 'A', 'J/m2','Kinetic Energy before parameterizations') + call addfld ('KE_pAP', horiz_only, 'A', 'J/m2','Kinetic Energy after parameterizations') + call addfld ('KE_pAM', horiz_only, 'A', 'J/m2','Kinetic Energy after dry mass correction') + + call addfld ('TT_pBF', horiz_only, 'A', 'kg/m2','Total column test tracer before energy fixer') + call addfld ('TT_pBP', horiz_only, 'A', 'kg/m2','Total column test tracer before parameterizations') + call addfld ('TT_pAP', horiz_only, 'A', 'kg/m2','Total column test tracer after parameterizations') + call addfld ('TT_pAM', horiz_only, 'A', 'kg/m2','Total column test tracer after dry mass correction') + + call addfld ('WV_pBF', horiz_only, 'A', 'kg/m2','Total column water vapor before energy fixer') + call addfld ('WV_pBP', horiz_only, 'A', 'kg/m2','Total column water vapor before parameterizations') + call addfld ('WV_pAP', horiz_only, 'A', 'kg/m2','Total column water vapor after parameterizations') + call addfld ('WV_pAM', horiz_only, 'A', 'kg/m2','Total column water vapor after dry mass correction') + + call addfld ('WL_pBF', horiz_only, 'A', 'kg/m2','Total column cloud water before energy fixer') + call addfld ('WL_pBP', horiz_only, 'A', 'kg/m2','Total column cloud water before parameterizations') + call addfld ('WL_pAP', horiz_only, 'A', 'kg/m2','Total column cloud water after parameterizations') + call addfld ('WL_pAM', horiz_only, 'A', 'kg/m2','Total column cloud water after dry mass correction') + + call addfld ('WI_pBF', horiz_only, 'A', 'kg/m2','Total column cloud ice before energy fixer') + call addfld ('WI_pBP', horiz_only, 'A', 'kg/m2','Total column cloud ice before parameterizations') + call addfld ('WI_pAP', horiz_only, 'A', 'kg/m2','Total column cloud ice after parameterizations') + call addfld ('WI_pAM', horiz_only, 'A', 'kg/m2','Total column cloud ice after dry mass correction') + ! + ! Axial Angular Momentum diagnostics + ! + call addfld ('MR_pBF', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column wind axial angular momentum before energy fixer') + call addfld ('MR_pBP', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column wind axial angular momentum before parameterizations') + call addfld ('MR_pAP', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column wind axial angular momentum after parameterizations') + call addfld ('MR_pAM', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column wind axial angular momentum after dry mass correction') + + call addfld ('MO_pBF', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column mass axial angular momentum before energy fixer') + call addfld ('MO_pBP', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column mass axial angular momentum before parameterizations') + call addfld ('MO_pAP', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column mass axial angular momentum after parameterizations') + call addfld ('MO_pAM', horiz_only, 'A', 'kg*m2/s*rad2',& + 'Total column mass axial angular momentum after dry mass correction') + +#ifdef DIRIND + call add_default ('AOD_VIS ', 1, ' ') + call add_default ('ABSVIS ', 1, ' ') + call add_default ('AODVVOLC', 1, ' ') + call add_default ('ABSVVOLC', 1, ' ') + call add_default ('DAYFOC ', 1, ' ') + call add_default ('CAODVIS ', 1, ' ') + call add_default ('CABSVIS ', 1, ' ') + call add_default ('CLDFREE ', 1, ' ') + call add_default ('N_AER ', 1, ' ') +#ifdef COLTST4INTCONS + call add_default ('TAUKC0 ', 1, ' ') + call add_default ('TAUKC1 ', 1, ' ') + call add_default ('TAUKC2 ', 1, ' ') + call add_default ('TAUKC4 ', 1, ' ') + call add_default ('TAUKC5 ', 1, ' ') + call add_default ('TAUKC6 ', 1, ' ') + call add_default ('TAUKC7 ', 1, ' ') + call add_default ('TAUKC8 ', 1, ' ') + call add_default ('TAUKC9 ', 1, ' ') + call add_default ('TAUKC10', 1, ' ') + call add_default ('TAUKC12', 1, ' ') + call add_default ('TAUKC14', 1, ' ') +! + call add_default ('MECKC0 ', 1, ' ') + call add_default ('MECKC1 ', 1, ' ') + call add_default ('MECKC2 ', 1, ' ') + call add_default ('MECKC4 ', 1, ' ') + call add_default ('MECKC5 ', 1, ' ') + call add_default ('MECKC6 ', 1, ' ') + call add_default ('MECKC7 ', 1, ' ') + call add_default ('MECKC8 ', 1, ' ') + call add_default ('MECKC9 ', 1, ' ') + call add_default ('MECKC10', 1, ' ') + call add_default ('MECKC12', 1, ' ') + call add_default ('MECKC14', 1, ' ') +#ifdef AEROCOM + call add_default ('CMDRY0 ', 1, ' ') + call add_default ('CMDRY1 ', 1, ' ') + call add_default ('CMDRY2 ', 1, ' ') + call add_default ('CMDRY4 ', 1, ' ') + call add_default ('CMDRY5 ', 1, ' ') + call add_default ('CMDRY6 ', 1, ' ') + call add_default ('CMDRY7 ', 1, ' ') + call add_default ('CMDRY8 ', 1, ' ') + call add_default ('CMDRY9 ', 1, ' ') + call add_default ('CMDRY10', 1, ' ') + call add_default ('CMDRY12', 1, ' ') + call add_default ('CMDRY14', 1, ' ') +#endif +#endif +!- call add_default ('N_AERORG', 1, ' ') + call add_default ('SSAVIS ', 1, ' ') + call add_default ('ASYMMVIS', 1, ' ') + call add_default ('EXTVIS ', 1, ' ') +!=0 call add_default ('RELH ', 1, ' ') +!akc6+ + call add_default ('BVISVOLC', 1, ' ') +!akc6- +!#ifdef SPAERO +! call add_default ('AODVISSP', 1, ' ') +! call add_default ('ABSVISSP', 1, ' ') +! call add_default ('XCDNC_SP', 1, ' ') +! call add_default ('AODV3DSP', 1, ' ') +! call add_default ('ABSV3DSP', 1, ' ') +!#endif +#ifdef AEROFFL + call add_default ('FSNT_DRF', 1, ' ') + call add_default ('FSNTCDRF', 1, ' ') + call add_default ('FSNS_DRF', 1, ' ') + call add_default ('FSNSCDRF', 1, ' ') + call add_default ('QRS_DRF ', 1, ' ') + call add_default ('QRSC_DRF', 1, ' ') + call add_default ('FLNT_DRF', 1, ' ') + call add_default ('FLNTCDRF', 1, ' ') + call add_default ('FSUTADRF', 1, ' ') + call add_default ('FSDS_DRF', 1, ' ') + call add_default ('FSUS_DRF', 1, ' ') + call add_default ('FSDSCDRF', 1, ' ') + call add_default ('FLUS ', 1, ' ') +!->ut call add_default ('FLNT_ORG', 1, ' ') +#endif ! aeroffl +#ifdef AEROCOM + call add_default ('AKCXS ', 1, ' ') + call add_default ('PMTOT ', 1, ' ') + call add_default ('PM25 ', 1, ' ') +!akc6+ + call add_default ('PM2P5 ', 1, ' ') + call add_default ('MMRPM2P5', 1, ' ') + call add_default ('MMRPM1 ', 1, ' ') +!akc6- + call add_default ('GRIDAREA', 1, ' ') + call add_default ('DAERH2O ', 1, ' ') + call add_default ('MMR_AH2O', 1, ' ') + call add_default ('ECDRYAER', 1, ' ') + call add_default ('ABSDRYAE', 1, ' ') + call add_default ('ECDRY440', 1, ' ') + call add_default ('ABSDR440', 1, ' ') + call add_default ('ECDRY870', 1, ' ') + call add_default ('ABSDR870', 1, ' ') + call add_default ('ASYMMDRY', 1, ' ') + call add_default ('ECDRYLT1', 1, ' ') + call add_default ('ABSDRYBC', 1, ' ') + call add_default ('ABSDRYOC', 1, ' ') + call add_default ('ABSDRYSU', 1, ' ') + call add_default ('ABSDRYSS', 1, ' ') + call add_default ('ABSDRYDU', 1, ' ') + call add_default ('OD550DRY', 1, ' ') + call add_default ('AB550DRY', 1, ' ') + call add_default ('DERLT05 ', 1, ' ') + call add_default ('DERGT05 ', 1, ' ') + call add_default ('DER ', 1, ' ') + call add_default ('DOD440 ', 1, ' ') + call add_default ('ABS440 ', 1, ' ') + call add_default ('DOD500 ', 1, ' ') + call add_default ('ABS500 ', 1, ' ') + call add_default ('DOD550 ', 1, ' ') +!tst +! call add_default ('DOD5503D', 1, ' ') +! call add_default ('AODVIS3D', 1, ' ') +!tst + call add_default ('ABS550 ', 1, ' ') + call add_default ('ABS550AL', 1, ' ') + call add_default ('DOD670 ', 1, ' ') + call add_default ('ABS670 ', 1, ' ') + call add_default ('DOD870 ', 1, ' ') + call add_default ('ABS870 ', 1, ' ') + call add_default ('DLOAD_MI', 1, ' ') + call add_default ('DLOAD_SS', 1, ' ') + call add_default ('DLOAD_S4', 1, ' ') + call add_default ('DLOAD_OC', 1, ' ') + call add_default ('DLOAD_BC', 1, ' ') + call add_default ('LOADBCAC', 1, ' ') + call add_default ('LOADBC0 ', 1, ' ') + call add_default ('LOADBC2 ', 1, ' ') + call add_default ('LOADBC4 ', 1, ' ') + call add_default ('LOADBC12', 1, ' ') + call add_default ('LOADBC14', 1, ' ') + call add_default ('LOADOCAC', 1, ' ') + call add_default ('LOADOC4 ', 1, ' ') + call add_default ('LOADOC14', 1, ' ') +#ifdef COLTST4INTCONS + call add_default ('COLRBC0 ', 1, ' ') + call add_default ('COLRBC2 ', 1, ' ') + call add_default ('COLRBC4 ', 1, ' ') + call add_default ('COLRBC12', 1, ' ') + call add_default ('COLRBC14', 1, ' ') + call add_default ('COLRBCAC', 1, ' ') + call add_default ('COLROC4 ', 1, ' ') + call add_default ('COLROC14', 1, ' ') + call add_default ('COLROCAC', 1, ' ') + call add_default ('COLRSULA', 1, ' ') + call add_default ('COLRSUL1', 1, ' ') + call add_default ('COLRSUL5', 1, ' ') +#endif ! COLTST4INTCONS +! + call add_default ('EC550AER', 1, ' ') + call add_default ('ABS550_A', 1, ' ') + call add_default ('BS550AER', 1, ' ') +! + call add_default ('EC550SO4', 1, ' ') + call add_default ('EC550BC ', 1, ' ') + call add_default ('EC550POM', 1, ' ') + call add_default ('EC550SS ', 1, ' ') + call add_default ('EC550DU ', 1, ' ') +! + call add_default ('CDOD440 ', 1, ' ') + call add_default ('CDOD550 ', 1, ' ') + call add_default ('CABS550 ', 1, ' ') + call add_default ('CABS550A', 1, ' ') + call add_default ('CDOD870 ', 1, ' ') + call add_default ('A550_DU ', 1, ' ') + call add_default ('A550_SS ', 1, ' ') + call add_default ('A550_SO4', 1, ' ') + call add_default ('A550_POM', 1, ' ') + call add_default ('A550_BC ', 1, ' ') + call add_default ('D440_DU ', 1, ' ') + call add_default ('D440_SS ', 1, ' ') + call add_default ('D440_SO4', 1, ' ') + call add_default ('D440_POM', 1, ' ') + call add_default ('D440_BC ', 1, ' ') + call add_default ('D500_DU ', 1, ' ') + call add_default ('D500_SS ', 1, ' ') + call add_default ('D500_SO4', 1, ' ') + call add_default ('D500_POM', 1, ' ') + call add_default ('D500_BC ', 1, ' ') + call add_default ('D550_DU ', 1, ' ') + call add_default ('D550_SS ', 1, ' ') + call add_default ('D550_SO4', 1, ' ') + call add_default ('D550_POM', 1, ' ') + call add_default ('D550_BC ', 1, ' ') + call add_default ('D670_DU ', 1, ' ') + call add_default ('D670_SS ', 1, ' ') + call add_default ('D670_SO4', 1, ' ') + call add_default ('D670_POM', 1, ' ') + call add_default ('D670_BC ', 1, ' ') + call add_default ('D870_DU ', 1, ' ') + call add_default ('D870_SS ', 1, ' ') + call add_default ('D870_SO4', 1, ' ') + call add_default ('D870_POM', 1, ' ') + call add_default ('D870_BC ', 1, ' ') + call add_default ('DLT_DUST', 1, ' ') + call add_default ('DLT_SS ', 1, ' ') + call add_default ('DLT_SO4 ', 1, ' ') + call add_default ('DLT_POM ', 1, ' ') + call add_default ('DLT_BC ', 1, ' ') + call add_default ('DGT_DUST', 1, ' ') + call add_default ('DGT_SS ', 1, ' ') + call add_default ('DGT_SO4 ', 1, ' ') + call add_default ('DGT_POM ', 1, ' ') + call add_default ('DGT_BC ', 1, ' ') + call add_default ('NNAT_0 ', 1, ' ') + call add_default ('NNAT_1 ', 1, ' ') + call add_default ('NNAT_2 ', 1, ' ') + call add_default ('NNAT_4 ', 1, ' ') + call add_default ('NNAT_5 ', 1, ' ') + call add_default ('NNAT_6 ', 1, ' ') + call add_default ('NNAT_7 ', 1, ' ') + call add_default ('NNAT_8 ', 1, ' ') + call add_default ('NNAT_9 ', 1, ' ') + call add_default ('NNAT_10 ', 1, ' ') + call add_default ('NNAT_12 ', 1, ' ') + call add_default ('NNAT_14 ', 1, ' ') + call add_default ('AIRMASSL', 1, ' ') !akc6 + call add_default ('AIRMASS ', 1, ' ') !akc6 + call add_default ('BETOTVIS', 1, ' ') + call add_default ('BATOTVIS', 1, ' ') + call add_default ('BATSW13 ', 1, ' ') + call add_default ('BATLW01 ', 1, ' ') +!akc6 call add_default ('AERLWA01', 1, ' ') +!+ + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call add_default(varName, 1, ' ') + enddo + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call add_default(varName, 1, ' ') + enddo +!++ + +!#ifdef RFMIPIRF +! do i=1,nbands +! do ib=1,nswbands +! write(c2,'(I2)') ib +! call add_default('AERTAUBND'//trim(adjustl(c2)), 1, ' ') +! call add_default('AERSSABND'//trim(adjustl(c2)), 1, ' ') +! call add_default('AERASYBND'//trim(adjustl(c2)), 1, ' ') +! +! call add_default('SDBND'//trim(adjustl(c2)), 1, ' ') +! call add_default('SUBND'//trim(adjustl(c2)), 1, ' ') +! enddo +! do ib=1,nlwbands +! write(c2,'(I2)') ib +! call add_default('LDBND'//trim(adjustl(c2)), 1, ' ') +! call add_default('LUBND'//trim(adjustl(c2)), 1, ' ') +! enddo +!#endif + + +#ifdef AEROCOM_INSITU + + do i=2,6 + + irh=RF(i) + modeString=" " + write(modeString,"(I2)"),irh + if(RF(i).eq.0) modeString="00" + +!- varName = "EC44RH"//trim(modeString) +!- call add_default(varName, 1, ' ') + varName = "EC55RH"//trim(modeString) + call add_default(varName, 1, ' ') +!- varName = "EC87RH"//trim(modeString) +!- call add_default(varName, 1, ' ') + +!- varName = "AB44RH"//trim(modeString) +!- call add_default(varName, 1, ' ') + varName = "AB55RH"//trim(modeString) + call add_default(varName, 1, ' ') +!- varName = "AB87RH"//trim(modeString) +!- call add_default(varName, 1, ' ') + + enddo + +#endif ! AEROCOM_INSITU + +!-- +!- +#endif ! aerocom +#endif ! dirind + +!#ifdef SPAERO +! call addfld ('FSNT_SP ', horiz_only, 'A','W/m^2','Total column absorbed solar flux (without SP aerosols)') +! call addfld ('FSNTC_SP', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (without SP aerosols)') +! call addfld ('FSNS_SP ', horiz_only, 'A','W/m^2','Surface absorbed solar flux (without SP aerosols)') +! call addfld ('FSNSC_SP', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (without SP aerosols)') +! call addfld ('FSNT_SP2', horiz_only, 'A','W/m^2','Total column absorbed solar flux (SP aerosols for DRF only)') +! call addfld ('FSNTCSP2', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (SP aerosols for DRF only)') +! call addfld ('FSNS_SP2', horiz_only, 'A','W/m^2','Surface absorbed solar flux (SP aerosols for DRF only)') +! call addfld ('FSNSCSP2', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (SP aerosols for DRF only)') +! call addfld ('FSNT_SP3', horiz_only, 'A','W/m^2','Total column absorbed solar flux (SP aerosols)') +! call addfld ('FSNTCSP3', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (SP aerosols)') +! call addfld ('FSNS_SP3', horiz_only, 'A','W/m^2','Surface absorbed solar flux (SP aerosols)') +! call addfld ('FSNSCSP3', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (SP aerosols)') +! call add_default ('FSNT_SP' , 1, ' ') +! call add_default ('FSNTC_SP', 1, ' ') +! call add_default ('FSNS_SP' , 1, ' ') +! call add_default ('FSNSC_SP', 1, ' ') +! call add_default ('FSNT_SP2', 1, ' ') +! call add_default ('FSNTCSP2', 1, ' ') +! call add_default ('FSNS_SP2', 1, ' ') +! call add_default ('FSNSCSP2', 1, ' ') +! call add_default ('FSNT_SP3', 1, ' ') +! call add_default ('FSNTCSP3', 1, ' ') +! call add_default ('FSNS_SP3', 1, ' ') +! call add_default ('FSNSCSP3', 1, ' ') +!#endif + + end subroutine diag_init_dry + + subroutine diag_init_moist(pbuf2d) + + ! Declare the history fields for which this module contains outfld calls. + + use cam_history, only: addfld, add_default, horiz_only + use cam_history, only: register_vector_field + use constituent_burden, only: constituent_burden_init + use physics_buffer, only: pbuf_set_field + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + integer :: k, m + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: ierr + !AL + integer :: ixcldnc + integer :: ixcldni + !AL + ! column burdens for all constituents except water vapor + call constituent_burden_init + + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + + ! outfld calls in diag_phys_writeout + call addfld ('OMEGAQ', (/ 'lev' /), 'A', 'kgPa/kgs', 'Vertical water transport' ) + call addfld ('VQ', (/ 'lev' /), 'A', 'm/skg/kg', 'Meridional water transport') + call addfld ('QQ', (/ 'lev' /), 'A', 'kg2/kg2', 'Eddy moisture variance') + + call addfld ('MQ', (/ 'lev' /), 'A', 'kg/m2','Water vapor mass in layer') + call addfld ('TMQ', horiz_only, 'A', 'kg/m2','Total (vertically integrated) precipitable water') + call addfld ('RELHUM', (/ 'lev' /), 'A', 'percent','Relative humidity') + call addfld ('RHW', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to liquid') + call addfld ('RHI', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to ice') + call addfld ('RHCFMIP', (/ 'lev' /), 'A', 'percent','Relative humidity with respect to water above 273 K, ice below 273 K') + + call addfld ('THE8501000', horiz_only, 'A', 'K','ThetaE difference 850 mb - 1000 mb') + call addfld ('THE9251000', horiz_only, 'A', 'K','ThetaE difference 925 mb - 1000 mb') + + call addfld ('Q1000', horiz_only, 'A', 'kg/kg','Specific Humidity at 1000 mbar pressure surface') + call addfld ('Q925', horiz_only, 'A', 'kg/kg','Specific Humidity at 925 mbar pressure surface') + call addfld ('Q850', horiz_only, 'A', 'kg/kg','Specific Humidity at 850 mbar pressure surface') + call addfld ('Q200', horiz_only, 'A', 'kg/kg','Specific Humidity at 700 mbar pressure surface') + call addfld ('QBOT', horiz_only, 'A', 'kg/kg','Lowest model level water vapor mixing ratio') + + call addfld ('PSDRY', horiz_only, 'A', 'Pa', 'Dry surface pressure') + call addfld ('PMID', (/ 'lev' /), 'A', 'Pa', 'Pressure at layer midpoints') + call addfld ('PDELDRY', (/ 'lev' /), 'A', 'Pa', 'Dry pressure difference between levels') + + ! outfld calls in diag_conv + + call addfld ('DTCOND', (/ 'lev' /), 'A','K/s','T tendency - moist processes') + call addfld ('DTCOND_24_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. cos coeff.') + call addfld ('DTCOND_24_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 24hr. sin coeff.') + call addfld ('DTCOND_12_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. cos coeff.') + call addfld ('DTCOND_12_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. sin coeff.') + call addfld ('DTCOND_08_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. cos coeff.') + call addfld ('DTCOND_08_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. sin coeff.') +!AL + call cnst_get_ind('NUMLIQ', ixcldnc) + call cnst_get_ind('NUMICE', ixcldni) +!AL + + call addfld ('PRECL', horiz_only, 'A', 'm/s','Large-scale (stable) precipitation rate (liq + ice)' ) + call addfld ('PRECC', horiz_only, 'A', 'm/s','Convective precipitation rate (liq + ice)' ) + call addfld ('PRECT', horiz_only, 'A', 'm/s','Total (convective and large-scale) precipitation rate (liq + ice)' ) + call addfld ('PREC_PCW', horiz_only, 'A', 'm/s','LS_pcw precipitation rate') + call addfld ('PREC_zmc', horiz_only, 'A', 'm/s','CV_zmc precipitation rate') + call addfld ('PRECTMX', horiz_only, 'X','m/s','Maximum (convective and large-scale) precipitation rate (liq+ice)' ) + call addfld ('PRECSL', horiz_only, 'A', 'm/s','Large-scale (stable) snow rate (water equivalent)' ) + call addfld ('PRECSC', horiz_only, 'A', 'm/s','Convective snow rate (water equivalent)' ) + call addfld ('PRECCav', horiz_only, 'A', 'm/s','Average large-scale precipitation (liq + ice)' ) + call addfld ('PRECLav', horiz_only, 'A', 'm/s','Average convective precipitation (liq + ice)' ) + + ! outfld calls in diag_surf + + call addfld ('SHFLX', horiz_only, 'A', 'W/m2','Surface sensible heat flux') + call addfld ('LHFLX', horiz_only, 'A', 'W/m2','Surface latent heat flux') + call addfld ('QFLX', horiz_only, 'A', 'kg/m2/s','Surface water flux') + + call addfld ('TAUX', horiz_only, 'A', 'N/m2','Zonal surface stress') + call addfld ('TAUY', horiz_only, 'A', 'N/m2','Meridional surface stress') + call addfld ('TREFHT', horiz_only, 'A', 'K','Reference height temperature') + call addfld ('TREFHTMN', horiz_only, 'M','K','Minimum reference height temperature over output period') + call addfld ('TREFHTMX', horiz_only, 'X','K','Maximum reference height temperature over output period') + call addfld ('QREFHT', horiz_only, 'A', 'kg/kg','Reference height humidity') + call addfld ('U10', horiz_only, 'A', 'm/s','10m wind speed') + call addfld ('RHREFHT', horiz_only, 'A', 'fraction','Reference height relative humidity') + + call addfld ('LANDFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by land') + call addfld ('ICEFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by sea-ice') + call addfld ('OCNFRAC', horiz_only, 'A', 'fraction','Fraction of sfc area covered by ocean') + + call addfld ('TREFMNAV', horiz_only, 'A', 'K','Average of TREFHT daily minimum') + call addfld ('TREFMXAV', horiz_only, 'A', 'K','Average of TREFHT daily maximum') + + call addfld ('TS', horiz_only, 'A', 'K','Surface temperature (radiative)') + call addfld ('TSMN', horiz_only, 'M','K','Minimum surface temperature over output period') + call addfld ('TSMX', horiz_only, 'X','K','Maximum surface temperature over output period') + call addfld ('SNOWHLND', horiz_only, 'A', 'm','Water equivalent snow depth') + call addfld ('SNOWHICE', horiz_only, 'A', 'm','Snow depth over ice', fill_value = 1.e30_r8) + call addfld ('TBOT', horiz_only, 'A', 'K','Lowest model level temperature') + + call addfld ('ASDIR', horiz_only, 'A', '1','albedo: shortwave, direct') + call addfld ('ASDIF', horiz_only, 'A', '1','albedo: shortwave, diffuse') + call addfld ('ALDIR', horiz_only, 'A', '1','albedo: longwave, direct') + call addfld ('ALDIF', horiz_only, 'A', '1','albedo: longwave, diffuse') + call addfld ('SST', horiz_only, 'A', 'K','sea surface temperature') + + + ! outfld calls in diag_phys_tend_writeout + + call addfld (ptendnam( 1),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name( 1))//' total physics tendency ' ) + + if (ixcldliq > 0) then + call addfld (ptendnam(ixcldliq),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldliq))//' total physics tendency ' ) + end if + if (ixcldice > 0) then + call addfld (ptendnam(ixcldice),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldice))//' total physics tendency ') + end if +!AL + call addfld (ptendnam(ixcldnc), (/ 'lev' /), 'A', '#/kg/s ',trim(cnst_name(ixcldnc))//' total physics tendency ') + call addfld (ptendnam(ixcldni), (/ 'lev' /), 'A', '#/kg/s ',trim(cnst_name(ixcldni))//' total physics tendency ') +!AL + if ( dycore_is('LR') )then + call addfld (dmetendnam( 1),(/ 'lev' /), 'A','kg/kg/s', & + trim(cnst_name( 1))//' dme adjustment tendency (FV) ') + if (ixcldliq > 0) then + call addfld (dmetendnam(ixcldliq),(/ 'lev' /), 'A','kg/kg/s', & + trim(cnst_name(ixcldliq))//' dme adjustment tendency (FV) ') + end if + if (ixcldice > 0) then + call addfld (dmetendnam(ixcldice),(/ 'lev' /), 'A','kg/kg/s', & + trim(cnst_name(ixcldice))//' dme adjustment tendency (FV) ') + end if +!AL + call addfld (dmetendnam(ixcldnc),(/ 'lev' /), 'A','#/kg/s ', & + trim(cnst_name(ixcldnc))//' dme adjustment tendency (FV) ') + call addfld (dmetendnam(ixcldni),(/ 'lev' /), 'A','#/kg/s ', & + trim(cnst_name(ixcldni))//' dme adjustment tendency (FV) ') +!AL + end if + + if ( history_budget ) then +!AL + call add_default (ptendnam(ixcldnc), history_budget_histfile_num, ' ') + call add_default (ptendnam(ixcldni), history_budget_histfile_num, ' ') +!AL + end if + + ! outfld calls in diag_physvar_ic + + call addfld ('QCWAT&IC', (/ 'lev' /), 'I','kg/kg','q associated with cloud water' ) + call addfld ('TCWAT&IC', (/ 'lev' /), 'I','kg/kg','T associated with cloud water' ) + call addfld ('LCWAT&IC', (/ 'lev' /), 'I','kg/kg','Cloud water (ice + liq' ) + call addfld ('CLOUD&IC', (/ 'lev' /), 'I','fraction','Cloud fraction' ) + call addfld ('CONCLD&IC', (/ 'lev' /), 'I','fraction','Convective cloud fraction' ) + call addfld ('TKE&IC', (/ 'ilev' /), 'I','m2/s2','Turbulent Kinetic Energy' ) + call addfld ('CUSH&IC', horiz_only, 'I','m','Convective Scale Height' ) + call addfld ('KVH&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (heat/moisture)' ) + call addfld ('KVM&IC', (/ 'ilev' /), 'I','m2/s','Vertical diffusion diffusivities (momentum)' ) + call addfld ('PBLH&IC', horiz_only, 'I','m','PBL height' ) + call addfld ('TPERT&IC', horiz_only, 'I','K','Perturbation temperature (eddies in PBL)' ) + call addfld ('QPERT&IC', horiz_only, 'I','kg/kg','Perturbation specific humidity (eddies in PBL)' ) + + ! CAM export state + call addfld('a2x_BCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic black carbon') + call addfld('a2x_BCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic black carbon') + call addfld('a2x_BCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic black carbon') + call addfld('a2x_OCPHIWET', horiz_only, 'A', 'kg/m2/s', 'wetdep of hydrophilic organic carbon') + call addfld('a2x_OCPHIDRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophilic organic carbon') + call addfld('a2x_OCPHODRY', horiz_only, 'A', 'kg/m2/s', 'drydep of hydrophobic organic carbon') + call addfld('a2x_DSTWET1', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin1)') + call addfld('a2x_DSTDRY1', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin1)') + call addfld('a2x_DSTWET2', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin2)') + call addfld('a2x_DSTDRY2', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin2)') + call addfld('a2x_DSTWET3', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin3)') + call addfld('a2x_DSTDRY3', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin3)') + call addfld('a2x_DSTWET4', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin4)') + call addfld('a2x_DSTDRY4', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin4)') + +#ifdef AEROCOM + call add_default ('RHW ', 1, ' ') +#endif ! aerocom + + ! defaults + if (history_amwg) then + call add_default (cnst_name(1), 1, ' ') + call add_default ('VQ ', 1, ' ') + call add_default ('TMQ ', 1, ' ') + call add_default ('PSL ', 1, ' ') + call add_default ('RELHUM ', 1, ' ') + + call add_default ('DTCOND ', 1, ' ') + call add_default ('PRECL ', 1, ' ') + call add_default ('PRECC ', 1, ' ') + call add_default ('PRECSL ', 1, ' ') + call add_default ('PRECSC ', 1, ' ') + call add_default ('SHFLX ', 1, ' ') + call add_default ('LHFLX ', 1, ' ') + call add_default ('QFLX ', 1, ' ') + call add_default ('TAUX ', 1, ' ') + call add_default ('TAUY ', 1, ' ') + call add_default ('TREFHT ', 1, ' ') + call add_default ('LANDFRAC', 1, ' ') + call add_default ('OCNFRAC ', 1, ' ') + call add_default ('QREFHT ', 1, ' ') + call add_default ('U10 ', 1, ' ') + call add_default ('ICEFRAC ', 1, ' ') + call add_default ('TS ', 1, ' ') + call add_default ('TSMN ', 1, ' ') + call add_default ('TSMX ', 1, ' ') + call add_default ('SNOWHLND', 1, ' ') + call add_default ('SNOWHICE', 1, ' ') + end if + + if (dycore_is('SE')) then + call add_default ('PSDRY', 1, ' ') + call add_default ('PMID', 1, ' ') + end if + + if (history_eddy) then + call add_default ('VQ ', 1, ' ') + endif + + if ( history_budget ) then + call add_default (cnst_name(1), history_budget_histfile_num, ' ') + call add_default ('PTTEND' , history_budget_histfile_num, ' ') + call add_default (ptendnam( 1), history_budget_histfile_num, ' ') + if (ixcldliq > 0) then + call add_default (ptendnam(ixcldliq), history_budget_histfile_num, ' ') + end if + if (ixcldice > 0) then + call add_default (ptendnam(ixcldice), history_budget_histfile_num, ' ') + end if + if ( dycore_is('LR') )then + call add_default(dmetendnam(1) , history_budget_histfile_num, ' ') + if (ixcldliq > 0) then + call add_default(dmetendnam(ixcldliq), history_budget_histfile_num, ' ') + end if + if (ixcldice > 0) then + call add_default(dmetendnam(ixcldice), history_budget_histfile_num, ' ') + end if + end if + if( history_budget_histfile_num > 1 ) then + call add_default ('DTCOND ' , history_budget_histfile_num, ' ') + end if + end if + + if (history_vdiag) then + call add_default ('PRECT ', 2, ' ') + call add_default ('PRECT ', 3, ' ') + call add_default ('PRECT ', 4, ' ') + end if + + ! Initial file - Optional fields + if (inithist_all.or.single_column) then + call add_default ('CONCLD&IC ',0, 'I') + call add_default ('QCWAT&IC ',0, 'I') + call add_default ('TCWAT&IC ',0, 'I') + call add_default ('LCWAT&IC ',0, 'I') + call add_default ('PBLH&IC ',0, 'I') + call add_default ('TPERT&IC ',0, 'I') + call add_default ('QPERT&IC ',0, 'I') + call add_default ('CLOUD&IC ',0, 'I') + call add_default ('TKE&IC ',0, 'I') + call add_default ('CUSH&IC ',0, 'I') + call add_default ('KVH&IC ',0, 'I') + call add_default ('KVM&IC ',0, 'I') + end if + + ! determine number of constituents for which convective tendencies must be computed + if (history_budget) then + dqcond_num = pcnst + else + if (diag_cnst_conv_tend == 'none') dqcond_num = 0 + if (diag_cnst_conv_tend == 'q_only') dqcond_num = 1 + if (diag_cnst_conv_tend == 'all') dqcond_num = pcnst + end if + + do m = 1, dqcond_num + dcconnam(m) = 'DC'//cnst_name(m) + end do + + if ((diag_cnst_conv_tend == 'q_only') .or. (diag_cnst_conv_tend == 'all') .or. history_budget) then + call addfld (dcconnam(1),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(1))//' tendency due to moist processes') + if ( diag_cnst_conv_tend == 'q_only' .or. diag_cnst_conv_tend == 'all' ) then + call add_default (dcconnam(1), 1, ' ') + end if + if( history_budget ) then + call add_default (dcconnam(1), history_budget_histfile_num, ' ') + end if + if (diag_cnst_conv_tend == 'all' .or. history_budget) then + do m = 2, pcnst + call addfld (dcconnam(m),(/ 'lev' /),'A', 'kg/kg/s',trim(cnst_name(m))//' tendency due to moist processes') + if( diag_cnst_conv_tend == 'all' ) then + call add_default (dcconnam(m), 1, ' ') + end if + if( history_budget .and. (m == ixcldliq .or. m == ixcldice) ) then + call add_default (dcconnam(m), history_budget_histfile_num, ' ') + end if + end do + end if + end if + + ! Pbuf field indices for collecting output data + relhum_idx = pbuf_get_index('RELHUM', errcode=ierr) + qcwat_idx = pbuf_get_index('QCWAT', errcode=ierr) + tcwat_idx = pbuf_get_index('TCWAT', errcode=ierr) + lcwat_idx = pbuf_get_index('LCWAT', errcode=ierr) + cld_idx = pbuf_get_index('CLD', errcode=ierr) + concld_idx = pbuf_get_index('CONCLD', errcode=ierr) + + tke_idx = pbuf_get_index('tke', errcode=ierr) + kvm_idx = pbuf_get_index('kvm', errcode=ierr) + kvh_idx = pbuf_get_index('kvh', errcode=ierr) + cush_idx = pbuf_get_index('cush', errcode=ierr) + + pblh_idx = pbuf_get_index('pblh', errcode=ierr) + tpert_idx = pbuf_get_index('tpert', errcode=ierr) + qpert_idx = pbuf_get_index('qpert', errcode=ierr) + + prec_dp_idx = pbuf_get_index('PREC_DP', errcode=ierr) + snow_dp_idx = pbuf_get_index('SNOW_DP', errcode=ierr) + prec_sh_idx = pbuf_get_index('PREC_SH', errcode=ierr) + snow_sh_idx = pbuf_get_index('SNOW_SH', errcode=ierr) + prec_sed_idx = pbuf_get_index('PREC_SED', errcode=ierr) + snow_sed_idx = pbuf_get_index('SNOW_SED', errcode=ierr) + prec_pcw_idx = pbuf_get_index('PREC_PCW', errcode=ierr) + snow_pcw_idx = pbuf_get_index('SNOW_PCW', errcode=ierr) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, trefmxav_idx, -1.0e36_r8) + call pbuf_set_field(pbuf2d, trefmnav_idx, 1.0e36_r8) + end if + + end subroutine diag_init_moist + + subroutine diag_init(pbuf2d) + use cam_history, only: addfld + + ! Declare the history fields for which this module contains outfld calls. + + type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + call phys_getopts(history_amwg_out = history_amwg , & + history_vdiag_out = history_vdiag , & + history_eddy_out = history_eddy , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + call diag_init_dry(pbuf2d) + if (moist_physics) then + call diag_init_moist(pbuf2d) + end if + + end subroutine diag_init + +!=============================================================================== + + subroutine diag_allocate_dry() + use infnan, only: nan, assignment(=) + + ! Allocate memory for module variables. + ! Done at the begining of a physics step at same point as the pbuf allocate + ! for variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_allocate_dry' + character(len=128) :: errmsg + integer :: istat + + allocate(dtcond(pcols,pver,begchunk:endchunk), stat=istat) + if ( istat /= 0 ) then + write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat + call endrun (errmsg) + end if + dtcond = nan + end subroutine diag_allocate_dry + + subroutine diag_allocate_moist() + use infnan, only: nan, assignment(=) + + ! Allocate memory for module variables. + ! Done at the begining of a physics step at same point as the pbuf allocate + ! for variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_allocate_moist' + character(len=128) :: errmsg + integer :: i, istat + + if (dqcond_num > 0) then + allocate(dqcond(dqcond_num)) + do i = 1, dqcond_num + allocate(dqcond(i)%cnst(pcols,pver,begchunk:endchunk), stat=istat) + if ( istat /= 0 ) then + write(errmsg, '(2a,i0)') sub, ': allocate failed, stat = ',istat + call endrun (errmsg) + end if + dqcond(i)%cnst = nan + end do + end if + + end subroutine diag_allocate_moist + + subroutine diag_allocate() + + call diag_allocate_dry() + if (moist_physics) then + call diag_allocate_moist() + end if + + end subroutine diag_allocate + +!=============================================================================== + + subroutine diag_deallocate_dry() + ! Deallocate memory for module variables. + ! Done at the end of a physics step at same point as the pbuf deallocate for + ! variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_deallocate_dry' + integer :: istat + + deallocate(dtcond, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end subroutine diag_deallocate_dry + + subroutine diag_deallocate_moist() + + ! Deallocate memory for module variables. + ! Done at the end of a physics step at same point as the pbuf deallocate for + ! variables with "physpkg" scope. + + ! Local variables + character(len=*), parameter :: sub = 'diag_deallocate_moist' + integer :: i, istat + + if (dqcond_num > 0) then + do i = 1, dqcond_num + deallocate(dqcond(i)%cnst, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end do + deallocate(dqcond, stat=istat) + if ( istat /= 0 ) call endrun (sub//': ERROR: deallocate failed') + end if + end subroutine diag_deallocate_moist + + subroutine diag_deallocate() + + call diag_deallocate_dry() + if (moist_physics) then + call diag_deallocate_moist() + end if + + end subroutine diag_deallocate + +!=============================================================================== + + subroutine diag_conv_tend_ini(state,pbuf) + + ! Initialize convective tendency calcs. + + ! Arguments: + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables: + + integer :: i, k, m, lchnk, ncol + real(r8), pointer, dimension(:,:) :: t_ttend + + lchnk = state%lchnk + ncol = state%ncol + + do k = 1, pver + do i = 1, ncol + dtcond(i,k,lchnk) = state%t(i,k) + end do + end do + + do m = 1, dqcond_num + do k = 1, pver + do i = 1, ncol + dqcond(m)%cnst(i,k,lchnk) = state%q(i,k,m) + end do + end do + end do + + !! initialize to pbuf T_TTEND to temperature at first timestep + if (is_first_step()) then + do m = 1, dyn_time_lvls + call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,m/), kount=(/pcols,pver,1/)) + t_ttend(:ncol,:) = state%t(:ncol,:) + end do + end if + + end subroutine diag_conv_tend_ini + +!=============================================================================== + + subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) + + !----------------------------------------------------------------------- + ! + ! Purpose: output dry physics diagnostics + ! + !----------------------------------------------------------------------- + use physconst, only: gravit, rga, rair, cpair, latvap, rearth, pi, cappa + use time_manager, only: get_nstep + use interpolate_data, only: vertinterp + use constituent_burden, only: constituent_burden_comp + use co2_cycle, only: c_i, co2_transport + + use tidal_diag, only: tidal_diag_write + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + ! + !---------------------------Local workspace----------------------------- + ! + real(r8) :: ftem(pcols,pver) ! temporary workspace + real(r8) :: ftem1(pcols,pver) ! another temporary workspace + real(r8) :: ftem2(pcols,pver) ! another temporary workspace + real(r8) :: z3(pcols,pver) ! geo-potential height + real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface + real(r8) :: tem2(pcols,pver) ! temporary workspace + real(r8) :: timestep(pcols) ! used for outfld call + real(r8) :: esl(pcols,pver) ! saturation vapor pressures + real(r8) :: esi(pcols,pver) ! + real(r8) :: dlon(pcols) ! width of grid cell (meters) + + real(r8), pointer :: psl(:) ! Sea Level Pressure + + integer :: i, k, m, lchnk, ncol, nstep + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + ncol = state%ncol + + ! Output NSTEP for debugging + nstep = get_nstep() + timestep(:ncol) = nstep + call outfld ('NSTEP ',timestep, pcols, lchnk) + + call outfld('T ',state%t , pcols ,lchnk ) + call outfld('PS ',state%ps, pcols ,lchnk ) + call outfld('U ',state%u , pcols ,lchnk ) + call outfld('V ',state%v , pcols ,lchnk ) + + call outfld('PHIS ',state%phis, pcols, lchnk ) + +#if (defined BFB_CAM_SCAM_IOP ) + call outfld('phis ',state%phis, pcols, lchnk ) +#endif + + do m = 1, pcnst + if (cnst_cam_outfld(m)) then + call outfld(cnst_name(m), state%q(1,1,m), pcols, lchnk) + end if + end do + + ! + ! Add height of surface to midpoint height above surface + ! + do k = 1, pver + z3(:ncol,k) = state%zm(:ncol,k) + state%phis(:ncol)*rga + end do + call outfld('Z3 ',z3,pcols,lchnk) + ! + ! Output Z3 on pressure surfaces + ! + if (hist_fld_active('Z1000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z1000 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z700')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z700 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, z3, p_surf, & + extrapolate='Z', ln_interp=.true., ps=state%ps, phis=state%phis, tbot=state%t(:,pver)) + call outfld('Z500 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z300')) then + call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z300 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z200 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z100')) then + call vertinterp(ncol, pcols, pver, state%pmid, 10000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z100 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z050')) then + call vertinterp(ncol, pcols, pver, state%pmid, 5000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z050 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('Z010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, z3, p_surf, ln_interp=.true.) + call outfld('Z010 ', p_surf, pcols, lchnk) + end if + if (hist_fld_active('UA010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%u, p_surf, ln_interp=.true.) + call outfld('UA010 ', p_surf, pcols, lchnk) + end if + ! + ! Quadratic height fiels Z3*Z3 + ! + ftem(:ncol,:) = z3(:ncol,:)*z3(:ncol,:) + call outfld('ZZ ',ftem,pcols,lchnk) + + ftem(:ncol,:) = z3(:ncol,:)*state%v(:ncol,:) + call outfld('VZ ',ftem, pcols,lchnk) + ! + ! Meridional advection fields + ! + ftem(:ncol,:) = state%v(:ncol,:)*state%t(:ncol,:) + call outfld ('VT ',ftem ,pcols ,lchnk ) + + if (hist_fld_active('VT100')) then + call vertinterp(ncol, pcols, pver, state%pmid, 10000._r8, ftem, p_surf, ln_interp=.true.) + call outfld('VT100 ', p_surf, pcols, lchnk) + end if + + ftem(:ncol,:) = state%v(:ncol,:)**2 + call outfld ('VV ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%v(:ncol,:) * state%u(:ncol,:) + call outfld ('VU ',ftem ,pcols ,lchnk ) + ! + ! zonal advection + ! + ftem(:ncol,:) = state%u(:ncol,:)**2 + call outfld ('UU ',ftem ,pcols ,lchnk ) + + ! Wind speed + ftem(:ncol,:) = sqrt( state%u(:ncol,:)**2 + state%v(:ncol,:)**2) + call outfld ('WSPEED ',ftem ,pcols ,lchnk ) + call outfld ('WSPDSRFMX',ftem(:,pver) ,pcols ,lchnk ) + call outfld ('WSPDSRFAV',ftem(:,pver) ,pcols ,lchnk ) + + ! Vertical velocity and advection + + if (single_column) then + call outfld('OMEGA ',wfld, pcols, lchnk ) + else + call outfld('OMEGA ',state%omega, pcols, lchnk ) + endif + +#if (defined BFB_CAM_SCAM_IOP ) + call outfld('omega ',state%omega, pcols, lchnk ) +#endif + + ftem(:ncol,:) = state%omega(:ncol,:)*state%t(:ncol,:) + call outfld('OMEGAT ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%u(:ncol,:) + call outfld('OMEGAU ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%v(:ncol,:) + call outfld('OMEGAV ',ftem, pcols, lchnk ) + ftem(:ncol,:) = state%omega(:ncol,:)*state%omega(:ncol,:) + call outfld('OMGAOMGA',ftem, pcols, lchnk ) + ! + ! Output omega at 850 and 500 mb pressure levels + ! + if (hist_fld_active('OMEGA850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%omega, p_surf) + call outfld('OMEGA850', p_surf, pcols, lchnk) + end if + if (hist_fld_active('OMEGA500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%omega, p_surf) + call outfld('OMEGA500', p_surf, pcols, lchnk) + end if + + ! Sea level pressure + call pbuf_get_field(pbuf, psl_idx, psl) + call cpslec(ncol, state%pmid, state%phis, state%ps, state%t, psl, gravit, rair) + call outfld('PSL', psl, pcols, lchnk) + + ! Output T,u,v fields on pressure surfaces + ! + if (hist_fld_active('T850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T400')) then + call vertinterp(ncol, pcols, pver, state%pmid, 40000._r8, state%t, p_surf, & + extrapolate='T', ps=state%ps, phis=state%phis) + call outfld('T400 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T300')) then + call vertinterp(ncol, pcols, pver, state%pmid, 30000._r8, state%t, p_surf) + call outfld('T300 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('T200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%t, p_surf) + call outfld('T200 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%u, p_surf) + call outfld('U850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%u, p_surf) + call outfld('U500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U250')) then + call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%u, p_surf) + call outfld('U250 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%u, p_surf) + call outfld('U200 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('U010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%u, p_surf) + call outfld('U010 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%v, p_surf) + call outfld('V850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V500')) then + call vertinterp(ncol, pcols, pver, state%pmid, 50000._r8, state%v, p_surf) + call outfld('V500 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V250')) then + call vertinterp(ncol, pcols, pver, state%pmid, 25000._r8, state%v, p_surf) + call outfld('V250 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('V200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%v, p_surf) + call outfld('V200 ', p_surf, pcols, lchnk ) + end if + + ftem(:ncol,:) = state%t(:ncol,:)*state%t(:ncol,:) + call outfld('TT ',ftem ,pcols ,lchnk ) + ! + ! Output U, V, T, P and Z at bottom level + ! + call outfld ('UBOT ', state%u(1,pver) , pcols, lchnk) + call outfld ('VBOT ', state%v(1,pver) , pcols, lchnk) + call outfld ('ZBOT ', state%zm(1,pver) , pcols, lchnk) + + !! Boundary layer atmospheric stability, temperature, water vapor diagnostics + + p_surf_t = -99.0_r8 ! Uninitialized to impossible value + if (hist_fld_active('T1000') .or. & + hist_fld_active('T9251000') .or. & + hist_fld_active('TH9251000') .or. & + hist_fld_active('T8501000') .or. & + hist_fld_active('TH8501000') .or. & + hist_fld_active('T7001000') .or. & + hist_fld_active('TH7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:,surf_100000)) + end if + + if ( hist_fld_active('T925') .or. & + hist_fld_active('T9251000') .or. & + hist_fld_active('TH9251000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:,surf_092500)) + end if + +!!! at 1000 mb and 925 mb + if (hist_fld_active('T1000')) then + call outfld('T1000 ', p_surf_t(:,surf_100000), pcols, lchnk ) + end if + + if (hist_fld_active('T925')) then + call outfld('T925 ', p_surf_t(:,surf_092500), pcols, lchnk ) + end if + + if (hist_fld_active('T9251000')) then + p_surf = p_surf_t(:,surf_092500) - p_surf_t(:,surf_100000) + call outfld('T9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH9251000')) then + p_surf = (p_surf_t(:,surf_092500)*(1000.0_r8/925.0_r8)**cappa) - (p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T8501000') .or. & + hist_fld_active('TH8501000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:,surf_085000)) + end if + +!!! at 1000 mb and 850 mb + if (hist_fld_active('T8501000')) then + p_surf = p_surf_t(:,surf_085000)-p_surf_t(:,surf_100000) + call outfld('T8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH8501000')) then + p_surf = (p_surf_t(:,surf_085000)*(1000.0_r8/850.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T7001000') .or. & + hist_fld_active('TH7001000') .or. & + hist_fld_active('T700')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:,surf_070000)) + end if + +!!! at 700 mb + if (hist_fld_active('T700')) then + call outfld('T700 ', p_surf_t(:,surf_070000), pcols, lchnk ) + end if + +!!! at 1000 mb and 700 mb + if (hist_fld_active('T7001000')) then + p_surf = p_surf_t(:,surf_070000)-p_surf_t(:,surf_100000) + call outfld('T7001000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('TH7001000')) then + p_surf = (p_surf_t(:,surf_070000)*(1000.0_r8/700.0_r8)**cappa)-(p_surf_t(:,surf_100000)*(1.0_r8)**cappa) + call outfld('TH7001000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('T010')) then + call vertinterp(ncol, pcols, pver, state%pmid, 1000._r8, state%t, p_surf) + call outfld('T010 ', p_surf, pcols, lchnk ) + end if + + !--------------------------------------------------------- + ! tidal diagnostics + !--------------------------------------------------------- + call tidal_diag_write(state) + + return + end subroutine diag_phys_writeout_dry + +!=============================================================================== + + subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) + + !----------------------------------------------------------------------- + ! + ! Purpose: record dynamics variables on physics grid + ! + !----------------------------------------------------------------------- + use physconst, only: gravit, rga, rair, cpair, latvap, rearth, pi, cappa, & + epsilo, rh2o + use interpolate_data, only: vertinterp + use constituent_burden, only: constituent_burden_comp + use co2_cycle, only: c_i, co2_transport + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(inout) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + ! + !---------------------------Local workspace----------------------------- + ! + real(r8) :: ftem(pcols,pver) ! temporary workspace + real(r8) :: ftem1(pcols,pver) ! another temporary workspace + real(r8) :: ftem2(pcols,pver) ! another temporary workspace + real(r8) :: z3(pcols,pver) ! geo-potential height + real(r8) :: p_surf(pcols) ! data interpolated to a pressure surface + real(r8) :: p_surf_q1(pcols) ! data interpolated to a pressure surface + real(r8) :: p_surf_q2(pcols) ! data interpolated to a pressure surface + real(r8) :: tem2(pcols,pver) ! temporary workspace + real(r8) :: esl(pcols,pver) ! saturation vapor pressures + real(r8) :: esi(pcols,pver) ! + + real(r8), pointer :: ftem_ptr(:,:) + + integer :: i, k, m, lchnk, ncol + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + ncol = state%ncol + do m=1,pcnst + if ( cnst_cam_outfld(m) ) then + call outfld(cnst_name(m),state%q(1,1,m),pcols ,lchnk ) + end if + end do + + if (co2_transport()) then + do m = 1,4 + call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(1,pver,c_i(m)), pcols, lchnk) + end do + end if + + ! column burdens of all constituents except water vapor + call constituent_burden_comp(state) + + call outfld('PSDRY', state%psdry, pcols, lchnk) + call outfld('PMID', state%pmid, pcols, lchnk) + call outfld('PDELDRY', state%pdeldry, pcols, lchnk) + + ! + ! Meridional advection fields + ! + ftem(:ncol,:) = state%v(:ncol,:)*state%q(:ncol,:,1) + call outfld ('VQ ',ftem ,pcols ,lchnk ) + + ftem(:ncol,:) = state%q(:ncol,:,1)*state%q(:ncol,:,1) + call outfld ('QQ ',ftem ,pcols ,lchnk ) + + ! Vertical velocity and advection + ftem(:ncol,:) = state%omega(:ncol,:)*state%q(:ncol,:,1) + call outfld('OMEGAQ ',ftem, pcols, lchnk ) + ! + ! Mass of q, by layer and vertically integrated + ! + ftem(:ncol,:) = state%q(:ncol,:,1) * state%pdel(:ncol,:) * rga + call outfld ('MQ ',ftem ,pcols ,lchnk ) + + do k=2,pver + ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) + end do + call outfld ('TMQ ',ftem, pcols ,lchnk ) + + ! Relative humidity + if (hist_fld_active('RELHUM')) then + if (relhum_idx > 0) then + call pbuf_get_field(pbuf, relhum_idx, ftem_ptr) + ftem(:ncol,:) = ftem_ptr(:ncol,:) + else + call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & + tem2(:ncol,:), ftem(:ncol,:)) + ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + end if + call outfld ('RELHUM ',ftem ,pcols ,lchnk ) + end if + +#ifdef AEROCOM + ! We want RHW output always when AEROCOM is on (not only if added to a namelist) + ! RH w.r.t liquid (water) + call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & + esl(:ncol,:), ftem(:ncol,:)) + ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + call outfld ('RHW ',ftem ,pcols ,lchnk ) +#endif + + if (hist_fld_active('RHW') .or. hist_fld_active('RHI') .or. hist_fld_active('RHCFMIP') ) then + +#ifndef AEROCOM + ! RH w.r.t liquid (water) + call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & + esl(:ncol,:), ftem(:ncol,:)) + ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + call outfld ('RHW ',ftem ,pcols ,lchnk ) +#endif AEROCOM + + ! Convert to RHI (ice) + do i=1,ncol + do k=1,pver + esi(i,k)=svp_ice(state%t(i,k)) + ftem1(i,k)=ftem(i,k)*esl(i,k)/esi(i,k) + end do + end do + call outfld ('RHI ',ftem1 ,pcols ,lchnk ) + + ! use temperature to decide if you populate with ftem (liquid, above 0 C) or ftem1 (ice, below 0 C) + + ftem2(:ncol,:)=ftem(:ncol,:) + + do i=1,ncol + do k=1,pver + if (state%t(i,k) .gt. 273) then + ftem2(i,k)=ftem(i,k) !!wrt water + else + ftem2(i,k)=ftem1(i,k) !!wrt ice + end if + end do + end do + + call outfld ('RHCFMIP ',ftem2 ,pcols ,lchnk ) + + end if + ! + ! Output q field on pressure surfaces + ! + if (hist_fld_active('Q850')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,1), p_surf) + call outfld('Q850 ', p_surf, pcols, lchnk ) + end if + if (hist_fld_active('Q200')) then + call vertinterp(ncol, pcols, pver, state%pmid, 20000._r8, state%q(1,1,1), p_surf) + call outfld('Q200 ', p_surf, pcols, lchnk ) + end if + ! + ! Output Q at bottom level + ! + call outfld ('QBOT ', state%q(1,pver,1), pcols, lchnk) + + ! Total energy of the atmospheric column for atmospheric heat storage calculations + + !! temporary variable to get surface geopotential in dimensions of (ncol,pver) + do k=1,pver + ftem1(:ncol,k)=state%phis(:ncol) !! surface geopotential in units (m2/s2) + end do + + !! calculate sum of sensible, kinetic, latent, and surface geopotential energy + !! E=CpT+PHIS+Lv*q+(0.5)*(u^2+v^2) + ftem(:ncol,:) = (cpair*state%t(:ncol,:) + ftem1(:ncol,:) + latvap*state%q(:ncol,:,1) + & + 0.5_r8*(state%u(:ncol,:)**2+state%v(:ncol,:)**2))*(state%pdel(:ncol,:)/gravit) + !! vertically integrate + do k=2,pver + ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) + end do + call outfld ('ATMEINT ',ftem(:ncol,1) ,pcols ,lchnk ) + + !! Boundary layer atmospheric stability, temperature, water vapor diagnostics + + if ( hist_fld_active('THE9251000') .or. & + hist_fld_active('THE8501000') .or. & + hist_fld_active('THE7001000')) then + if (p_surf_t(1, surf_100000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%t, p_surf_t(:, surf_100000)) + end if + end if + + if ( hist_fld_active('TH9251000') .or. & + hist_fld_active('THE9251000')) then + if (p_surf_t(1, surf_092500) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%t, p_surf_t(:, surf_092500)) + end if + end if + + if ( hist_fld_active('Q1000') .or. & + hist_fld_active('THE9251000') .or. & + hist_fld_active('THE8501000') .or. & + hist_fld_active('THE7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%q(1,1,1), p_surf_q1) + end if + + if (hist_fld_active('THE9251000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%q(1,1,1), p_surf_q2) + end if + +!!! at 1000 mb and 925 mb + if (hist_fld_active('Q1000')) then + call outfld('Q1000 ', p_surf_q1, pcols, lchnk ) + end if + + if (hist_fld_active('Q925')) then + call outfld('Q925 ', p_surf_q2, pcols, lchnk ) + end if + + if (hist_fld_active('THE9251000')) then + p_surf = ((p_surf_t(:, surf_092500)*(1000.0_r8/925.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_092500)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE9251000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('THE8501000')) then + if (p_surf_t(1, surf_085000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%t, p_surf_t(:, surf_085000)) + end if + end if + +!!! at 1000 mb and 850 mb + if (hist_fld_active('THE8501000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,1), p_surf_q2) + p_surf = ((p_surf_t(:, surf_085000)*(1000.0_r8/850.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_085000)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE8501000 ', p_surf, pcols, lchnk ) + end if + + if (hist_fld_active('THE7001000')) then + if (p_surf_t(1, surf_070000) < 0.0_r8) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%t, p_surf_t(:, surf_070000)) + end if + end if + +!!! at 1000 mb and 700 mb + if (hist_fld_active('THE7001000')) then + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%q(1,1,1), p_surf_q2) + p_surf = ((p_surf_t(:, surf_070000)*(1000.0_r8/700.0_r8)**cappa) * & + exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_070000)))) - & + (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) + call outfld('THE7001000 ', p_surf, pcols, lchnk ) + end if + + return + end subroutine diag_phys_writeout_moist + +!=============================================================================== + + subroutine diag_phys_writeout(state, pbuf) + + !----------------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! + ! Local variable + ! + real(r8) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface + + call diag_phys_writeout_dry(state, pbuf, p_surf_t) + + if (moist_physics) then + call diag_phys_writeout_moist(state, pbuf, p_surf_t) + end if + + end subroutine diag_phys_writeout + +!=============================================================================== + + subroutine diag_conv(state, ztodt, pbuf) + + !----------------------------------------------------------------------- + ! + ! Output diagnostics associated with all convective processes. + ! + !----------------------------------------------------------------------- + use physconst, only: cpair + use tidal_diag, only: get_tidal_coeffs + + ! Arguments: + + real(r8), intent(in) :: ztodt ! timestep for computing physics tendencies + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! convective precipitation variables + real(r8), pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8), pointer :: snow_dp(:) ! snow from ZM convection + real(r8), pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8), pointer :: snow_sh(:) ! snow from Hack convection + real(r8), pointer :: prec_sed(:) ! total precipitation from ZM convection + real(r8), pointer :: snow_sed(:) ! snow from ZM convection + real(r8), pointer :: prec_pcw(:) ! total precipitation from Hack convection + real(r8), pointer :: snow_pcw(:) ! snow from Hack convection + + ! Local variables: + + integer :: i, k, m, lchnk, ncol + + real(r8) :: rtdt + + real(r8):: precc(pcols) ! convective precip rate + real(r8):: precl(pcols) ! stratiform precip rate + real(r8):: snowc(pcols) ! convective snow rate + real(r8):: snowl(pcols) ! stratiform snow rate + real(r8):: prect(pcols) ! total (conv+large scale) precip rate + real(r8) :: dcoef(6) ! for tidal component of T tend + + lchnk = state%lchnk + ncol = state%ncol + + rtdt = 1._r8/ztodt + + if (moist_physics) then + if (prec_dp_idx > 0) then + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp) + else + nullify(prec_dp) + end if + if (snow_dp_idx > 0) then + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp) + else + nullify(snow_dp) + end if + if (prec_sh_idx > 0) then + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh) + else + nullify(prec_sh) + end if + if (snow_sh_idx > 0) then + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh) + else + nullify(snow_sh) + end if + if (prec_sed_idx > 0) then + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed) + else + nullify(prec_sed) + end if + if (snow_sed_idx > 0) then + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed) + else + nullify(snow_sed) + end if + if (prec_pcw_idx > 0) then + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw) + else + nullify(prec_pcw) + end if + if (snow_pcw_idx > 0) then + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw) + else + nullify(snow_pcw) + end if + + ! Precipitation rates (multi-process) + if (associated(prec_dp) .and. associated(prec_sh)) then + precc(:ncol) = prec_dp(:ncol) + prec_sh(:ncol) + else if (associated(prec_dp)) then + precc(:ncol) = prec_dp(:ncol) + else if (associated(prec_sh)) then + precc(:ncol) = prec_sh(:ncol) + else + precc(:ncol) = 0._r8 + end if + if (associated(prec_sed) .and. associated(prec_pcw)) then + precl(:ncol) = prec_sed(:ncol) + prec_pcw(:ncol) + else if (associated(prec_sed)) then + precl(:ncol) = prec_sed(:ncol) + else if (associated(prec_pcw)) then + precl(:ncol) = prec_pcw(:ncol) + else + precl(:ncol) = 0._r8 + end if + if (associated(snow_dp) .and. associated(snow_sh)) then + snowc(:ncol) = snow_dp(:ncol) + snow_sh(:ncol) + else if (associated(snow_dp)) then + snowc(:ncol) = snow_dp(:ncol) + else if (associated(snow_sh)) then + snowc(:ncol) = snow_sh(:ncol) + else + snowc(:ncol) = 0._r8 + end if + if (associated(snow_sed) .and. associated(snow_pcw)) then + snowl(:ncol) = snow_sed(:ncol) + snow_pcw(:ncol) + else if (associated(snow_sed)) then + snowl(:ncol) = snow_sed(:ncol) + else if (associated(snow_pcw)) then + snowl(:ncol) = snow_pcw(:ncol) + else + snowl(:ncol) = 0._r8 + end if + prect(:ncol) = precc(:ncol) + precl(:ncol) + + call outfld('PRECC ', precc, pcols, lchnk ) + call outfld('PRECL ', precl, pcols, lchnk ) + if (associated(prec_pcw)) then + call outfld('PREC_PCW', prec_pcw,pcols ,lchnk ) + end if + if (associated(prec_dp)) then + call outfld('PREC_zmc', prec_dp ,pcols ,lchnk ) + end if + call outfld('PRECSC ', snowc, pcols, lchnk ) + call outfld('PRECSL ', snowl, pcols, lchnk ) + call outfld('PRECT ', prect, pcols, lchnk ) + call outfld('PRECTMX ', prect, pcols, lchnk ) + + call outfld('PRECLav ', precl, pcols, lchnk ) + call outfld('PRECCav ', precc, pcols, lchnk ) + +#if ( defined BFB_CAM_SCAM_IOP ) + call outfld('Prec ' , prect, pcols, lchnk ) +#endif + + ! Total convection tendencies. + + do k = 1, pver + do i = 1, ncol + dtcond(i,k,lchnk) = (state%t(i,k) - dtcond(i,k,lchnk))*rtdt + end do + end do + call outfld('DTCOND ', dtcond(:,:,lchnk), pcols, lchnk) + + ! output tidal coefficients + call get_tidal_coeffs( dcoef ) + call outfld( 'DTCOND_24_SIN', dtcond(:ncol,:,lchnk)*dcoef(1), ncol, lchnk ) + call outfld( 'DTCOND_24_COS', dtcond(:ncol,:,lchnk)*dcoef(2), ncol, lchnk ) + call outfld( 'DTCOND_12_SIN', dtcond(:ncol,:,lchnk)*dcoef(3), ncol, lchnk ) + call outfld( 'DTCOND_12_COS', dtcond(:ncol,:,lchnk)*dcoef(4), ncol, lchnk ) + call outfld( 'DTCOND_08_SIN', dtcond(:ncol,:,lchnk)*dcoef(5), ncol, lchnk ) + call outfld( 'DTCOND_08_COS', dtcond(:ncol,:,lchnk)*dcoef(6), ncol, lchnk ) + + do m = 1, dqcond_num + if ( cnst_cam_outfld(m) ) then + do k = 1, pver + do i = 1, ncol + dqcond(m)%cnst(i,k,lchnk) = (state%q(i,k,m) - dqcond(m)%cnst(i,k,lchnk))*rtdt + end do + end do + call outfld(dcconnam(m), dqcond(m)%cnst(:,:,lchnk), pcols, lchnk) + end if + end do + + end if + end subroutine diag_conv + +!=============================================================================== + + subroutine diag_surf (cam_in, cam_out, state, pbuf) + + !----------------------------------------------------------------------- + ! + ! Purpose: record surface diagnostics + ! + !----------------------------------------------------------------------- + + use time_manager, only: is_end_curr_day + use co2_cycle, only: c_i, co2_transport + use constituents, only: sflxnam + + !----------------------------------------------------------------------- + ! + ! Input arguments + ! + type(cam_in_t), intent(in) :: cam_in + type(cam_out_t), intent(in) :: cam_out + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + ! + !---------------------------Local workspace----------------------------- + ! + integer :: i, k, m ! indexes + integer :: lchnk ! chunk identifier + integer :: ncol ! longitude dimension + real(r8) tem2(pcols) ! temporary workspace + real(r8) ftem(pcols) ! temporary workspace + + real(r8), pointer :: trefmnav(:) ! daily minimum tref + real(r8), pointer :: trefmxav(:) ! daily maximum tref + + ! + !----------------------------------------------------------------------- + ! + lchnk = cam_in%lchnk + ncol = cam_in%ncol + + if (moist_physics) then + call outfld('SHFLX', cam_in%shf, pcols, lchnk) + call outfld('LHFLX', cam_in%lhf, pcols, lchnk) + call outfld('QFLX', cam_in%cflx(1,1), pcols, lchnk) + + call outfld('TAUX', cam_in%wsx, pcols, lchnk) + call outfld('TAUY', cam_in%wsy, pcols, lchnk) + call outfld('TREFHT ', cam_in%tref, pcols, lchnk) + call outfld('TREFHTMX', cam_in%tref, pcols, lchnk) + call outfld('TREFHTMN', cam_in%tref, pcols, lchnk) + call outfld('QREFHT', cam_in%qref, pcols, lchnk) + call outfld('U10', cam_in%u10, pcols, lchnk) + ! + ! Calculate and output reference height RH (RHREFHT) + + call qsat(cam_in%tref(:ncol), state%ps(:ncol), tem2(:ncol), ftem(:ncol)) + ftem(:ncol) = cam_in%qref(:ncol)/ftem(:ncol)*100._r8 + + + call outfld('RHREFHT', ftem, pcols, lchnk) + + +#if (defined BFB_CAM_SCAM_IOP ) + call outfld('shflx ',cam_in%shf, pcols, lchnk) + call outfld('lhflx ',cam_in%lhf, pcols, lchnk) + call outfld('trefht ',cam_in%tref, pcols, lchnk) +#endif + ! + ! Ouput ocn and ice fractions + ! + call outfld('LANDFRAC', cam_in%landfrac, pcols, lchnk) + call outfld('ICEFRAC', cam_in%icefrac, pcols, lchnk) + call outfld('OCNFRAC', cam_in%ocnfrac, pcols, lchnk) + ! + ! Compute daily minimum and maximum of TREF + ! + call pbuf_get_field(pbuf, trefmxav_idx, trefmxav) + call pbuf_get_field(pbuf, trefmnav_idx, trefmnav) + do i = 1,ncol + trefmxav(i) = max(cam_in%tref(i),trefmxav(i)) + trefmnav(i) = min(cam_in%tref(i),trefmnav(i)) + end do + if (is_end_curr_day()) then + call outfld('TREFMXAV', trefmxav,pcols, lchnk ) + call outfld('TREFMNAV', trefmnav,pcols, lchnk ) + trefmxav(:ncol) = -1.0e36_r8 + trefmnav(:ncol) = 1.0e36_r8 + endif + + call outfld('TBOT', cam_out%tbot, pcols, lchnk) + call outfld('TS', cam_in%ts, pcols, lchnk) + call outfld('TSMN', cam_in%ts, pcols, lchnk) + call outfld('TSMX', cam_in%ts, pcols, lchnk) + call outfld('SNOWHLND', cam_in%snowhland, pcols, lchnk) + call outfld('SNOWHICE', cam_in%snowhice, pcols, lchnk) + call outfld('ASDIR', cam_in%asdir, pcols, lchnk) + call outfld('ASDIF', cam_in%asdif, pcols, lchnk) + call outfld('ALDIR', cam_in%aldir, pcols, lchnk) + call outfld('ALDIF', cam_in%aldif, pcols, lchnk) + call outfld('SST', cam_in%sst, pcols, lchnk) + + if (co2_transport()) then + do m = 1,4 + call outfld(sflxnam(c_i(m)), cam_in%cflx(:,c_i(m)), pcols, lchnk) + end do + end if + end if + + end subroutine diag_surf + +!=============================================================================== + + subroutine diag_export(cam_out) + + !----------------------------------------------------------------------- + ! + ! Purpose: Write export state to history file + ! + !----------------------------------------------------------------------- + + ! arguments + type(cam_out_t), intent(inout) :: cam_out + + ! Local variables: + integer :: lchnk ! chunk identifier + logical :: atm_dep_flux ! true ==> sending deposition fluxes to coupler. + ! Otherwise, set them to zero. + !----------------------------------------------------------------------- + + lchnk = cam_out%lchnk + + call phys_getopts(atm_dep_flux_out=atm_dep_flux) + + if (.not. atm_dep_flux) then + ! set the fluxes to zero before outfld and sending them to the + ! coupler + cam_out%bcphiwet = 0.0_r8 + cam_out%bcphidry = 0.0_r8 + cam_out%bcphodry = 0.0_r8 + cam_out%ocphiwet = 0.0_r8 + cam_out%ocphidry = 0.0_r8 + cam_out%ocphodry = 0.0_r8 + cam_out%dstwet1 = 0.0_r8 + cam_out%dstdry1 = 0.0_r8 + cam_out%dstwet2 = 0.0_r8 + cam_out%dstdry2 = 0.0_r8 + cam_out%dstwet3 = 0.0_r8 + cam_out%dstdry3 = 0.0_r8 + cam_out%dstwet4 = 0.0_r8 + cam_out%dstdry4 = 0.0_r8 + end if + + if (moist_physics) then + call outfld('a2x_BCPHIWET', cam_out%bcphiwet, pcols, lchnk) + call outfld('a2x_BCPHIDRY', cam_out%bcphidry, pcols, lchnk) + call outfld('a2x_BCPHODRY', cam_out%bcphodry, pcols, lchnk) + call outfld('a2x_OCPHIWET', cam_out%ocphiwet, pcols, lchnk) + call outfld('a2x_OCPHIDRY', cam_out%ocphidry, pcols, lchnk) + call outfld('a2x_OCPHODRY', cam_out%ocphodry, pcols, lchnk) + call outfld('a2x_DSTWET1', cam_out%dstwet1, pcols, lchnk) + call outfld('a2x_DSTDRY1', cam_out%dstdry1, pcols, lchnk) + call outfld('a2x_DSTWET2', cam_out%dstwet2, pcols, lchnk) + call outfld('a2x_DSTDRY2', cam_out%dstdry2, pcols, lchnk) + call outfld('a2x_DSTWET3', cam_out%dstwet3, pcols, lchnk) + call outfld('a2x_DSTDRY3', cam_out%dstdry3, pcols, lchnk) + call outfld('a2x_DSTWET4', cam_out%dstwet4, pcols, lchnk) + call outfld('a2x_DSTDRY4', cam_out%dstdry4, pcols, lchnk) + end if + + end subroutine diag_export + +!####################################################################### + + subroutine diag_physvar_ic (lchnk, pbuf, cam_out, cam_in) + ! + !--------------------------------------------- + ! + ! Purpose: record physics variables on IC file + ! + !--------------------------------------------- + ! + + ! + ! Arguments + ! + integer , intent(in) :: lchnk ! chunk identifier + type(physics_buffer_desc), pointer :: pbuf(:) + + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(inout) :: cam_in + ! + !---------------------------Local workspace----------------------------- + ! + integer :: k ! indices + integer :: itim_old ! indices + + real(r8), pointer, dimension(:,:) :: cwat_var + real(r8), pointer, dimension(:,:) :: conv_var_3d + real(r8), pointer, dimension(: ) :: conv_var_2d + real(r8), pointer :: tpert(:), pblh(:), qpert(:) + ! + !----------------------------------------------------------------------- + ! + if( write_inithist() .and. moist_physics ) then + + ! + ! Associate pointers with physics buffer fields + ! + itim_old = pbuf_old_tim_idx() + + if (qcwat_idx > 0) then + call pbuf_get_field(pbuf, qcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('QCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (tcwat_idx > 0) then + call pbuf_get_field(pbuf, tcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('TCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (lcwat_idx > 0) then + call pbuf_get_field(pbuf, lcwat_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('LCWAT&IC ',cwat_var, pcols,lchnk) + end if + + if (cld_idx > 0) then + call pbuf_get_field(pbuf, cld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('CLOUD&IC ',cwat_var, pcols,lchnk) + end if + + if (concld_idx > 0) then + call pbuf_get_field(pbuf, concld_idx, cwat_var, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call outfld('CONCLD&IC ',cwat_var, pcols,lchnk) + end if + + if (cush_idx > 0) then + call pbuf_get_field(pbuf, cush_idx, conv_var_2d ,(/1,itim_old/), (/pcols,1/)) + call outfld('CUSH&IC ',conv_var_2d, pcols,lchnk) + + end if + + if (tke_idx > 0) then + call pbuf_get_field(pbuf, tke_idx, conv_var_3d) + call outfld('TKE&IC ',conv_var_3d, pcols,lchnk) + end if + + if (kvm_idx > 0) then + call pbuf_get_field(pbuf, kvm_idx, conv_var_3d) + call outfld('KVM&IC ',conv_var_3d, pcols,lchnk) + end if + + if (kvh_idx > 0) then + call pbuf_get_field(pbuf, kvh_idx, conv_var_3d) + call outfld('KVH&IC ',conv_var_3d, pcols,lchnk) + end if + + if (qpert_idx > 0) then + call pbuf_get_field(pbuf, qpert_idx, qpert) + call outfld('QPERT&IC ', qpert, pcols, lchnk) + end if + + if (pblh_idx > 0) then + call pbuf_get_field(pbuf, pblh_idx, pblh) + call outfld('PBLH&IC ', pblh, pcols, lchnk) + end if + + if (tpert_idx > 0) then + call pbuf_get_field(pbuf, tpert_idx, tpert) + call outfld('TPERT&IC ', tpert, pcols, lchnk) + end if + + end if + + end subroutine diag_physvar_ic + + +!####################################################################### + + !subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht + + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for temperature + ! + !--------------------------------------------------------------- + + use check_energy, only: check_energy_get_integrals + use physconst, only: cpair + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + + real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) + real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns in chunk + real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables + real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: heat_glob ! tht: T-tend from fixer (FV only) + real(r8) :: tedif_glob !+tht energy flux from fixer (FV only) + ! CAM pointers to get variables from the physics buffer + real(r8), pointer, dimension(:,:) :: t_ttend + integer :: itim_old,m + + !----------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! Dump out post-physics state (FV only) + + call outfld('TAP', state%t, pcols, lchnk ) + call outfld('UAP', state%u, pcols, lchnk ) + call outfld('VAP', state%v, pcols, lchnk ) + + !tht: heat tendencies from dme_adjust + if (dycore_is('LR')) then + tmp_t(:ncol,:pver) = (state%t(:ncol,:pver) - tmp_t(:ncol,:pver))/ztodt ! T tendency + call outfld('PTTEND_DME', tmp_t, pcols, lchnk ) + if(present(dsema))call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy + if(present(eflx) )call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy + end if + + ! Total physics tendency for Temperature + ! (remove global fixer tendency from total for FV and SE dycores) + + if (dycore_is('LR') .or. dycore_is('SE')) then + call check_energy_get_integrals( heat_glob_out=heat_glob , tedif_glob_out=tedif_glob ) !+tht tedif + ftem2(:ncol) = heat_glob/cpair + call outfld('TFIX', ftem2, pcols, lchnk ) +!+tht + ftem2(:ncol) = tedif_glob/ztodt + call outfld('EBREAK', ftem2, pcols, lchnk ) +!-tht + ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair + else + ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) + end if + call outfld('PTTEND',ftem3, pcols, lchnk ) + + ! Total (physics+dynamics, everything!) tendency for Temperature + + !! get temperature stored in physics buffer + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, t_ttend_idx, t_ttend, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + !! calculate and outfld the total temperature tendency + ftem3(:ncol,:) = (state%t(:ncol,:) - t_ttend(:ncol,:))/ztodt + call outfld('TTEND_TOT', ftem3, pcols, lchnk) + + !! update physics buffer with this time-step's temperature + t_ttend(:ncol,:) = state%t(:ncol,:) + + end subroutine diag_phys_tend_writeout_dry + +!####################################################################### + + subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & + tmp_q, tmp_cldliq, tmp_cldice, tmp_cldnc, tmp_cldni & + ,qini, cldliqini, cldiceini , cldncini, cldniini ) + + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for moisture + ! + !--------------------------------------------------------------- + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8), intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics +!AL + real(r8) , intent(inout) :: tmp_cldnc(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(inout) :: tmp_cldni(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics + real(r8) , intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics +!AL + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns in chunk + real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: rtdt + integer :: ixcldice, ixcldliq! constituent indices for cloud liquid and ice water. +!AL + integer :: ixnumice, ixnumliq! constituent indices for cloud liquid and ice water. +!AL + + lchnk = state%lchnk + ncol = state%ncol + rtdt = 1._r8/ztodt + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) +!AL + call cnst_get_ind('NUMLIQ', ixnumliq) + call cnst_get_ind('NUMICE', ixnumice) +!AL + + if ( cnst_cam_outfld( 1) ) then + call outfld (apcnst( 1), state%q(1,1, 1), pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq)) then + call outfld (apcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if ( cnst_cam_outfld(ixcldice) ) then + call outfld (apcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + end if + end if + + ! Tendency for dry mass adjustment of q (FV only) + + if (dycore_is('LR')) then + tmp_q (:ncol,:pver) = (state%q(:ncol,:pver, 1) - tmp_q (:ncol,:pver))*rtdt + if (ixcldliq > 0) then + tmp_cldliq(:ncol,:pver) = (state%q(:ncol,:pver,ixcldliq) - tmp_cldliq(:ncol,:pver))*rtdt + else + tmp_cldliq(:ncol,:pver) = 0.0_r8 + end if + if (ixcldice > 0) then + tmp_cldice(:ncol,:pver) = (state%q(:ncol,:pver,ixcldice) - tmp_cldice(:ncol,:pver))*rtdt + else + tmp_cldice(:ncol,:pver) = 0.0_r8 + end if + if ( cnst_cam_outfld( 1) ) then + call outfld (dmetendnam( 1), tmp_q , pcols, lchnk) + end if + if (ixcldliq > 0) then + if ( cnst_cam_outfld(ixcldliq) ) then + call outfld (dmetendnam(ixcldliq), tmp_cldliq, pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if ( cnst_cam_outfld(ixcldice) ) then + call outfld (dmetendnam(ixcldice), tmp_cldice, pcols, lchnk) + end if + end if +!AL + tmp_cldnc(:ncol,:pver) = (state%q(:ncol,:pver,ixnumliq) - tmp_cldnc(:ncol,:pver))*rtdt + tmp_cldni(:ncol,:pver) = (state%q(:ncol,:pver,ixnumice) - tmp_cldni(:ncol,:pver))*rtdt + if ( cnst_cam_outfld(ixnumliq) ) call outfld (dmetendnam(ixnumliq), tmp_cldnc, pcols, lchnk) + if ( cnst_cam_outfld(ixnumice) ) call outfld (dmetendnam(ixnumice), tmp_cldni, pcols, lchnk) +!AL + end if + + ! Total physics tendency for moisture and other tracers + + if ( cnst_cam_outfld( 1) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver, 1) - qini (:ncol,:pver) )*rtdt + call outfld (ptendnam( 1), ftem3, pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldliq) - cldliqini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixcldliq), ftem3, pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if ( cnst_cam_outfld(ixcldice) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixcldice) - cldiceini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixcldice), ftem3, pcols, lchnk) + end if + end if +!AL + if ( cnst_cam_outfld(ixnumliq) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixnumliq) - cldncini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixnumliq), ftem3, pcols, lchnk) + end if + if ( cnst_cam_outfld(ixnumice) ) then + ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixnumice) - cldniini(:ncol,:pver) )*rtdt + call outfld (ptendnam(ixnumice), ftem3, pcols, lchnk) + end if + +!AL + + end subroutine diag_phys_tend_writeout_moist + +!####################################################################### + +!AL +! subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & +! tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) +!AL + subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt & + , tmp_q, tmp_t, tmp_cldliq, tmp_cldice, tmp_cldnc,tmp_cldni & + , qini, cldliqini, cldiceini,cldncini, cldniini, eflx, dsema) + !--------------------------------------------------------------- + ! + ! Purpose: Dump physics tendencies for moisture and temperature + ! + !--------------------------------------------------------------- + + ! Arguments + + type(physics_state), intent(in) :: state + + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8) , intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) + real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics +!AL + real(r8) , intent(inout) :: tmp_cldnc(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(inout) :: tmp_cldni(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics + real(r8) , intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics +!AL + real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + + !----------------------------------------------------------------------- + + !call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht + if (moist_physics) then + call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & + tmp_q, tmp_cldliq, tmp_cldice, tmp_cldnc, tmp_cldni & + ,qini, cldliqini, cldiceini , cldncini, cldniini) + end if + + end subroutine diag_phys_tend_writeout + +!####################################################################### + + subroutine diag_state_b4_phys_write_dry (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump dry state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + !---------------------------Local workspace----------------------------- + ! + integer :: lchnk ! chunk index + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + + call outfld('TBP', state%t, pcols, lchnk ) + + end subroutine diag_state_b4_phys_write_dry + + subroutine diag_state_b4_phys_write_moist (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump moist state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + !---------------------------Local workspace----------------------------- + ! + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk index + ! + !----------------------------------------------------------------------- + ! + lchnk = state%lchnk + + call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) + call cnst_get_ind('CLDICE', ixcldice, abort=.false.) + + if ( cnst_cam_outfld( 1) ) then + call outfld (bpcnst( 1), state%q(1,1, 1), pcols, lchnk) + end if + if (ixcldliq > 0) then + if (cnst_cam_outfld(ixcldliq)) then + call outfld (bpcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + end if + end if + if (ixcldice > 0) then + if (cnst_cam_outfld(ixcldice)) then + call outfld (bpcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + end if + end if + + end subroutine diag_state_b4_phys_write_moist + + subroutine diag_state_b4_phys_write (state) + ! + !--------------------------------------------------------------- + ! + ! Purpose: Dump state just prior to executing physics + ! + !--------------------------------------------------------------- + ! + ! Arguments + ! + type(physics_state), intent(in) :: state + ! + + call diag_state_b4_phys_write_dry(state) + if (moist_physics) then + call diag_state_b4_phys_write_moist(state) + end if + end subroutine diag_state_b4_phys_write + +end module cam_diagnostics diff --git a/src/NorESM/cldfrc2m.F90 b/src/NorESM/cldfrc2m.F90 new file mode 100644 index 0000000000..337ec40cd4 --- /dev/null +++ b/src/NorESM/cldfrc2m.F90 @@ -0,0 +1,1161 @@ +module cldfrc2m + +! cloud fraction calculations + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols +use physconst, only: rair +use wv_saturation, only: qsat_water, svp_water, svp_ice +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + +implicit none +private +save + +public :: & + cldfrc2m_readnl, & + cldfrc2m_init, & + astG_PDF_single, & + astG_PDF, & + astG_RHU_single, & + astG_RHU, & + aist_single, & + aist_vector, & + CAMstfrac, & + rhmini_const, & + rhmaxi_const, & + rhminis_const, & + rhmaxis_const + +! Namelist variables +real(r8) :: cldfrc2m_rhmini ! Minimum rh for ice cloud fraction > 0. +real(r8) :: cldfrc2m_rhmaxi +real(r8) :: cldfrc2m_rhminis ! Minimum rh for ice cloud fraction > 0 in the stratsophere. +real(r8) :: cldfrc2m_rhmaxis +logical :: cldfrc2m_do_subgrid_growth = .false. +! -------------------------- ! +! Parameters for Ice Stratus ! +! -------------------------- ! +real(r8), protected :: rhmini_const ! Minimum rh for ice cloud fraction > 0. +real(r8), protected :: rhmaxi_const +real(r8), protected :: rhminis_const ! Minimum rh for ice cloud fraction > 0. +real(r8), protected :: rhmaxis_const + +!real(r8), parameter :: qist_min = 1.e-7_r8 ! Minimum in-stratus ice IWC constraint [ kg/kg ] +real(r8), parameter :: qist_min = 4.e-6_r8 ! Minimum in-stratus ice IWC constraint [ kg/kg ] +real(r8), parameter :: qist_max = 2.5e-4_r8 ! Maximum in-stratus ice IWC constraint [ kg/kg ] + +! ----------------------------- ! +! Parameters for Liquid Stratus ! +! ----------------------------- ! + +logical, parameter :: CAMstfrac = .false. ! If .true. (.false.), + ! use Slingo (triangular PDF-based) liquid stratus fraction +logical, parameter :: freeze_dry = .false. ! If .true., use 'freeze dry' in liquid stratus fraction formula +real(r8) :: rhminl_const ! Critical RH for low-level liquid stratus clouds +real(r8) :: rhminl_adj_land_const ! rhminl adjustment for snowfree land +real(r8) :: rhminh_const ! Critical RH for high-level liquid stratus clouds +real(r8) :: premit ! Top height for mid-level liquid stratus fraction +real(r8) :: premib ! Bottom height for mid-level liquid stratus fraction +integer :: iceopt ! option for ice cloud closure + ! 1=wang & sassen 2=schiller (iciwc) + ! 3=wood & field, 4=Wilson (based on smith) + ! 5=modified slingo (ssat & empyt cloud) +real(r8) :: icecrit ! Critical RH for ice clouds in Wilson & Ballard closure + ! ( smaller = more ice clouds ) + +!================================================================================================ +contains +!================================================================================================ + +subroutine cldfrc2m_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, masterprocid, mpi_logical, mpi_real8 + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'cldfrc2m_readnl' + + namelist /cldfrc2m_nl/ cldfrc2m_rhmini, cldfrc2m_rhmaxi, cldfrc2m_rhminis, cldfrc2m_rhmaxis, cldfrc2m_do_subgrid_growth + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'cldfrc2m_nl', status=ierr) + if (ierr == 0) then + read(unitn, cldfrc2m_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + ! set local variables + rhmini_const = cldfrc2m_rhmini + rhmaxi_const = cldfrc2m_rhmaxi + rhminis_const = cldfrc2m_rhminis + rhmaxis_const = cldfrc2m_rhmaxis + + end if + + ! Broadcast namelist variables + call mpi_bcast(rhmini_const, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(rhmaxi_const, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(rhminis_const, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(rhmaxis_const, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(cldfrc2m_do_subgrid_growth, 1, mpi_logical,masterprocid, mpicom, ierr) + +end subroutine cldfrc2m_readnl + +!================================================================================================ + +subroutine cldfrc2m_init() + + use cloud_fraction, only: cldfrc_getparams + + call cldfrc_getparams(rhminl_out=rhminl_const, rhminl_adj_land_out=rhminl_adj_land_const, & + rhminh_out=rhminh_const, premit_out=premit, premib_out=premib, & + iceopt_out=iceopt, icecrit_out=icecrit) + + if( masterproc ) then + write(iulog,*) 'cldfrc2m parameters:' + write(iulog,*) ' rhminl = ', rhminl_const + write(iulog,*) ' rhminl_adj_land = ', rhminl_adj_land_const + write(iulog,*) ' rhminh = ', rhminh_const + write(iulog,*) ' premit = ', premit + write(iulog,*) ' premib = ', premib + write(iulog,*) ' iceopt = ', iceopt + write(iulog,*) ' icecrit = ', icecrit + write(iulog,*) ' rhmini = ', rhmini_const + write(iulog,*) ' rhmaxi = ', rhmaxi_const + write(iulog,*) ' rhminis = ', rhminis_const + write(iulog,*) ' rhmaxis = ', rhmaxis_const + write(iulog,*) ' do_subgrid_growth = ', cldfrc2m_do_subgrid_growth + end if + +end subroutine cldfrc2m_init + +!================================================================================================ + + +subroutine astG_PDF_single(U, p, qv, landfrac, snowh, a, Ga, orhmin, & + rhminl_in, rhminl_adj_land_in, rhminh_in ) + + ! --------------------------------------------------------- ! + ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! + ! analytical formulation of triangular PDF. ! + ! Here, 'dV' is the ratio of 'half-width of PDF / qs(p,T)', ! + ! so using constant 'dV' assume that width is proportional ! + ! to the saturation specific humidity. ! + ! dV ~ 0.1. ! + ! cldrh : RH of in-stratus( = 1 if no supersaturation) ! + ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! + ! G is discontinuous across U = 1. In fact, it does not ! + ! matter whether Ga = 1.e10 or 0 at a = 1: I derived that ! + ! they will produce the same results. ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: U ! Relative humidity + real(r8), intent(in) :: p ! Pressure [Pa] + real(r8), intent(in) :: qv ! Grid-mean water vapor specific humidity [kg/kg] + real(r8), intent(in) :: landfrac ! Land fraction + real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: a ! Stratus fraction + real(r8), intent(out) :: Ga ! dU/da + real(r8), optional, intent(out) :: orhmin ! Critical RH + + real(r8), optional, intent(in) :: rhminl_in ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in ! Critical relative humidity for high-level liquid stratus + + ! Local variables + integer :: i ! Loop indexes + real(r8) dV ! Width of triangular PDF + real(r8) cldrh ! RH of stratus cloud + real(r8) rhmin ! Critical RH + real(r8) rhwght + + real(r8) :: rhminl + real(r8) :: rhminl_adj_land + real(r8) :: rhminh + + ! Statement functions + logical land + land = nint(landfrac) == 1 + + ! ---------- ! + ! Parameters ! + ! ---------- ! + + cldrh = 1.0_r8 + + rhminl = rhminl_const + if (present(rhminl_in)) rhminl = rhminl_in + rhminl_adj_land = rhminl_adj_land_const + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in + rhminh = rhminh_const + if (present(rhminh_in)) rhminh = rhminh_in + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + if( p .ge. premib ) then + + if( land .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + if( freeze_dry ) then + a = a *max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + endif + + elseif( p .lt. premit ) then + + rhmin = rhminh + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + else + + rhwght = (premib-(max(p,premit)))/(premib-premit) + + ! if( land .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + endif + + if (present(orhmin)) orhmin = rhmin + +end subroutine astG_PDF_single + +!================================================================================================ + +subroutine astG_PDF(U_in, p_in, qv_in, landfrac_in, snowh_in, a_out, Ga_out, ncol, & + rhminl_in, rhminl_adj_land_in, rhminh_in ) + + ! --------------------------------------------------------- ! + ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! + ! analytical formulation of triangular PDF. ! + ! Here, 'dV' is the ratio of 'half-width of PDF / qs(p,T)', ! + ! so using constant 'dV' assume that width is proportional ! + ! to the saturation specific humidity. ! + ! dV ~ 0.1. ! + ! cldrh : RH of in-stratus( = 1 if no supersaturation) ! + ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! + ! G is discontinuous across U = 1. In fact, it does not ! + ! matter whether Ga = 1.e10 or 0 at a = 1: I derived that ! + ! they will produce the same results. ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: U_in(pcols) ! Relative humidity + real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] + real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor specific humidity [kg/kg] + real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction + real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: a_out(pcols) ! Stratus fraction + real(r8), intent(out) :: Ga_out(pcols) ! dU/da + integer, intent(in) :: ncol + + real(r8), optional, intent(in) :: rhminl_in(pcols) ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in(pcols) ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in(pcols) ! Critical relative humidity for high-level liquid stratus + + real(r8) :: rhminl ! Critical relative humidity for low-level liquid stratus + real(r8) :: rhminl_adj_land ! Adjustment drop of rhminl over the land + real(r8) :: rhminh ! Critical relative humidity for high-level liquid stratus + + real(r8) :: U ! Relative humidity + real(r8) :: p ! Pressure [Pa] + real(r8) :: qv ! Grid-mean water vapor specific humidity [kg/kg] + real(r8) :: landfrac ! Land fraction + real(r8) :: snowh ! Snow depth (liquid water equivalent) + + real(r8) :: a ! Stratus fraction + real(r8) :: Ga ! dU/da + + ! Local variables + integer :: i ! Loop indexes + real(r8) dV ! Width of triangular PDF + real(r8) cldrh ! RH of stratus cloud + real(r8) rhmin ! Critical RH + real(r8) rhwght + + ! Statement functions + logical land + land(i) = nint(landfrac_in(i)) == 1 + + ! ---------- ! + ! Parameters ! + ! ---------- ! + + cldrh = 1.0_r8 + + rhminl = rhminl_const + rhminl_adj_land = rhminl_adj_land_const + rhminh = rhminh_const + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + a_out(:) = 0._r8 + Ga_out(:) = 0._r8 + + do i = 1, ncol + + U = U_in(i) + p = p_in(i) + qv = qv_in(i) + landfrac = landfrac_in(i) + snowh = snowh_in(i) + + if (present(rhminl_in)) rhminl = rhminl_in(i) + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in(i) + if (present(rhminh_in)) rhminh = rhminh_in(i) + + if( p .ge. premib ) then + + if( land(i) .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + if( freeze_dry ) then + a = a *max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + endif + + elseif( p .lt. premit ) then + + rhmin = rhminh + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + else + + rhwght = (premib-(max(p,premit)))/(premib-premit) + + ! if( land(i) .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + + dV = cldrh - rhmin + + if( U .ge. 1._r8 ) then + a = 1._r8 + Ga = 1.e10_r8 + elseif( U .gt. (cldrh-dV/6._r8) .and. U .lt. 1._r8 ) then + a = 1._r8 - (-3._r8/sqrt(2._r8)*(U-cldrh)/dV)**(2._r8/3._r8) + Ga = dV/sqrt(2._r8)*sqrt(1._r8-a) + elseif( U .gt. (cldrh-dV) .and. U .le. (cldrh-dV/6._r8) ) then + a = 4._r8*(cos((1._r8/3._r8)*(acos((3._r8/2._r8/sqrt(2._r8))* & + (1._r8+(U-cldrh)/dV))-2._r8*3.141592_r8)))**2._r8 + Ga = dV/sqrt(2._r8)*(1._r8/sqrt(a)-sqrt(a)) + elseif( U .le. (cldrh-dV) ) then + a = 0._r8 + Ga = 1.e10_r8 + endif + + endif + + a_out(i) = a + Ga_out(i) = Ga + + enddo + +end subroutine astG_PDF +!================================================================================================ + +subroutine astG_RHU_single(U, p, qv, landfrac, snowh, a, Ga, orhmin, & + rhminl_in, rhminl_adj_land_in, rhminh_in ) + + ! --------------------------------------------------------- ! + ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! + ! CAM35 cloud fraction formula. ! + ! Below is valid only for CAMUW at 1.9x2.5 fv dynamics core ! + ! For the other cases, I should re-define 'rhminl,rhminh' & ! + ! 'premib,premit'. ! + ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! + ! G is discontinuous across U = 1. ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: U ! Relative humidity + real(r8), intent(in) :: p ! Pressure [Pa] + real(r8), intent(in) :: qv ! Grid-mean water vapor specific humidity [kg/kg] + real(r8), intent(in) :: landfrac ! Land fraction + real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: a ! Stratus fraction + real(r8), intent(out) :: Ga ! dU/da + real(r8), optional, intent(out) :: orhmin ! Critical RH + + real(r8), optional, intent(in) :: rhminl_in ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in ! Critical relative humidity for high-level liquid stratus + + ! Local variables + real(r8) rhmin ! Critical RH + real(r8) rhdif ! Factor for stratus fraction + real(r8) rhwght + + real(r8) :: rhminl + real(r8) :: rhminl_adj_land + real(r8) :: rhminh + + ! Statement functions + logical land + land = nint(landfrac) == 1 + + rhminl = rhminl_const + if (present(rhminl_in)) rhminl = rhminl_in + rhminl_adj_land = rhminl_adj_land_const + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in + rhminh = rhminh_const + if (present(rhminh_in)) rhminh = rhminh_in + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + if( p .ge. premib ) then + + if( land .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0.0_r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e20_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + if( freeze_dry ) then + a = a*max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + endif + + elseif( p .lt. premit ) then + + rhmin = rhminh + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0._r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e20_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + + else + + rhwght = (premib-(max(p,premit)))/(premib-premit) + + ! if( land .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0._r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e10_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + + endif + + if (present(orhmin)) orhmin = rhmin + +end subroutine astG_RHU_single + +!================================================================================================ + +subroutine astG_RHU(U_in, p_in, qv_in, landfrac_in, snowh_in, a_out, Ga_out, ncol, & + rhminl_in, rhminl_adj_land_in, rhminh_in ) + + ! --------------------------------------------------------- ! + ! Compute 'stratus fraction(a)' and Gs=(dU/da) from the ! + ! CAM35 cloud fraction formula. ! + ! Below is valid only for CAMUW at 1.9x2.5 fv dynamics core ! + ! For the other cases, I should re-define 'rhminl,rhminh' & ! + ! 'premib,premit'. ! + ! Note that if U > 1, Ga = 1.e10 instead of Ga = 0, that is ! + ! G is discontinuous across U = 1. ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: U_in(pcols) ! Relative humidity + real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] + real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor specific humidity [kg/kg] + real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction + real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: a_out(pcols) ! Stratus fraction + real(r8), intent(out) :: Ga_out(pcols) ! dU/da + integer, intent(in) :: ncol + + real(r8), optional, intent(in) :: rhminl_in(pcols) ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in(pcols) ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in(pcols) ! Critical relative humidity for high-level liquid stratus + + real(r8) :: U ! Relative humidity + real(r8) :: p ! Pressure [Pa] + real(r8) :: qv ! Grid-mean water vapor specific humidity [kg/kg] + real(r8) :: landfrac ! Land fraction + real(r8) :: snowh ! Snow depth (liquid water equivalent) + + real(r8) :: rhminl ! Critical relative humidity for low-level liquid stratus + real(r8) :: rhminl_adj_land ! Adjustment drop of rhminl over the land + real(r8) :: rhminh ! Critical relative humidity for high-level liquid stratus + + real(r8) :: a ! Stratus fraction + real(r8) :: Ga ! dU/da + + ! Local variables + integer i + real(r8) rhmin ! Critical RH + real(r8) rhdif ! Factor for stratus fraction + real(r8) rhwght + + ! Statement functions + logical land + land(i) = nint(landfrac_in(i)) == 1 + + rhminl = rhminl_const + rhminl_adj_land = rhminl_adj_land_const + rhminh = rhminh_const + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + a_out(:) = 0._r8 + Ga_out(:) = 0._r8 + + do i = 1, ncol + + U = U_in(i) + p = p_in(i) + qv = qv_in(i) + landfrac = landfrac_in(i) + snowh = snowh_in(i) + + if (present(rhminl_in)) rhminl = rhminl_in(i) + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in(i) + if (present(rhminh_in)) rhminh = rhminh_in(i) + + if( p .ge. premib ) then + + if( land(i) .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0.0_r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e20_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + if( freeze_dry ) then + a = a*max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + Ga = Ga/max(0.15_r8,min(1.0_r8,qv/0.0030_r8)) + endif + + elseif( p .lt. premit ) then + + rhmin = rhminh + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0._r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e20_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + + else + + rhwght = (premib-(max(p,premit)))/(premib-premit) + + ! if( land(i) .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + + rhdif = (U-rhmin)/(1.0_r8-rhmin) + a = min(1._r8,(max(rhdif,0._r8))**2) + if( (U.ge.1._r8) .or. (U.le.rhmin) ) then + Ga = 1.e10_r8 + else + Ga = 0.5_r8*(1._r8-rhmin)*((1._r8-rhmin)/(U-rhmin)) + endif + + endif + + a_out(i) = a + Ga_out(i) = Ga + + enddo + +end subroutine astG_RHU + +!================================================================================================ + +subroutine aist_single(qv, T, p, qi, landfrac, snowh, aist, & + rhmaxi_in, rhmini_in, rhminl_in, rhminl_adj_land_in, rhminh_in, & + qsatfac_out) + + ! --------------------------------------------------------- ! + ! Compute non-physical ice stratus fraction ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: qv ! Grid-mean water vapor[kg/kg] + real(r8), intent(in) :: T ! Temperature + real(r8), intent(in) :: p ! Pressure [Pa] + real(r8), intent(in) :: qi ! Grid-mean ice water content [kg/kg] + real(r8), intent(in) :: landfrac ! Land fraction + real(r8), intent(in) :: snowh ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: aist ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) + + real(r8), optional, intent(in) :: rhmaxi_in + real(r8), optional, intent(in) :: rhmini_in ! Critical relative humidity for ice stratus + real(r8), optional, intent(in) :: rhminl_in ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in ! Critical relative humidity for high-level liquid stratus + real(r8), optional, intent(out) :: qsatfac_out ! Subgrid scaling factor for qsat + + ! Local variables + real(r8) rhmin ! Critical RH + real(r8) rhwght + + real(r8) a,b,c,as,bs,cs ! Fit parameters + real(r8) Kc ! Constant for ice cloud calc (wood & field) + real(r8) ttmp ! Limited temperature + real(r8) icicval ! Empirical IWC value [ kg/kg ] + real(r8) rho ! Local air density + real(r8) esl ! Liq sat vapor pressure + real(r8) esi ! Ice sat vapor pressure + real(r8) ncf,phi ! Wilson and Ballard parameters + real(r8) es, qs + + real(r8) rhi ! grid box averaged relative humidity over ice + real(r8) minice ! minimum grid box avg ice for having a 'cloud' + real(r8) mincld ! minimum ice cloud fraction threshold + real(r8) icimr ! in cloud ice mixing ratio + real(r8) rhdif ! working variable for slingo scheme + + real(r8) :: rhmaxi + real(r8) :: rhmini + real(r8) :: rhminl + real(r8) :: rhminl_adj_land + real(r8) :: rhminh + + ! Statement functions + logical land + land = nint(landfrac) == 1 + + ! --------- ! + ! Constants ! + ! --------- ! + + ! Wang and Sassen IWC paramters ( Option.1 ) + a = 26.87_r8 + b = 0.569_r8 + c = 0.002892_r8 + ! Schiller parameters ( Option.2 ) + as = -68.4202_r8 + bs = 0.983917_r8 + cs = 2.81795_r8 + ! Wood and Field parameters ( Option.3 ) + Kc = 75._r8 + ! Wilson & Ballard closure ( Option.4. smaller = more ice clouds) + ! Slingo modified (option 5) + minice = 1.e-12_r8 + mincld = 1.e-4_r8 + + rhmaxi = rhmaxi_const + if (present(rhmaxi_in)) rhmaxi = rhmaxi_in + rhmini = rhmini_const + if (present(rhmini_in)) rhmini = rhmini_in + rhminl = rhminl_const + if (present(rhminl_in)) rhminl = rhminl_in + rhminl_adj_land = rhminl_adj_land_const + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in + rhminh = rhminh_const + if (present(rhminh_in)) rhminh = rhminh_in + if (present(qsatfac_out)) qsatfac_out = 1.0_r8 + + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + call qsat_water(T, p, es, qs) + esl = svp_water(T) + esi = svp_ice(T) + + if( iceopt.lt.3 ) then + if( iceopt.eq.1 ) then + ttmp = max(195._r8,min(T,253._r8)) - 273.16_r8 + icicval = a + b * ttmp + c * ttmp**2._r8 + rho = p/(rair*T) + icicval = icicval * 1.e-6_r8 / rho + else + ttmp = max(190._r8,min(T,273.16_r8)) + icicval = 10._r8 **(as * bs**ttmp + cs) + icicval = icicval * 1.e-6_r8 * 18._r8 / 28.97_r8 + endif + aist = max(0._r8,min(qi/icicval,1._r8)) + elseif( iceopt.eq.3 ) then + aist = 1._r8 - exp(-Kc*qi/(qs*(esi/esl))) + aist = max(0._r8,min(aist,1._r8)) + elseif( iceopt.eq.4) then + if( p .ge. premib ) then + if( land .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + elseif( p .lt. premit ) then + rhmin = rhminh + else + rhwght = (premib-(max(p,premit)))/(premib-premit) + ! if( land .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + endif + ncf = qi/((1._r8 - icecrit)*qs) + if( ncf.le.0._r8 ) then + aist = 0._r8 + elseif( ncf.gt.0._r8 .and. ncf.le.1._r8/6._r8 ) then + aist = 0.5_r8*(6._r8 * ncf)**(2._r8/3._r8) + elseif( ncf.gt.1._r8/6._r8 .and. ncf.lt.1._r8 ) then + phi = (acos(3._r8*(1._r8-ncf)/2._r8**(3._r8/2._r8))+4._r8*3.1415927_r8)/3._r8 + aist = (1._r8 - 4._r8 * cos(phi) * cos(phi)) + else + aist = 1._r8 + endif + aist = max(0._r8,min(aist,1._r8)) + elseif (iceopt.eq.5) then + ! set rh ice cloud fraction + rhi= (qv+qi)/qs * (esl/esi) + if (rhmaxi .eq. rhmini) then + if (rhi .gt. rhmini) then + rhdif = 1._r8 + else + rhdif = 0._r8 + end if + else + rhdif = (rhi-rhmini) / (rhmaxi - rhmini) + end if + aist = min(1.0_r8, max(rhdif,0._r8)**2) + + ! Similar to alpha in Wilson & Ballard (1999), determine a + ! scaling factor for saturation vapor pressure that reflects + ! the cloud fraction, rhmini, and rhmaxi. + ! + ! NOTE: Limit qsatfac so that adjusted RHliq would be 1. or less. + if (present(qsatfac_out) .and. cldfrc2m_do_subgrid_growth) then + qsatfac_out = max(min(qv / qs, 1._r8), (1._r8 - aist) * rhmini + aist * rhmaxi) + end if + + ! limiter to remove empty cloud and ice with no cloud + ! and set icecld fraction to mincld if ice exists + + if (qi.lt.minice) then + aist=0._r8 + else + aist=max(mincld,aist) + endif + + ! enforce limits on icimr + if (qi.ge.minice) then + icimr=qi/aist + + !minimum + if (icimr.lt.qist_min) then + !aist = max(0._r8,min(1._r8,qi/qist_min)) + aist = max(0._r8,min(1._r8,sqrt(aist*qi/qist_min))) + endif + !maximum + if (icimr.gt.qist_max) then + aist = max(0._r8,min(1._r8,qi/qist_max)) + endif + + endif + endif + + ! 0.999_r8 is added to prevent infinite 'ql_st' at the end of instratus_condensate + ! computed after updating 'qi_st'. + + aist = max(0._r8,min(aist,0.999_r8)) + +end subroutine aist_single + +!================================================================================================ + +subroutine aist_vector(qv_in, T_in, p_in, qi_in, ni_in, landfrac_in, snowh_in, aist_out, ncol, & + rhmaxi_in, rhmini_in, rhminl_in, rhminl_adj_land_in, rhminh_in, & + qsatfac_out ) + + ! --------------------------------------------------------- ! + ! Compute non-physical ice stratus fraction ! + ! --------------------------------------------------------- ! + + real(r8), intent(in) :: qv_in(pcols) ! Grid-mean water vapor[kg/kg] + real(r8), intent(in) :: T_in(pcols) ! Temperature + real(r8), intent(in) :: p_in(pcols) ! Pressure [Pa] + real(r8), intent(in) :: qi_in(pcols) ! Grid-mean ice water content [kg/kg] + real(r8), intent(in) :: ni_in(pcols) ! Grid-mean ice water number concentration [#/kg] + real(r8), intent(in) :: landfrac_in(pcols) ! Land fraction + real(r8), intent(in) :: snowh_in(pcols) ! Snow depth (liquid water equivalent) + + real(r8), intent(out) :: aist_out(pcols) ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) + integer, intent(in) :: ncol + + real(r8), optional, intent(in) :: rhmaxi_in(pcols) + real(r8), optional, intent(in) :: rhmini_in(pcols) ! Critical relative humidity for ice stratus + real(r8), optional, intent(in) :: rhminl_in(pcols) ! Critical relative humidity for low-level liquid stratus + real(r8), optional, intent(in) :: rhminl_adj_land_in(pcols) ! Adjustment drop of rhminl over the land + real(r8), optional, intent(in) :: rhminh_in(pcols) ! Critical relative humidity for high-level liquid stratus + real(r8), optional, intent(out) :: qsatfac_out(pcols) ! Subgrid scaling factor for qsat + + ! Local variables + + real(r8) qv ! Grid-mean water vapor[kg/kg] + real(r8) T ! Temperature + real(r8) p ! Pressure [Pa] + real(r8) qi ! Grid-mean ice water content [kg/kg] + real(r8) ni + real(r8) landfrac ! Land fraction + real(r8) snowh ! Snow depth (liquid water equivalent) + + real(r8) rhmaxi ! Critical relative humidity for ice stratus + real(r8) rhmini ! Critical relative humidity for ice stratus + real(r8) rhminl ! Critical relative humidity for low-level liquid stratus + real(r8) rhminl_adj_land ! Adjustment drop of rhminl over the land + real(r8) rhminh ! Critical relative humidity for high-level liquid stratus + + real(r8) aist ! Non-physical ice stratus fraction ( 0<= aist <= 1 ) + + real(r8) rhmin ! Critical RH + real(r8) rhwght + + real(r8) a,b,c,as,bs,cs,ah,bh,ch ! Fit parameters + real(r8) nil + real(r8) Kc ! Constant for ice cloud calc (wood & field) + real(r8) ttmp ! Limited temperature + real(r8) icicval ! Empirical IWC value [ kg/kg ] + real(r8) rho ! Local air density + real(r8) esl ! Liq sat vapor pressure + real(r8) esi ! Ice sat vapor pressure + real(r8) ncf,phi ! Wilson and Ballard parameters + real(r8) qs + real(r8) esat_in(pcols) + real(r8) qsat_in(pcols) + + real(r8) rhi ! grid box averaged relative humidity over ice + real(r8) minice ! minimum grid box avg ice for having a 'cloud' + real(r8) mincld ! minimum ice cloud fraction threshold + real(r8) icimr ! in cloud ice mixing ratio + real(r8) rhdif ! working variable for slingo scheme + + integer i + + + ! Statement functions + logical land + land(i) = nint(landfrac_in(i)) == 1 + + ! --------- ! + ! Constants ! + ! --------- ! + + ! Wang and Sassen IWC paramters ( Option.1 ) + a = 26.87_r8 + b = 0.569_r8 + c = 0.002892_r8 + ! Schiller parameters ( Option.2 ) + as = -68.4202_r8 + bs = 0.983917_r8 + cs = 2.81795_r8 + ! Wood and Field parameters ( Option.3 ) + Kc = 75._r8 + ! Wilson & Ballard closure ( Option.4. smaller = more ice clouds) + ! Slingo modified (option 5) + minice = 1.e-12_r8 + mincld = 1.e-4_r8 + + rhmaxi = rhmaxi_const + + rhmini = rhmini_const + rhminl = rhminl_const + rhminl_adj_land = rhminl_adj_land_const + rhminh = rhminh_const + + if (present(qsatfac_out)) qsatfac_out = 1.0_r8 + + ! ---------------- ! + ! Main computation ! + ! ---------------- ! + + aist_out(:) = 0._r8 + esat_in(:) = 0._r8 + qsat_in(:) = 0._r8 + + call qsat_water(T_in(1:ncol), p_in(1:ncol), & + esat_in(1:ncol), qsat_in(1:ncol)) + + do i = 1, ncol + + landfrac = landfrac_in(i) + snowh = snowh_in(i) + T = T_in(i) + qv = qv_in(i) + p = p_in(i) + qi = qi_in(i) + ni = ni_in(i) + qs = qsat_in(i) + esl = svp_water(T) + esi = svp_ice(T) + + if (present(rhmaxi_in)) rhmaxi = rhmaxi_in(i) + if (present(rhmini_in)) rhmini = rhmini_in(i) + if (present(rhminl_in)) rhminl = rhminl_in(i) + if (present(rhminl_adj_land_in)) rhminl_adj_land = rhminl_adj_land_in(i) + if (present(rhminh_in)) rhminh = rhminh_in(i) + + if( iceopt.lt.3 ) then + if( iceopt.eq.1 ) then + ttmp = max(195._r8,min(T,253._r8)) - 273.16_r8 + icicval = a + b * ttmp + c * ttmp**2._r8 + rho = p/(rair*T) + icicval = icicval * 1.e-6_r8 / rho + else + ttmp = max(190._r8,min(T,273.16_r8)) + icicval = 10._r8 **(as * bs**ttmp + cs) + icicval = icicval * 1.e-6_r8 * 18._r8 / 28.97_r8 + endif + aist = max(0._r8,min(qi/icicval,1._r8)) + elseif( iceopt.eq.3 ) then + aist = 1._r8 - exp(-Kc*qi/(qs*(esi/esl))) + aist = max(0._r8,min(aist,1._r8)) + elseif( iceopt.eq.4) then + if( p .ge. premib ) then + if( land(i) .and. (snowh.le.0.000001_r8) ) then + rhmin = rhminl - rhminl_adj_land + else + rhmin = rhminl + endif + elseif( p .lt. premit ) then + rhmin = rhminh + else + rhwght = (premib-(max(p,premit)))/(premib-premit) + ! if( land(i) .and. (snowh.le.0.000001_r8) ) then + ! rhmin = rhminh*rhwght + (rhminl - rhminl_adj_land)*(1.0_r8-rhwght) + ! else + rhmin = rhminh*rhwght + rhminl*(1.0_r8-rhwght) + ! endif + endif + ncf = qi/((1._r8 - icecrit)*qs) + if( ncf.le.0._r8 ) then + aist = 0._r8 + elseif( ncf.gt.0._r8 .and. ncf.le.1._r8/6._r8 ) then + aist = 0.5_r8*(6._r8 * ncf)**(2._r8/3._r8) + elseif( ncf.gt.1._r8/6._r8 .and. ncf.lt.1._r8 ) then + phi = (acos(3._r8*(1._r8-ncf)/2._r8**(3._r8/2._r8))+4._r8*3.1415927_r8)/3._r8 + aist = (1._r8 - 4._r8 * cos(phi) * cos(phi)) + else + aist = 1._r8 + endif + aist = max(0._r8,min(aist,1._r8)) + elseif (iceopt.eq.5) then + ! set rh ice cloud fraction + rhi= (qv+qi)/qs * (esl/esi) + if (rhmaxi .eq. rhmini) then + if (rhi .gt. rhmini) then + rhdif = 1._r8 + else + rhdif = 0._r8 + end if + else + rhdif = (rhi-rhmini) / (rhmaxi - rhmini) + end if + aist = min(1.0_r8, max(rhdif,0._r8)**2) + + elseif (iceopt.eq.6) then + !----- ICE CLOUD OPTION 6: fit based on T and Number (Gettelman: based on Heymsfield obs) + ! Use observations from Heymsfield et al 2012 of IWC and Ni v. Temp + ! Multivariate fit follows form of Boudala 2002: ICIWC = a * exp(b*T) * N^c + ! a=6.73e-8, b=0.05, c=0.349 + ! N is #/L, so need to convert Ni_L=N*rhoa/1000. + ah= 6.73834e-08_r8 + bh= 0.0533110_r8 + ch= 0.3493813_r8 + rho=p/(rair*T) + nil=ni*rho/1000._r8 + icicval = ah * exp(bh*T) * nil**ch + !result is in g m-3, convert to kg H2O / kg air (icimr...) + icicval = icicval / rho / 1000._r8 + aist = max(0._r8,min(qi/icicval,1._r8)) + aist = min(aist,1._r8) + + endif + + if (iceopt.eq.5 .or. iceopt.eq.6) then + + ! Similar to alpha in Wilson & Ballard (1999), determine a + ! scaling factor for saturation vapor pressure that reflects + ! the cloud fraction, rhmini, and rhmaxi. + ! + ! NOTE: Limit qsatfac so that adjusted RHliq would be 1. or less. + if (present(qsatfac_out) .and. cldfrc2m_do_subgrid_growth) then + qsatfac_out(i) = max(min(qv / qs, 1._r8), (1._r8 - aist) * rhmini + aist * rhmaxi) + end if + + ! limiter to remove empty cloud and ice with no cloud + ! and set icecld fraction to mincld if ice exists + + if (qi.lt.minice) then + aist=0._r8 + else + aist=max(mincld,aist) + endif + + ! enforce limits on icimr + if (qi.ge.minice) then + icimr=qi/aist + + !minimum + if (icimr.lt.qist_min) then + !aist = max(0._r8,min(1._r8,qi/qist_min)) + aist = max(0._r8,min(1._r8,sqrt(aist*qi/qist_min))) + endif + !maximum + if (icimr.gt.qist_max) then + aist = max(0._r8,min(1._r8,qi/qist_max)) + endif + + endif + endif + + ! 0.999_r8 is added to prevent infinite 'ql_st' at the end of instratus_condensate + ! computed after updating 'qi_st'. + + aist = max(0._r8,min(aist,0.999_r8)) + + aist_out(i) = aist + + enddo + +end subroutine aist_vector + +!================================================================================================ + +end module cldfrc2m diff --git a/src/NorESM/ctem.F90 b/src/NorESM/ctem.F90 new file mode 100644 index 0000000000..d63729c755 --- /dev/null +++ b/src/NorESM/ctem.F90 @@ -0,0 +1,616 @@ +!----------------------------------------------------------------------------- +! circulation diagnostics -- terms of the Transformed Eulerian Mean (TEM) equation +!----------------------------------------------------------------------------- +module ctem + + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use pmgrid, only: plon, plev, plevp + use cam_logfile, only: iulog + use cam_history, only: addfld, outfld, add_default, horiz_only + use cam_abortutils, only: endrun + + implicit none + private + + public :: ctem_readnl + public :: ctem_init + public :: ctem_diags + public :: do_circulation_diags + + real(r8) :: rplon + real(r8) :: iref_p(plevp) ! interface reference pressure for vertical interpolation + integer :: ip_b ! level index where hybrid levels become purely pressure + integer :: zm_limit + + logical :: do_circulation_diags = .false. + +contains + +!================================================================================ + + subroutine ctem_diags( u3, v3, omga, pt, h2o, ps, pe, grid) + + use physconst, only : zvir, cappa + use dynamics_vars, only : T_FVDYCORE_GRID + use hycoef, only : ps0 + use interpolate_data, only : vertinterp +#ifdef SPMD + use mpishorthand, only : mpilog, mpiint + use parutilitiesmodule, only : pargatherint +#endif + +!------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------- + type(T_FVDYCORE_GRID), intent(in) :: grid ! FV Dynamics grid + + real(r8), intent(in) :: ps(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) ! surface pressure (pa) + real(r8), intent(in) :: u3(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! zonal velocity (m/s) + real(r8), intent(in) :: v3(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! meridional velocity (m/s) + real(r8), intent(in) :: omga(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! pressure velocity + real(r8), intent(in) :: pe(grid%ifirstxy:grid%ilastxy,plevp,grid%jfirstxy:grid%jlastxy) ! interface pressure (pa) + real(r8), intent(in) :: pt(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,plev) ! virtual temperature + real(r8), intent(in) :: h2o(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,plev) ! water constituent (kg/kg) + +!------------------------------------------------------------- +! ... local variables +!------------------------------------------------------------- + real(r8), parameter :: hscale = 7000._r8 ! pressure scale height + real(r8), parameter :: navp = 1.e35_r8 !+tht use this only for T, missing winds are set to zero + + real(r8) :: pinterp + real(r8) :: w(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! vertical velocity + real(r8) :: th(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! pot. temperature + + real(r8) :: pm(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! mid-point pressure + + real(r8) :: pexf ! Exner function + real(r8) :: psurf + + real(r8) :: ui(grid%ifirstxy:grid%ilastxy,plevp) ! interpolated zonal velocity + real(r8) :: vi(grid%ifirstxy:grid%ilastxy,plevp) ! interpolated meridional velocity + real(r8) :: wi(grid%ifirstxy:grid%ilastxy,plevp) ! interpolated vertical velocity + real(r8) :: thi(grid%ifirstxy:grid%ilastxy,plevp) ! interpolated pot. temperature + + real(r8) :: um(plevp) ! zonal mean zonal velocity + real(r8) :: vm(plevp) ! zonal mean meridional velocity + real(r8) :: wm(plevp) ! zonal mean vertical velocity + real(r8) :: thm(plevp) ! zonal mean pot. temperature + + real(r8) :: ud(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of zonal velocity + real(r8) :: vd(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of meridional velocity + real(r8) :: wd(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of vertical velocity + real(r8) :: thd(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of pot. temperature + + real(r8) :: vthp(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of zonal velocity + real(r8) :: wthp(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of meridional velocity + real(r8) :: uvp(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of vertical velocity + real(r8) :: uwp(grid%ifirstxy:grid%ilastxy,plevp) ! zonal deviation of pot. temperature + + real(r8) :: rdiv(plevp) + + integer :: ip_gm1g(plon,grid%jfirstxy:grid%jlastxy) ! contains level index-1 where blocked points begin + integer :: zm_cnt(plevp) ! counter + integer :: i,j,k + integer :: nlons + + logical :: has_zm(plevp,grid%jfirstxy:grid%jlastxy) ! .true. the (z,y) point is a valid zonal mean + integer :: ip_gm1(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy) ! contains level index-1 where blocked points begin + + real(r8) :: vth(plevp,grid%jfirstxy:grid%jlastxy) ! VTH flux + real(r8) :: uv(plevp,grid%jfirstxy:grid%jlastxy) ! UV flux + real(r8) :: wth(plevp,grid%jfirstxy:grid%jlastxy) ! WTH flux + real(r8) :: uw(plevp,grid%jfirstxy:grid%jlastxy) ! UW flux + real(r8) :: u2d(plevp,grid%jfirstxy:grid%jlastxy) ! zonally averaged U + real(r8) :: v2d(plevp,grid%jfirstxy:grid%jlastxy) ! zonally averaged V + real(r8) :: th2d(plevp,grid%jfirstxy:grid%jlastxy) ! zonally averaged TH + real(r8) :: w2d(plevp,grid%jfirstxy:grid%jlastxy) ! zonally averaged W + real(r8) :: thig(grid%ifirstxy:grid%ilastxy,plevp,grid%jfirstxy:grid%jlastxy) ! interpolated pot. temperature + + real(r8) :: tmp2(grid%ifirstxy:grid%ilastxy) + real(r8) :: tmp3(grid%ifirstxy:grid%ilastxy,plevp) + + integer :: beglat, endlat ! begin,end latitude indicies + integer :: beglon, endlon ! begin,end longitude indicies + + beglon = grid%ifirstxy + endlon = grid%ilastxy + beglat = grid%jfirstxy + endlat = grid%jlastxy + +!omp parallel do private (i,j,k,pexf,psurf) +lat_loop1 : & + do j = beglat, endlat + do k = 1, plev + do i = beglon, endlon +!------------------------------------------------------------- +! Calculate pressure and Exner function +!------------------------------------------------------------- + pm(i,k,j) = 0.5_r8 * ( pe(i,k,j) + pe(i,k+1,j) ) + pexf = (ps0 / pm(i,k,j))**cappa +!------------------------------------------------------------- +! Convert virtual temperature to temperature and calculate potential temperature +!------------------------------------------------------------- + th(i,k,j) = pt(i,j,k) / (1._r8 + zvir*h2o(i,j,k)) + th(i,k,j) = th(i,k,j) * pexf +!------------------------------------------------------------- +! Calculate vertical velocity +!------------------------------------------------------------- + w(i,k,j) = - hscale * omga(i,k,j) / pm(i,k,j) + end do + end do +!------------------------------------------------------------- +! Keep track of where the bottom is in each column +! (i.e., largest index for which P(k) <= PS) +!------------------------------------------------------------- + ip_gm1(:,j) = plevp + do i = beglon, endlon + psurf = ps(i,j) + do k = ip_b+1, plevp + if( iref_p(k) <= psurf ) then + ip_gm1(i,j) = k + end if + end do + end do + end do lat_loop1 + + nlons = endlon - beglon + 1 + +#ifdef SPMD + if( grid%twod_decomp == 1 ) then + if (grid%iam .lt. grid%npes_xy) then + call pargatherint( grid%commxy_x, 0, ip_gm1, grid%strip2dx, ip_gm1g ) + endif + else + ip_gm1g(:,:) = ip_gm1(:,:) + end if +#else + ip_gm1g(:,:) = ip_gm1(:,:) +#endif +#ifdef CTEM_DIAGS + write(iulog,*) '====================================================' + do j = beglat,endlat + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,'(20i3)') ip_gm1(:,j) + end do + if( grid%myidxy_x == 0 ) then + do j = beglat,endlat + write(iulog,*) '====================================================' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,'(20i3)') ip_gm1g(:,j) + end do + write(iulog,*) '====================================================' +#else +#ifdef SPMD + if( grid%myidxy_x == 0 ) then +#endif +#endif +lat_loop2 : & + do j = beglat, endlat + zm_cnt(:ip_b) = plon + do k = ip_b+1, plevp + zm_cnt(k) = count( ip_gm1g(:,j) >= k ) + end do + has_zm(:ip_b,j) = .true. + do k = ip_b+1, plevp + has_zm(k,j) = zm_cnt(k) >= zm_limit + end do + end do lat_loop2 +#ifdef SPMD + end if + if( grid%twod_decomp == 1 ) then + call mpibcast( has_zm, plevp*(endlat-beglat+1), mpilog, 0, grid%commxy_x ) + call mpibcast( ip_gm1g, plon*(endlat-beglat+1), mpiint, 0, grid%commxy_x ) + end if +#endif + +#ifdef CTEM_DIAGS + if( grid%myidxy_y == 12 ) then + write(iulog,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,beglat + write(iulog,*) 'has_zm' + write(iulog,'(20l2)') has_zm(:,beglat) + write(iulog,*) 'ip_gm1g' + write(iulog,'(20i4)') ip_gm1g(:,beglat) + write(iulog,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + end if +#endif + +lat_loop3 : & + do j = beglat, endlat +!------------------------------------------------------------- +! Vertical interpolation +!------------------------------------------------------------- + do k = 1, plevp + pinterp = iref_p(k) +!------------------------------------------------------------- +! Zonal velocity +!------------------------------------------------------------- + call vertinterp( nlons, nlons, plev, pm(beglon,1,j), pinterp, & + u3(beglon,1,j), ui(beglon,k) ) +!------------------------------------------------------------- +! Meridional velocity +!------------------------------------------------------------- + call vertinterp( nlons, nlons, plev, pm(beglon,1,j), pinterp, & + v3(beglon,1,j), vi(beglon,k) ) +!------------------------------------------------------------- +! Vertical velocity +!------------------------------------------------------------- + call vertinterp( nlons, nlons, plev, pm(beglon,1,j), pinterp, & + w(beglon,1,j), wi(beglon,k) ) +!------------------------------------------------------------- +! Pot. Temperature +!------------------------------------------------------------- + call vertinterp( nlons, nlons, plev, pm(beglon,1,j), pinterp, & + th(beglon,1,j), thi(beglon,k) ) + end do +#ifdef CTEM_DIAGS + if( j == endlat ) then + write(iulog,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,*) 'iref_p' + write(iulog,'(5g15.7)') iref_p(:) + write(iulog,'(''pm(endlon,:,'',i2,'')'')') j + write(iulog,'(5g15.7)') pm(endlon,:,j) + write(iulog,'(''u3(endlon,:,'',i2,'')'')') j + write(iulog,'(5g15.7)') u3(endlon,:,j) + write(iulog,*) 'ui(endlon,:)' + write(iulog,'(5g15.7)') ui(endlon,:) + write(iulog,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + end if +#endif + +!------------------------------------------------------------- +! Calculate zonal averages +!------------------------------------------------------------- + do k = ip_b+1, plevp + if( has_zm(k,j) ) then + where( ip_gm1(beglon:endlon,j) < k ) + ui(beglon:endlon,k) = 0._r8 + vi(beglon:endlon,k) = 0._r8 + wi(beglon:endlon,k) = 0._r8 + thi(beglon:endlon,k) = 0._r8 + endwhere + end if + end do + + call par_xsum( grid, ui, plevp, um ) + call par_xsum( grid, vi, plevp, vm ) + call par_xsum( grid, wi, plevp, wm ) + call par_xsum( grid, thi, plevp, thm ) +#ifdef CTEM_DIAGS + if( j == endlat .and. grid%myidxy_y == 12 ) then + write(iulog,*) '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,*) 'um after par_xsum' + write(iulog,'(5g15.7)') um(:) + write(iulog,*) '$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' + end if +#endif + do k = 1, ip_b + um(k) = um(k) * rplon + vm(k) = vm(k) * rplon + wm(k) = wm(k) * rplon + thm(k) = thm(k) * rplon + u2d(k,j) = um(k) + v2d(k,j) = vm(k) + th2d(k,j) = thm(k) + w2d(k,j) = wm(k) + end do + do k = ip_b+1, plevp + if( has_zm(k,j) ) then + rdiv(k) = 1._r8/count( ip_gm1g(:,j) >= k ) +!+tht define zonal mean winds taking zero for below-ground value + u2d(k,j) = um(k) * rplon + v2d(k,j) = vm(k) * rplon + w2d(k,j) = wm(k) * rplon +!-tht + um(k) = um(k) * rdiv(k) + vm(k) = vm(k) * rdiv(k) + wm(k) = wm(k) * rdiv(k) + thm(k) = thm(k) * rdiv(k) + !u2d(k,j) = um(k) !+tht c'd out + !v2d(k,j) = vm(k) !+tht c'd out + th2d(k,j) = thm(k) + !w2d(k,j) = wm(k) !+tht c'd out + else + u2d(k,j) = 0._r8 ! navp + v2d(k,j) = 0._r8 ! navp + th2d(k,j) = navp + w2d(k,j) = 0._r8 ! navp + end if + end do + +!------------------------------------------------------------- +! Calculate zonal deviations +!------------------------------------------------------------- + do k = 1, ip_b + ud(beglon:endlon,k) = ui(beglon:endlon,k) - um(k) + vd(beglon:endlon,k) = vi(beglon:endlon,k) - vm(k) + wd(beglon:endlon,k) = wi(beglon:endlon,k) - wm(k) + thd(beglon:endlon,k) = thi(beglon:endlon,k) - thm(k) + end do + + do k = ip_b+1, plevp + if( has_zm(k,j) ) then + where( ip_gm1g(beglon:endlon,j) >= k ) + ud(beglon:endlon,k) = ui(beglon:endlon,k) - um(k) + vd(beglon:endlon,k) = vi(beglon:endlon,k) - vm(k) + wd(beglon:endlon,k) = wi(beglon:endlon,k) - wm(k) + thd(beglon:endlon,k) = thi(beglon:endlon,k) - thm(k) + elsewhere + ud(beglon:endlon,k) = 0._r8 + vd(beglon:endlon,k) = 0._r8 + wd(beglon:endlon,k) = 0._r8 + thd(beglon:endlon,k) = 0._r8 + endwhere + end if + end do + +!------------------------------------------------------------- +! Calculate fluxes +!------------------------------------------------------------- + do k = 1, ip_b + vthp(:,k) = vd(:,k) * thd(:,k) + wthp(:,k) = wd(:,k) * thd(:,k) + uwp(:,k) = wd(:,k) * ud(:,k) + uvp(:,k) = vd(:,k) * ud(:,k) + end do + + do k = ip_b+1, plevp + if( has_zm(k,j) ) then + vthp(:,k) = vd(:,k) * thd(:,k) + wthp(:,k) = wd(:,k) * thd(:,k) + uwp(:,k) = wd(:,k) * ud(:,k) + uvp(:,k) = vd(:,k) * ud(:,k) + else + vthp(:,k) = 0._r8 + wthp(:,k) = 0._r8 + uwp(:,k) = 0._r8 + uvp(:,k) = 0._r8 + end if + end do + +#ifdef CTEM_DIAGS + if( j == endlat .and. grid%myidxy_y == 12 ) then + write(iulog,*) '#################################################' + write(iulog,*) 'DIAGNOSTICS before par_xsum' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,*) 'has_zm' + write(iulog,*) has_zm(:,j) + write(iulog,*) 'rdiv' + write(iulog,'(5g15.7)') rdiv(:) + write(iulog,*) 'wm' + write(iulog,'(5g15.7)') wm(:) + write(iulog,*) 'um' + write(iulog,'(5g15.7)') um(:) + write(iulog,*) 'uw' + write(iulog,'(5g15.7)') uw(:) + write(iulog,*) '#################################################' + end if +#endif + call par_xsum( grid, vthp, plevp, vth(1,j) ) + call par_xsum( grid, wthp, plevp, wth(1,j) ) + call par_xsum( grid, uvp, plevp, uv(1,j) ) + call par_xsum( grid, uwp, plevp, uw(1,j) ) +#ifdef CTEM_DIAGS + if( j == endlat .and. grid%myidxy_y == 12 ) then + write(iulog,*) '#################################################' + write(iulog,'(''iam,myidxy_x,myidxy_y,j = '',4i4)') grid%iam,grid%myidxy_x,grid%myidxy_y,j + write(iulog,*) 'uw after par_xsum' + write(iulog,'(5g15.7)') uw(:,j) + write(iulog,*) '#################################################' + end if +#endif + do k = 1, ip_b + vth(k,j) = vth(k,j) * rplon + wth(k,j) = wth(k,j) * rplon + uw(k,j) = uw(k,j) * rplon + uv(k,j) = uv(k,j) * rplon + end do + do k = ip_b+1, plevp + if( has_zm(k,j) ) then + vth(k,j) = vth(k,j) * rdiv(k) + wth(k,j) = wth(k,j) * rdiv(k) + uw(k,j) = uw(k,j) * rdiv(k) + uv(k,j) = uv(k,j) * rdiv(k) + else + vth(k,j) = 0._r8 ! navp + wth(k,j) = 0._r8 ! navp + uw(k,j) = 0._r8 ! navp + uv(k,j) = 0._r8 ! navp + end if + end do + + thig(:,:,j) = thi(:,:) + end do lat_loop3 + +!------------------------------------------------------------- +! Do the output +!------------------------------------------------------------- + latloop: do j = beglat,endlat + +!------------------------------------------------------------- +! zonal-mean output +!------------------------------------------------------------- + do k = 1,plevp + tmp3(grid%ifirstxy,k) = vth(k,j) + enddo + call outfld( 'VTHzm', tmp3(grid%ifirstxy,:), 1, j ) + + do k = 1,plevp + tmp3(grid%ifirstxy,k) = wth(k,j) + enddo + call outfld( 'WTHzm', tmp3(grid%ifirstxy,:), 1, j ) + + do k = 1,plevp + tmp3(grid%ifirstxy,k) = uv(k,j) + enddo + call outfld( 'UVzm', tmp3(grid%ifirstxy,:), 1, j ) + + do k = 1,plevp + tmp3(grid%ifirstxy,k) = uw(k,j) + enddo + call outfld( 'UWzm', tmp3(grid%ifirstxy,:), 1, j ) + do k = 1,plevp + tmp3(grid%ifirstxy,k) = u2d(k,j) + enddo + call outfld( 'Uzm', tmp3(grid%ifirstxy,:), 1, j ) + do k = 1,plevp + tmp3(grid%ifirstxy,k) = v2d(k,j) + enddo + call outfld( 'Vzm', tmp3(grid%ifirstxy,:), 1, j ) + do k = 1,plevp + tmp3(grid%ifirstxy,k) = w2d(k,j) + enddo + call outfld( 'Wzm', tmp3(grid%ifirstxy,:), 1, j ) + do k = 1,plevp + tmp3(grid%ifirstxy,k) = th2d(k,j) + enddo + call outfld( 'THzm', tmp3(grid%ifirstxy,:), 1, j ) + +!------------------------------------------------------------- +! 3D output +!------------------------------------------------------------- + do k = 1,plevp + do i = beglon,endlon + tmp3(i,k) = thig(i,k,j) + enddo + enddo + call outfld( 'TH', tmp3, nlons, j ) + +!------------------------------------------------------------- +! horizontal output +!------------------------------------------------------------- + tmp2(beglon:endlon) = ip_gm1(beglon:endlon,j) + call outfld( 'MSKtem', tmp2, nlons, j ) + + enddo latloop + + end subroutine ctem_diags + +!================================================================================= + + subroutine ctem_init() + + use hycoef, only : hyai, hybi, ps0 + use phys_control, only : phys_getopts + +!------------------------------------------------------------- +! ... local variables +!------------------------------------------------------------- + integer :: k + logical :: history_waccm + + if (.not.do_circulation_diags) return + + rplon = 1._r8/plon + zm_limit = plon/3 + +!------------------------------------------------------------- +! Calculate reference pressure +!------------------------------------------------------------- + do k = 1, plevp + iref_p(k) = (hyai(k) + hybi(k)) * ps0 + end do + if( masterproc ) then + write(iulog,*) 'ctem_inti: iref_p' + write(iulog,'(1p5g15.7)') iref_p(:) + end if + +!------------------------------------------------------------- +! Find level where hybrid levels become purely pressure +!------------------------------------------------------------- + ip_b = -1 + do k = 1,plev + if( hybi(k) == 0._r8 ) ip_b = k + end do + + call phys_getopts( history_waccm_out = history_waccm ) + +!------------------------------------------------------------- +! Initialize output buffer +!------------------------------------------------------------- + call addfld ('VTHzm',(/ 'ilev' /),'A','MK/S','Meridional Heat Flux: 3D zon. mean', gridname='fv_centers_zonal' ) + call addfld ('WTHzm',(/ 'ilev' /),'A','MK/S','Vertical Heat Flux: 3D zon. mean', gridname='fv_centers_zonal' ) + call addfld ('UVzm', (/ 'ilev' /),'A','M2/S2','Meridional Flux of Zonal Momentum: 3D zon. mean', gridname='fv_centers_zonal' ) + call addfld ('UWzm', (/ 'ilev' /),'A','M2/S2','Vertical Flux of Zonal Momentum: 3D zon. mean', gridname='fv_centers_zonal' ) + + call addfld ('Uzm', (/ 'ilev' /),'A','M/S','Zonal-Mean zonal wind - defined on ilev', gridname='fv_centers_zonal' ) + call addfld ('Vzm', (/ 'ilev' /),'A','M/S','Zonal-Mean meridional wind - defined on ilev', gridname='fv_centers_zonal' ) + call addfld ('Wzm', (/ 'ilev' /),'A','M/S','Zonal-Mean vertical wind - defined on ilev', gridname='fv_centers_zonal' ) + call addfld ('THzm', (/ 'ilev' /),'A', 'K','Zonal-Mean potential temp - defined on ilev', gridname='fv_centers_zonal' ) + + call addfld ('TH', (/ 'ilev' /),'A','K', 'Potential Temperature', gridname='fv_centers' ) + call addfld ('MSKtem',horiz_only, 'A','1', 'TEM mask', gridname='fv_centers' ) + +!------------------------------------------------------------- +! primary tapes: 3D fields +!------------------------------------------------------------- + call add_default ('VTHzm', 1, ' ') + call add_default ('WTHzm', 1, ' ') + call add_default ('UVzm' , 1, ' ') + call add_default ('UWzm' , 1, ' ') + call add_default ('TH' , 1, ' ') + call add_default ('MSKtem',1, ' ') +! LSG 20190604: add Uzm, Vzm, Wzm and THzm to defaults + call add_default ('Uzm', 1, ' ') + call add_default ('Vzm', 1, ' ') + call add_default ('Wzm', 1, ' ') + call add_default ('THzm', 1, ' ') + + if (history_waccm) then + call add_default ('MSKtem',7, ' ') + call add_default ('VTHzm', 7, ' ') + call add_default ('UVzm', 7, ' ') + call add_default ('UWzm', 7, ' ') + call add_default ('Uzm', 7, ' ') + call add_default ('Vzm', 7, ' ') + call add_default ('Wzm', 7, ' ') + call add_default ('THzm', 7, ' ') + end if + + if (masterproc) then + write(iulog,*) 'ctem_inti: do_circulation_diags = ',do_circulation_diags + endif + + end subroutine ctem_init + +!================================================================================ + +subroutine ctem_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_logical + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'ctem_readnl' + + namelist /circ_diag_nl/ do_circulation_diags + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'circ_diag_nl', status=ierr) + if (ierr == 0) then + read(unitn, circ_diag_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(do_circulation_diags, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subname//": FATAL: mpi_bcast: do_circulation_diags") + +end subroutine ctem_readnl + +end module ctem diff --git a/src/NorESM/fv/dp_coupling.F90 b/src/NorESM/fv/dp_coupling.F90 new file mode 100644 index 0000000000..e74d54c6f3 --- /dev/null +++ b/src/NorESM/fv/dp_coupling.F90 @@ -0,0 +1,998 @@ +module dp_coupling +!BOP +! +! !MODULE: dp_coupling --- dynamics-physics coupling module +! + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use phys_grid + + use physics_types, only: physics_state, physics_tend + use constituents, only: pcnst + use physconst, only: gravit, zvir, cpairv, rairv + use geopotential, only: geopotential_t + use check_energy, only: check_energy_timestep_init + use dynamics_vars, only: T_FVDYCORE_GRID, t_fvdycore_state + use dyn_internal_state,only: get_dyn_state + use dyn_comp, only: dyn_import_t, dyn_export_t, fv_print_dpcoup_warn + use cam_abortutils, only: endrun +#if defined ( SPMD ) + use spmd_dyn, only: local_dp_map, block_buf_nrecs, chunk_buf_nrecs +#endif + use perf_mod + use cam_logfile, only: iulog + +!-------------------------------------------- +! Variables needed for WACCM-X +!-------------------------------------------- + use constituents, only: cnst_get_ind !Needed to access constituent indices +! +! !PUBLIC MEMBER FUNCTIONS: + PUBLIC d_p_coupling, p_d_coupling + +! +! !DESCRIPTION: +! +! This module provides +! +! \begin{tabular}{|l|l|} \hline \hline +! d\_p\_coupling & dynamics output to physics input \\ \hline +! p\_d\_coupling & physics output to dynamics input \\ \hline +! \hline +! \end{tabular} +! +! !REVISION HISTORY: +! 00.06.01 Boville Creation +! 01.10.01 Lin Various revisions +! 01.03.26 Sawyer Added ProTeX documentation +! 01.06.27 Mirin Separate noncoupling coding into new routines +! 01.07.13 Mirin Some support for multi-2D decompositions +! 02.03.01 Worley Support for nontrivial physics remapping +! 03.03.28 Boville set all physics_state elements, add check_energy_timestep_init +! 03.08.13 Sawyer Removed ghost N1 region in u3sxy +! 05.06.28 Sawyer Simplified interfaces -- only XY decomposition +! 05.10.25 Sawyer Extensive refactoring, dyn_interface +! 05.11.10 Sawyer Now using dyn_import/export_t containers +! 06.07.01 Sawyer Transitioned constituents to T_TRACERS +! +!EOP +!----------------------------------------------------------------------- + + private + real(r8), parameter :: D0_5 = 0.5_r8 + real(r8), parameter :: D1_0 = 1.0_r8 + +CONTAINS + +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: d_p_coupling --- convert dynamics output to physics input +! +! !INTERFACE: + subroutine d_p_coupling(grid, phys_state, phys_tend, pbuf2d, dyn_out) + +! !USES: + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, & + pbuf_get_field + use constituents, only: qmin + use physics_types, only: set_state_pdry, set_wet_to_dry + + use pmgrid, only: plev + use ctem, only: ctem_diags, do_circulation_diags + use diag_module, only: fv_diag_am_calc + use gravity_waves_sources, only: gws_src_fnct + use physconst, only: physconst_update + use shr_const_mod, only: shr_const_rwv + use dyn_comp, only: frontgf_idx, frontga_idx, uzm_idx + use qbo, only: qbo_use_forcing + use phys_control, only: use_gw_front, use_gw_front_igw, waccmx_is + use zonal_mean, only: zonal_mean_3D + use d2a3dikj_mod, only: d2a3dikj + use qneg_module, only: qneg3 + +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! !INPUT PARAMETERS: +! + type(t_fvdycore_grid), intent(in) :: grid + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + type(dyn_export_t), intent(in) :: dyn_out ! dynamics export + +! !OUTPUT PARAMETERS: + + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + + +! !DESCRIPTION: +! +! Coupler for converting dynamics output variables into physics +! input variables +! +! !REVISION HISTORY: +! 00.06.01 Boville Creation +! 01.07.13 AAM Some support for multi-2D decompositions +! 02.03.01 Worley Support for nontrivial physics remapping +! 02.05.02 Sawyer u3s made inout due to ghosting in d2a3dikj +! 03.08.05 Sawyer Removed pe11k, pe11kln (for defunct Rayl fric) +! 04.08.29 Eaton Added lat, lon coords to physics_state type +! 05.06.28 Sawyer Simplified interface -- on XY decomp vars. +! 05.07.06 Sawyer Added dyn_state as argument +! 05.10.31 Sawyer Refactoring, replaced dyn_state by dyn_interface +! +!EOP +!----------------------------------------------------------------------- +!BOC +! !LOCAL VARIABLES: + + type(t_fvdycore_state), pointer :: dyn_state + +! Variables from dynamics export container + real(r8), pointer :: phisxy(:,:) ! surface geopotential + real(r8), pointer :: psxy (:,:) ! surface pressure + real(r8), pointer :: u3sxy(:,:,:) ! u-wind on d-grid + real(r8), pointer :: v3sxy(:,:,:) ! v-wind on d-grid + real(r8), pointer :: du3sxy(:,:,:) ! u-wind increment on d-grid + real(r8), pointer :: dv3sxy(:,:,:) ! v-wind increment on d-grid + real(r8), pointer :: dua3sxy(:,:,:) ! u-wind adv. inc. on d-grid + real(r8), pointer :: dva3sxy(:,:,:) ! v-wind adv. inc. on d-grid + real(r8), pointer :: duf3sxy(:,:,:) ! u-wind fixer inc.on d-grid + real(r8), pointer :: ptxy (:,:,:) ! Virtual pot temp + real(r8), pointer :: tracer(:,:,:,:) ! constituents + real(r8), pointer :: omgaxy(:,:,:) ! vertical velocity + real(r8), pointer :: pexy (:,:,:) ! edge pressure + real(r8), pointer :: pelnxy(:,:,:) ! log(pe) + real(r8), pointer :: pkxy (:,:,:) ! pe**cappa + real(r8), pointer :: pkzxy (:,:,:) ! f-v mean of pk + + integer :: i,ib,j,k,m,lchnk ! indices + integer :: ncol ! number of columns in current chunk + integer :: lats(pcols) ! array of latitude indices + integer :: lons(pcols) ! array of longitude indices + integer :: blksiz ! number of columns in 2D block + integer :: tsize ! amount of data per grid point passed to physics + integer, allocatable, dimension(:,:) :: bpter + ! offsets into block buffer for packing data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for unpacking data + + real(r8) :: qmavl ! available q at level pver-1 + real(r8) :: dqreq ! q change at pver-1 required to remove q get_dyn_state() + + if (use_gw_front .or. use_gw_front_igw) then + + allocate(frontgf(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy), stat=astat) + if( astat /= 0 ) then + write(iulog,*) 'd_p_coupling: failed to allocate frontgf; error = ',astat + call endrun + end if + + allocate(frontga(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy), stat=astat) + if( astat /= 0 ) then + write(iulog,*) 'd_p_coupling: failed to allocate frontga; error = ',astat + call endrun + end if + + end if + + nullify(pbuf_chnk) + nullify(pbuf_frontgf) + nullify(pbuf_frontga) + nullify(pbuf_uzm) + + fraction = 0.1_r8 + + phisxy => dyn_out%phis + psxy => dyn_out%ps + u3sxy => dyn_out%u3s + v3sxy => dyn_out%v3s + ptxy => dyn_out%pt + tracer => dyn_out%tracer + + omgaxy => dyn_out%omga + pexy => dyn_out%pe + pelnxy => dyn_out%peln + pkxy => dyn_out%pk + pkzxy => dyn_out%pkz + + km = grid%km + kmp1 = km + 1 + + ifirstxy = grid%ifirstxy + ilastxy = grid%ilastxy + jfirstxy = grid%jfirstxy + jlastxy = grid%jlastxy + + iam = grid%iam +!----------------------------------------------------------------------- +! Transform dynamics staggered winds to physics grid (D=>A) +!----------------------------------------------------------------------- + + call t_startf ('d2a3dikj') + allocate (u3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (v3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + + if (iam .lt. grid%npes_xy) then + call d2a3dikj(grid, dyn_state%am_correction, u3sxy, v3sxy, u3, v3) + end if ! (iam .lt. grid%npes_xy) + + call t_stopf ('d2a3dikj') + + if ( do_circulation_diags ) then + call t_startf('DP_CPLN_ctem') + call ctem_diags( u3, v3, omgaxy, ptxy(:,jfirstxy:jlastxy,:), tracer(:,jfirstxy:jlastxy,:,1), & + psxy, pexy, grid) + call t_stopf('DP_CPLN_ctem') + endif + + if (dyn_state%am_diag) then + du3sxy => dyn_out%du3s + dv3sxy => dyn_out%dv3s + dua3sxy => dyn_out%dua3s + dva3sxy => dyn_out%dva3s + duf3sxy => dyn_out%duf3s + allocate (du3 (ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (dv3 (ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (dua3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (dva3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (duf3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) + allocate (dummy(ifirstxy:ilastxy,jfirstxy:jlastxy, km)) + du3(:,:,:) = 0._r8 + dv3(:,:,:) = 0._r8 + dua3(:,:,:) = 0._r8 + dva3(:,:,:) = 0._r8 + duf3(:,:,:) = 0._r8 + dummy(:,:,:) = 0._r8 + + if (iam .lt. grid%npes_xy) then + ! (note dummy use of dva3 hence call order matters) + call d2a3dikj(grid, dyn_state%am_correction,duf3sxy, dummy, duf3 ,dva3) + call d2a3dikj(grid, dyn_state%am_correction,dua3sxy, dva3sxy, dua3, dva3) + call d2a3dikj(grid, dyn_state%am_correction, du3sxy, dv3sxy, du3 , dv3 ) + end if ! (iam .lt. grid%npes_xy) + + call t_startf('DP_CPLN_fv_am') + call fv_diag_am_calc(grid, psxy, pexy, du3, dv3, dua3, dva3, duf3) + call t_stopf('DP_CPLN_fv_am') + endif + + if (use_gw_front .or. use_gw_front_igw) then + call t_startf('DP_CPLN_gw_sources') + call gws_src_fnct(grid, u3, v3, ptxy, tracer(:,jfirstxy:jlastxy,:,1), pexy, frontgf, frontga) + call t_stopf('DP_CPLN_gw_sources') + end if + if (qbo_use_forcing) then + call zonal_mean_3D(grid, plev, u3, uzm) + end if + +!----------------------------------------------------------------------- +! Copy data from dynamics data structure to physics data structure +!----------------------------------------------------------------------- +has_local_map : & + if (local_dp_map) then + +! This declaration is too long; this parallel section needs some stuff +! pulled out into routines. +!$omp parallel do private (lchnk, ncol, i, k, m, ic, jc, lons, lats, pic, pbuf_chnk, pbuf_uzm, pbuf_frontgf, pbuf_frontga) +chnk_loop1 : & + do lchnk = begchunk,endchunk + ncol = phys_state(lchnk)%ncol + call get_lon_all_p(lchnk, ncol, lons) + call get_lat_all_p(lchnk, ncol, lats) + + pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) + + if (use_gw_front .or. use_gw_front_igw) then + call pbuf_get_field(pbuf_chnk, frontgf_idx, pbuf_frontgf) + call pbuf_get_field(pbuf_chnk, frontga_idx, pbuf_frontga) + end if + + if (qbo_use_forcing) then + call pbuf_get_field(pbuf_chnk, uzm_idx, pbuf_uzm) + end if + + do i=1,ncol + ic = lons(i) + jc = lats(i) + phys_state(lchnk)%ps(i) = psxy(ic,jc) + phys_state(lchnk)%phis(i) = phisxy(ic,jc) + pic(i) = pkxy(ic,jc,pver+1) + enddo + do k=1,km + do i=1,ncol + ic = lons(i) + jc = lats(i) + phys_state(lchnk)%u (i,k) = u3(ic,k,jc) + phys_state(lchnk)%v (i,k) = v3(ic,k,jc) + phys_state(lchnk)%omega(i,k) = omgaxy(ic,k,jc) + phys_state(lchnk)%t (i,k) = ptxy(ic,jc,k) / (D1_0 + zvir*tracer(ic,jc,k,1)) + phys_state(lchnk)%exner(i,k) = pic(i) / pkzxy(ic,jc,k) + + if (use_gw_front .or. use_gw_front_igw) then + pbuf_frontgf(i,k) = frontgf(ic,k,jc) + pbuf_frontga(i,k) = frontga(ic,k,jc) + endif + + if (qbo_use_forcing) then + pbuf_uzm(i,k) = uzm(k,jc) + end if + + end do + end do + + do k=1,kmp1 + do i=1,ncol +! +! edge-level pressure arrays: copy from the arrays computed by dynpkg +! + ic = lons(i) + jc = lats(i) + phys_state(lchnk)%pint (i,k) = pexy (ic,k,jc) + phys_state(lchnk)%lnpint(i,k) = pelnxy(ic,k,jc) + end do + end do + +! +! Copy constituents +! Dry types converted from moist to dry m.r. at bottom of this routine +! + do m=1,pcnst + do k=1,km + do i=1,ncol + phys_state(lchnk)%q(i,k,m) = & + tracer(lons(i),lats(i),k,m) + end do + end do + end do + + end do chnk_loop1 + + else has_local_map + + boff = 6 + if (use_gw_front .or. use_gw_front_igw) boff = boff+2 + if (qbo_use_forcing) boff = boff+1 + + tsize = boff + 1 + pcnst + + blksiz = (jlastxy-jfirstxy+1)*(ilastxy-ifirstxy+1) + allocate( bpter(blksiz,0:km),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'd_p_coupling: failed to allocate bpter; error = ',astat + call endrun + end if + allocate( bbuffer(tsize*block_buf_nrecs),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'd_p_coupling: failed to allocate bbuffer; error = ',astat + call endrun + end if + allocate( cbuffer(tsize*chunk_buf_nrecs),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'd_p_coupling: failed to allocate cbuffer; error = ',astat + call endrun + end if + + if (iam .lt. grid%npes_xy) then + call block_to_chunk_send_pters(iam+1,blksiz,kmp1,tsize,bpter) + endif + +!$omp parallel do private (j, i, ib, k, m) + do j=jfirstxy,jlastxy + do i=ifirstxy,ilastxy + ib = (j-jfirstxy)*(ilastxy-ifirstxy+1) + (i-ifirstxy+1) + + bbuffer(bpter(ib,0)+4:bpter(ib,0)+boff+pcnst) = 0.0_r8 + + bbuffer(bpter(ib,0)) = pexy(i,kmp1,j) + bbuffer(bpter(ib,0)+1) = pelnxy(i,kmp1,j) + bbuffer(bpter(ib,0)+2) = psxy(i,j) + bbuffer(bpter(ib,0)+3) = phisxy(i,j) + + do k=1,km + + bbuffer(bpter(ib,k)) = pexy(i,k,j) + bbuffer(bpter(ib,k)+1) = pelnxy(i,k,j) + bbuffer(bpter(ib,k)+2) = u3 (i,k,j) + bbuffer(bpter(ib,k)+3) = v3 (i,k,j) + bbuffer(bpter(ib,k)+4) = omgaxy(i,k,j) + bbuffer(bpter(ib,k)+5) = ptxy(i,j,k) / (D1_0 + zvir*tracer(i,j,k,1)) + bbuffer(bpter(ib,k)+6) = pkxy(i,j,pver+1) / pkzxy(i,j,k) + + if (use_gw_front .or. use_gw_front_igw) then + bbuffer(bpter(ib,k)+7) = frontgf(i,k,j) + bbuffer(bpter(ib,k)+8) = frontga(i,k,j) + end if + + if (qbo_use_forcing) then + bbuffer(bpter(ib,k)+9) = uzm(k,j) + end if + + do m=1,pcnst + bbuffer(bpter(ib,k)+boff+m) = tracer(i,j,k,m) + end do + + end do + end do + end do + + call t_barrierf('sync_blk_to_chk', grid%commxy) + call t_startf ('block_to_chunk') + call transpose_block_to_chunk(tsize, bbuffer, cbuffer) + call t_stopf ('block_to_chunk') + +!$omp parallel do private (lchnk, ncol, i, k, m, cpter, pbuf_chnk, pbuf_uzm, pbuf_frontgf, pbuf_frontga) +chnk_loop2 : & + do lchnk = begchunk,endchunk + ncol = phys_state(lchnk)%ncol + + pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) + + if (use_gw_front .or. use_gw_front_igw) then + call pbuf_get_field(pbuf_chnk, frontgf_idx, pbuf_frontgf) + call pbuf_get_field(pbuf_chnk, frontga_idx, pbuf_frontga) + end if + + if (qbo_use_forcing) then + call pbuf_get_field(pbuf_chnk, uzm_idx, pbuf_uzm) + end if + + call block_to_chunk_recv_pters(lchnk,pcols,pver+1,tsize,cpter) + + do i=1,ncol + + phys_state(lchnk)%pint (i,pver+1) = cbuffer(cpter(i,0)) + phys_state(lchnk)%lnpint(i,pver+1) = cbuffer(cpter(i,0)+1) + phys_state(lchnk)%ps(i) = cbuffer(cpter(i,0)+2) + phys_state(lchnk)%phis(i) = cbuffer(cpter(i,0)+3) + + do k=1,km + + phys_state(lchnk)%pint (i,k) = cbuffer(cpter(i,k)) + phys_state(lchnk)%lnpint(i,k) = cbuffer(cpter(i,k)+1) + phys_state(lchnk)%u (i,k) = cbuffer(cpter(i,k)+2) + phys_state(lchnk)%v (i,k) = cbuffer(cpter(i,k)+3) + phys_state(lchnk)%omega (i,k) = cbuffer(cpter(i,k)+4) + phys_state(lchnk)%t (i,k) = cbuffer(cpter(i,k)+5) + phys_state(lchnk)%exner (i,k) = cbuffer(cpter(i,k)+6) + + if (use_gw_front .or. use_gw_front_igw) then + pbuf_frontgf(i,k) = cbuffer(cpter(i,k)+7) + pbuf_frontga(i,k) = cbuffer(cpter(i,k)+8) + end if + + if (qbo_use_forcing) then + pbuf_uzm(i,k) = cbuffer(cpter(i,k)+9) + end if + + ! dry type constituents converted from moist to dry at bottom of routine + do m=1,pcnst + phys_state(lchnk)%q(i,k,m) = cbuffer(cpter(i,k)+boff+m) + end do + + end do + end do + + end do chnk_loop2 + + deallocate(bpter) + deallocate(bbuffer) + deallocate(cbuffer) + + endif has_local_map + +!+tht (dlw/jgo) +!-------------------------------------------- +! Check for negative water constituents later +!-------------------------------------------- + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) +!-tht +!------------------------------------------------------ +! Get indices to access O, O2, H, H2, and N species +!------------------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call cnst_get_ind('O', ixo) + call cnst_get_ind('O2', ixo2) + call cnst_get_ind('H', ixh) + call cnst_get_ind('H2', ixh2) + call cnst_get_ind('N', ixn) + endif +! +! Evaluate derived quantities +! + call t_startf ('derived_fields') +!$omp parallel do private (lchnk, ncol, i, k, m, qmavl, dqreq, qbot, qbotm1, zvirv, pbuf_chnk, mmrSum_O_O2_H) + do lchnk = begchunk,endchunk + ncol = phys_state(lchnk)%ncol + do k=1,km + do i=1,ncol + phys_state(lchnk)%pdel (i,k) = phys_state(lchnk)%pint(i,k+1) - phys_state(lchnk)%pint(i,k) + phys_state(lchnk)%rpdel(i,k) = D1_0/phys_state(lchnk)%pdel(i,k) + phys_state(lchnk)%pmid (i,k) = D0_5*(phys_state(lchnk)%pint(i,k) + phys_state(lchnk)%pint(i,k+1)) + phys_state(lchnk)%lnpmid(i,k) = log(phys_state(lchnk)%pmid(i,k)) + end do + end do + +! Attempt to remove negative constituents in bottom layer only by moving from next level +! This is a BAB kludge to avoid masses of warning messages for cloud water and ice, since +! the vertical remapping operator currently being used for cam is not strictly monotonic +! at the endpoints. + do m=1,pcnst + do i=1,ncol + if (phys_state(lchnk)%q(i,pver,m) < qmin(m)) then +! available q in 2nd level + qmavl = phys_state(lchnk)%q (i,pver-1,m) - qmin(m) +! required q change in bottom level rescaled to mass fraction in 2nd level + dqreq = (qmin(m) - phys_state(lchnk)%q(i,pver,m)) & + * phys_state(lchnk)%pdel(i,pver) / phys_state(lchnk)%pdel(i,pver-1) + qbot = phys_state(lchnk)%q(i,pver ,m) + qbotm1 = phys_state(lchnk)%q(i,pver-1,m) + if (dqreq < qmavl) then + phys_state(lchnk)%q(i,pver ,m) = qmin(m) + phys_state(lchnk)%q(i,pver-1,m) = phys_state(lchnk)%q(i,pver-1,m) - dqreq + ! Comment out these log messages since they can make the log files so + ! large that they're unusable. + if (dqreq>qmin(m) .and. dqreq>fraction*qbotm1 .and. (trim(fv_print_dpcoup_warn) == "full")) & + write(iulog,*) 'dpcoup dqreq', m, lchnk, i, qbot, qbotm1, dqreq + else + ! Comment out these log messages since they can make the log files so + ! large that they're unusable. + if (dqreq>qmin(m) .and. (trim(fv_print_dpcoup_warn) == "full")) then + write(iulog,*) 'dpcoup cant adjust', m, lchnk, i, qbot, qbotm1, dqreq + end if + end if + end if + end do + end do + +!----------------------------------------------------------------------------------------------------------------- +! Ensure O2 + O + H (N2) mmr greater than one. Check for unusually large H2 values and set to lower value +!----------------------------------------------------------------------------------------------------------------- + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + do i=1,ncol + do k=1,pver + + if (phys_state(lchnk)%q(i,k,ixo) < mmrMin) phys_state(lchnk)%q(i,k,ixo) = mmrMin + if (phys_state(lchnk)%q(i,k,ixo2) < mmrMin) phys_state(lchnk)%q(i,k,ixo2) = mmrMin + + mmrSum_O_O2_H = phys_state(lchnk)%q(i,k,ixo)+phys_state(lchnk)%q(i,k,ixo2)+phys_state(lchnk)%q(i,k,ixh) + + if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then + + phys_state(lchnk)%q(i,k,ixo) = phys_state(lchnk)%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + phys_state(lchnk)%q(i,k,ixo2) = phys_state(lchnk)%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + phys_state(lchnk)%q(i,k,ixh) = phys_state(lchnk)%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H + + endif + + if(phys_state(lchnk)%q(i,k,ixh2) .gt. 6.e-5_r8) then + phys_state(lchnk)%q(i,k,ixh2) = 6.e-5_r8 + endif + + end do + end do + endif + +!----------------------------------------------------------------------------- +! Call physconst_update to compute cpairv, rairv, mbarv, and cappav as constituent dependent variables +! and compute molecular viscosity(kmvis) and conductivity(kmcnd) +!----------------------------------------------------------------------------- + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call physconst_update(phys_state(lchnk)%q, phys_state(lchnk)%t, lchnk, ncol) + endif + +!------------------------------------------------------------------------ +! Fill local zvirv variable; calculated for WACCM-X +!------------------------------------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv(:,:,lchnk) -1._r8 + else + zvirv(:,:) = zvir + endif +! +! Compute initial geopotential heights + call geopotential_t (phys_state(lchnk)%lnpint, phys_state(lchnk)%lnpmid , phys_state(lchnk)%pint , & + phys_state(lchnk)%pmid , phys_state(lchnk)%pdel , phys_state(lchnk)%rpdel , & + phys_state(lchnk)%t , phys_state(lchnk)%q(:,:,1), rairv(:,:,lchnk), gravit, zvirv, & + phys_state(lchnk)%zi , phys_state(lchnk)%zm , ncol ) + +! Compute initial dry static energy, include surface geopotential + do k = 1, pver + do i=1,ncol + phys_state(lchnk)%s(i,k) = cpairv(i,k,lchnk)*phys_state(lchnk)%t(i,k) & + + gravit*phys_state(lchnk)%zm(i,k) + phys_state(lchnk)%phis(i) + end do + end do + +! +! Convert dry type constituents from moist to dry mixing ratio +! + call set_state_pdry(phys_state(lchnk)) ! First get dry pressure to use for this timestep + call set_wet_to_dry(phys_state(lchnk)) ! Dynamics had moist, physics wants dry. + +!+tht (dlw/jgo) +! +! +! Ensure tracers are all positive +! + call qneg3('D_P_COUPLING',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,phys_state(lchnk)%q) + m = ixcldliq + call qneg3('D_P_COUPLING/CLDLIQ',lchnk ,ncol ,pcols ,pver , & + m, m, qmin(m) ,phys_state(lchnk)%q(1,1,m) ) + m = ixcldice + call qneg3('D_P_COUPLING/CLDICE',lchnk ,ncol ,pcols ,pver , & + m, m, qmin(m) ,phys_state(lchnk)%q(1,1,m) ) +!-tht + +! Compute energy and water integrals of input state + + pbuf_chnk => pbuf_get_chunk(pbuf2d, lchnk) + call check_energy_timestep_init(phys_state(lchnk), phys_tend(lchnk), pbuf_chnk) + + end do + call t_stopf('derived_fields') + + deallocate (u3) + deallocate (v3) + if (dyn_state%am_diag) then + deallocate (du3) + deallocate (dv3) + deallocate (dua3) + deallocate (dva3) + deallocate (duf3) + deallocate (dummy) + end if + + end subroutine d_p_coupling +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: p_d_coupling --- convert physics output to dynamics input +! +! !INTERFACE: + subroutine p_d_coupling(grid, phys_state, phys_tend, & + dyn_in, dtime, zvir, cappa, ptop) + +! !USES: +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_fields +#endif + use physics_buffer, only: physics_buffer_desc + use physconst, only: physconst_calc_kappav + +!----------------------------------------------------------------------- + implicit none + +! Variables ending in xy are xy-decomposition instanciations. + + type(T_FVDYCORE_GRID), intent(in) :: grid ! FV Dynamics grid + +! !INPUT PARAMETERS: + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend), intent(inout), dimension(begchunk:endchunk) :: phys_tend + type(dyn_import_t), intent(inout) :: dyn_in + + real(r8), intent(in) :: dtime + real(r8), intent(in) :: zvir + real(r8), intent(in) :: cappa + real(r8), intent(in) :: ptop + +! !DESCRIPTION: +! +! Coupler for converting physics output variables into dynamics input variables +! +! !REVISION HISTORY: +! 00.06.01 Boville Creation +! 01.06.08 AAM Compactified +! 01.07.13 AAM Some support for multi-2D decompositions +! 02.03.01 Worley Support for nontrivial physics remapping +! 02.08.06 Sawyer T3 added -- updated to current temperature +! 05.07.12 Sawyer Added dyn_state as argument +! 05.09.23 Sawyer Transitioned to XY decomposition vars. only +! 05.10.31 Sawyer Replaced dyn_state with dyn_interface +! +!EOP +!----------------------------------------------------------------------- +!BOC +! !LOCAL VARIABLES: + + type(t_fvdycore_state), pointer :: dyn_state + +! Variables from the dynamics import container + + real(r8), pointer :: psxy(:,:) + real(r8), pointer :: u3sxy(:,:,:) + real(r8), pointer :: v3sxy(:,:,:) + real(r8), pointer :: t3xy(:,:,:) ! Temperature + real(r8), pointer :: ptxy(:,:,:) ! Virt. pot. temp. + real(r8), pointer :: tracer(:,:,:,:) ! Constituents + + real(r8), pointer :: pexy(:,:,:) + real(r8), pointer :: delpxy(:,:,:) + real(r8), pointer :: pkxy(:,:,:) + real(r8), pointer :: pkzxy(:,:,:) + +! Local workspace + + real(r8):: dudtxy(grid%ifirstxy:grid%ilastxy,& + grid%km,grid%jfirstxy:grid%jlastxy) + real(r8):: dvdtxy(grid%ifirstxy:grid%ilastxy,& + grid%km,grid%jfirstxy:grid%jlastxy) + real(r8):: dummy_pelnxy(grid%ifirstxy:grid%ilastxy,grid%km+1, & + grid%jfirstxy:grid%jlastxy) + + integer :: i, ib, k, m, j, lchnk ! indices + integer :: ncol ! number of columns in current chunk + integer :: lats(pcols) ! array of latitude indices + integer :: lons(pcols) ! array of longitude indices + integer :: blksiz ! number of columns in 2D block + integer :: tsize ! amount of data per grid point passed to physics + integer, allocatable, dimension(:,:) :: bpter + ! offsets into block buffer for unpacking data + integer :: cpter(pcols,0:pver) ! offsets into chunk buffer for packing data + + real(r8) :: dt5 + real(r8), allocatable, dimension(:) :: & + bbuffer, cbuffer ! transpose buffers +#if (! defined SPMD) + integer :: block_buf_nrecs = 0 + integer :: chunk_buf_nrecs = 0 + logical :: local_dp_map=.true. +#endif + integer :: km, iam + integer :: ifirstxy, ilastxy, jfirstxy, jlastxy + + real(r8) :: cappa3v( grid%ifirstxy:grid%ilastxy,& + grid%jfirstxy:grid%jlastxy, grid%km ) + + dyn_state => get_dyn_state() + +! Pull the variables out of the dynamics export container + + psxy => dyn_in%ps + u3sxy => dyn_in%u3s + v3sxy => dyn_in%v3s + t3xy => dyn_in%t3 + ptxy => dyn_in%pt + tracer => dyn_in%tracer + + pexy => dyn_in%pe + delpxy => dyn_in%delp + pkxy => dyn_in%pk + pkzxy => dyn_in%pkz + + km = grid%km + + ifirstxy = grid%ifirstxy + ilastxy = grid%ilastxy + jfirstxy = grid%jfirstxy + jlastxy = grid%jlastxy + + iam = grid%iam + +!---------------------------End Local workspace------------------------- + +#if ( defined OFFLINE_DYN ) +! +! set the dyn flds to offline meteorological data +! + call get_met_fields( phys_state, phys_tend, dtime ) +#endif +! ------------------------------------------------------------------------- +! Copy temperature, tendencies and constituents to dynamics data structures +! ------------------------------------------------------------------------- + +! ------------------------------------------------------------------------- +! Copy onto xy decomposition, then transpose to yz decomposition +! ------------------------------------------------------------------------- + + if (local_dp_map) then + +!$omp parallel do private(lchnk, i, k, ncol, m, lons, lats) + + do lchnk = begchunk,endchunk + ncol = get_ncols_p(lchnk) + call get_lon_all_p(lchnk, ncol, lons) + call get_lat_all_p(lchnk, ncol, lats) + + do k = 1, km + do i = 1, ncol + dvdtxy(lons(i),k,lats(i)) = phys_tend(lchnk)%dvdt(i,k) + dudtxy(lons(i),k,lats(i)) = phys_tend(lchnk)%dudt(i,k) + ptxy (lons(i),lats(i),k) = phys_state(lchnk)%t(i,k) + delpxy(lons(i),lats(i),k) = phys_state(lchnk)%pdel(i,k) + enddo + enddo + + do m=1,pcnst + do k=1,km + do i=1,ncol + tracer(lons(i),lats(i),k,m) = & + phys_state(lchnk)%q(i,k,m) + end do + end do + end do + + enddo + + else + + tsize = 4 + pcnst + + blksiz = (jlastxy-jfirstxy+1)*(ilastxy-ifirstxy+1) + allocate(bpter(blksiz,0:km)) + allocate(bbuffer(tsize*block_buf_nrecs)) + allocate(cbuffer(tsize*chunk_buf_nrecs)) + +!$omp parallel do private (lchnk, ncol, i, k, m, cpter) + do lchnk = begchunk,endchunk + ncol = get_ncols_p(lchnk) + + call chunk_to_block_send_pters(lchnk,pcols,km+1,tsize,cpter) + + do i=1,ncol + cbuffer(cpter(i,0):cpter(i,0)+3+pcnst) = 0.0_r8 + end do + + do k=1,km + do i=1,ncol + + cbuffer(cpter(i,k)) = phys_tend(lchnk)%dvdt(i,k) + cbuffer(cpter(i,k)+1) = phys_tend(lchnk)%dudt(i,k) + cbuffer(cpter(i,k)+2) = phys_state(lchnk)%t(i,k) + cbuffer(cpter(i,k)+3) = phys_state(lchnk)%pdel(i,k) + + do m=1,pcnst + cbuffer(cpter(i,k)+3+m) = phys_state(lchnk)%q(i,k,m) + end do + + end do + + end do + + end do + + call t_barrierf('sync_chk_to_blk', grid%commxy) + call t_startf ('chunk_to_block') + call transpose_chunk_to_block(tsize, cbuffer, bbuffer) + call t_stopf ('chunk_to_block') + + if (iam .lt. grid%npes_xy) then + call chunk_to_block_recv_pters(iam+1,blksiz,km+1,tsize,bpter) + endif + +!$omp parallel do private (j, i, ib, k, m) + do j=jfirstxy,jlastxy + do k=1,km + do i=ifirstxy,ilastxy + ib = (j-jfirstxy)*(ilastxy-ifirstxy+1) + (i-ifirstxy+1) + + dvdtxy(i,k,j) = bbuffer(bpter(ib,k)) + dudtxy(i,k,j) = bbuffer(bpter(ib,k)+1) + ptxy (i,j,k) = bbuffer(bpter(ib,k)+2) + delpxy(i,j,k) = bbuffer(bpter(ib,k)+3) + + do m=1,pcnst + tracer(i,j,k,m) = bbuffer(bpter(ib,k)+3+m) + end do + + enddo + enddo + enddo + + deallocate(bpter) + deallocate(bbuffer) + deallocate(cbuffer) + + endif + +! WS: 02.08.06: Update t3 to temperature +!$omp parallel do private(i,j,k) + do k=1,km + do j = jfirstxy,jlastxy + do i = ifirstxy,ilastxy + t3xy(i,j,k) = ptxy(i,j,k) + enddo + enddo + enddo + +! ------------------------------------------------------------------------- +! Update u3s and v3s from tendencies dudt and dvdt. +! ------------------------------------------------------------------------- + dt5 = D0_5*dtime + + call t_barrierf('sync_uv3s_update', grid%commxy) + call t_startf('uv3s_update') + if (iam .lt. grid%npes_xy) then + call uv3s_update(grid, dudtxy, u3sxy, dvdtxy, v3sxy, dt5, & + dyn_state%am_correction) + end if ! (iam .lt. grid%npes_xy) + call t_stopf('uv3s_update') + +! ------------------------------------------------------------------------- +! Compute pt, q3, pe, delp, ps, peln, pkz and pk. +! For 2-D decomposition, delp is transposed to delpxy, pexy is computed +! from delpxy (and ptop), and pexy is transposed back to pe. +! Note that pt, q3, delp and pe are input parameters as well. +! ------------------------------------------------------------------------- + call t_barrierf('sync_p_d_adjust', grid%commxy) + call t_startf ('p_d_adjust') + if (iam .lt. grid%npes_xy) then + if (grid%high_alt) then + call physconst_calc_kappav(ifirstxy,ilastxy,jfirstxy,jlastxy,1,km, grid%ntotq, tracer, cappa3v ) + else + cappa3v = cappa + endif + call p_d_adjust(grid, tracer, dummy_pelnxy, pkxy, pkzxy, zvir, cappa3v, & + delpxy, ptxy, pexy, psxy, ptop) + end if ! (iam .lt. grid%npes_xy) + call t_stopf ('p_d_adjust') + +!EOC + end subroutine p_d_coupling +!----------------------------------------------------------------------- +end module dp_coupling diff --git a/src/NorESM/fv/metdata.F90 b/src/NorESM/fv/metdata.F90 new file mode 100644 index 0000000000..fd8faafcdf --- /dev/null +++ b/src/NorESM/fv/metdata.F90 @@ -0,0 +1,2445 @@ +module metdata +!----------------------------------------------------------------------- +! +! BOP +! +! !MODULE: metdata +! +! !DESCRIPTION +! Handles reading and interpolating offline meteorological data which +! is used to drive the dynamics. +! +! !USES + use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 + use shr_cal_mod, only: shr_cal_gregorian + use time_manager, only: get_curr_date, get_step_size, timemgr_is_caltype + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, begchunk, endchunk + use time_manager, only: get_curr_calday, get_curr_date, get_step_size + use cam_abortutils, only: endrun + use dynamics_vars, only: T_FVDYCORE_GRID + +#if ( defined SPMD ) + use mpishorthand, only: mpicom, mpir8, mpiint,mpichar + use mod_comm, only: mp_sendirr,mp_recvirr +#endif + use perf_mod + use cam_logfile, only: iulog + use pio, only: file_desc_t, pio_put_att, pio_global, pio_get_att, pio_inq_att, & + pio_inq_dimid, pio_inq_dimlen, pio_closefile, pio_get_var, pio_inq_varid, & + pio_offset_kind + use cam_pio_utils, only: cam_pio_openfile + + + implicit none + + private ! all unless made public + save + +! !PUBLIC MEMBERS + + public :: metdata_dyn_init ! subroutine to open files, allocate blocked arrays, etc + public :: metdata_phys_init ! subroutine to allocate chunked arrays + public :: advance_met ! subroutine to read more data and interpolate + public :: get_met_fields ! interface to set meteorology fields + public :: get_met_srf1 + public :: get_met_srf2 + public :: get_us_vs + public :: metdata_readnl + public :: met_winds_on_walls + public :: write_met_restart + public :: read_met_restart + public :: met_rlx + public :: met_fix_mass + public :: met_srf_feedback + !++ IH + public :: met_nudge_only_uvps + !-- IH + + interface write_met_restart + Module procedure write_met_restart_bin + Module procedure write_met_restart_pio + end interface + + interface read_met_restart + Module procedure read_met_restart_bin + Module procedure read_met_restart_pio + end interface + + + !------------------------------------------------------------------ + ! Interface to access the meteorology fields. Possible invocations + ! are as follows: + ! call get_met_fields( physics_state, us, vs , tend, dt ) + ! call get_met_fields( u, v ) + ! call get_met_fields( cam_in_t ) + !------------------------------------------------------------------ + Interface get_met_fields ! overload accessors + Module Procedure get_dyn_flds + Module Procedure get_uv_centered + Module Procedure get_ps + Module Procedure get_ocn_ice_frcs + End Interface + + real(r8), allocatable :: met_ps_next(:,:) ! PS interpolated to next timestep + real(r8), allocatable :: met_ps_curr(:,:) ! PS interpolated to next timestep + + logical :: met_cell_wall_winds = .false. ! true => met data winds are defined on model grid cell walls + logical :: met_remove_file = .false. ! delete metdata file when finished with it + + character(len=16) :: met_shflx_name = 'SHFLX' + character(len=16) :: met_qflx_name = 'QFLX' + real(r8) :: met_snowh_factor = 1._r8 + real(r8) :: met_shflx_factor = 1._r8 + real(r8) :: met_qflx_factor = 1._r8 + logical :: met_srf_feedback = .true. + logical :: met_srf_nudge_flux = .true. ! wsx, wsy, shf, and cflx nudged rather than forced. + ! This is done primarily to prevent unrealistic + ! surface temperatures. + + logical :: met_srf_land = .true. ! nudge surface fields over land (if false ignores + ! all surface nudging for gridboxes with LANDFRAC=1) + logical :: met_srf_land_scale = .false. ! when met_srf_land is false, nudges proportional + ! to the non land fraction, rather than just where + ! LANDFRAC=1 + logical :: met_srf_rad = .false. ! nudge albedo and lwup? + logical :: met_srf_refs = .false. ! nudge 2m Q and T and 10m wind + logical :: met_srf_sst = .false. ! nudge sea surface temperature + logical :: met_srf_tau = .true. ! nudge taux and tauy + logical :: met_nudge_temp = .true. ! nudge atmospheric temperature + + + ! radiation/albedo surface field fill value (where there is no sunlight) read in from input data file + real(r8) :: srf_fill_value + + !++ IH + logical :: met_nudge_only_uvps = .true. ! When true, only U, V and PS is nudged. + ! When false, other variables can also be nudged + ! (T, Q, TAUY, TAUX, SHFLX, QFLX, TS, SHOWH,...) + !-- IH + +! !REVISION HISTORY: +! 31 Oct 2003 Francis Vitt Creation +! 05 Feb 2004 F Vitt Removed reading/inperpolating PS for current timestep +! -- only met_ps_next is needed +! 10 Nov 2004 F Vitt Implemented ability to read from series of files +! 16 Dec 2004 F Vitt Added offline_met_defaultopts and offline_met_setopts +! 14 Jul 2005 W Sawyer Removed pmgrid, spmd_dyn dependencies +! 12 Apr 2006 W Sawyer Removed unneeded ghosting of met_us, met_vs +! 08 Apr 2010 J Edwards Replaced serial netcdf calls with pio interface +! 16 Sep 2016 IH Karset Implemented ability to nudge only U, V and PS and change +! the relaxation time +! +! EOP +!----------------------------------------------------------------------- +! $Id$ +! $Author$ +!----------------------------------------------------------------------- + + type input2d + real(r8), dimension(:,:), pointer :: data => null() + endtype input2d + + type input3d + real(r8), dimension(:,:,:), pointer :: data => null() + endtype input3d + + real(r8), allocatable :: met_t(:,:,:) ! interpolated temperature + real(r8), allocatable :: met_u(:,:,:) ! interpolated zonal wind + real(r8), allocatable :: met_v(:,:,:) ! interpolated meridional wind + real(r8), allocatable :: met_us(:,:,:) ! interpolated zonal wind -staggered + real(r8), allocatable :: met_vs(:,:,:) ! interpolated meridional wind -staggered + real(r8), allocatable :: met_q(:,:,:) ! interpolated water vapor + + real(r8), allocatable :: met_lhflx(:,:)! interpolated latent heat flux + real(r8), allocatable :: met_shflx(:,:)! interpolated sensible heat flux + real(r8), allocatable :: met_qflx(:,:) ! interpolated water vapor flux + real(r8), allocatable :: met_taux(:,:) ! interpolated + real(r8), allocatable :: met_tauy(:,:) ! interpolated + real(r8), allocatable :: met_snowh(:,:) ! interpolated snow height + + real(r8), allocatable :: met_ts(:,:) ! interpolated + + real(r8), allocatable :: met_asdir(:,:) ! interpolated VIS direct albedo + real(r8), allocatable :: met_asdif(:,:) ! interpolated VIS diffuse albedo + real(r8), allocatable :: met_aldir(:,:) ! interpolated NIR direct albedo + real(r8), allocatable :: met_aldif(:,:) ! interpolated NIR diffuse albedo + real(r8), allocatable :: met_lwup(:,:) ! interpolated upwelling LW flux + real(r8), allocatable :: met_sst(:,:) ! interpolated sea surface temperature + real(r8), allocatable :: met_icefrac(:,:) ! interpolated ice fraction + real(r8), allocatable :: met_qref(:,:) ! interpolated reference (2m) specific humidity + real(r8), allocatable :: met_tref(:,:) ! interpolated reference (2m) temperature + real(r8), allocatable :: met_u10(:,:) ! interpolated 10m wind speed + + type(input3d) :: met_ti(2) + type(input3d) :: met_ui(2) + type(input3d) :: met_vi(2) + type(input3d) :: met_usi(2) + type(input3d) :: met_vsi(2) + type(input3d) :: met_qi(2) + + type(input2d) :: met_psi_next(2) + type(input2d) :: met_psi_curr(2) + type(input2d) :: met_lhflxi(2) + type(input2d) :: met_shflxi(2) + type(input2d) :: met_qflxi(2) + type(input2d) :: met_tauxi(2) + type(input2d) :: met_tauyi(2) + type(input2d) :: met_tsi(2) + type(input2d) :: met_snowhi(2) + type(input2d) :: met_asdiri(2) + type(input2d) :: met_asdifi(2) + type(input2d) :: met_aldiri(2) + type(input2d) :: met_aldifi(2) + type(input2d) :: met_lwupi(2) + type(input2d) :: met_ssti(2) + type(input2d) :: met_icefraci(2) + type(input2d) :: met_qrefi(2) + type(input2d) :: met_trefi(2) + type(input2d) :: met_u10i(2) + + integer :: dateid ! var id of the date in the netCDF + integer :: secid ! var id of the sec data + real(r8) :: datatimem = -1.e36_r8 ! time of prv. values read in + real(r8) :: datatimep = -1.e36_r8 ! time of nxt. values read in + real(r8) :: datatimemn = -1.e36_r8 ! time of prv. values read in for next timestep + real(r8) :: datatimepn = -1.e36_r8 ! time of nxt. values read in for next timestep + + integer, parameter :: nm=1 ! array index for previous (minus) data + integer, parameter :: np=2 ! array indes for next (plus) data + + real(r8) :: curr_mod_time ! model time - calendar day + real(r8) :: next_mod_time ! model time - calendar day - next time step + + character(len=256) :: curr_filename, next_filename, met_data_file + character(len=256) :: met_filenames_list = '' + character(len=256) :: met_data_path = '' + type(file_desc_t) :: curr_fileid, next_fileid ! the id of the NetCDF file + real(r8), pointer, dimension(:) :: curr_data_times => null() + real(r8), pointer, dimension(:) :: next_data_times => null() + + real(r8) :: alpha = 1.0_r8 ! don't read in water vapor + ! real(r8), private :: alpha = 0.0 ! read in water vaper each time step + + real(r8), parameter :: D0_0 = 0.0_r8 + real(r8), parameter :: D0_5 = 0.5_r8 + real(r8), parameter :: D0_75 = 0.75_r8 + real(r8), parameter :: D1_0 = 1.0_r8 + real(r8), parameter :: days_per_month = 30.6_r8 + real(r8), parameter :: days_per_non_leapyear = 365.0_r8 + real(r8), parameter :: days_per_year = 365.25_r8 + real(r8), parameter :: seconds_per_day = 86400.0_r8 + real(r8), parameter :: fill_value = -9999.0_r8 + + logical :: online_test = .false. + logical :: debug = .false. + + real(r8) :: met_rlx(pver) + integer :: met_levels + integer :: num_met_levels + + real(r8) :: met_rlx_top = 60._r8 + real(r8) :: met_rlx_bot = 50._r8 + + real(r8) :: met_rlx_bot_top = 0._r8 + real(r8) :: met_rlx_bot_bot = 0._r8 + + real(r8) :: met_rlx_time = 0._r8 + +#if ( defined OFFLINE_DYN ) + logical :: met_fix_mass = .true. +#else + logical :: met_fix_mass = .false. +#endif + logical :: has_ts = .false. + logical :: has_lhflx = .false. ! Is LHFLX present in the met file? + +contains + +!------------------------------------------------------------------------- +! meteorology data options +!------------------------------------------------------------------------- + subroutine metdata_readnl(nlfile) + + 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 + character(len=*), parameter :: subname = 'metdata_readnl' + + namelist /metdata_nl/ & + met_data_file, & + met_data_path, & + met_remove_file, & + met_cell_wall_winds, & + met_filenames_list, & + met_rlx_top, & + met_rlx_bot, & + met_rlx_bot_top, & + met_rlx_bot_bot, & + met_rlx_time, & + !++ IH: new option for uvps + met_nudge_only_uvps, & + !-- IH + met_fix_mass, & + met_shflx_name, & + met_shflx_factor, & + met_snowh_factor, & + met_qflx_name, & + met_qflx_factor, & + met_srf_feedback, & + met_srf_nudge_flux, & + met_srf_land, & + met_srf_land_scale, & + met_srf_rad, & + met_srf_refs, & + met_srf_sst, & + met_srf_tau, & + met_nudge_temp + + ! Read namelist + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'metdata_nl', status=ierr) + if (ierr == 0) then + read(unitn, metdata_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + +#if ( defined SPMD ) + + ! Broadcast namelist variables + + call mpibcast (met_data_file ,len(met_data_file) ,mpichar,0,mpicom) + call mpibcast (met_data_path ,len(met_data_path) ,mpichar,0,mpicom) + call mpibcast (met_remove_file ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_cell_wall_winds,1 ,mpilog, 0, mpicom ) + call mpibcast (met_filenames_list ,len(met_filenames_list),mpichar,0,mpicom) + call mpibcast (met_rlx_top, 1 ,mpir8, 0, mpicom ) + call mpibcast (met_rlx_bot, 1 ,mpir8, 0, mpicom ) + call mpibcast (met_rlx_bot_top, 1 ,mpir8, 0, mpicom ) + call mpibcast (met_rlx_bot_bot, 1 ,mpir8, 0, mpicom ) + call mpibcast (met_rlx_time, 1 ,mpir8, 0, mpicom ) + call mpibcast (met_fix_mass, 1 ,mpilog, 0, mpicom ) + call mpibcast (met_qflx_name ,len(met_qflx_name), mpichar,0,mpicom) + call mpibcast (met_shflx_name ,len(met_shflx_name), mpichar,0,mpicom) + call mpibcast (met_qflx_factor ,1, mpir8, 0, mpicom ) + call mpibcast (met_shflx_factor ,1, mpir8, 0, mpicom ) + call mpibcast (met_snowh_factor ,1, mpir8, 0, mpicom ) + call mpibcast (met_srf_feedback ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_nudge_flux ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_land ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_land_scale ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_rad ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_refs ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_sst ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_srf_tau ,1 ,mpilog, 0, mpicom ) + call mpibcast (met_nudge_temp ,1 ,mpilog, 0, mpicom ) + !++ IH + call mpibcast (met_nudge_only_uvps ,1 ,mpilog, 0, mpicom ) + !-- IH +#endif + + if (masterproc) then + write(iulog,*)'Time-variant meteorological dataset (met_data_file) is: ', trim(met_data_file) + write(iulog,*)'Meteorological data file will be removed (met_remove_file): ', met_remove_file + write(iulog,*)'Meteorological winds are on cell walls (met_cell_wall_winds): ', met_cell_wall_winds + write(iulog,*)'Meteorological file names list file: ', trim(met_filenames_list) + write(iulog,*)'Meteorological relax ramp region top at top is (km): ', met_rlx_top + write(iulog,*)'Meteorological relax ramp region bottom at top is (km): ', met_rlx_bot + write(iulog,*)'Meteorological relax ramp region top at bottom is (km): ', met_rlx_bot_top + write(iulog,*)'Meteorological relax ramp region bottom at bottom is (km): ', met_rlx_bot_bot + write(iulog,*)'Meteorological relaxation time (hours): ',met_rlx_time + write(iulog,*)'Offline driver mass fixer is trurned on (met_fix_mass): ',met_fix_mass + write(iulog,*)'Meteorological shflx field name : ', trim(met_shflx_name) + write(iulog,*)'Meteorological shflx multiplication factor : ', met_shflx_factor + write(iulog,*)'Meteorological qflx field name : ', trim(met_qflx_name) + write(iulog,*)'Meteorological qflx multiplication factor : ', met_qflx_factor + write(iulog,*)'Meteorological snowh multiplication factor : ', met_snowh_factor + write(iulog,*)'Meteorological allow srf models feedbacks : ', met_srf_feedback + write(iulog,*)'Meteorological allow srf land nudging : ', met_srf_land + write(iulog,*)'Meteorological scale srf land nudging : ', met_srf_land_scale + write(iulog,*)'Meteorological allow srf radiation nudging : ', met_srf_rad + write(iulog,*)'Meteorological allow srf reference field nudging : ', met_srf_refs + write(iulog,*)'Meteorological allow srf sst nudging : ', met_srf_sst + write(iulog,*)'Meteorological allow srf tau nudging : ', met_srf_tau + write(iulog,*)'Meteorological allow atm tempature nudging : ',met_nudge_temp + !++ IH + write(iulog,*)'Meteorological fields to nudge (u, v and ps, or more) : ', met_nudge_only_uvps + !-- IH + endif + + end subroutine metdata_readnl + +!-------------------------------------------------------------------------- +! Opens file, allocates arrays +!-------------------------------------------------------------------------- + subroutine metdata_dyn_init(grid) + use infnan, only : nan, assignment(=) + use cam_control_mod, only : restart_run + implicit none + +! !INPUT PARAMETERS: + type (T_FVDYCORE_GRID), intent(in) :: grid + + + integer :: im, km, jfirst, jlast, kfirst, klast + integer :: ng_d, ng_s + + im = grid%im + km = grid%km + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + ng_d = grid%ng_d + ng_s = grid%ng_s + + + if (.not. restart_run) then ! initial run or branch run + curr_filename = met_data_file + next_filename = '' + else + ! restart run + ! curr_filename & next_filename already set by restart_dynamics + endif + + call open_met_datafile( curr_filename, curr_fileid, curr_data_times, met_data_path, check_dims=.true., grid=grid) + + if ( len_trim(next_filename) > 0 ) & + call open_met_datafile( next_filename, next_fileid, next_data_times, met_data_path ) + +! +! allocate space for data arrays ... +! + ! dynamics grid + + allocate( met_psi_next(nm)%data(im, jfirst:jlast) ) + allocate( met_psi_next(np)%data(im, jfirst:jlast) ) + allocate( met_psi_curr(nm)%data(im, jfirst:jlast) ) + allocate( met_psi_curr(np)%data(im, jfirst:jlast) ) + allocate( met_ps_next(im, jfirst:jlast) ) + allocate( met_ps_curr(im, jfirst:jlast) ) + + allocate( met_us(im, jfirst-ng_d:jlast+ng_s, kfirst:klast) ) + allocate( met_vs(im, jfirst-ng_s:jlast+ng_d, kfirst:klast) ) + + met_us = nan + met_vs = nan + + if (met_cell_wall_winds) then + allocate( met_usi(nm)%data(im, jfirst:jlast, kfirst:klast) ) + allocate( met_usi(np)%data(im, jfirst:jlast, kfirst:klast) ) + allocate( met_vsi(nm)%data(im, jfirst:jlast, kfirst:klast) ) + allocate( met_vsi(np)%data(im, jfirst:jlast, kfirst:klast) ) + endif + + if (.not. met_cell_wall_winds) then + + allocate( met_u(im, jfirst-ng_d:jlast+ng_d, kfirst:klast) ) + allocate( met_ui(nm)%data(im, jfirst:jlast, kfirst:klast) ) + allocate( met_ui(np)%data(im, jfirst:jlast, kfirst:klast) ) + + allocate( met_v(im, jfirst-ng_s:jlast+ng_d, kfirst:klast) ) + allocate( met_vi(nm)%data(im, jfirst:jlast, kfirst:klast) ) + allocate( met_vi(np)%data(im, jfirst:jlast, kfirst:klast) ) + + endif + + end subroutine metdata_dyn_init + +!================================================================================= + + subroutine metdata_phys_init + use infnan, only : nan, assignment(=) + use cam_history, only : addfld, horiz_only + + call addfld ('MET_RLX', (/ 'lev' /), 'A', ' ', 'Meteorology relax function', gridname='fv_centers') + call addfld ('MET_TAUX', horiz_only, 'A', ' ', 'Meteorology taux', gridname='physgrid') + call addfld ('MET_TAUY', horiz_only, 'A', ' ', 'Meteorology tauy', gridname='physgrid') + call addfld ('MET_LHFX', horiz_only, 'A', ' ', 'Meteorology lhflx', gridname='physgrid') + call addfld ('MET_SHFX', horiz_only, 'A', ' ', 'Meteorology shflx', gridname='physgrid') + call addfld ('MET_QFLX', horiz_only, 'A', ' ', 'Meteorology qflx', gridname='physgrid') + call addfld ('MET_PS', horiz_only, 'A', ' ', 'Meteorology PS', gridname='fv_centers') + call addfld ('MET_T', (/ 'lev' /), 'A', ' ', 'Meteorology T', gridname='physgrid') + call addfld ('MET_U', (/ 'lev' /), 'A', ' ', 'Meteorology U', gridname='fv_centers') + call addfld ('MET_V', (/ 'lev' /), 'A', ' ', 'Meteorology V', gridname='fv_centers') + call addfld ('MET_SNOWH', horiz_only, 'A', ' ', 'Meteorology snow height', gridname='physgrid') + + call addfld ('MET_TS', horiz_only, 'A', 'K', 'Meteorology TS', gridname='physgrid') + call addfld ('MET_OCNFRC', horiz_only, 'A', 'fraction', 'Ocean frac derived from met TS', gridname='physgrid') + call addfld ('MET_ICEFRC', horiz_only, 'A', 'fraction', 'Sea ice frac derived from met TS', gridname='physgrid') + + call addfld ('MET_ASDIR', horiz_only, 'A', '1', 'Meteorology ASDIR', gridname='physgrid') + call addfld ('MET_ASDIF', horiz_only, 'A', '1', 'Meteorology ASDIF', gridname='physgrid') + call addfld ('MET_ALDIR', horiz_only, 'A', '1', 'Meteorology ALDIR', gridname='physgrid') + call addfld ('MET_ALDIF', horiz_only, 'A', '1', 'Meteorology ALDIF', gridname='physgrid') + call addfld ('MET_LWUP', horiz_only, 'A', 'Wm-2', 'Meteorology LWUP', gridname='physgrid') + call addfld ('MET_SST', horiz_only, 'A', 'K', 'Meteorology SST', gridname='physgrid') + call addfld ('MET_ICEFRAC', horiz_only, 'A', 'K', 'Meteorology ICEFRAC', gridname='physgrid') + call addfld ('MET_QREF', horiz_only, 'A', 'kg/kg', 'Meteorology QREF', gridname='physgrid') + call addfld ('MET_TREF', horiz_only, 'A', 'K', 'Meteorology TREF', gridname='physgrid') + call addfld ('MET_U10', horiz_only, 'A', 'ms-1', 'Meteorology U10', gridname='physgrid') + +! allocate chunked arrays + + allocate( met_ti(nm)%data(pcols,pver,begchunk:endchunk) ) + allocate( met_ti(np)%data(pcols,pver,begchunk:endchunk) ) + allocate( met_t(pcols,pver,begchunk:endchunk) ) + + allocate( met_qi(nm)%data(pcols,pver,begchunk:endchunk) ) + allocate( met_qi(np)%data(pcols,pver,begchunk:endchunk) ) + allocate( met_q(pcols,pver,begchunk:endchunk) ) + + allocate( met_lhflxi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_lhflxi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_lhflx(pcols,begchunk:endchunk) ) + + allocate( met_shflxi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_shflxi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_shflx(pcols,begchunk:endchunk) ) + + allocate( met_qflxi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_qflxi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_qflx(pcols,begchunk:endchunk) ) + + allocate( met_tauxi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_tauxi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_taux(pcols,begchunk:endchunk) ) + + allocate( met_tauyi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_tauyi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_tauy(pcols,begchunk:endchunk) ) + + allocate( met_tsi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_tsi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_ts(pcols,begchunk:endchunk) ) + met_ts(:,:) = nan + + if(.not.met_srf_feedback) then + allocate( met_snowhi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_snowhi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_snowh(pcols,begchunk:endchunk) ) + met_snowh(:,:) = nan + endif + + if(met_srf_rad) then + allocate( met_asdiri(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_asdiri(np)%data(pcols,begchunk:endchunk) ) + allocate( met_asdir(pcols,begchunk:endchunk) ) + + allocate( met_asdifi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_asdifi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_asdif(pcols,begchunk:endchunk) ) + + allocate( met_aldiri(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_aldiri(np)%data(pcols,begchunk:endchunk) ) + allocate( met_aldir(pcols,begchunk:endchunk) ) + + allocate( met_aldifi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_aldifi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_aldif(pcols,begchunk:endchunk) ) + + allocate( met_lwupi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_lwupi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_lwup(pcols,begchunk:endchunk) ) + end if + + if(met_srf_refs) then + allocate( met_qrefi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_qrefi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_qref(pcols,begchunk:endchunk) ) + + allocate( met_trefi(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_trefi(np)%data(pcols,begchunk:endchunk) ) + allocate( met_tref(pcols,begchunk:endchunk) ) + + allocate( met_u10i(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_u10i(np)%data(pcols,begchunk:endchunk) ) + allocate( met_u10(pcols,begchunk:endchunk) ) + end if + + if(met_srf_sst) then + allocate( met_ssti(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_ssti(np)%data(pcols,begchunk:endchunk) ) + allocate( met_sst(pcols,begchunk:endchunk) ) + + allocate( met_icefraci(nm)%data(pcols,begchunk:endchunk) ) + allocate( met_icefraci(np)%data(pcols,begchunk:endchunk) ) + allocate( met_icefrac(pcols,begchunk:endchunk) ) + end if + + call set_met_rlx() + + ! initialize phys surface fields... + call get_model_time() + call check_files() + call read_phys_srf_flds() + call interp_phys_srf_flds() + datatimem = -1.e36_r8 + datatimep = -1.e36_r8 + end subroutine metdata_phys_init + + +!----------------------------------------------------------------------- +! Reads more data if needed and interpolates data to current model time +!----------------------------------------------------------------------- + subroutine advance_met(grid) + use cam_history, only : outfld + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + + real(r8) :: met_rlx_2d(grid%ifirstxy:grid%ilastxy,grid%km) + integer :: i,j,k, idim + + call t_startf('MET__advance') + +! +! + call get_model_time() + + if ( ( curr_mod_time > datatimep ) .or. & + ( next_mod_time > datatimepn ) ) then + call check_files() + endif + + if ( curr_mod_time > datatimep ) then + call read_next_metdata(grid) + end if + + if ( next_mod_time > datatimepn ) then + call read_next_ps(grid) + end if + +! need to inperpolate the data, regardless ! +! each mpi tasks needs to interpolate + call interpolate_metdata(grid) + + call t_stopf('MET__advance') + + idim = grid%ilastxy - grid%ifirstxy + 1 + do j = grid%jfirstxy, grid%jlastxy + do k = 1, grid%km + do i = grid%ifirstxy, grid%ilastxy + met_rlx_2d(i,k) = met_rlx(k) + enddo + enddo + call outfld('MET_RLX',met_rlx_2d, idim, j) + enddo + end subroutine advance_met + +!------------------------------------------------------------------- +! Method to get some the meteorology data. +! Sets the following cam_in_t member fields to the +! meteorology data : +! qflx +! lhflx +! shflx +! taux +! tauy +! snowh +!------------------------------------------------------------------- + subroutine get_met_srf2( cam_in ) + use camsrfexch, only: cam_in_t + use phys_grid, only: get_ncols_p + use cam_history, only: outfld + use shr_const_mod, only: shr_const_stebol + use physconst, only: latvap, latice + + implicit none + + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + + integer :: c,ncol,i + real(r8) :: met_rlx_sfc(pcols) + real(r8) :: lcl_rlx(pcols) + + !++ IH don't nudge the stress and the heat fluxes if met_nudge_only_uvps is true + if (.not. met_nudge_only_uvps) then + !-- IH + do c=begchunk,endchunk + ncol = get_ncols_p(c) + + ! Nudge or force the surface fields? + if (met_srf_nudge_flux) then + met_rlx_sfc(:ncol) = met_rlx(pver) + else + met_rlx_sfc(:ncol) = 1._r8 + end if + + ! Don't nudge the surface for locations that are entirely land? + if (.not. met_srf_land) then + + ! Nudging land and forcing ocean. + if (met_srf_land_scale) then + met_rlx_sfc(:ncol) = (1._r8 - cam_in(c)%landfrac(:ncol)) * met_rlx_sfc(:ncol) + cam_in(c)%landfrac(:ncol) * met_rlx(pver) + else + where(cam_in(c)%landfrac(:ncol) .eq. 1._r8) met_rlx_sfc(:ncol) = 0._r8 + end if + end if + + if (met_srf_tau) then + cam_in(c)%wsx(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%wsx(:ncol) + met_rlx_sfc(:ncol) * met_taux(:ncol,c) + cam_in(c)%wsy(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%wsy(:ncol) + met_rlx_sfc(:ncol) * met_tauy(:ncol,c) + end if + + cam_in(c)%shf(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%shf(:ncol) + & + met_rlx_sfc(:ncol) * (met_shflx(:ncol,c) * met_shflx_factor) + cam_in(c)%cflx(:ncol,1) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%cflx(:ncol,1) + & + met_rlx_sfc(:ncol) * (met_qflx(:ncol,c) * met_qflx_factor) + + ! If present, nudge the latent heat; otherwise, make an approximation by scaling the + ! water vapor flux. + if (has_lhflx) then + cam_in(c)%lhf(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%lhf(:ncol) + & + met_rlx_sfc(:ncol) * (met_lhflx(:ncol,c) * met_qflx_factor) + else + cam_in(c)%lhf(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%lhf(:ncol) + & + met_rlx_sfc(:ncol) * (met_qflx(:ncol,c) * met_qflx_factor * latvap) + end if + + if (met_srf_rad) then + + ! There can be fill values in the albedos from the met fields, so use the cam_in value + ! if fill is detected. This could be jumpy if that value gets used, but should be in + ! an area with no downwelling solar. Time interpolate around the terminator could cause + ! problems, but the interpolation provides a non-fill value if either endpoint of the + ! interpolation is not fill. + lcl_rlx(:ncol) = met_rlx_sfc(:ncol) + where(met_asdir(:ncol,c) .eq. srf_fill_value) lcl_rlx(:ncol) = 0._r8 + cam_in(c)%asdir(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%asdir(:ncol) + lcl_rlx(:ncol) * met_asdir(:ncol,c) + + lcl_rlx(:ncol) = met_rlx_sfc(:ncol) + where(met_asdif(:ncol,c) .eq. srf_fill_value) lcl_rlx(:ncol) = 0._r8 + cam_in(c)%asdif(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%asdif(:ncol) + lcl_rlx(:ncol) * met_asdif(:ncol,c) + + lcl_rlx(:ncol) = met_rlx_sfc(:ncol) + where(met_aldir(:ncol,c) .eq. srf_fill_value) lcl_rlx(:ncol) = 0._r8 + cam_in(c)%aldir(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%aldir(:ncol) + lcl_rlx(:ncol) * met_aldir(:ncol,c) + + lcl_rlx(:ncol) = met_rlx_sfc(:ncol) + where(met_aldif(:ncol,c) .eq. srf_fill_value) lcl_rlx(:ncol) = 0._r8 + cam_in(c)%aldif(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%aldif(:ncol) + lcl_rlx(:ncol) * met_aldif(:ncol,c) + + cam_in(c)%lwup(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%lwup(:ncol) + met_rlx_sfc(:ncol) * met_lwup(:ncol,c) + end if + + if (met_srf_refs) then + cam_in(c)%qref(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%qref(:ncol) + met_rlx_sfc(:ncol) * met_qref(:ncol,c) + cam_in(c)%tref(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%tref(:ncol) + met_rlx_sfc(:ncol) * met_tref(:ncol,c) + cam_in(c)%u10(:ncol) = (1._r8-met_rlx_sfc(:ncol)) * cam_in(c)%u10(:ncol) + met_rlx_sfc(:ncol) * met_u10(:ncol,c) + end if + + if (met_srf_sst) then + + ! Meteorological sst is 0 over 100% land, so use the cam_in value if the meteorology thinks + ! it is land. + lcl_rlx(:ncol) = met_rlx_sfc(:ncol) + where(met_sst(:ncol,c) .eq. srf_fill_value) lcl_rlx(:ncol) = 0._r8 + cam_in(c)%sst(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%sst(:ncol) + lcl_rlx(:ncol) * met_sst(:ncol,c) + + cam_in(c)%icefrac(:ncol) = (1._r8-lcl_rlx(:ncol)) * cam_in(c)%icefrac(:ncol) + lcl_rlx(:ncol) * met_icefrac(:ncol,c) + end if + end do ! Chunk loop + + !++ IH + end if + !-- IH + + if (debug) then + if (masterproc) then + write(iulog,*)'METDATA maxval(met_taux),minval(met_taux): ',maxval(met_taux),minval(met_taux) + write(iulog,*)'METDATA maxval(met_tauy),minval(met_tauy): ',maxval(met_tauy),minval(met_tauy) + write(iulog,*)'METDATA maxval(met_lhflx),minval(met_lhflx): ',maxval(met_lhflx),minval(met_lhflx) + write(iulog,*)'METDATA maxval(met_shflx),minval(met_shflx): ',maxval(met_shflx),minval(met_shflx) + write(iulog,*)'METDATA maxval(met_qflx),minval(met_qflx): ',maxval(met_qflx),minval(met_qflx) + write(iulog,*)'METDATA maxval(met_asdir),minval(met_asdir): ',maxval(met_asdir),minval(met_asdir) + write(iulog,*)'METDATA maxval(met_asdif),minval(met_asdif): ',maxval(met_asdif),minval(met_asdif) + write(iulog,*)'METDATA maxval(met_aldir),minval(met_aldir): ',maxval(met_aldir),minval(met_aldir) + write(iulog,*)'METDATA maxval(met_aldif),minval(met_aldif): ',maxval(met_aldif),minval(met_aldif) + write(iulog,*)'METDATA maxval(met_lwup),minval(met_lwup): ',maxval(met_lwup),minval(met_lwup) + write(iulog,*)'METDATA maxval(met_qref),minval(met_qref): ',maxval(met_qref),minval(met_qref) + write(iulog,*)'METDATA maxval(met_tref),minval(met_tref): ',maxval(met_tref),minval(met_tref) + write(iulog,*)'METDATA maxval(met_u10),minval(met_u10): ',maxval(met_u10),minval(met_u10) + write(iulog,*)'METDATA maxval(met_sst),minval(met_sst): ',maxval(met_sst),minval(met_sst) + write(iulog,*)'METDATA maxval(met_icefrac),minval(met_icefrac): ',maxval(met_icefrac),minval(met_icefrac) + endif + endif + + do c = begchunk, endchunk + call outfld('MET_TAUX',cam_in(c)%wsx , pcols ,c ) + call outfld('MET_TAUY',cam_in(c)%wsy , pcols ,c ) + call outfld('MET_LHFX',cam_in(c)%lhf , pcols ,c ) + call outfld('MET_SHFX',cam_in(c)%shf , pcols ,c ) + call outfld('MET_QFLX',cam_in(c)%cflx(:,1) , pcols ,c ) + call outfld('MET_ASDIR',cam_in(c)%asdir , pcols ,c ) + call outfld('MET_ASDIF',cam_in(c)%asdif , pcols ,c ) + call outfld('MET_ALDIR',cam_in(c)%aldir , pcols ,c ) + call outfld('MET_ALDIF',cam_in(c)%aldif , pcols ,c ) + call outfld('MET_LWUP',cam_in(c)%lwup , pcols ,c ) + call outfld('MET_QREF',cam_in(c)%qref , pcols ,c ) + call outfld('MET_TREF',cam_in(c)%tref , pcols ,c ) + call outfld('MET_U10',cam_in(c)%u10 , pcols ,c ) + call outfld('MET_SST',cam_in(c)%sst , pcols ,c ) + call outfld('MET_ICEFRAC',cam_in(c)%icefrac , pcols ,c ) + enddo + + end subroutine get_met_srf2 + +!------------------------------------------------------------------- +!------------------------------------------------------------------- + subroutine get_met_srf1( cam_in ) + use camsrfexch, only: cam_in_t + use phys_grid, only: get_ncols_p + use cam_history, only: outfld + use shr_const_mod, only: shr_const_stebol + + implicit none + + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + + integer :: c,ncol,i + + if (met_srf_feedback) return + if (.not.has_ts) then + call endrun('The meteorolgy input must have TS to run with met_srf_feedback set to FALSE') + endif + + !++ IH don't nudge TS and SNOWH if met_nudge_only_uvps is true + if (.not. met_nudge_only_uvps) then + !-- IH + do c=begchunk,endchunk + ncol = get_ncols_p(c) + cam_in(c)%ts(:ncol) = met_ts(:ncol,c) + do i = 1,ncol + cam_in(c)%snowhland(i) = met_snowh(i,c)*cam_in(c)%landfrac(i) * met_snowh_factor + enddo + end do ! Chunk loop + !++ IH + end if + !-- IH + + if (debug) then + if (masterproc) then + write(iulog,*)'METDATA maxval(met_ts),minval(met_ts): ',maxval(met_ts),minval(met_ts) + write(iulog,*)'METDATA maxval(met_snowh),minval(met_snowh): ',maxval(met_snowh),minval(met_snowh) + endif + endif + + do c = begchunk, endchunk + call outfld('MET_SNOWH',cam_in(c)%snowhland, pcols ,c ) + enddo + + end subroutine get_met_srf1 + +!------------------------------------------------------------------- +!------------------------------------------------------------------- + subroutine get_ocn_ice_frcs( lndfrc, ocnfrc, icefrc, lchnk, ncol ) + + use shr_const_mod, only: SHR_CONST_TKFRZSW + use shr_const_mod, only: SHR_CONST_TKFRZ + use cam_history, only: outfld + + ! args + real(r8), intent( in) :: lndfrc (pcols) + real(r8), intent(out) :: ocnfrc (pcols) + real(r8), intent(out) :: icefrc (pcols) + + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + + ! local vars + integer :: i + + if (met_srf_sst) then + do i = 1,ncol + + ! If configured for using SST, and ICEFRAC, then get icefrc + ! directly from the meteorological data. + icefrc(i) = min(met_icefrac(i,lchnk), 1._r8 - lndfrc(i)) + ocnfrc(i) = 1._r8 - lndfrc(i) - icefrc(i) + enddo + else + + if (.not.has_ts) then + if (masterproc) then + write(iulog,*) 'get_ocn_ice_frcs: TS is not in the met dataset and cannot set ocnfrc and icefrc' + write(iulog,*) ' try setting drydep_method to xactive_atm or table' + call endrun('get_ocn_ice_frcs: TS is not in the met dataset') + endif + endif + + do i = 1,ncol + + if ( met_ts(i,lchnk) < SHR_CONST_TKFRZ-2._r8 ) then + ocnfrc(i) = 0._r8 + icefrc(i) = 1._r8 - lndfrc(i) + else + icefrc(i) = 0._r8 + ocnfrc(i) = 1._r8 - lndfrc(i) + endif + + enddo + end if + + call outfld('MET_TS', met_ts(:ncol,lchnk) , ncol ,lchnk ) + call outfld('MET_OCNFRC', ocnfrc(:ncol) , ncol ,lchnk ) + call outfld('MET_ICEFRC', icefrc(:ncol) , ncol ,lchnk ) + + endsubroutine get_ocn_ice_frcs + +!------------------------------------------------------------------- +! allows access to physics state fields +! q : water vapor +! ps : surface pressure +! t : temperature +!------------------------------------------------------------------- + subroutine get_dyn_flds( state, tend, dt ) + + use physics_types, only: physics_state, physics_tend, physics_dme_adjust + use ppgrid, only: pcols, pver, begchunk, endchunk + use phys_grid, only: get_ncols_p + use cam_history, only: outfld + + implicit none + + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: tend + real(r8), intent(in ) :: dt ! model physics timestep + + integer :: lats(pcols) ! array of latitude indices + integer :: lons(pcols) ! array of longitude indices + integer :: c, ncol, i,j,k + real(r8):: qini(pcols,pver) ! initial specific humidity + + real(r8) :: tmp(pcols,pver) + + call t_startf('MET__GET_DYN2') + + !++ IH don't nudge T and Q if met_nudge_only_uvps is true + ! (I don't think Q is nudged by the defalut settings anyways since alpha is 1) + if (.not. met_nudge_only_uvps) then + !-- IH + do c = begchunk, endchunk + ncol = get_ncols_p(c) + do k=1,pver + do i=1,ncol + if (met_nudge_temp) then + state(c)%t(i,k) = (1._r8-met_rlx(k))*state(c)%t(i,k) + met_rlx(k)*met_t(i,k,c) + end if + + qini(i,k) = state(c)%q(i,k,1) + + ! at this point tracer mixing ratios have already been + ! converted from dry to moist + state(c)%q(i,k,1) = alpha*state(c)%q(i,k,1) + (D1_0-alpha)*met_q(i,k,c) + + if ((state(c)%q(i,k,1) < D0_0).and. (alpha .ne. D1_0 )) state(c)%q(i,k,1) = D0_0 + + end do + + end do + + ! now adjust mass of each layer now that water vapor has changed + if (( .not. online_test ) .and. (alpha .ne. D1_0 )) then + call physics_dme_adjust(state(c), tend(c), qini, dt) + endif + + end do + !++ IH + endif + !-- IH + + if (debug) then + if (masterproc) then + write(iulog,*)'METDATA maxval(met_t),minval(met_t): ', maxval(met_t),minval(met_t) + write(iulog,*)'METDATA maxval(met_ps_next),minval(met_ps_next): ', maxval(met_ps_next),minval(met_ps_next) + endif + endif + + do c = begchunk, endchunk + call outfld('MET_T ',state(c)%t , pcols ,c ) + enddo + call t_stopf('MET__GET_DYN2') + + end subroutine get_dyn_flds + +!------------------------------------------------------------------------ +! get the meteorological winds on the grid cell centers (A-grid) +!------------------------------------------------------------------------ + subroutine get_uv_centered( grid, u, v ) + + use cam_history, only: outfld + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + real(r8), intent(out) :: u(grid%im, grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d, & + grid%kfirst:grid%klast) ! u-wind on A-grid + real(r8), intent(out) :: v(grid%im, grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d, & + grid%kfirst:grid%klast) ! v-wind on A-grid + + integer :: i,j,k + + integer :: jm, jfirst, jlast, jfirstxy, jlastxy, kfirst, klast, ng_d, ng_s, ifirstxy, ilastxy + + real(r8) :: u3s_tmp(grid%ifirstxy:grid%ilastxy,grid%km) + real(r8) :: v3s_tmp(grid%ifirstxy:grid%ilastxy,grid%km) + + jm = grid%jm + jfirstxy= grid%jfirstxy + jlastxy = grid%jlastxy + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + ifirstxy= grid%ifirstxy + ilastxy = grid%ilastxy + + ng_d = grid%ng_d + ng_s = grid%ng_s + + u(:,:,:) = D0_0 + v(:,:,:) = D0_0 + + u( :, max(1,jfirst-ng_d):min(jm,jlast+ng_d), kfirst:klast ) = & + met_u(:, max(1,jfirst-ng_d):min(jm,jlast+ng_d), kfirst:klast ) + + v( :, max(1,jfirst-ng_s):min(jm,jlast+ng_d), kfirst:klast ) = & + met_v(:, max(1,jfirst-ng_s):min(jm,jlast+ng_d), kfirst:klast ) + + if (masterproc) then + if (debug) write(iulog,*)'METDATA maxval(u),minval(u),maxval(v),minval(v) : ',& + maxval(u(:, max(1,jfirst-ng_d):min(jm,jlast+ng_d), kfirst:klast )),& + minval(u(:, max(1,jfirst-ng_d):min(jm,jlast+ng_d), kfirst:klast )),& + maxval(v(:, max(1,jfirst-ng_s):min(jm,jlast+ng_d), kfirst:klast )),& + minval(v(:, max(1,jfirst-ng_s):min(jm,jlast+ng_d), kfirst:klast )) + endif + + if ( grid%twod_decomp .eq. 0 ) then + do j = jfirst, jlast + do k = kfirst, klast + do i = 1, grid%im + u3s_tmp(i,k) = u(i,j,k) + v3s_tmp(i,k) = v(i,j,k) + enddo + enddo + call outfld ('MET_U ', u3s_tmp, grid%im, j ) + call outfld ('MET_V ', v3s_tmp, grid%im, j ) + enddo + endif + + end subroutine get_uv_centered + +!------------------------------------------------------------------------ +! get the meteorological surface pressure interp to dyn substep +!------------------------------------------------------------------------ + subroutine get_ps( grid, ps, nsubsteps, n ) + + use cam_history, only: outfld + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + real(r8), intent(out) :: ps(grid%im, grid%jfirst:grid%jlast) + integer, intent(in) :: nsubsteps + integer, intent(in) :: n + + real(r8) :: num1, num2 + integer :: j + + num1 = n + num2 = nsubsteps + + ps(:,:) = met_ps_curr(:,:) + num1*(met_ps_next(:,:)-met_ps_curr(:,:))/num2 + + if ( grid%twod_decomp .eq. 0 ) then + do j = grid%jfirst, grid%jlast + call outfld('MET_PS',ps(:,j), grid%im ,j ) + enddo + endif + end subroutine get_ps + +!------------------------------------------------------------------------ +! get the meteorological winds on the grid cell walls (vorticity winds) +! us : staggered zonal wind +! vs : staggered meridional wind +!------------------------------------------------------------------------ + subroutine get_us_vs( grid, us, vs ) + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + real(r8), intent(inout) :: us(grid%im, grid%jfirst-grid%ng_d:grid%jlast+grid%ng_s, & + grid%kfirst:grid%klast) ! u-wind on d-grid + real(r8), intent(inout) :: vs(grid%im, grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d, & + grid%kfirst:grid%klast) ! v-wind on d-grid + + integer :: i,j,k + + integer :: jm, jfirst, jlast, kfirst, klast, ng_d, ng_s + + jm = grid%jm + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + ng_d = grid%ng_d + ng_s = grid%ng_s + + call t_startf('MET__get_us_vs') + + ! vertical relaxation (blending) occurs in dyn_run (dyn_comp.F90) + + us(:,:,:) = 1.e36_r8 + vs(:,:,:) = 1.e36_r8 + us( :, max(2,jfirst): min(jm,jlast), kfirst:klast) = & + met_us( :, max(2,jfirst): min(jm,jlast), kfirst:klast) + vs( :, max(1,jfirst): min(jm,jlast), kfirst:klast) = & + met_vs( :, max(1,jfirst): min(jm,jlast), kfirst:klast) + if (masterproc) then + if (debug) write(iulog,*)grid%iam,': METDATA maxval(us),minval(us),maxval(vs),minval(vs) : ',& + maxval(us( :, max(2,jfirst): min(jm,jlast), kfirst:klast)),& + minval(us( :, max(2,jfirst): min(jm,jlast), kfirst:klast)),& + maxval(vs( :, max(1,jfirst): min(jm,jlast), kfirst:klast)),& + minval(vs( :, max(1,jfirst): min(jm,jlast), kfirst:klast)) + endif + +!!$ if (debug) then +!!$ u3s_tmp = 1.e36 +!!$ do j = jfirst, jlast +!!$ do k = kfirst, klast +!!$ do i = 1, im +!!$ if (j >= 2) u3s_tmp(i,k) = us(i,j,k) +!!$ v3s_tmp(i,k) = vs(i,j,k) +!!$ enddo +!!$ enddo +!!$ call outfld ('MET_US ', u3s_tmp, im, j ) +!!$ call outfld ('MET_VS ', v3s_tmp, im, j ) +!!$ enddo +!!$ endif +!!$ + call t_stopf('MET__get_us_vs') + + end subroutine get_us_vs + +!------------------------------------------------------------------------- +! writes file names to restart file +!------------------------------------------------------------------------- + + subroutine write_met_restart_pio(File) + type(file_desc_t), intent(inout) :: File + integer :: ierr + ierr = pio_put_att(File, PIO_GLOBAL, 'current_metdata_filename', curr_filename) + ierr = pio_put_att(File, PIO_GLOBAL, 'next_metdata_filename', next_filename) + + end subroutine write_met_restart_pio + subroutine read_met_restart_pio(File) + type(file_desc_t), intent(inout) :: File + + integer :: ierr, xtype + integer(pio_offset_kind) :: slen + + ierr = pio_inq_att(File, PIO_GLOBAL, 'current_metdata_filename',xtype, slen) + ierr = pio_get_att(File, PIO_GLOBAL, 'current_metdata_filename', curr_filename) + curr_filename(slen+1:256) = '' + + ierr = pio_inq_att(File, PIO_GLOBAL, 'next_metdata_filename',xtype, slen) + ierr = pio_get_att(File, PIO_GLOBAL, 'next_metdata_filename', next_filename) + next_filename(slen+1:256) = '' + + end subroutine read_met_restart_pio + + subroutine write_met_restart_bin( nrg ) + implicit none + integer,intent(in) :: nrg ! Unit number + integer :: ioerr ! error status + + if (masterproc) then + write(nrg, iostat=ioerr) curr_filename + if (ioerr /= 0 ) then + write(iulog,*) 'WRITE ioerror ',ioerr,' on i/o unit = ',nrg + call endrun ('WRITE_RESTART_DYNAMICS') + end if + write(nrg, iostat=ioerr) next_filename + if (ioerr /= 0 ) then + write(iulog,*) 'WRITE ioerror ',ioerr,' on i/o unit = ',nrg + call endrun ('WRITE_RESTART_DYNAMICS') + end if + end if + end subroutine write_met_restart_bin + +!------------------------------------------------------------------------- +! reads file names from restart file +!------------------------------------------------------------------------- + subroutine read_met_restart_bin( nrg ) + implicit none + integer,intent(in) :: nrg ! Unit number + integer :: ioerr ! error status + + if (masterproc) then + read(nrg, iostat=ioerr) curr_filename + if (ioerr /= 0 ) then + write(iulog,*) 'READ ioerror ',ioerr,' on i/o unit = ',nrg + call endrun ('READ_RESTART_DYNAMICS') + end if + read(nrg, iostat=ioerr) next_filename + if (ioerr /= 0 ) then + write(iulog,*) 'READ ioerror ',ioerr,' on i/o unit = ',nrg + call endrun ('READ_RESTART_DYNAMICS') + end if + end if + +#if ( defined SPMD ) + call mpibcast ( curr_filename ,len(curr_filename) ,mpichar,0,mpicom) + call mpibcast ( next_filename ,len(next_filename) ,mpichar,0,mpicom) +#endif + end subroutine read_met_restart_bin + +!------------------------------------------------------------------------- +! returns true if the met winds are defined on cell walls +!------------------------------------------------------------------------- + function met_winds_on_walls() + logical :: met_winds_on_walls + + met_winds_on_walls = met_cell_wall_winds + end function met_winds_on_walls + +! internal methods : + +!------------------------------------------------------------------------- +! transfers cell-centered winds to cell walls +!------------------------------------------------------------------------- + subroutine transfer_windsToWalls(grid) + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + integer :: i,j,k + integer :: im, jfirst, jlast, kfirst, klast + + im = grid%im + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + + call t_startf('MET__transfer_windsToWalls') + +!$omp parallel do private (i, j, k) + do k = kfirst, klast + + do j = jfirst+1,jlast + do i = 1,im + met_us(i,j,k) = ( met_u(i,j,k) + met_u(i,j-1,k) )*D0_5 + end do + end do + +#if defined( SPMD ) + if ( jfirst .gt. 1 ) then + do i = 1, im + ! met_u is alread ghosted at this point + met_us(i,jfirst,k) = ( met_u(i,jfirst,k) + met_u(i,jfirst-1,k) )*D0_5 + enddo + endif +#endif + + do j = jfirst,jlast + met_vs(1,j,k) = ( met_v(1,j,k) + met_v(im,j,k) )*D0_5 + do i = 2,im + met_vs(i,j,k) = ( met_v(i,j,k) + met_v(i-1,j,k) )*D0_5 + end do + end do + end do + + call t_stopf('MET__transfer_windsToWalls') + + end subroutine transfer_windsToWalls + + subroutine get_model_time() + implicit none + integer yr, mon, day, ncsec ! components of a date + + call t_startf('MET__get_model_time') + + call get_curr_date(yr, mon, day, ncsec) + + curr_mod_time = get_time_float( yr, mon, day, ncsec ) + next_mod_time = curr_mod_time + get_step_size()/seconds_per_day + + call t_stopf('MET__get_model_time') + + end subroutine get_model_time + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine check_files() + + use shr_sys_mod, only: shr_sys_system + use ioFileMod, only: getfil + + implicit none + +!----------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------- + character(len=256) :: ctmp + character(len=256) :: loc_fname + integer :: istat + + + if (next_mod_time > curr_data_times(size(curr_data_times))) then + if ( .not. associated(next_data_times) ) then + ! open next file... + next_filename = incr_filename( curr_filename ) + call open_met_datafile( next_filename, next_fileid, next_data_times, met_data_path ) + endif + endif + + if ( associated(next_data_times) ) then + if (curr_mod_time >= next_data_times(1)) then + + ! close current file ... + call pio_closefile( curr_fileid ) + if (masterproc) then + ! remove if requested + if( met_remove_file ) then + call getfil( curr_filename, loc_fname, 0 ) + write(iulog,*) 'check_files: removing file = ',trim(loc_fname) + ctmp = 'rm -f ' // trim(loc_fname) + write(iulog,*) 'check_files: fsystem issuing command - ' + write(iulog,*) trim(ctmp) + call shr_sys_system( ctmp, istat ) + end if + endif + + curr_filename = next_filename + curr_fileid = next_fileid + + deallocate( curr_data_times ) + allocate( curr_data_times( size( next_data_times ) ) ) + curr_data_times(:) = next_data_times(:) + + next_filename = '' + + deallocate( next_data_times ) + nullify( next_data_times ) + + endif + endif + + end subroutine check_files + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + function incr_filename( filename ) + + !----------------------------------------------------------------------- + ! ... Increment or decrement a date string withing a filename + ! the filename date section is assumed to be of the form + ! yyyy-dd-mm + !----------------------------------------------------------------------- + + use string_utils, only : incstr + use shr_file_mod, only : shr_file_getunit, shr_file_freeunit + + implicit none + + + character(len=*), intent(in) :: filename ! present dynamical dataset filename + character(len=256) :: incr_filename ! next filename in the sequence + + ! set new next_filename ... + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: pos, pos1, istat + character(len=256) :: fn_new, line + character(len=6) :: seconds + character(len=5) :: num + integer :: ios,unitnumber + + if ( len_trim(met_filenames_list) .eq. 0) then + !----------------------------------------------------------------------- + ! ... ccm type filename + !----------------------------------------------------------------------- + pos = len_trim( filename ) + fn_new = filename(:pos) + if (masterproc) write(iulog,*) 'incr_flnm: old filename = ',trim(fn_new) + if( fn_new(pos-2:) == '.nc' ) then + pos = pos - 3 + end if + istat = incstr( fn_new(:pos), 1 ) + if( istat /= 0 ) then + write(iulog,*) 'incr_flnm: incstr returned ', istat + write(iulog,*) ' while trying to decrement ',trim( fn_new ) + call endrun + end if + + else + + ! open met_filenames_list + if (masterproc) write(iulog,*) 'incr_flnm: old filename = ',trim(filename) + if (masterproc) write(iulog,*) 'incr_flnm: open met_filenames_list : ',met_filenames_list + unitnumber = shr_file_getUnit() + open( unit=unitnumber, file=met_filenames_list, iostat=ios, status="OLD") + if (ios /= 0) then + call endrun('not able to open met_filenames_list file: '//met_filenames_list) + endif + + ! read file names + read( unit=unitnumber, fmt='(A)', iostat=ios ) line + if (ios /= 0) then + call endrun('not able to increment file name from met_filenames_list file: '//met_filenames_list) + endif + do while( trim(line) /= trim(filename) ) + read( unit=unitnumber, fmt='(A)', iostat=ios ) line + if (ios /= 0) then + call endrun('not able to increment file name from met_filenames_list file: '//met_filenames_list) + endif + enddo + + read( unit=unitnumber, fmt='(A)', iostat=ios ) line + if (ios /= 0) then + call endrun('not able to increment file name from met_filenames_list file: '//met_filenames_list) + endif + fn_new = trim(line) + + close(unit=unitnumber) + call shr_file_freeUnit(unitnumber) + endif + incr_filename = trim(fn_new) + if (masterproc) write(iulog,*) 'incr_flnm: new filename = ',incr_filename + + end function incr_filename + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine find_times( itms, fids, datatm, datatp, time ) + + implicit none + + integer, intent(out) :: itms(2) ! record numbers that bracket time + type(file_desc_t), intent(out) :: fids(2) ! ids of files that contains these recs + real(r8), intent(in) :: time ! time of interest + real(r8), intent(out):: datatm, datatp + + integer np1 ! current forward time index of dataset + integer n,i ! + integer :: curr_tsize, next_tsize, all_tsize + + real(r8), allocatable, dimension(:):: all_data_times + + curr_tsize = size(curr_data_times) + next_tsize = 0 + if ( associated(next_data_times)) next_tsize = size(next_data_times) + + all_tsize = curr_tsize + next_tsize + + allocate( all_data_times( all_tsize ) ) + + all_data_times(:curr_tsize) = curr_data_times(:) + if (next_tsize > 0) all_data_times(curr_tsize+1:all_tsize) = next_data_times(:) + + ! find bracketing times + do n=1, all_tsize-1 + np1 = n + 1 + datatm = all_data_times(n) + datatp = all_data_times(np1) + if ( (time .ge. datatm) .and. (time .le. datatp) ) then + goto 20 + endif + enddo + + write(iulog,*)'FIND_TIMES: Failed to find dates bracketing desired time =', time + write(iulog,*)' datatm = ',datatm + write(iulog,*)' datatp = ',datatp + write(iulog,*)' all_data_times = ',all_data_times + + call endrun + +20 continue + + deallocate( all_data_times ) + + itms(1) = n + itms(2) = np1 + fids(:) = curr_fileid + + do i=1,2 + if ( itms(i) > curr_tsize ) then + itms(i) = itms(i) - curr_tsize + fids(i) = next_fileid + endif + enddo + + end subroutine find_times + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine read_next_ps(grid) + use ncdio_atm, only: infld + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + + integer :: recnos(2) + type(file_desc_t) :: fids(2) + character(len=8) :: varname + integer :: ifirstxy, ilastxy, jfirstxy, jlastxy + + real(r8) :: wrk_xy(grid%ifirstxy:grid%ilastxy, grid%jfirstxy:grid%jlastxy ) + + logical :: readvar + + if(online_test) then + varname='arch_PS' + else + varname='PS' + end if + + jfirstxy= grid%jfirstxy + jlastxy = grid%jlastxy + ifirstxy= grid%ifirstxy + ilastxy = grid%ilastxy + + call find_times( recnos, fids, datatimemn, datatimepn, next_mod_time ) + + call infld(varname, fids(1), 'lon', 'lat', ifirstxy, ilastxy, jfirstxy, jlastxy, & + wrk_xy, readvar, gridname='fv_centers', timelevel=recnos(1)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_2d( wrk_xy, met_psi_next(nm)%data, grid ) + + call infld(varname, fids(2), 'lon', 'lat', ifirstxy, ilastxy, jfirstxy, jlastxy, & + wrk_xy, readvar, gridname='fv_centers', timelevel=recnos(2)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_2d( wrk_xy, met_psi_next(np)%data, grid ) + + if(masterproc) write(iulog,*)'READ_NEXT_PS: Read meteorological data ' + + end subroutine read_next_ps + +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + subroutine transpose_xy2yz_2d( xy_2d, yz_2d, grid ) + + implicit none + type (T_FVDYCORE_GRID), intent(in) :: grid + real(r8), intent(in) :: xy_2d(grid%ifirstxy:grid%ilastxy, grid%jfirstxy:grid%jlastxy) + real(r8), intent(out) :: yz_2d(1:grid%im, grid%jfirst:grid%jlast) + + real(r8) :: xy3(grid%ifirstxy:grid%ilastxy, grid%jfirstxy:grid%jlastxy, 1:grid%npr_z ) + integer :: i,j,k + + if (grid%iam .lt. grid%npes_xy) then + if ( grid%twod_decomp .eq. 1 ) then + +#if defined( SPMD ) +!$omp parallel do private(i,j,k) + do k=1,grid%npr_z + do j=grid%jfirstxy,grid%jlastxy + do i=grid%ifirstxy,grid%ilastxy + xy3(i,j,k) = xy_2d(i,j) + enddo + enddo + enddo + + call mp_sendirr(grid%commxy, grid%xy2d_to_yz2d%SendDesc, & + grid%xy2d_to_yz2d%RecvDesc, xy3, yz_2d, & + modc=grid%modc_dynrun ) + call mp_recvirr(grid%commxy, grid%xy2d_to_yz2d%SendDesc, & + grid%xy2d_to_yz2d%RecvDesc, xy3, yz_2d, & + modc=grid%modc_dynrun ) +#endif + + else + yz_2d(:,:) = xy_2d(:,:) + endif + endif ! (grid%iam .lt. grid%npes_xy) + + end subroutine transpose_xy2yz_2d + +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + subroutine transpose_xy2yz_3d( xy_3d, yz_3d, grid ) + + implicit none + type (T_FVDYCORE_GRID), intent(in) :: grid + real(r8), intent(in) :: xy_3d(grid%ifirstxy:grid%ilastxy, grid%jfirstxy:grid%jlastxy, 1:grid%km ) + real(r8), intent(out) :: yz_3d(1:grid%im, grid%jfirst:grid%jlast, grid%kfirst:grid%klast) + + if (grid%iam .lt. grid%npes_xy) then + if ( grid%twod_decomp .eq. 1 ) then +#if defined( SPMD ) + call mp_sendirr( grid%commxy, grid%ijk_xy_to_yz%SendDesc, & + grid%ijk_xy_to_yz%RecvDesc, xy_3d, yz_3d, & + modc=grid%modc_dynrun ) + call mp_recvirr( grid%commxy, grid%ijk_xy_to_yz%SendDesc, & + grid%ijk_xy_to_yz%RecvDesc, xy_3d, yz_3d, & + modc=grid%modc_dynrun ) +#endif + else + yz_3d(:,:,:) = xy_3d(:,:,:) + endif + endif ! (grid%iam .lt. grid%npes_xy) + + end subroutine transpose_xy2yz_3d + + + +!------------------------------------------------------------------------ +!------------------------------------------------------------------------ + subroutine read_next_metdata(grid) + use ncdio_atm, only: infld + use cam_grid_support, only: cam_grid_check, cam_grid_id + use cam_grid_support, only: cam_grid_get_dim_names + + implicit none + + type (T_FVDYCORE_GRID), intent(in) :: grid + integer recnos(2), i ! + type(file_desc_t) :: fids(2) + + character(len=8) :: Uname, Vname, Tname, Qname, psname + character(len=8) :: dim1name, dim2name + integer :: im, jm, km + logical :: readvar + integer :: ifirstxy, ilastxy, jfirstxy, jlastxy + real(r8), allocatable :: wrk2_xy(:,:) + real(r8), allocatable :: wrk3_xy(:,:,:) + real(r8), allocatable :: tmp_data(:,:,:) + integer :: elev1,blev1, elev2,blev2 + integer :: elev3,blev3, elev4,blev4 + integer :: grid_id ! grid ID for data mapping + + call t_startf('MET__read_next_metdata') + + jfirstxy= grid%jfirstxy + jlastxy = grid%jlastxy + ifirstxy= grid%ifirstxy + ilastxy = grid%ilastxy + + im = grid%im + jm = grid%jm + km = grid%km + + call find_times( recnos, fids, datatimem, datatimep, curr_mod_time ) + ! + ! Set up hyperslab corners + ! + + if(online_test) then + Tname='arch_T' + Qname='arch_Q' + PSname='arch_PS' + if(met_cell_wall_winds) then + Uname='arch_US' + Vname='arch_VS' + else + Uname='arch_U' + Vname='arch_V' + end if + else + Tname='T' + Qname='Q' + PSname='PS' + if(met_cell_wall_winds) then + Uname='US' + Vname='VS' + else + Uname='U' + Vname='V' + end if + + end if + + + if ( num_met_levels>km ) then + + blev1 = 1 + elev1 = km + + blev2 = num_met_levels-km+1 + elev2 = num_met_levels + + blev3 = num_met_levels-km+1 + elev3 = num_met_levels + + blev4 = 1 + elev4 = num_met_levels + + else + + blev1 = km-num_met_levels+1 + elev1 = km + + blev2 = 1 + elev2 = num_met_levels + + blev3 = 1 + elev3 = km + + blev4 = km-num_met_levels+1 + elev4 = km + + endif + + allocate(tmp_data(pcols, 1:num_met_levels, begchunk:endchunk)) + allocate(wrk2_xy(ifirstxy:ilastxy, jfirstxy:jlastxy)) + allocate(wrk3_xy(ifirstxy:ilastxy, jfirstxy:jlastxy, 1:max(km,num_met_levels))) + + ! physgrid intput for FV is probably always lon/lat but let's be pedantic + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun('read_next_metdata: Internal error, no "physgrid" grid') + end if + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + + do i=1,2 + + met_ti(i)%data = 0._r8 + + call infld(Tname, fids(i), dim1name, 'lev', dim2name, 1, pcols, 1,num_met_levels , & + begchunk, endchunk, tmp_data, readvar, gridname='physgrid',timelevel=recnos(i)) + + met_ti(i)%data(:,blev1:elev1,:) = tmp_data(:, blev2:elev2, :) + + met_qi(i)%data = 0._r8 + + call infld(Qname, fids(i), dim1name, 'lev', dim2name, 1, pcols, 1,num_met_levels, & + begchunk, endchunk, tmp_data, readvar, gridname='physgrid',timelevel=recnos(i)) + + met_qi(i)%data(:,blev1:elev1,:) = tmp_data(:, blev2:elev2, :) + + if (met_cell_wall_winds) then + + wrk3_xy = 0._r8 + met_usi(i)%data(:,:,:) = 0._r8 + call infld(Uname, fids(i), 'lon', 'slat', 'lev', ifirstxy, ilastxy, jfirstxy, jlastxy, & + 1,num_met_levels, wrk3_xy(:,:,blev4:elev4), readvar, gridname='fv_u_stagger',timelevel=recnos(i)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_3d( wrk3_xy(:,:,blev3:elev3), met_usi(i)%data(:,:,:), grid ) + + wrk3_xy = 0._r8 + met_vsi(i)%data(:,:,:) = 0._r8 + call infld(Vname, fids(i), 'slon', 'lat', 'lev', ifirstxy, ilastxy, jfirstxy, jlastxy, & + 1,num_met_levels, wrk3_xy(:,:,blev4:elev4), readvar, gridname='fv_v_stagger',timelevel=recnos(i)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_3d( wrk3_xy(:,:,blev3:elev3), met_vsi(i)%data(:,:,:), grid ) + + else + + ! read into lower portion of the array... + + wrk3_xy = 0._r8 + met_ui(i)%data = 0._r8 + call infld(Uname, fids(i), 'lon', 'lat', 'lev', ifirstxy, ilastxy, jfirstxy, jlastxy, & + 1,num_met_levels, wrk3_xy(:,:,blev4:elev4), readvar, gridname='fv_centers',timelevel=recnos(i)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_3d( wrk3_xy(:,:,blev3:elev3), met_ui(i)%data(:,:,:), grid ) + + wrk3_xy = 0._r8 + met_vi(i)%data = 0._r8 + call infld(Vname, fids(i), 'lon', 'lat', 'lev', ifirstxy, ilastxy, jfirstxy, jlastxy, & + 1,num_met_levels, wrk3_xy(:,:,blev4:elev4), readvar, gridname='fv_centers',timelevel=recnos(i)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_3d( wrk3_xy(:,:,blev3:elev3), met_vi(i)%data(:,:,:), grid ) + + endif ! met_cell_wall_winds + + call infld(PSname, fids(i), 'lon', 'lat', ifirstxy, ilastxy, jfirstxy, jlastxy, & + wrk2_xy, readvar, gridname='fv_centers', timelevel=recnos(i)) + + ! transpose xy -> yz decomposition + call transpose_xy2yz_2d( wrk2_xy, met_psi_curr(i)%data, grid ) + + enddo + + deallocate(tmp_data) + deallocate(wrk3_xy) + deallocate(wrk2_xy) + + ! 2-D feilds + call read_phys_srf_flds( ) + + if(masterproc) write(iulog,*)'READ_NEXT_METDATA: Read meteorological data ' + + call t_stopf('MET__read_next_metdata') + + end subroutine read_next_metdata + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine read_phys_srf_flds( ) + use ncdio_atm, only: infld + + integer :: i, recnos(2) + type(file_desc_t) :: fids(2) + logical :: readvar + + call find_times( recnos, fids, datatimem, datatimep, curr_mod_time ) + do i=1,2 + + call infld(met_shflx_name, fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_shflxi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + + if (has_lhflx) then + call infld('LHFLX', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_lhflxi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + end if + + call infld(met_qflx_name, fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_qflxi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('TAUX', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_tauxi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('TAUY', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_tauyi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + + if ( .not.met_srf_feedback ) then + call infld('SNOWH', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_snowhi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + endif + + if (has_ts) then + call infld('TS', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_tsi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + endif + + if (met_srf_rad) then + call infld('ASDIR', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_asdiri(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('ASDIF', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_asdifi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('ALDIR', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_aldiri(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('ALDIF', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_aldifi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('LWUP', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_lwupi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + endif + + if (met_srf_refs) then + call infld('QREF', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_qrefi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('TREF', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_trefi(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('U10', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_u10i(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + endif + + if (met_srf_sst) then + call infld('SST', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_ssti(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + call infld('ICEFRAC', fids(i), 'lon', 'lat', 1, pcols, begchunk, endchunk, & + met_icefraci(i)%data, readvar, gridname='physgrid',timelevel=recnos(i)) + endif + enddo + end subroutine read_phys_srf_flds + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine interp_phys_srf_flds( ) + use phys_grid, only: get_ncols_p + real(r4) :: fact1, fact2 + real(r8) :: deltat + integer :: i, c, ncol + + deltat = datatimep - datatimem + fact1 = (datatimep - curr_mod_time)/deltat + fact2 = D1_0-fact1 + + + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + if (has_lhflx) then + met_lhflx(i,c) = fact1*met_lhflxi(nm)%data(i,c) + fact2*met_lhflxi(np)%data(i,c) + end if + met_shflx(i,c) = fact1*met_shflxi(nm)%data(i,c) + fact2*met_shflxi(np)%data(i,c) + met_qflx(i,c) = fact1*met_qflxi(nm)%data(i,c) + fact2*met_qflxi(np)%data(i,c) + met_taux(i,c) = fact1*met_tauxi(nm)%data(i,c) + fact2*met_tauxi(np)%data(i,c) + met_tauy(i,c) = fact1*met_tauyi(nm)%data(i,c) + fact2*met_tauyi(np)%data(i,c) + enddo + enddo + if ( .not.met_srf_feedback ) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + met_snowh(i,c) = fact1*met_snowhi(nm)%data(i,c) + fact2*met_snowhi(np)%data(i,c) + enddo + enddo + endif + if (has_ts) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + met_ts(i,c) = fact1*met_tsi(nm)%data(i,c) + fact2*met_tsi(np)%data(i,c) + enddo + enddo + endif + if (met_srf_rad) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + ! Albedo can be fillValue from the meteorology where the is no downwelling + ! solar. However, this changes slowly, so for interpolation use either end-point + ! if nothing is present. If there is no solar, then the albedo won't matter, so + ! should not cause problems. + if (met_asdiri(nm)%data(i,c) .eq. srf_fill_value) then + met_asdir(i,c) = met_asdiri(np)%data(i,c) + else if (met_asdiri(np)%data(i,c) .eq. srf_fill_value) then + met_asdir(i,c) = met_asdiri(nm)%data(i,c) + else + met_asdir(i,c) = fact1*met_asdiri(nm)%data(i,c) + fact2*met_asdiri(np)%data(i,c) + endif + + if (met_asdifi(nm)%data(i,c) .eq. srf_fill_value) then + met_asdif(i,c) = met_asdifi(np)%data(i,c) + else if (met_asdifi(np)%data(i,c) .eq. srf_fill_value) then + met_asdif(i,c) = met_asdifi(nm)%data(i,c) + else + met_asdif(i,c) = fact1*met_asdifi(nm)%data(i,c) + fact2*met_asdifi(np)%data(i,c) + endif + + if (met_aldiri(nm)%data(i,c) .eq. srf_fill_value) then + met_aldir(i,c) = met_aldiri(np)%data(i,c) + else if (met_aldiri(np)%data(i,c) .eq. srf_fill_value) then + met_aldir(i,c) = met_aldiri(nm)%data(i,c) + else + met_aldir(i,c) = fact1*met_aldiri(nm)%data(i,c) + fact2*met_aldiri(np)%data(i,c) + endif + + if (met_aldifi(nm)%data(i,c) .eq. srf_fill_value) then + met_aldif(i,c) = met_aldifi(np)%data(i,c) + else if (met_aldifi(np)%data(i,c) .eq. srf_fill_value) then + met_aldif(i,c) = met_aldifi(nm)%data(i,c) + else + met_aldif(i,c) = fact1*met_aldifi(nm)%data(i,c) + fact2*met_aldifi(np)%data(i,c) + endif + + met_lwup(i,c) = fact1*met_lwupi(nm)%data(i,c) + fact2*met_lwupi(np)%data(i,c) + enddo + enddo + endif + if (met_srf_refs) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + met_qref(i,c) = fact1*met_qrefi(nm)%data(i,c) + fact2*met_qrefi(np)%data(i,c) + met_tref(i,c) = fact1*met_trefi(nm)%data(i,c) + fact2*met_trefi(np)%data(i,c) + met_u10(i,c) = fact1*met_u10i(nm)%data(i,c) + fact2*met_u10i(np)%data(i,c) + enddo + enddo + endif + if (met_srf_sst) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + ! The sst is fill value over land, which should not change from timestep to + ! timestep, but just in case use the sst value if only one is present. + if (met_ssti(nm)%data(i,c) .eq. srf_fill_value) then + met_sst(i,c) = met_ssti(np)%data(i,c) + else if (met_ssti(np)%data(i,c) .eq. srf_fill_value) then + met_sst(i,c) = met_ssti(nm)%data(i,c) + else + met_sst(i,c) = fact1*met_ssti(nm)%data(i,c) + fact2*met_ssti(np)%data(i,c) + endif + met_icefrac(i,c) = fact1*met_icefraci(nm)%data(i,c) + fact2*met_icefraci(np)%data(i,c) + enddo + enddo + endif + + end subroutine interp_phys_srf_flds +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + subroutine interpolate_metdata(grid) + use phys_grid, only: get_ncols_p +#if defined( SPMD ) + use mod_comm, only : mp_send4d_ns, mp_recv4d_ns +#endif + + implicit none + type (T_FVDYCORE_GRID), intent(in) :: grid + + real(r4) fact1, fact2 + real(r4) nfact1, nfact2 + real(r8) deltat,deltatn + integer :: i,c,k, ncol + integer :: im, jm, km, jfirst, jlast, kfirst, klast, ng_d, ng_s + + im = grid%im + jm = grid%jm + km = grid%km + jfirst = grid%jfirst + jlast = grid%jlast + kfirst = grid%kfirst + klast = grid%klast + ng_d = grid%ng_d + ng_s = grid%ng_s + + call t_startf('MET__interpolate_metdata') + + deltat = datatimep - datatimem + deltatn = datatimepn - datatimemn + + fact1 = (datatimep - curr_mod_time)/deltat +! fact2 = (curr_mod_time - datatimem)/deltat + fact2 = D1_0-fact1 + + nfact1 = (datatimepn - next_mod_time)/deltatn +! nfact2 = (next_mod_time - datatimemn)/deltatn + nfact2 = D1_0-nfact1 + + met_q = 0.0_r8 + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do k=1,pver + do i=1,ncol + met_t(i,k,c) = fact1*met_ti(nm)%data(i,k,c) + fact2*met_ti(np)%data(i,k,c) + met_q(i,k,c) = fact1*met_qi(nm)%data(i,k,c) + fact2*met_qi(np)%data(i,k,c) + enddo + enddo + enddo + + if (.not. online_test) where (met_q .lt. D0_0) met_q = D0_0 + + met_ps_next(:,:) = nfact1*met_psi_next(nm)%data(:,:) + nfact2*met_psi_next(np)%data(:,:) + met_ps_curr(:,:) = fact1*met_psi_curr(nm)%data(:,:) + fact2*met_psi_curr(np)%data(:,:) + + call interp_phys_srf_flds() + + if (has_ts) then + do c=begchunk,endchunk + ncol = get_ncols_p(c) + do i=1,ncol + met_ts(i,c) = fact1*met_tsi(nm)%data(i,c) + fact2*met_tsi(np)%data(i,c) + enddo + enddo + endif + + if ( .not. met_cell_wall_winds ) then + + met_u(1:im,jfirst:jlast,kfirst:klast) = fact1*met_ui(nm)%data(1:im,jfirst:jlast,kfirst:klast) & + + fact2*met_ui(np)%data(1:im,jfirst:jlast,kfirst:klast) + met_v(1:im,jfirst:jlast,kfirst:klast) = fact1*met_vi(nm)%data(1:im,jfirst:jlast,kfirst:klast) & + + fact2*met_vi(np)%data(1:im,jfirst:jlast,kfirst:klast) + + ! ghost u,v +#if defined( SPMD ) + call mp_send4d_ns( grid%commxy, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, met_u ) + call mp_send4d_ns( grid%commxy, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, met_v ) + call mp_recv4d_ns( grid%commxy, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_d, met_u ) + call mp_recv4d_ns( grid%commxy, im, jm, km, 1, jfirst, jlast, & + kfirst, klast, ng_d, ng_s, met_v ) +#endif + + ! average to cell walls (vorticity winds) + call transfer_windsToWalls(grid) + else + met_us(:,jfirst:jlast,kfirst:klast) = fact1*met_usi(nm)%data(:,jfirst:jlast,kfirst:klast) + & + fact2*met_usi(np)%data(:,jfirst:jlast,kfirst:klast) + met_vs(:,jfirst:jlast,kfirst:klast) = fact1*met_vsi(nm)%data(:,jfirst:jlast,kfirst:klast) + & + fact2*met_vsi(np)%data(:,jfirst:jlast,kfirst:klast) + + endif + + ! ghost staggered u,v + ! WS 2006.04.11: not necessary here since it will be done in cd_core + +! write(iulog,*)'INTERPOLATE_METDATA: complete.' + + call t_stopf('MET__interpolate_metdata') + + end subroutine interpolate_metdata + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine get_dimension( fid, dname, dsize ) + implicit none + type(file_desc_t), intent(in) :: fid + character(*), intent(in) :: dname + integer, intent(out) :: dsize + + integer :: dimid, ierr + + ierr = pio_inq_dimid( fid, dname, dimid ) + ierr = pio_inq_dimlen( fid, dimid, dsize ) + + end subroutine get_dimension + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine open_met_datafile( fname, fileid, times, datapath, check_dims, grid ) + + use ioFileMod, only: getfil + use pio, only: pio_seterrorhandling, PIO_INTERNAL_ERROR, PIO_BCAST_ERROR, PIO_NOERR + + implicit none + + character(*), intent(in) :: fname + type(file_desc_t), intent(inout) :: fileid + real(r8), pointer, intent(inout) :: times(:) + character(*), intent(in) :: datapath + logical, optional, intent(in) :: check_dims + type (T_FVDYCORE_GRID), optional, intent(in) :: grid + + character(len=256) :: filepath + character(len=256) :: filen + integer :: year, month, day, dsize, i, timesize + integer :: dateid,secid + integer, allocatable , dimension(:) :: dates, datesecs + integer :: ierr + integer :: im, jm, km + integer :: varid + + ! + ! open file and get fileid + ! + if (len_trim( datapath )>0) then + filepath = trim(datapath)//'/'//trim(fname) + else + filepath = trim(fname) + endif + call getfil( filepath, filen, 0 ) + + call cam_pio_openfile( fileid, filen, 0 ) + + call pio_seterrorhandling(fileid, PIO_BCAST_ERROR) + + ierr = pio_inq_varid( fileid, 'TS', varid ) + !++IH + if (.not. met_nudge_only_uvps) then + !--IH + has_ts = ierr==PIO_NOERR + !++IH + endif + !--IH + + ierr = pio_inq_varid( fileid, 'LHFLX', varid ) + !++IH + if (.not. met_nudge_only_uvps) then + !--IH + has_lhflx = ierr==PIO_NOERR + !++IH + endif + !--IH + + call pio_seterrorhandling(fileid, PIO_INTERNAL_ERROR) + + if (masterproc) write(iulog,*) 'open_met_datafile: ',trim(filen) + + call get_dimension( fileid, 'time', timesize ) + + if ( associated(times) ) deallocate(times) + allocate( times(timesize) ) + + allocate( dates(timesize) ) + allocate( datesecs(timesize) ) + + ierr = pio_inq_varid( fileid, 'date', dateid ) + ierr = pio_inq_varid( fileid, 'datesec', secid ) + + ierr = pio_get_var( fileid, dateid, dates ) + ierr = pio_get_var( fileid, secid, datesecs ) + + do i=1,timesize + year = dates(i) / 10000 + month = mod(dates(i),10000)/100 + day = mod(dates(i),100) + times(i) = get_time_float( year, month, day, datesecs(i) ) + enddo + + deallocate( dates ) + deallocate( datesecs ) + + +! +! check that the data dim sizes match models dimensions +! + if (present(check_dims) .and. present(grid)) then + im = grid%im + jm = grid%jm + km = grid%km + + if (check_dims) then + + call get_dimension( fileid, 'lon', dsize ) + if (dsize /= im) then + write(iulog,*)'open_met_datafile: lonsiz=',dsize,' must = ',im + call endrun + endif + call get_dimension( fileid, 'lat', dsize ) + if (dsize /= jm) then + write(iulog,*)'open_met_datafile: latsiz=',dsize,' must = ',jm + call endrun + endif + call get_dimension( fileid, 'lev', dsize ) + met_levels = min( dsize, km ) + num_met_levels = dsize + endif + endif + + if (met_srf_rad) then + ierr = pio_inq_varid( fileid, 'ASDIR', varid ) + ierr = pio_get_att( fileid, varid, '_FillValue', srf_fill_value) + endif + + end subroutine open_met_datafile + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + function get_time_float( year, month, day, sec ) + +! returns float representation of time -- number of days +! since 1 jan 0001 00:00:00.000 + + implicit none + + integer, intent(in) :: year, month, day + integer, intent(in) :: sec + real(r8) :: get_time_float + +! ref date is 1 jan 0001 + + integer :: refyr, refmn, refdy + real(r8) :: refsc, fltdy + integer :: doy(12) + +! jan feb mar apr may jun jul aug sep oct nov dec +! 31 28 31 30 31 30 31 31 31 31 30 31 + data doy / 1, 32, 60, 91,121,152,182,213,244,274,305,335 / + + refyr = 1 + refmn = 1 + refdy = 1 + refsc = D0_0 + + if ( timemgr_is_caltype(trim(shr_cal_gregorian))) then + fltdy = greg2jday(year, month, day) - greg2jday(refyr,refmn,refdy) + else ! assume no_leap (all years are 365 days) + fltdy = (year - refyr)*days_per_non_leapyear + & + (doy(month)-doy(refmn)) + & + (day-refdy) + endif + + get_time_float = fltdy + ((sec-refsc)/seconds_per_day) + + endfunction get_time_float + +!----------------------------------------------------------------------- +! ... Return Julian day number given Gregorian date. +! +! Algorithm from Hatcher,D.A., Simple Formulae for Julian Day Numbers +! and Calendar Dates, Q.Jl.R.astr.Soc. (1984) v25, pp 53-55. +!----------------------------------------------------------------------- + function greg2jday( year, month, day ) + + implicit none + + integer, intent(in) :: year, month, day + integer :: greg2jday + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: ap, mp + integer :: y, d, n, g + + !----------------------------------------------------------------------- + ! ... Modify year and month numbers + !----------------------------------------------------------------------- + ap = year - (12 - month)/10 + mp = MOD( month-3,12 ) + if( mp < 0 ) then + mp = mp + 12 + end if + + !----------------------------------------------------------------------- + ! ... Julian day + !----------------------------------------------------------------------- + y = INT( days_per_year*( ap + 4712 ) ) + d = INT( days_per_month*mp + D0_5 ) + n = y + d + day + 59 + g = INT( D0_75*INT( ap/100 + 49 ) ) - 38 + greg2jday = n - g + + end function greg2jday + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine set_met_rlx( ) + !++ IH + ! The relaxation time between surface and met_rlx_bot is given by + ! namelist input met_rlx (hours). This will decay exponentially between + ! met_rlx_bot and met_rlx_top. 6h relaxation time when dt is 1800s gives + ! met_rlx = 1800/(6*3600) = 0.8333. + !-- IH + + use pmgrid, only: plev + use hycoef, only: hypm, ps0 + + integer :: k, k_cnt, k_top + real(r8), parameter :: h0 = 7._r8 ! scale height (km) + real(r8), parameter :: hsec = 3600._r8 ! seconds per hour + real(r8) :: p_top, p_bot + real(r8) :: p_bot_top, p_bot_bot + real(r8) :: met_max_rlxdt, dtime_hrs + +996 format( 'set_met_rlx: ',a15, I10 ) +997 format( 'set_met_rlx: ',a15, E10.2 ) +998 format( 'set_met_rlx: ',a15, PLEV(E10.2)) +999 format( 'set_met_rlx: ',a15, PLEV(F10.5)) +993 format( 'set_met_rlx: ',a25, E10.2 ) +991 format( 'set_met_rlx: ',a25, I4, E10.2, E10.2 ) + + met_rlx(:) = 999._r8 + + dtime_hrs = get_step_size()/hsec ! hours + + if (met_rlx_time > dtime_hrs) then + met_max_rlxdt = dtime_hrs/met_rlx_time + elseif (met_rlx_time < 0._r8) then + met_max_rlxdt = 0._r8 + else + met_max_rlxdt = 1._r8 + endif + + if (masterproc) then + write(iulog,fmt=993) ' met_rlx_time in hrs= ', met_rlx_time + write(iulog,fmt=993) ' met_max_rlxdt in % = ', met_max_rlxdt*100._r8 + endif + + p_top = ps0 * exp( - met_rlx_top/h0 ) + p_bot = ps0 * exp( - met_rlx_bot/h0 ) + + p_bot_top = ps0 * exp( - met_rlx_bot_top/h0 ) + p_bot_bot = ps0 * exp( - met_rlx_bot_bot/h0 ) + + if (masterproc) then + write(iulog,fmt=997) 'p_top = ',p_top + write(iulog,fmt=997) 'p_bot = ',p_bot + write(iulog,fmt=997) 'p_bot_top = ',p_bot_top + write(iulog,fmt=997) 'p_bot_bot = ',p_bot_bot + endif + + if ( p_bot < hypm( pver-met_levels+1 ) .and. ( met_levels < pver ) ) then + call endrun( 'set_met_rlx: met_rlx_bot is too high ' ) + endif + + met_rlx = 0._r8 + + where (p_top <= hypm .and. hypm < p_bot) + met_rlx = 999._r8 + endwhere + + where( p_bot <= hypm .and. hypm <= p_bot_top ) + met_rlx = met_max_rlxdt + endwhere + + where(p_bot_top < hypm .and. hypm <= p_bot_bot) + met_rlx = -999._r8 + endwhere + + if ( any( met_rlx(:) /= met_max_rlxdt) ) then + k_top = max(plev - met_levels, 1) + + ! ramp region at model top + k_cnt = count(p_top < hypm .and. hypm < p_bot) + if (k_cnt > 0) then + k_top = max(plev - met_levels, 1) + do while ( met_rlx(k_top) /= 999._r8 ) + k_top = k_top + 1 + if ( k_top == pver ) then + call endrun ( 'set_met_rlx: cannot find ramped region ') + endif + enddo + + met_rlx(1:k_top) = 0._r8 + + k_cnt = count( met_rlx == 999._r8 ) + + if (masterproc) then + write(iulog,*) 'top of model ramped region:' + write(iulog,fmt=996) 'k_cnt = ',k_cnt + write(iulog,fmt=996) 'k_top = ',k_top + endif + + do k = k_top,k_top+k_cnt + met_rlx(k) = met_max_rlxdt*real( k - k_top ) / real(k_cnt) + enddo + endif + + ! ramp region at model bottom + k_cnt = count(p_bot_top < hypm .and. hypm < p_bot_bot) + if (k_cnt > 0) then + k_top = max(plev - met_levels, 1) + do while ( met_rlx(k_top) /= -999._r8 ) + k_top = k_top + 1 + if ( k_top == pver ) then + call endrun ( 'set_met_rlx: cannot find ramped region ') + endif + enddo + + if (masterproc) then + write(iulog,*) 'bottom of model ramped region:' + write(iulog,fmt=996) 'k_cnt = ',k_cnt + write(iulog,fmt=996) 'k_top = ',k_top + endif + + do k = k_top,k_top+k_cnt-1 + met_rlx(k) = met_max_rlxdt*(1._r8 - real( k - k_top +1) / real(k_cnt)) + enddo + endif + + endif + + if (masterproc) then + write(iulog,fmt=996) ' met_levels = ',met_levels + write(iulog,fmt=996) 'non-zero terms:',count( met_rlx /= 0._r8 ) + endif + + if ( met_levels < count( met_rlx /= 0._r8 ) ) then + call endrun('set_met_rlx: met_rlx_top is too high for the meteorology data') + endif + + if (masterproc) then + do k = max(plev - met_levels, 1), pver + write(iulog,fmt=991) 'press levels, met_rlx = ', k, hypm(k), met_rlx(k) + end do + endif + + if ( any( (met_rlx > 1._r8) .or. (met_rlx < 0._r8) ) ) then + if (masterproc) then + write(iulog,fmt=993) 'set_met_rlx: dtime_hrs in hrs = ', dtime_hrs + write(iulog,fmt=993) 'set_met_rlx:met_rlx_time in hrs = ', met_rlx_time + write(iulog,fmt=993) 'set_met_rlx: met_max_rlxdt = ', met_max_rlxdt + write(iulog,fmt=999) 'set_met_rlx: met_rlx = ', met_rlx + endif + call endrun('Offline meteorology relaxation function not set correctly.') + endif + + end subroutine set_met_rlx + +end module metdata diff --git a/src/NorESM/macrop_driver.F90 b/src/NorESM/macrop_driver.F90 new file mode 100644 index 0000000000..8defa67d42 --- /dev/null +++ b/src/NorESM/macrop_driver.F90 @@ -0,0 +1,1219 @@ + module macrop_driver + + !------------------------------------------------------------------------------------------------------- + ! Purpose: + ! + ! Provides the CAM interface to the prognostic cloud macrophysics + ! + ! Author: Andrew Gettelman, Cheryl Craig October 2010 + ! Origin: modified from stratiform.F90 elements + ! (Boville 2002, Coleman 2004, Park 2009, Kay 2010) + !------------------------------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use physconst, only: latice, latvap + use phys_control, only: phys_getopts + use constituents, only: cnst_get_ind, pcnst + use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_field, pbuf_old_tim_idx + use time_manager, only: is_first_step + use cldwat2m_macro, only: ini_macro + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use zm_conv_intr, only: zmconv_microp + + implicit none + private + save + + public :: macrop_driver_readnl + public :: macrop_driver_register + public :: macrop_driver_init + public :: macrop_driver_tend + public :: liquid_macro_tend + + logical, public :: do_cldice ! .true., park macrophysics is prognosing cldice + logical, public :: do_cldliq ! .true., park macrophysics is prognosing cldliq + logical, public :: do_detrain ! .true., park macrophysics is detraining ice into stratiform + + ! ------------------------- ! + ! Private Module Parameters ! + ! ------------------------- ! + + ! 'cu_det_st' : If .true. (.false.), detrain cumulus liquid condensate into the pre-existing liquid stratus + ! (environment) without (with) macrophysical evaporation. If there is no pre-esisting stratus, + ! evaporate cumulus liquid condensate. This option only influences the treatment of cumulus + ! liquid condensate, not cumulus ice condensate. + + logical, parameter :: cu_det_st = .false. + + ! Parameters used for selecting generalized critical RH for liquid and ice stratus + integer :: rhminl_opt = 0 + integer :: rhmini_opt = 0 + + + character(len=16) :: shallow_scheme + logical :: use_shfrc ! Local copy of flag from convect_shallow_use_shfrc + + integer :: & + ixcldliq, &! cloud liquid amount index + ixcldice, &! cloud ice amount index + ixnumliq, &! cloud liquid number index + ixnumice, &! cloud ice water index + qcwat_idx, &! qcwat index in physics buffer + lcwat_idx, &! lcwat index in physics buffer + iccwat_idx, &! iccwat index in physics buffer + nlwat_idx, &! nlwat index in physics buffer + niwat_idx, &! niwat index in physics buffer + tcwat_idx, &! tcwat index in physics buffer + CC_T_idx, &! + CC_qv_idx, &! + CC_ql_idx, &! + CC_qi_idx, &! + CC_nl_idx, &! + CC_ni_idx, &! + CC_qlst_idx, &! + cld_idx, &! cld index in physics buffer + ast_idx, &! stratiform cloud fraction index in physics buffer + aist_idx, &! ice stratiform cloud fraction index in physics buffer + alst_idx, &! liquid stratiform cloud fraction index in physics buffer + qist_idx, &! ice stratiform in-cloud IWC + qlst_idx, &! liquid stratiform in-cloud LWC + concld_idx, &! concld index in physics buffer + fice_idx, & + cmeliq_idx, & + shfrc_idx + + 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. + + + integer :: & + tke_idx = -1, &! tke defined at the model interfaces + qtl_flx_idx = -1, &! overbar(w'qtl' where qtl = qv + ql) from the PBL scheme + qti_flx_idx = -1, &! overbar(w'qti' where qti = qv + qi) from the PBL scheme + cmfr_det_idx = -1, &! detrained convective mass flux from UNICON + qlr_det_idx = -1, &! detrained convective ql from UNICON + qir_det_idx = -1, &! detrained convective qi from UNICON + cmfmc_sh_idx = -1 + + contains + + ! =============================================================================== + subroutine macrop_driver_readnl(nlfile) + + 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 + + ! Namelist variables + logical :: macro_park_do_cldice = .true. ! do_cldice = .true., park macrophysics is prognosing cldice + logical :: macro_park_do_cldliq = .true. ! do_cldliq = .true., park macrophysics is prognosing cldliq + logical :: macro_park_do_detrain = .true. ! do_detrain = .true., park macrophysics is detraining ice into stratiform + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'macrop_driver_readnl' + + namelist /macro_park_nl/ macro_park_do_cldice, macro_park_do_cldliq, macro_park_do_detrain + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'macro_park_nl', status=ierr) + if (ierr == 0) then + read(unitn, macro_park_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + ! set local variables + + do_cldice = macro_park_do_cldice + do_cldliq = macro_park_do_cldliq + do_detrain = macro_park_do_detrain + + end if + +#ifdef SPMD + ! Broadcast namelist variables + call mpibcast(do_cldice, 1, mpilog, 0, mpicom) + call mpibcast(do_cldliq, 1, mpilog, 0, mpicom) + call mpibcast(do_detrain, 1, mpilog, 0, mpicom) +#endif + +end subroutine macrop_driver_readnl + + !================================================================================================ + + subroutine macrop_driver_register + + !---------------------------------------------------------------------- ! + ! ! + ! Register the constituents (cloud liquid and cloud ice) and the fields ! + ! in the physics buffer. ! + ! ! + !---------------------------------------------------------------------- ! + + + use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls + + !----------------------------------------------------------------------- + + call phys_getopts(shallow_scheme_out=shallow_scheme) + + 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('CLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cld_idx) + call pbuf_add_field('CONCLD', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), concld_idx) + + call pbuf_add_field('QCWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), qcwat_idx) + call pbuf_add_field('LCWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), lcwat_idx) + call pbuf_add_field('ICCWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), iccwat_idx) + call pbuf_add_field('NLWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), nlwat_idx) + call pbuf_add_field('NIWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), niwat_idx) + call pbuf_add_field('TCWAT', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), tcwat_idx) + + call pbuf_add_field('FICE', 'physpkg', dtype_r8, (/pcols,pver/), fice_idx) + + call pbuf_add_field('CMELIQ', 'physpkg', dtype_r8, (/pcols,pver/), cmeliq_idx) + + end subroutine macrop_driver_register + + !============================================================================ ! + ! ! + !============================================================================ ! + + subroutine macrop_driver_init(pbuf2d) + + !-------------------------------------------- ! + ! ! + ! Initialize the cloud water parameterization ! + ! ! + !-------------------------------------------- ! + use physics_buffer, only : pbuf_get_index + use cam_history, only: addfld, add_default + use convect_shallow, only: convect_shallow_use_shfrc + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: history_budget ! Output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: istat + + character(len=*), parameter :: subname = 'macrop_driver_init' + !----------------------------------------------------------------------- + + ! Initialization routine for cloud macrophysics + if (shallow_scheme .eq. 'UNICON') rhminl_opt = 1 + call ini_macro(rhminl_opt, rhmini_opt) + + call phys_getopts(history_aerosol_out = history_aerosol , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = history_budget_histfile_num ) + + ! Find out whether shfrc from convect_shallow will be used in cldfrc + + if( convect_shallow_use_shfrc() ) then + use_shfrc = .true. + shfrc_idx = pbuf_get_index('shfrc') + else + use_shfrc = .false. + endif + + 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 ('SHDLFLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained liquid water from shallow convection' ) + call addfld ('SHDLFICE', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained ice from shallow convection' ) + call addfld ('DPDLFT', (/ 'lev' /), 'A', 'K/s', 'T-tendency due to deep convective detrainment' ) + call addfld ('SHDLFT', (/ 'lev' /), 'A', 'K/s', 'T-tendency due to shallow convective detrainment' ) + + call addfld ('ZMDLF', (/ 'lev' /), 'A', 'kg/kg/s', 'Detrained liquid water from ZM convection' ) + + call addfld ('MACPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Revised macrophysics' ) + call addfld ('MACPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Revised macrophysics' ) + call addfld ('MACPDLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ tendency - Revised macrophysics' ) + call addfld ('MACPDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency - Revised macrophysics' ) + + call addfld ('CLDVAPADJ', (/ 'lev' /), 'A', 'kg/kg/s', & + 'Q tendency associated with liq/ice adjustment - Revised macrophysics' ) + call addfld ('CLDLIQADJ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ adjustment tendency - Revised macrophysics' ) + call addfld ('CLDICEADJ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE adjustment tendency - Revised macrophysics' ) + call addfld ('CLDLIQDET', (/ 'lev' /), 'A', 'kg/kg/s', & + 'Detrainment of conv cld liq into envrionment - Revised macrophysics' ) + call addfld ('CLDICEDET', (/ 'lev' /), 'A', 'kg/kg/s', & + 'Detrainment of conv cld ice into envrionment - Revised macrophysics' ) + call addfld ('CLDLIQLIM', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ limiting tendency - Revised macrophysics' ) + call addfld ('CLDICELIM', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE limiting tendency - Revised macrophysics' ) + + call addfld ('AST', (/ 'lev' /), 'A', '1', 'Stratus cloud fraction' ) + call addfld ('LIQCLDF', (/ 'lev' /), 'A', '1', 'Stratus Liquid cloud fraction' ) + call addfld ('ICECLDF', (/ 'lev' /), 'A', '1', 'Stratus ICE cloud fraction' ) + + call addfld ('CLDST', (/ 'lev' /), 'A', 'fraction', 'Stratus cloud fraction' ) + call addfld ('CONCLD', (/ 'lev' /), 'A', 'fraction', 'Convective cloud cover' ) + + call addfld ('CLR_LIQ', (/ 'lev' /), 'A', 'fraction', 'Clear sky fraction for liquid stratus' ) + call addfld ('CLR_ICE', (/ 'lev' /), 'A', 'fraction', 'Clear sky fraction for ice stratus' ) + + call addfld ('CLDLIQSTR', (/ 'lev' /), 'A', 'kg/kg', 'Stratiform CLDLIQ' ) + call addfld ('CLDICESTR', (/ 'lev' /), 'A', 'kg/kg', 'Stratiform CLDICE' ) + call addfld ('CLDLIQCON', (/ 'lev' /), 'A', 'kg/kg', 'Convective CLDLIQ' ) + call addfld ('CLDICECON', (/ 'lev' /), 'A', 'kg/kg', 'Convective CLDICE' ) + + call addfld ('CLDSICE', (/ 'lev' /), 'A', 'kg/kg', 'CloudSat equivalent ice mass mixing ratio' ) + call addfld ('CMELIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of cond-evap of liq within the cloud' ) + + 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 ('QITENDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency from Ice Saturation Adjustment' ) + call addfld ('NITENDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'NUMICE tendency from Ice Saturation Adjustment' ) +!AL + call addfld ('DPDLFNC ', (/ 'lev' /), 'A', '#/kg/s ', 'Detrained liquid number from deep convection' ) + call addfld ('DPDLFNI ', (/ 'lev' /), 'A', '#/kg/s ', 'Detrained ice number from deep convection' ) + call addfld ('SHDLFNC ', (/ 'lev' /), 'A', '#/kg/s ', 'Detrained liquid number from shallow convection') + call addfld ('SHDLFNI ', (/ 'lev' /), 'A', '#/kg/s ', 'Detrained ice number from shallow convection' ) + call addfld ('MACPDNC ', (/ 'lev' /), 'A', '#/kg/s ', 'NC tendency - Revised macrophysics' ) + call addfld ('MACPDNI ', (/ 'lev' /), 'A', '#/kg/s ', 'NI tendency - Revised macrophysics' ) +!AL + if ( history_budget ) then + + call add_default ('DPDLFLIQ ', history_budget_histfile_num, ' ') + call add_default ('DPDLFICE ', history_budget_histfile_num, ' ') + call add_default ('SHDLFLIQ ', history_budget_histfile_num, ' ') + call add_default ('SHDLFICE ', history_budget_histfile_num, ' ') + call add_default ('DPDLFT ', history_budget_histfile_num, ' ') + call add_default ('SHDLFT ', history_budget_histfile_num, ' ') + call add_default ('ZMDLF ', history_budget_histfile_num, ' ') + + call add_default ('MACPDT ', history_budget_histfile_num, ' ') + call add_default ('MACPDQ ', history_budget_histfile_num, ' ') + call add_default ('MACPDLIQ ', history_budget_histfile_num, ' ') + call add_default ('MACPDICE ', history_budget_histfile_num, ' ') + + call add_default ('CLDVAPADJ', history_budget_histfile_num, ' ') + call add_default ('CLDLIQLIM', history_budget_histfile_num, ' ') + call add_default ('CLDLIQDET', history_budget_histfile_num, ' ') + call add_default ('CLDLIQADJ', history_budget_histfile_num, ' ') + call add_default ('CLDICELIM', history_budget_histfile_num, ' ') + call add_default ('CLDICEDET', history_budget_histfile_num, ' ') + call add_default ('CLDICEADJ', history_budget_histfile_num, ' ') + + call add_default ('CMELIQ ', history_budget_histfile_num, ' ') + +!AL + call add_default ('DPDLFNC ', history_budget_histfile_num, ' ') + call add_default ('DPDLFNI ', history_budget_histfile_num, ' ') + call add_default ('SHDLFNC ', history_budget_histfile_num, ' ') + call add_default ('SHDLFNI ', history_budget_histfile_num, ' ') + call add_default ('MACPDNC ', history_budget_histfile_num, ' ') + call add_default ('MACPDNI ', history_budget_histfile_num, ' ') +!AL + end if + + ! Get constituent indices + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('NUMLIQ', ixnumliq) + call cnst_get_ind('NUMICE', ixnumice) + + ! Get physics buffer indices + CC_T_idx = pbuf_get_index('CC_T') + CC_qv_idx = pbuf_get_index('CC_qv') + CC_ql_idx = pbuf_get_index('CC_ql') + CC_qi_idx = pbuf_get_index('CC_qi') + CC_nl_idx = pbuf_get_index('CC_nl') + CC_ni_idx = pbuf_get_index('CC_ni') + CC_qlst_idx = pbuf_get_index('CC_qlst') + cmfmc_sh_idx = pbuf_get_index('CMFMC_SH') + + 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 + + + if (rhminl_opt > 0 .or. rhmini_opt > 0) then + cmfr_det_idx = pbuf_get_index('cmfr_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires cmfr_det in pbuf') + if (rhminl_opt > 0) then + qlr_det_idx = pbuf_get_index('qlr_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires qlr_det in pbuf') + end if + if (rhmini_opt > 0) then + qir_det_idx = pbuf_get_index('qir_det', istat) + if (istat < 0) call endrun(subname//': macrop option requires qir_det in pbuf') + end if + end if + + if (rhminl_opt == 2 .or. rhmini_opt == 2) then + tke_idx = pbuf_get_index('tke') + if (rhminl_opt == 2) then + qtl_flx_idx = pbuf_get_index('qtl_flx', istat) + if (istat < 0) call endrun(subname//': macrop option requires qtl_flx in pbuf') + end if + if (rhmini_opt == 2) then + qti_flx_idx = pbuf_get_index('qti_flx', istat) + if (istat < 0) call endrun(subname//': macrop option requires qti_flx in pbuf') + end if + end if + + ! Init pbuf fields. Note that the fields CLD, CONCLD, QCWAT, LCWAT, + ! ICCWAT, and TCWAT are initialized in phys_inidat. + if (is_first_step()) then + call pbuf_set_field(pbuf2d, ast_idx, 0._r8) + call pbuf_set_field(pbuf2d, aist_idx, 0._r8) + call pbuf_set_field(pbuf2d, alst_idx, 0._r8) + call pbuf_set_field(pbuf2d, qist_idx, 0._r8) + call pbuf_set_field(pbuf2d, qlst_idx, 0._r8) + call pbuf_set_field(pbuf2d, nlwat_idx, 0._r8) + call pbuf_set_field(pbuf2d, niwat_idx, 0._r8) + end if + + ! the following are physpkg, so they need to be init every time + call pbuf_set_field(pbuf2d, fice_idx, 0._r8) + call pbuf_set_field(pbuf2d, cmeliq_idx, 0._r8) + + end subroutine macrop_driver_init + + !============================================================================ ! + ! ! + !============================================================================ ! + + + subroutine macrop_driver_tend( & + state, ptend, dtime, landfrac, & + ocnfrac, snowh, & + dlf, dlf2, cmfmc, ts, & + sst, zdu, & + pbuf, & + det_s, det_ice) + + !-------------------------------------------------------- ! + ! ! + ! Purpose: ! + ! ! + ! Interface to detrain, cloud fraction and ! + ! cloud macrophysics subroutines ! + ! ! + ! Author: A. Gettelman, C. Craig, Oct 2010 ! + ! based on stratiform_tend by D.B. Coleman 4/2010 ! + ! ! + !-------------------------------------------------------- ! + + use cloud_fraction, only: cldfrc, cldfrc_fice + use physics_types, only: physics_state, physics_ptend + use physics_types, only: physics_ptend_init, physics_update + use physics_types, only: physics_ptend_sum, physics_state_copy + use physics_types, only: physics_state_dealloc + use cam_history, only: outfld + use constituents, only: cnst_get_ind, pcnst + use cldwat2m_macro, only: mmacro_pcond + use physconst, only: cpair, tmelt, gravit + use time_manager, only: get_nstep + + use ref_pres, only: top_lev => trop_cloud_top_lev + + ! + ! Input arguments + ! + + type(physics_state), intent(in) :: state ! State variables + type(physics_ptend), intent(out) :: ptend ! macrophysics parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer + + real(r8), intent(in) :: dtime ! Timestep + real(r8), intent(in) :: landfrac(pcols) ! Land fraction (fraction) + real(r8), intent(in) :: ocnfrac (pcols) ! Ocean fraction (fraction) + real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) + real(r8), intent(in) :: dlf(pcols,pver) ! Detrained water from convection schemes + real(r8), intent(in) :: dlf2(pcols,pver) ! Detrained water from shallow convection scheme + real(r8), intent(in) :: cmfmc(pcols,pverp) ! Deep + Shallow Convective mass flux [ kg /s/m^2 ] + + real(r8), intent(in) :: ts(pcols) ! Surface temperature + real(r8), intent(in) :: sst(pcols) ! Sea surface temperature + real(r8), intent(in) :: zdu(pcols,pver) ! Detrainment rate from deep convection + + + ! 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 + ! + + type(physics_state) :: state_loc ! Local copy of the state variable + type(physics_ptend) :: ptend_loc ! Local parameterization tendencies + + integer i,k + integer :: lchnk ! Chunk identifier + integer :: ncol ! Number of atmospheric columns + + ! Physics buffer fields + + integer itim_old + real(r8), pointer, dimension(:,:) :: qcwat ! Cloud water old q + real(r8), pointer, dimension(:,:) :: tcwat ! Cloud water old temperature + real(r8), pointer, dimension(:,:) :: lcwat ! Cloud liquid water old q + real(r8), pointer, dimension(:,:) :: iccwat ! Cloud ice water old q + real(r8), pointer, dimension(:,:) :: nlwat ! Cloud liquid droplet number condentration. old. + real(r8), pointer, dimension(:,:) :: niwat ! Cloud ice droplet number condentration. old. + real(r8), pointer, dimension(:,:) :: CC_T ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_qv ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_ql ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_qi ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_nl ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_ni ! Grid-mean microphysical tendency + real(r8), pointer, dimension(:,:) :: CC_qlst ! In-liquid stratus microphysical tendency + real(r8), pointer, dimension(:,:) :: cld ! Total cloud fraction + real(r8), pointer, dimension(:,:) :: ast ! Relative humidity cloud fraction + real(r8), pointer, dimension(:,:) :: aist ! Physical ice stratus fraction + real(r8), pointer, dimension(:,:) :: alst ! Physical liquid stratus fraction + real(r8), pointer, dimension(:,:) :: qist ! Physical in-cloud IWC + real(r8), pointer, dimension(:,:) :: qlst ! Physical in-cloud LWC + real(r8), pointer, dimension(:,:) :: concld ! Convective cloud fraction + + real(r8), pointer, dimension(:,:) :: shfrc ! Cloud fraction from shallow convection scheme + real(r8), pointer, dimension(:,:) :: cmfmc_sh ! Shallow convective mass flux (pcols,pverp) [ kg/s/m^2 ] + + real(r8), pointer, dimension(:,:) :: cmeliq + + real(r8), pointer, dimension(:,:) :: tke + real(r8), pointer, dimension(:,:) :: qtl_flx + real(r8), pointer, dimension(:,:) :: qti_flx + real(r8), pointer, dimension(:,:) :: cmfr_det + real(r8), pointer, dimension(:,:) :: qlr_det + real(r8), pointer, dimension(:,:) :: qir_det + + ! Convective cloud to the physics buffer for purposes of ql contrib. to radn. + + real(r8), pointer, dimension(:,:) :: fice_ql ! Cloud ice/water partitioning ratio. + + ! 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) :: latsub + + ! tendencies for ice saturation adjustment + real(r8) :: stend(pcols,pver) + real(r8) :: qvtend(pcols,pver) + real(r8) :: qitend(pcols,pver) + real(r8) :: initend(pcols,pver) + + ! Local variables for cldfrc + + real(r8) cldst(pcols,pver) ! Stratus cloud fraction + real(r8) rhcloud(pcols,pver) ! Relative humidity cloud (last timestep) + real(r8) clc(pcols) ! Column convective cloud amount + real(r8) rhu00(pcols,pver) ! RH threshold for cloud + real(r8) icecldf(pcols,pver) ! Ice cloud fraction + real(r8) liqcldf(pcols,pver) ! Liquid cloud fraction (combined into cloud) + real(r8) relhum(pcols,pver) ! RH, output to determine drh/da + + ! Local variables for macrophysics + + real(r8) rdtime ! 1./dtime + real(r8) qtend(pcols,pver) ! Moisture tendencies + real(r8) ttend(pcols,pver) ! Temperature tendencies + real(r8) ltend(pcols,pver) ! Cloud liquid water tendencies + real(r8) fice(pcols,pver) ! Fractional ice content within cloud + real(r8) fsnow(pcols,pver) ! Fractional snow production + real(r8) homoo(pcols,pver) + real(r8) qcreso(pcols,pver) + real(r8) prcio(pcols,pver) + real(r8) praio(pcols,pver) + real(r8) qireso(pcols,pver) + real(r8) ftem(pcols,pver) + real(r8) pracso (pcols,pver) + real(r8) dpdlfliq(pcols,pver) + real(r8) dpdlfice(pcols,pver) + real(r8) shdlfliq(pcols,pver) + real(r8) shdlfice(pcols,pver) + real(r8) dpdlft (pcols,pver) + real(r8) shdlft (pcols,pver) +!AL + real(r8) dpdlfnc(pcols,pver) + real(r8) dpdlfni(pcols,pver) + real(r8) shdlfnc(pcols,pver) + real(r8) shdlfni(pcols,pver) +!AL + + real(r8) dum1 + real(r8) qc(pcols,pver) + real(r8) qi(pcols,pver) + real(r8) nc(pcols,pver) + real(r8) ni(pcols,pver) + + logical lq(pcnst) + + ! Output from mmacro_pcond + + real(r8) tlat(pcols,pver) + real(r8) qvlat(pcols,pver) + real(r8) qcten(pcols,pver) + real(r8) qiten(pcols,pver) + real(r8) ncten(pcols,pver) + real(r8) niten(pcols,pver) + + ! Output from mmacro_pcond + + real(r8) qvadj(pcols,pver) ! Macro-physics adjustment tendency from "positive_moisture" call (vapor) + real(r8) qladj(pcols,pver) ! Macro-physics adjustment tendency from "positive_moisture" call (liquid) + real(r8) qiadj(pcols,pver) ! Macro-physics adjustment tendency from "positive_moisture" call (ice) + real(r8) qllim(pcols,pver) ! Macro-physics tendency from "instratus_condensate" call (liquid) + real(r8) qilim(pcols,pver) ! Macro-physics tendency from "instratus_condensate" call (ice) + + ! For revised macophysics, mmacro_pcond + + real(r8) itend(pcols,pver) + real(r8) lmitend(pcols,pver) + real(r8) zeros(pcols,pver) + real(r8) t_inout(pcols,pver) + real(r8) qv_inout(pcols,pver) + real(r8) ql_inout(pcols,pver) + real(r8) qi_inout(pcols,pver) + real(r8) concld_old(pcols,pver) + + ! Note that below 'clr_old' is defined using 'alst_old' not 'ast_old' for full consistency with the + ! liquid condensation process which is using 'alst' not 'ast'. + ! For microconsistency use 'concld_old', since 'alst_old' was computed using 'concld_old'. + ! Since convective updraft fractional area is small, it does not matter whether 'concld' or 'concld_old' is used. + ! Note also that 'clri_old' is defined using 'ast_old' since current microphysics is operating on 'ast_old' + real(r8) clrw_old(pcols,pver) ! (1 - concld_old - alst_old) + real(r8) clri_old(pcols,pver) ! (1 - concld_old - ast_old) + + real(r8) nl_inout(pcols,pver) + real(r8) ni_inout(pcols,pver) + + real(r8) nltend(pcols,pver) + real(r8) nitend(pcols,pver) + + + ! For detraining cumulus condensate into the 'stratus' without evaporation + ! This is for use in mmacro_pcond + + real(r8) dlf_T(pcols,pver) + real(r8) dlf_qv(pcols,pver) + real(r8) dlf_ql(pcols,pver) + real(r8) dlf_qi(pcols,pver) + real(r8) dlf_nl(pcols,pver) + real(r8) dlf_ni(pcols,pver) + + ! Local variables for CFMIP calculations + real(r8) :: mr_lsliq(pcols,pver) ! mixing_ratio_large_scale_cloud_liquid (kg/kg) + real(r8) :: mr_lsice(pcols,pver) ! mixing_ratio_large_scale_cloud_ice (kg/kg) + real(r8) :: mr_ccliq(pcols,pver) ! mixing_ratio_convective_cloud_liquid (kg/kg) + real(r8) :: mr_ccice(pcols,pver) ! mixing_ratio_convective_cloud_ice (kg/kg) + + ! CloudSat equivalent ice mass mixing ratio (kg/kg) + real(r8) :: cldsice(pcols,pver) + + ! ====================================================================== + + lchnk = state%lchnk + ncol = state%ncol + + call physics_state_copy(state, state_loc) ! Copy state to local state_loc. + + ! Associate pointers with physics buffer fields + + itim_old = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, qcwat_idx, qcwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, tcwat_idx, tcwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, lcwat_idx, lcwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, iccwat_idx, iccwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, nlwat_idx, nlwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, niwat_idx, niwat, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, cc_t_idx, cc_t, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_qv_idx, cc_qv, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_ql_idx, cc_ql, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_qi_idx, cc_qi, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_nl_idx, cc_nl, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_ni_idx, cc_ni, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cc_qlst_idx, cc_qlst, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + 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, aist_idx, aist, 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, qist_idx, qist, 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, cmeliq_idx, cmeliq) + +! For purposes of convective ql. + + call pbuf_get_field(pbuf, fice_idx, fice_ql ) + + call pbuf_get_field(pbuf, cmfmc_sh_idx, cmfmc_sh) + + ! check that qcwat and tcwat were initialized; if not then do it now. + if (qcwat(1,1) == huge(1._r8)) then + qcwat(:ncol,:) = state%q(:ncol,:,1) + end if + if (tcwat(1,1) == huge(1._r8)) then + tcwat(:ncol,:) = state%t(:ncol,:) + end if + + ! Initialize convective detrainment tendency + + dlf_T(:,:) = 0._r8 + dlf_qv(:,:) = 0._r8 + dlf_ql(:,:) = 0._r8 + dlf_qi(:,:) = 0._r8 + dlf_nl(:,:) = 0._r8 + dlf_ni(:,:) = 0._r8 + + ! ------------------------------------- ! + ! From here, process computation begins ! + ! ------------------------------------- ! + + ! ----------------------------------------------------------------------------- ! + ! Detrainment of convective condensate into the environment or stratiform cloud ! + ! ----------------------------------------------------------------------------- ! + + lq(:) = .FALSE. + lq(ixcldliq) = .TRUE. + lq(ixcldice) = .TRUE. + lq(ixnumliq) = .TRUE. + lq(ixnumice) = .TRUE. + call physics_ptend_init(ptend_loc, state%psetcols, 'pcwdetrain', ls=.true., lq=lq) ! Initialize local physics_ptend object + + ! Procedures : + ! (1) Partition detrained convective cloud water into liquid and ice based on T. + ! This also involves heating. + ! If convection scheme can handle this internally, this step is not necssary. + ! (2) Assuming a certain effective droplet radius, computes number concentration + ! of detrained convective cloud liquid and ice. + ! (3) If 'cu_det_st = .true' ('false'), detrain convective cloud 'liquid' into + ! the pre-existing 'liquid' stratus ( mean environment ). The former does + ! not involve any macrophysical evaporation while the latter does. This is + ! a kind of 'targetted' deposition. Then, force in-stratus LWC to be bounded + ! by qcst_min and qcst_max in mmacro_pcond. + ! (4) In contrast to liquid, convective ice is detrained into the environment + ! and involved in the sublimation. Similar bounds as liquid stratus are imposed. + ! This is the key procesure generating upper-level cirrus clouds. + ! The unit of dlf : [ kg/kg/s ] + + 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 + + det_s(:) = 0._r8 + det_ice(:) = 0._r8 + + dpdlfliq = 0._r8 + dpdlfice = 0._r8 + shdlfliq = 0._r8 + shdlfice = 0._r8 + dpdlft = 0._r8 + shdlft = 0._r8 + + do k = top_lev, pver + do i = 1, state_loc%ncol + if( state_loc%t(i,k) > 268.15_r8 ) then + dum1 = 0.0_r8 + elseif( state_loc%t(i,k) < 238.15_r8 ) then + dum1 = 1.0_r8 + else + dum1 = ( 268.15_r8 - state_loc%t(i,k) ) / 30._r8 + endif + + ! If detrainment was done elsewhere, still update the variables used for output + ! assuming that the temperature split between liquid and ice is the same as assumed + ! here. + 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 + if (do_detrain) then + ptend_loc%q(i,k,ixcldliq) = dlf(i,k) * ( 1._r8 - dum1 ) + ptend_loc%q(i,k,ixcldice) = dlf(i,k) * dum1 + ! dum2 = dlf(i,k) * ( 1._r8 - 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 + ! dum2 = dlf(i,k) * dum1 + 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 + else + ptend_loc%q(i,k,ixcldliq) = 0._r8 + ptend_loc%q(i,k,ixcldice) = 0._r8 + ptend_loc%q(i,k,ixnumliq) = 0._r8 + ptend_loc%q(i,k,ixnumice) = 0._r8 + ptend_loc%s(i,k) = 0._r8 + end if + + + 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)*state_loc%pdel(i,k)/gravit + det_ice(i) = det_ice(i) - ptend_loc%q(i,k,ixcldice)*state_loc%pdel(i,k)/gravit + + ! Targetted detrainment of convective liquid water either directly into the + ! existing liquid stratus or into the environment. + if( cu_det_st ) then + dlf_T(i,k) = ptend_loc%s(i,k)/cpair + dlf_qv(i,k) = 0._r8 + dlf_ql(i,k) = ptend_loc%q(i,k,ixcldliq) + dlf_qi(i,k) = ptend_loc%q(i,k,ixcldice) + dlf_nl(i,k) = ptend_loc%q(i,k,ixnumliq) + dlf_ni(i,k) = ptend_loc%q(i,k,ixnumice) + ptend_loc%q(i,k,ixcldliq) = 0._r8 + ptend_loc%q(i,k,ixcldice) = 0._r8 + ptend_loc%q(i,k,ixnumliq) = 0._r8 + ptend_loc%q(i,k,ixnumice) = 0._r8 + ptend_loc%s(i,k) = 0._r8 + dpdlfliq(i,k) = 0._r8 + dpdlfice(i,k) = 0._r8 + shdlfliq(i,k) = 0._r8 + shdlfice(i,k) = 0._r8 + dpdlft (i,k) = 0._r8 + shdlft (i,k) = 0._r8 + else + if (zmconv_microp) then + dpdlfliq(i,k) = dlfzm(i,k) + dpdlfice(i,k) = difzm(i,k) + dpdlft (i,k) = 0._r8 + else + dpdlfliq(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( 1._r8 - dum1 ) + dpdlfice(i,k) = ( dlf(i,k) - dlf2(i,k) ) * ( dum1 ) + dpdlft (i,k) = ( dlf(i,k) - dlf2(i,k) ) * dum1 * latice/cpair + end if + + shdlfliq(i,k) = dlf2(i,k) * ( 1._r8 - dum1 ) + shdlfice(i,k) = dlf2(i,k) * ( dum1 ) + shdlft (i,k) = dlf2(i,k) * dum1 * latice/cpair +!AL + dpdlfnc(i,k) = 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 liq + dpdlfni(i,k) = 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 ice + shdlfnc(i,k) = 3._r8 * ( dlf2(i,k)* ( 1._r8 - dum1 ) ) / (4._r8*3.14_r8*10.e-6_r8**3*997._r8) ! Shallow Convection liq + shdlfni(i,k) = 3._r8 * ( dlf2(i,k)* dum1 ) / (4._r8*3.14_r8*50.e-6_r8**3*500._r8) ! Shallow Convection ice +!AL + endif + end do + end do + + call outfld( 'DPDLFLIQ ', dpdlfliq, pcols, lchnk ) + call outfld( 'DPDLFICE ', dpdlfice, pcols, lchnk ) + call outfld( 'SHDLFLIQ ', shdlfliq, pcols, lchnk ) + call outfld( 'SHDLFICE ', shdlfice, pcols, lchnk ) + call outfld( 'DPDLFT ', dpdlft , pcols, lchnk ) + call outfld( 'SHDLFT ', shdlft , pcols, lchnk ) +!AL + call outfld( 'DPDLFNC ', dpdlfnc, pcols, lchnk ) + call outfld( 'DPDLFNI ', dpdlfni, pcols, lchnk ) + call outfld( 'SHDLFNC ', shdlfnc, pcols, lchnk ) + call outfld( 'SHDLFNI ', shdlfni, pcols, lchnk ) +!AL + call outfld( 'ZMDLF', dlf , pcols, state_loc%lchnk ) + + det_ice(:ncol) = det_ice(:ncol)/1000._r8 ! divide by density of water + + ! Add the detrainment tendency to the output tendency + call physics_ptend_init(ptend, state%psetcols, 'macrop') + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! update local copy of state with the detrainment tendency + ! ptend_loc is reset to zero by this call + call physics_update(state_loc, ptend_loc, dtime) + + ! -------------------------------------- ! + ! Computation of Various Cloud Fractions ! + ! -------------------------------------- ! + + ! ----------------------------------------------------------------------------- ! + ! Treatment of cloud fraction in CAM4 and CAM5 differs ! + ! (1) CAM4 ! + ! . Cumulus AMT = Deep Cumulus AMT ( empirical fcn of mass flux ) + ! + ! Shallow Cumulus AMT ( empirical fcn of mass flux ) ! + ! . Stratus AMT = max( RH stratus AMT, Stability Stratus AMT ) ! + ! . Cumulus and Stratus are 'minimally' overlapped without hierarchy. ! + ! . Cumulus LWC,IWC is assumed to be the same as Stratus LWC,IWC ! + ! (2) CAM5 ! + ! . Cumulus AMT = Deep Cumulus AMT ( empirical fcn of mass flux ) + ! + ! Shallow Cumulus AMT ( internally fcn of mass flux and w ) ! + ! . Stratus AMT = fcn of environmental-mean RH ( no Stability Stratus ) ! + ! . Cumulus and Stratus are non-overlapped with higher priority on Cumulus ! + ! . Cumulus ( both Deep and Shallow ) has its own LWC and IWC. ! + ! ----------------------------------------------------------------------------- ! + + concld_old(:ncol,top_lev:pver) = concld(:ncol,top_lev:pver) + + nullify(tke, qtl_flx, qti_flx, cmfr_det, qlr_det, qir_det) + if (tke_idx > 0) call pbuf_get_field(pbuf, tke_idx, tke) + if (qtl_flx_idx > 0) call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + if (qti_flx_idx > 0) call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + if (cmfr_det_idx > 0) call pbuf_get_field(pbuf, cmfr_det_idx, cmfr_det) + if (qlr_det_idx > 0) call pbuf_get_field(pbuf, qlr_det_idx, qlr_det) + if (qir_det_idx > 0) call pbuf_get_field(pbuf, qir_det_idx, qir_det) + + clrw_old(:ncol,:top_lev-1) = 0._r8 + clri_old(:ncol,:top_lev-1) = 0._r8 + do k = top_lev, pver + do i = 1, ncol + clrw_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - alst(i,k) ) ) + clri_old(i,k) = max( 0._r8, min( 1._r8, 1._r8 - concld(i,k) - ast(i,k) ) ) + end do + end do + + if( use_shfrc ) then + call pbuf_get_field(pbuf, shfrc_idx, shfrc ) + else + allocate(shfrc(pcols,pver)) + shfrc(:,:) = 0._r8 + endif + + ! CAM5 only uses 'concld' output from the below subroutine. + ! Stratus ('ast' = max(alst,aist)) and total cloud fraction ('cld = ast + concld') + ! will be computed using this updated 'concld' in the stratiform macrophysics + ! scheme (mmacro_pcond) later below. + + call t_startf("cldfrc") + + call cldfrc( lchnk, ncol, pbuf, & + state_loc%pmid, state_loc%t, state_loc%q(:,:,1), state_loc%omega, & + state_loc%phis, shfrc, use_shfrc, & + cld, rhcloud, clc, state_loc%pdel, & + cmfmc, cmfmc_sh, landfrac,snowh, concld, cldst, & + ts, sst, state_loc%pint(:,pverp), zdu, ocnfrac, rhu00, & + state_loc%q(:,:,ixcldice), icecldf, liqcldf, & + relhum, 0 ) + + call t_stopf("cldfrc") + + ! ---------------------------------------------- ! + ! Stratiform Cloud Macrophysics and Microphysics ! + ! ---------------------------------------------- ! + + lchnk = state_loc%lchnk + ncol = state_loc%ncol + rdtime = 1._r8/dtime + + ! Define fractional amount of stratus condensate and precipitation in ice phase. + ! This uses a ramp ( -30 ~ -10 for fice, -5 ~ 0 for fsnow ). + ! The ramp within convective cloud may be different + + call cldfrc_fice( ncol, state_loc%t, fice, fsnow ) + + + lq(:) = .FALSE. + + lq(1) = .true. + lq(ixcldice) = .true. + lq(ixcldliq) = .true. + + lq(ixnumliq) = .true. + lq(ixnumice) = .true. + + ! Initialize local physics_ptend object again + call physics_ptend_init(ptend_loc, state%psetcols, 'macro_park', & + ls=.true., lq=lq ) + + ! --------------------------------- ! + ! Liquid Macrop_Driver Macrophysics ! + ! --------------------------------- ! + + call t_startf('mmacro_pcond') + + zeros(:ncol,top_lev:pver) = 0._r8 + qc(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixcldliq) + qi(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixcldice) + nc(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixnumliq) + ni(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,ixnumice) + + ! In CAM5, 'microphysical forcing' ( CC_... ) and 'the other advective forcings' ( ttend, ... ) + ! are separately provided into the prognostic microp_driver macrophysics scheme. This is an + ! attempt to resolve in-cloud and out-cloud forcings. + + if( get_nstep() .le. 1 ) then + tcwat(:ncol,top_lev:pver) = state_loc%t(:ncol,top_lev:pver) + qcwat(:ncol,top_lev:pver) = state_loc%q(:ncol,top_lev:pver,1) + lcwat(:ncol,top_lev:pver) = qc(:ncol,top_lev:pver) + qi(:ncol,top_lev:pver) + iccwat(:ncol,top_lev:pver) = qi(:ncol,top_lev:pver) + nlwat(:ncol,top_lev:pver) = nc(:ncol,top_lev:pver) + niwat(:ncol,top_lev:pver) = ni(:ncol,top_lev:pver) + ttend(:ncol,:) = 0._r8 + qtend(:ncol,:) = 0._r8 + ltend(:ncol,:) = 0._r8 + itend(:ncol,:) = 0._r8 + nltend(:ncol,:) = 0._r8 + nitend(:ncol,:) = 0._r8 + CC_T(:ncol,:) = 0._r8 + CC_qv(:ncol,:) = 0._r8 + CC_ql(:ncol,:) = 0._r8 + CC_qi(:ncol,:) = 0._r8 + CC_nl(:ncol,:) = 0._r8 + CC_ni(:ncol,:) = 0._r8 + CC_qlst(:ncol,:) = 0._r8 + else + ttend(:ncol,top_lev:pver) = ( state_loc%t(:ncol,top_lev:pver) - tcwat(:ncol,top_lev:pver)) * rdtime & + - CC_T(:ncol,top_lev:pver) + qtend(:ncol,top_lev:pver) = ( state_loc%q(:ncol,top_lev:pver,1) - qcwat(:ncol,top_lev:pver)) * rdtime & + - CC_qv(:ncol,top_lev:pver) + ltend(:ncol,top_lev:pver) = ( qc(:ncol,top_lev:pver) + qi(:ncol,top_lev:pver) - lcwat(:ncol,top_lev:pver) ) * rdtime & + - (CC_ql(:ncol,top_lev:pver) + CC_qi(:ncol,top_lev:pver)) + itend(:ncol,top_lev:pver) = ( qi(:ncol,top_lev:pver) - iccwat(:ncol,top_lev:pver)) * rdtime & + - CC_qi(:ncol,top_lev:pver) + nltend(:ncol,top_lev:pver) = ( nc(:ncol,top_lev:pver) - nlwat(:ncol,top_lev:pver)) * rdtime & + - CC_nl(:ncol,top_lev:pver) + nitend(:ncol,top_lev:pver) = ( ni(:ncol,top_lev:pver) - niwat(:ncol,top_lev:pver)) * rdtime & + - CC_ni(:ncol,top_lev:pver) + endif + lmitend(:ncol,top_lev:pver) = ltend(:ncol,top_lev:pver) - itend(:ncol,top_lev:pver) + + t_inout(:ncol,top_lev:pver) = tcwat(:ncol,top_lev:pver) + qv_inout(:ncol,top_lev:pver) = qcwat(:ncol,top_lev:pver) + ql_inout(:ncol,top_lev:pver) = lcwat(:ncol,top_lev:pver) - iccwat(:ncol,top_lev:pver) + qi_inout(:ncol,top_lev:pver) = iccwat(:ncol,top_lev:pver) + nl_inout(:ncol,top_lev:pver) = nlwat(:ncol,top_lev:pver) + ni_inout(:ncol,top_lev:pver) = niwat(:ncol,top_lev:pver) + + ! Liquid Microp_Driver Macrophysics. + ! The main roles of this subroutines are + ! (1) compute net condensation rate of stratiform liquid ( cmeliq ) + ! (2) compute liquid stratus and ice stratus fractions. + ! Note 'ttend...' are advective tendencies except microphysical process while + ! 'CC...' are microphysical tendencies. + + call mmacro_pcond( lchnk, ncol, dtime, state_loc%pmid, state_loc%pdel, & + t_inout, qv_inout, ql_inout, qi_inout, nl_inout, ni_inout, & + ttend, qtend, lmitend, itend, nltend, nitend, & + CC_T, CC_qv, CC_ql, CC_qi, CC_nl, CC_ni, CC_qlst, & + dlf_T, dlf_qv, dlf_ql, dlf_qi, dlf_nl, dlf_ni, & + concld_old, concld, clrw_old, clri_old, landfrac, snowh, & + tke, qtl_flx, qti_flx, cmfr_det, qlr_det, qir_det, & + tlat, qvlat, qcten, qiten, ncten, niten, & + cmeliq, qvadj, qladj, qiadj, qllim, qilim, & + cld, alst, aist, qlst, qist, do_cldice ) + + ! Copy of concld/fice to put in physics buffer + ! Below are used only for convective cloud. + + fice_ql(:ncol,:top_lev-1) = 0._r8 + fice_ql(:ncol,top_lev:pver) = fice(:ncol,top_lev:pver) + + + ! Compute net stratus fraction using maximum over-lapping assumption + ast(:ncol,:top_lev-1) = 0._r8 + ast(:ncol,top_lev:pver) = max( alst(:ncol,top_lev:pver), aist(:ncol,top_lev:pver) ) + + call t_stopf('mmacro_pcond') + + do k = top_lev, pver + do i = 1, ncol + ptend_loc%s(i,k) = tlat(i,k) + ptend_loc%q(i,k,1) = qvlat(i,k) + ptend_loc%q(i,k,ixcldliq) = qcten(i,k) + ptend_loc%q(i,k,ixcldice) = qiten(i,k) + ptend_loc%q(i,k,ixnumliq) = ncten(i,k) + ptend_loc%q(i,k,ixnumice) = niten(i,k) + + ! Check to make sure that the macrophysics code is respecting the flags that control + ! whether cldwat should be prognosing cloud ice and cloud liquid or not. + if ((.not. do_cldice) .and. (qiten(i,k) /= 0.0_r8)) then + call endrun("macrop_driver:ERROR - "// & + "Cldwat is configured not to prognose cloud ice, but mmacro_pcond has ice mass tendencies.") + end if + if ((.not. do_cldice) .and. (niten(i,k) /= 0.0_r8)) then + call endrun("macrop_driver:ERROR -"// & + " Cldwat is configured not to prognose cloud ice, but mmacro_pcond has ice number tendencies.") + end if + + if ((.not. do_cldliq) .and. (qcten(i,k) /= 0.0_r8)) then + call endrun("macrop_driver:ERROR - "// & + "Cldwat is configured not to prognose cloud liquid, but mmacro_pcond has liquid mass tendencies.") + end if + if ((.not. do_cldliq) .and. (ncten(i,k) /= 0.0_r8)) then + call endrun("macrop_driver:ERROR - "// & + "Cldwat is configured not to prognose cloud liquid, but mmacro_pcond has liquid number tendencies.") + end if + end do + end do + + ! update the output tendencies with the mmacro_pcond tendencies + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! state_loc is the equlibrium state after macrophysics + call physics_update(state_loc, ptend_loc, dtime) + + call outfld('CLR_LIQ', clrw_old, pcols, lchnk) + call outfld('CLR_ICE', clri_old, pcols, lchnk) + + call outfld( 'MACPDT ', tlat , pcols, lchnk ) + call outfld( 'MACPDQ ', qvlat, pcols, lchnk ) + call outfld( 'MACPDLIQ ', qcten, pcols, lchnk ) + call outfld( 'MACPDICE ', qiten, pcols, lchnk ) + call outfld( 'CLDVAPADJ', qvadj, pcols, lchnk ) + call outfld( 'CLDLIQADJ', qladj, pcols, lchnk ) + call outfld( 'CLDICEADJ', qiadj, pcols, lchnk ) + call outfld( 'CLDLIQDET', dlf_ql, pcols, lchnk ) + call outfld( 'CLDICEDET', dlf_qi, pcols, lchnk ) + call outfld( 'CLDLIQLIM', qllim, pcols, lchnk ) + call outfld( 'CLDICELIM', qilim, pcols, lchnk ) + + call outfld( 'ICECLDF ', aist, pcols, lchnk ) + call outfld( 'LIQCLDF ', alst, pcols, lchnk ) + call outfld( 'AST', ast, pcols, lchnk ) + + call outfld( 'CONCLD ', concld, pcols, lchnk ) + call outfld( 'CLDST ', cldst, pcols, lchnk ) + + call outfld( 'CMELIQ' , cmeliq, pcols, lchnk ) + +!AL + call outfld( 'MACPDNC ', ncten, pcols, lchnk ) + call outfld( 'MACPDNI ', niten, pcols, lchnk ) +!AL + + ! calculations and outfld calls for CLDLIQSTR, CLDICESTR, CLDLIQCON, CLDICECON for CFMIP + + ! initialize local variables + mr_ccliq = 0._r8 !! not seen by radiation, so setting to 0 + mr_ccice = 0._r8 !! not seen by radiation, so setting to 0 + mr_lsliq = 0._r8 + mr_lsice = 0._r8 + + do k=top_lev,pver + do i=1,ncol + if (cld(i,k) .gt. 0._r8) then + mr_lsliq(i,k) = state_loc%q(i,k,ixcldliq) + mr_lsice(i,k) = state_loc%q(i,k,ixcldice) + else + mr_lsliq(i,k) = 0._r8 + mr_lsice(i,k) = 0._r8 + end if + end do + end do + + call outfld( 'CLDLIQSTR ', mr_lsliq, pcols, lchnk ) + call outfld( 'CLDICESTR ', mr_lsice, pcols, lchnk ) + call outfld( 'CLDLIQCON ', mr_ccliq, pcols, lchnk ) + call outfld( 'CLDICECON ', mr_ccice, pcols, lchnk ) + + ! ------------------------------------------------- ! + ! Save equilibrium state variables for macrophysics ! + ! at the next time step ! + ! ------------------------------------------------- ! + cldsice = 0._r8 + do k = top_lev, pver + tcwat(:ncol,k) = state_loc%t(:ncol,k) + qcwat(:ncol,k) = state_loc%q(:ncol,k,1) + lcwat(:ncol,k) = state_loc%q(:ncol,k,ixcldliq) + state_loc%q(:ncol,k,ixcldice) + iccwat(:ncol,k) = state_loc%q(:ncol,k,ixcldice) + nlwat(:ncol,k) = state_loc%q(:ncol,k,ixnumliq) + niwat(:ncol,k) = state_loc%q(:ncol,k,ixnumice) + cldsice(:ncol,k) = lcwat(:ncol,k) * min(1.0_r8, max(0.0_r8, (tmelt - tcwat(:ncol,k)) / 20._r8)) + end do + + call outfld( 'CLDSICE' , cldsice, pcols, lchnk ) + + ! ptend_loc is deallocated in physics_update above + call physics_state_dealloc(state_loc) + +end subroutine macrop_driver_tend + + +! Saturation adjustment for liquid +! +! With CLUBB, we are seeing relative humidity with respect to water +! greater than 1. This should not be happening and is not what the +! microphsyics expects from the macrophysics. As a work around while +! this issue is investigated in CLUBB, this routine will enfornce a +! maximum RHliq of 1 everywhere in the atmosphere. Any excess water will +! be converted into cloud drops. +elemental subroutine liquid_macro_tend(npccn,t,p,qv,qc,nc,xxlv,deltat,stend,qvtend,qctend,nctend) + + use wv_sat_methods, only: wv_sat_qsat_ice, wv_sat_qsat_water + use micro_mg_utils, only: rhow + use physconst, only: rair + use cldfrc2m, only: rhmini_const, rhmaxi_const + + real(r8), intent(in) :: npccn !Activated number of cloud condensation nuclei + real(r8), intent(in) :: t !temperature (k) + real(r8), intent(in) :: p !pressure (pa) + real(r8), intent(in) :: qv !water vapor mixing ratio + real(r8), intent(in) :: qc !liquid mixing ratio + real(r8), intent(in) :: nc !liquid number concentration + real(r8), intent(in) :: xxlv !latent heat of vaporization + real(r8), intent(in) :: deltat !timestep + real(r8), intent(out) :: stend ! 'temperature' tendency + real(r8), intent(out) :: qvtend !vapor tendency + real(r8), intent(out) :: qctend !liquid mass tendency + real(r8), intent(out) :: nctend !liquid number tendency + + + real(r8) :: ESL + real(r8) :: QSL + + stend = 0._r8 + qvtend = 0._r8 + qctend = 0._r8 + nctend = 0._r8 + + ! calculate qsatl from t,p,q + call wv_sat_qsat_water(t, p, ESL, QSL) + + ! Don't allow supersaturation with respect to liquid. + if (qv.gt.QSL) then + + qctend = (qv - QSL) / deltat + qvtend = 0._r8 - qctend + stend = qctend * xxlv ! moist static energy tend...[J/kg/s] ! + + ! If drops exists (more than 1 L-1) and there is condensation, + ! do not add to number (= growth), otherwise add 6um drops. + ! + ! This is somewhat arbitrary, but ensures that some reasonable droplet + ! size is create to remove the excess water. This could be enhanced to + ! look at npccn, but ideally this entire routine should go away. + if (nc*p/rair/t.lt.1e3_r8.and.(qc+qctend*deltat).gt.1e-18_r8) then + nctend = nctend + 3._r8 * qctend/(4._r8*3.14_r8*6.e-6_r8**3*rhow) + endif + endif +end subroutine liquid_macro_tend + +end module macrop_driver diff --git a/src/NorESM/micro_mg1_0.F90 b/src/NorESM/micro_mg1_0.F90 new file mode 100644 index 0000000000..880021d9ee --- /dev/null +++ b/src/NorESM/micro_mg1_0.F90 @@ -0,0 +1,3905 @@ +module micro_mg1_0 + +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics +! +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +! +! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice +! microphysics in cooperation with the MG liquid microphysics. This is +! controlled by the do_cldice variable. +! +! NOTE: If do_cldice is false, then MG microphysics should not update CLDICE +! or NUMICE; however, it is assumed that the other microphysics scheme will have +! updated CLDICE and NUMICE. The other microphysics should handle the following +! processes that would have been done by MG: +! - Detrainment (liquid and ice) +! - Homogeneous ice nucleation +! - Heterogeneous ice nucleation +! - Bergeron process +! - Melting of ice +! - Freezing of cloud drops +! - Autoconversion (ice -> snow) +! - Growth/Sublimation of ice +! - Sedimentation of ice +!--------------------------------------------------------------------------------- +! modification for sub-columns, HM, (orig 8/11/10) +! This is done using the logical 'microp_uniform' set to .true. = uniform for subcolumns +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure to specific humidity formula +! 3) svp over water +! 4) svp over ice + +#ifndef HAVE_GAMMA_INTRINSICS +use shr_spfn_mod, only: gamma => shr_spfn_gamma +#endif + + use wv_sat_methods, only: & + svp_water => wv_sat_svp_water, & + svp_ice => wv_sat_svp_ice, & + svp_to_qsat => wv_sat_svp_to_qsat + + use phys_control, only: phys_getopts + +implicit none +private +save + +! Note: The liu_in option has been removed, as there was a serious bug with this +! option being set to false. The code now behaves as if the default liu_in=.true. +! is always on. Addition/reinstatement of ice nucleation options will likely be +! done outside of this module. + +public :: & + micro_mg_init, & + micro_mg_get_cols, & + micro_mg_tend + +integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real + +real(r8) :: g !gravity +real(r8) :: r !Dry air Gas constant +real(r8) :: rv !water vapor gas contstant +real(r8) :: cpp !specific heat of dry air +real(r8) :: rhow !density of liquid water +real(r8) :: tmelt ! Freezing point of water (K) +real(r8) :: xxlv ! latent heat of vaporization +real(r8) :: xlf !latent heat of freezing +real(r8) :: xxls !latent heat of sublimation + +real(r8) :: rhosn ! bulk density snow +real(r8) :: rhoi ! bulk density ice + +real(r8) :: ac,bc,as,bs,ai,bi,ar,br !fall speed parameters +real(r8) :: ci,di !ice mass-diameter relation parameters +real(r8) :: cs,ds !snow mass-diameter relation parameters +real(r8) :: cr,dr !drop mass-diameter relation parameters +real(r8) :: f1s,f2s !ventilation param for snow +real(r8) :: Eii !collection efficiency aggregation of ice +real(r8) :: Ecr !collection efficiency cloud droplets/rain +real(r8) :: f1r,f2r !ventilation param for rain +real(r8) :: DCS !autoconversion size threshold +real(r8) :: qsmall !min mixing ratio +real(r8) :: bimm,aimm !immersion freezing +real(r8) :: rhosu !typical 850mn air density +real(r8) :: mi0 ! new crystal mass +real(r8) :: rin ! radius of contact nuclei +real(r8) :: pi ! pi + +! Additional constants to help speed up code + +real(r8) :: cons1 +real(r8) :: cons4 +real(r8) :: cons5 +real(r8) :: cons6 +real(r8) :: cons7 +real(r8) :: cons8 +real(r8) :: cons11 +real(r8) :: cons13 +real(r8) :: cons14 +real(r8) :: cons16 +real(r8) :: cons17 +real(r8) :: cons22 +real(r8) :: cons23 +real(r8) :: cons24 +real(r8) :: cons25 +real(r8) :: cons27 +real(r8) :: cons28 + +real(r8) :: lammini +real(r8) :: lammaxi +real(r8) :: lamminr +real(r8) :: lammaxr +real(r8) :: lammins +real(r8) :: lammaxs + +! parameters for snow/rain fraction for convective clouds +real(r8) :: tmax_fsnow ! max temperature for transition to convective snow +real(r8) :: tmin_fsnow ! min temperature for transition to convective snow + +!needed for findsp +real(r8) :: tt0 ! Freezing temperature + +real(r8) :: csmin,csmax,minrefl,mindbz + +real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. + +logical :: use_hetfrz_classnuc ! option to use heterogeneous freezing + +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor + +! Switches for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used +! +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. +logical :: nccons ! nccons=.true. to specify constant cloud droplet number +logical :: nicons ! nicons=.true. to specify constant cloud ice number + +! parameters for specified ice and droplet number concentration +! note: these are local in-cloud values, not grid-mean +real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3) +real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3) + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg_init( & + kind, gravit, rair, rh2o, cpair, & + rhoh2o, tmelt_in, latvap, latice, & + rhmini_in, micro_mg_dcs, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & + nccons_in, nicons_in, ncnst_in, ninst_in, errstring) + +!----------------------------------------------------------------------- +! +! Purpose: +! initialize constants for the morrison microphysics +! +! Author: Andrew Gettelman Dec 2005 +! +!----------------------------------------------------------------------- + +integer, intent(in) :: kind ! Kind used for reals +real(r8), intent(in) :: gravit +real(r8), intent(in) :: rair +real(r8), intent(in) :: rh2o +real(r8), intent(in) :: cpair +real(r8), intent(in) :: rhoh2o +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. +real(r8), intent(in) :: micro_mg_dcs +logical, intent(in) :: use_hetfrz_classnuc_in +character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method +real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor +logical, intent(in) :: nccons_in +logical, intent(in) :: nicons_in +real(r8), intent(in) :: ncnst_in +real(r8), intent(in) :: ninst_in + +character(128), intent(out) :: errstring ! Output status (non-blank for error return) + +integer k + +integer l,m, iaer +real(r8) surften ! surface tension of water w/respect to air (N/m) +real(r8) arg +!----------------------------------------------------------------------- + +errstring = ' ' + +if( kind .ne. r8 ) then + errstring = 'micro_mg_init: KIND of reals does not match' + return +end if + +!declarations for morrison codes (transforms variable names) + +g= gravit !gravity +r= rair !Dry air Gas constant: note units(phys_constants are in J/K/kmol) +rv= rh2o !water vapor gas contstant +cpp = cpair !specific heat of dry air +rhow = rhoh2o !density of liquid water +tmelt = tmelt_in +rhmini = rhmini_in +micro_mg_precip_frac_method = micro_mg_precip_frac_method_in +micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + +nccons = nccons_in +nicons = nicons_in +ncnst = ncnst_in +ninst = ninst_in + +! latent heats + +xxlv = latvap ! latent heat vaporization +xlf = latice ! latent heat freezing +xxls = xxlv + xlf ! latent heat of sublimation + +! flags +use_hetfrz_classnuc = use_hetfrz_classnuc_in + +! parameters for snow/rain fraction for convective clouds + +tmax_fsnow = tmelt +tmin_fsnow = tmelt-5._r8 + +! parameters below from Reisner et al. (1998) +! density parameters (kg/m3) + +rhosn = 250._r8 ! bulk density snow (++ ceh) +rhoi = 500._r8 ! bulk density ice +rhow = 1000._r8 ! bulk density liquid + + +! fall speed parameters, V = aD^b +! V is in m/s + +! droplets +ac = 3.e7_r8 +bc = 2._r8 + +! snow +as = 11.72_r8 +bs = 0.41_r8 + +! cloud ice +ai = 700._r8 +bi = 1._r8 + +! rain +ar = 841.99667_r8 +br = 0.8_r8 + +! particle mass-diameter relationship +! currently we assume spherical particles for cloud ice/snow +! m = cD^d + +pi= 3.1415927_r8 + +! cloud ice mass-diameter relationship + +ci = rhoi*pi/6._r8 +di = 3._r8 + +! snow mass-diameter relationship + +cs = rhosn*pi/6._r8 +ds = 3._r8 + +! drop mass-diameter relationship + +cr = rhow*pi/6._r8 +dr = 3._r8 + +! ventilation parameters for snow +! hall and prupacher + +f1s = 0.86_r8 +f2s = 0.28_r8 + +! collection efficiency, aggregation of cloud ice and snow + +Eii = 0.1_r8 + +! collection efficiency, accretion of cloud water by rain + +Ecr = 1.0_r8 + +! ventilation constants for rain + +f1r = 0.78_r8 +f2r = 0.32_r8 + +! autoconversion size threshold for cloud ice to snow (m) + +Dcs = micro_mg_dcs + +! smallest mixing ratio considered in microphysics + +qsmall = 1.e-18_r8 + +! immersion freezing parameters, bigg 1953 + +bimm = 100._r8 +aimm = 0.66_r8 + +! typical air density at 850 mb + +rhosu = 85000._r8/(rair * tmelt) + +! mass of new crystal due to aerosol freezing and growth (kg) + +mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) + +! radius of contact nuclei aerosol (m) + +rin = 0.1e-6_r8 + +! freezing temperature +tt0=273.15_r8 + +pi=4._r8*atan(1.0_r8) + +!Range of cloudsat reflectivities (dBz) for analytic simulator +csmin= -30._r8 +csmax= 26._r8 +mindbz = -99._r8 +! minrefl = 10._r8**(mindbz/10._r8) +minrefl = 1.26e-10_r8 + +! Define constants to help speed up code (limit calls to gamma function) + +cons1=gamma(1._r8+di) +cons4=gamma(1._r8+br) +cons5=gamma(4._r8+br) +cons6=gamma(1._r8+ds) +cons7=gamma(1._r8+bs) +cons8=gamma(4._r8+bs) +cons11=gamma(3._r8+bs) +cons13=gamma(5._r8/2._r8+br/2._r8) +cons14=gamma(5._r8/2._r8+bs/2._r8) +cons16=gamma(1._r8+bi) +cons17=gamma(4._r8+bi) +cons22=(4._r8/3._r8*pi*rhow*(25.e-6_r8)**3) +cons23=dcs**3 +cons24=dcs**2 +cons25=dcs**bs +cons27=xxlv**2 +cons28=xxls**2 + +lammaxi = 1._r8/10.e-6_r8 +lammini = 1._r8/(2._r8*dcs) +lammaxr = 1._r8/20.e-6_r8 +lamminr = 1._r8/500.e-6_r8 +lammaxs = 1._r8/10.e-6_r8 +lammins = 1._r8/2000.e-6_r8 + +end subroutine micro_mg_init + +!=============================================================================== +!microphysics routine for each timestep goes here... + +subroutine micro_mg_tend ( & + microp_uniform, pcols, pver, ncol, top_lev, deltatin,& + tn, qn, qc, qi, nc, & + ni, p, pdel, cldn, liqcldf, & + relvar, accre_enhan, & + icecldf, rate1ord_cw2pr_st, naai, npccnin, & + rndst, nacon, tlat, qvlat, qctend, & + qitend, nctend, nitend, effc, effc_fn, & + effi, prect, preci, nevapr, evapsnow, am_evp_st, & + prain, prodsnow, cmeout, deffi, pgamrad, & + lamcrad, qsout, dsout, rflx, sflx, & + qrout, reff_rain, reff_snow, qcsevap, qisevap, & + qvres, cmeiout, vtrmc, vtrmi, qcsedten, & + qisedten, prao, prco, mnuccco, mnuccto, & + msacwio, psacwso, bergso, bergo, melto, & + homoo, qcreso, prcio, praio, qireso, & + mnuccro, pracso, meltsdt, frzrdt, mnuccdo, & + nrout, nsout, refl, arefl, areflz, & + frefl, csrfl, acsrfl, fcsrfl, rercld, & + ncai, ncal, qrout2, qsout2, nrout2, & + nsout2, drout2, dsout2, freqs, freqr, & + nfice, prer_evap, do_cldice, errstring, & + tnd_qsnow, tnd_nsnow, re_ice, & + frzimm, frzcnt, frzdep , & +!AL + nnuccco, nnuccto, npsacwso, nsubco, nprao, & + nprc1o, nqcsedten, nqisedten, nmelto, nhomoo, & + nimelto, nihomoo, nsacwio, nsubio, nprcio, & + npraio, nnudepo, npccno, nnuccdo, mnudepo, & + nctncons,nctnnbmn,nctnszmn, & + nctnszmx,nctnncld,nitncons,nitnszmn, & + nitnszmx,nitnncld) + +!AL + +! input arguments +logical, intent(in) :: microp_uniform ! True = configure uniform for sub-columns False = use w/o sub-columns (standard) +integer, intent(in) :: pcols ! size of column (first) index +integer, intent(in) :: pver ! number of layers in columns +integer, intent(in) :: ncol ! number of columns +integer, intent(in) :: top_lev ! top level microphys is applied +real(r8), intent(in) :: deltatin ! time step (s) +real(r8), intent(in) :: tn(pcols,pver) ! input temperature (K) +real(r8), intent(in) :: qn(pcols,pver) ! input h20 vapor mixing ratio (kg/kg) +real(r8), intent(in) :: relvar(pcols,pver) ! relative variance of cloud water (-) +real(r8), intent(in) :: accre_enhan(pcols,pver) ! optional accretion enhancement factor (-) + +! note: all input cloud variables are grid-averaged +real(r8), intent(inout) :: qc(pcols,pver) ! cloud water mixing ratio (kg/kg) +real(r8), intent(inout) :: qi(pcols,pver) ! cloud ice mixing ratio (kg/kg) +real(r8), intent(inout) :: nc(pcols,pver) ! cloud water number conc (1/kg) +real(r8), intent(inout) :: ni(pcols,pver) ! cloud ice number conc (1/kg) +real(r8), intent(in) :: p(pcols,pver) ! air pressure (pa) +real(r8), intent(in) :: pdel(pcols,pver) ! pressure difference across level (pa) +real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction +real(r8), intent(in) :: icecldf(pcols,pver) ! ice cloud fraction +real(r8), intent(in) :: liqcldf(pcols,pver) ! liquid cloud fraction + +real(r8), intent(out) :: rate1ord_cw2pr_st(pcols,pver) ! 1st order rate for direct cw to precip conversion +! used for scavenging +! Inputs for aerosol activation +real(r8), intent(in) :: naai(pcols,pver) ! ice nulceation number (from microp_aero_ts) +real(r8), intent(in) :: npccnin(pcols,pver) ! ccn activated number tendency (from microp_aero_ts) +real(r8), intent(in) :: rndst(pcols,pver,4) ! radius of 4 dust bins for contact freezing (from microp_aero_ts) +real(r8), intent(in) :: nacon(pcols,pver,4) ! number in 4 dust bins for contact freezing (from microp_aero_ts) + +! Used with CARMA cirrus microphysics +! (or similar external microphysics model) +logical, intent(in) :: do_cldice ! Prognosing cldice + +! output arguments + +real(r8), intent(out) :: tlat(pcols,pver) ! latent heating rate (W/kg) +real(r8), intent(out) :: qvlat(pcols,pver) ! microphysical tendency qv (1/s) +real(r8), intent(out) :: qctend(pcols,pver) ! microphysical tendency qc (1/s) +real(r8), intent(out) :: qitend(pcols,pver) ! microphysical tendency qi (1/s) +real(r8), intent(out) :: nctend(pcols,pver) ! microphysical tendency nc (1/(kg*s)) +real(r8), intent(out) :: nitend(pcols,pver) ! microphysical tendency ni (1/(kg*s)) +real(r8), intent(out) :: effc(pcols,pver) ! droplet effective radius (micron) +real(r8), intent(out) :: effc_fn(pcols,pver) ! droplet effective radius, assuming nc = 1.e8 kg-1 +real(r8), intent(out) :: effi(pcols,pver) ! cloud ice effective radius (micron) +real(r8), intent(out) :: prect(pcols) ! surface precip rate (m/s) +real(r8), intent(out) :: preci(pcols) ! cloud ice/snow precip rate (m/s) +real(r8), intent(out) :: nevapr(pcols,pver) ! evaporation rate of rain + snow +real(r8), intent(out) :: evapsnow(pcols,pver)! sublimation rate of snow +real(r8), intent(out) :: am_evp_st(pcols,pver)! stratiform evaporation area +real(r8), intent(out) :: prain(pcols,pver) ! production of rain + snow +real(r8), intent(out) :: prodsnow(pcols,pver)! production of snow +real(r8), intent(out) :: cmeout(pcols,pver) ! evap/sub of cloud +real(r8), intent(out) :: deffi(pcols,pver) ! ice effective diameter for optics (radiation) +real(r8), intent(out) :: pgamrad(pcols,pver) ! ice gamma parameter for optics (radiation) +real(r8), intent(out) :: lamcrad(pcols,pver) ! slope of droplet distribution for optics (radiation) +real(r8), intent(out) :: qsout(pcols,pver) ! snow mixing ratio (kg/kg) +real(r8), intent(out) :: dsout(pcols,pver) ! snow diameter (m) +real(r8), intent(out) :: rflx(pcols,pver+1) ! grid-box average rain flux (kg m^-2 s^-1) +real(r8), intent(out) :: sflx(pcols,pver+1) ! grid-box average snow flux (kg m^-2 s^-1) +real(r8), intent(out) :: qrout(pcols,pver) ! grid-box average rain mixing ratio (kg/kg) +real(r8), intent(inout) :: reff_rain(pcols,pver) ! rain effective radius (micron) +real(r8), intent(inout) :: reff_snow(pcols,pver) ! snow effective radius (micron) +real(r8), intent(out) :: qcsevap(pcols,pver) ! cloud water evaporation due to sedimentation +real(r8), intent(out) :: qisevap(pcols,pver) ! cloud ice sublimation due to sublimation +real(r8), intent(out) :: qvres(pcols,pver) ! residual condensation term to ensure RH < 100% +real(r8), intent(out) :: cmeiout(pcols,pver) ! grid-mean cloud ice sub/dep +real(r8), intent(out) :: vtrmc(pcols,pver) ! mass-weighted cloud water fallspeed +real(r8), intent(out) :: vtrmi(pcols,pver) ! mass-weighted cloud ice fallspeed +real(r8), intent(out) :: qcsedten(pcols,pver) ! qc sedimentation tendency +real(r8), intent(out) :: qisedten(pcols,pver) ! qi sedimentation tendency +! microphysical process rates for output (mixing ratio tendencies) +real(r8), intent(out) :: prao(pcols,pver) ! accretion of cloud by rain +real(r8), intent(out) :: prco(pcols,pver) ! autoconversion of cloud to rain +real(r8), intent(out) :: mnuccco(pcols,pver) ! mixing rat tend due to immersion freezing +real(r8), intent(out) :: mnuccto(pcols,pver) ! mixing ratio tend due to contact freezing +real(r8), intent(out) :: msacwio(pcols,pver) ! mixing ratio tend due to H-M splintering +real(r8), intent(out) :: psacwso(pcols,pver) ! collection of cloud water by snow +real(r8), intent(out) :: bergso(pcols,pver) ! bergeron process on snow +real(r8), intent(out) :: bergo(pcols,pver) ! bergeron process on cloud ice +real(r8), intent(out) :: melto(pcols,pver) ! melting of cloud ice +real(r8), intent(out) :: homoo(pcols,pver) ! homogeneos freezign cloud water +real(r8), intent(out) :: qcreso(pcols,pver) ! residual cloud condensation due to removal of excess supersat +real(r8), intent(out) :: prcio(pcols,pver) ! autoconversion of cloud ice to snow +real(r8), intent(out) :: praio(pcols,pver) ! accretion of cloud ice by snow +real(r8), intent(out) :: qireso(pcols,pver) ! residual ice deposition due to removal of excess supersat +real(r8), intent(out) :: mnuccro(pcols,pver) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) +real(r8), intent(out) :: pracso (pcols,pver) ! mixing ratio tendency due to accretion of rain by snow (1/s) +real(r8), intent(out) :: meltsdt(pcols,pver) ! latent heating rate due to melting of snow (W/kg) +real(r8), intent(out) :: frzrdt (pcols,pver) ! latent heating rate due to homogeneous freezing of rain (W/kg) +real(r8), intent(out) :: mnuccdo(pcols,pver) ! mass tendency from ice nucleation +real(r8), intent(out) :: nrout(pcols,pver) ! rain number concentration (1/m3) +real(r8), intent(out) :: nsout(pcols,pver) ! snow number concentration (1/m3) +real(r8), intent(out) :: refl(pcols,pver) ! analytic radar reflectivity +real(r8), intent(out) :: arefl(pcols,pver) !average reflectivity will zero points outside valid range +real(r8), intent(out) :: areflz(pcols,pver) !average reflectivity in z. +real(r8), intent(out) :: frefl(pcols,pver) +real(r8), intent(out) :: csrfl(pcols,pver) !cloudsat reflectivity +real(r8), intent(out) :: acsrfl(pcols,pver) !cloudsat average +real(r8), intent(out) :: fcsrfl(pcols,pver) +real(r8), intent(out) :: rercld(pcols,pver) ! effective radius calculation for rain + cloud +real(r8), intent(out) :: ncai(pcols,pver) ! output number conc of ice nuclei available (1/m3) +real(r8), intent(out) :: ncal(pcols,pver) ! output number conc of CCN (1/m3) +real(r8), intent(out) :: qrout2(pcols,pver) +real(r8), intent(out) :: qsout2(pcols,pver) +real(r8), intent(out) :: nrout2(pcols,pver) +real(r8), intent(out) :: nsout2(pcols,pver) +real(r8), intent(out) :: drout2(pcols,pver) ! mean rain particle diameter (m) +real(r8), intent(out) :: dsout2(pcols,pver) ! mean snow particle diameter (m) +real(r8), intent(out) :: freqs(pcols,pver) +real(r8), intent(out) :: freqr(pcols,pver) +real(r8), intent(out) :: nfice(pcols,pver) +real(r8), intent(out) :: prer_evap(pcols,pver) + +real(r8) :: nevapr2(pcols,pver) + +character(128), intent(out) :: errstring ! Output status (non-blank for error return) +!AL +real(r8), intent(out) :: nnuccco(pcols,pver) ! immersion freezing +real(r8), intent(out) :: nnuccto(pcols,pver) ! contact freezing +real(r8), intent(out) :: npsacwso(pcols,pver) ! accr. snow +real(r8), intent(out) :: nsubco(pcols,pver) ! evaporation of droplet +real(r8), intent(out) :: nprao(pcols,pver) ! accretion +real(r8), intent(out) :: nprc1o(pcols,pver) ! autoconversion +real(r8), intent(out) :: nqcsedten(pcols,pver) ! nqc sedimentation tendency +real(r8), intent(out) :: nqisedten(pcols,pver) ! nqc sedimentation tendency +real(r8), intent(out) :: nmelto(pcols,pver) ! melting of cloud ice +real(r8), intent(out) :: nhomoo(pcols,pver) ! homogeneos freezign cloud water +real(r8), intent(out) :: nimelto(pcols,pver) ! melting of cloud ice +real(r8), intent(out) :: nihomoo(pcols,pver) ! homogeneos freezign cloud water +real(r8), intent(out) :: nsacwio(pcols,pver) ! numb conc tend due to HM ice multiplication +real(r8), intent(out) :: nsubio(pcols,pver) ! evaporation of cloud ice number (sublimation?) +real(r8), intent(out) :: nprcio(pcols,pver) ! numb conc tend due to auto of cloud ice to snow +real(r8), intent(out) :: npraio(pcols,pver) ! numb conc tend due to accr of cloud ice by snow +real(r8), intent(out) :: nnudepo(pcols,pver) ! deposition? +real(r8), intent(out) :: npccno(pcols,pver) ! activation +real(r8), intent(out) :: nnuccdo(pcols,pver) ! ni nucleation +real(r8), intent(out) :: mnudepo(pcols,pver) ! deposition (mass) +real(r8), intent(out) :: nctncons(pcols,pver) ! nc tuning to conserve number in substeps +real(r8), intent(out) :: nctnnbmn(pcols,pver) ! nc tuning: minimum droplet number +real(r8), intent(out) :: nctnszmn(pcols,pver) ! nc tuning: minimum slope +real(r8), intent(out) :: nctnszmx(pcols,pver) ! nc tuning: maximum slope +real(r8), intent(out) :: nctnncld(pcols,pver) ! nc tuning: removal of nc when qc is zero after mg +real(r8), intent(out) :: nitncons(pcols,pver) ! ni tuning to conserve number in substeps +real(r8), intent(out) :: nitnszmn(pcols,pver) ! ni tuning: minimum slope +real(r8), intent(out) :: nitnszmx(pcols,pver) ! ni tuning: maximum slope +real(r8), intent(out) :: nitnncld(pcols,pver) ! ni tuning: removal of ni when qi is zero after mg +!AL + + + +! Tendencies calculated by external schemes that can replace MG's native +! process tendencies. + +! Used with CARMA cirrus microphysics +! (or similar external microphysics model) +real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) +real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) +real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m) + +! From external ice nucleation. +real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) +real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) +real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) + +! local workspace +! all units mks unless otherwise stated + +! Additional constants to help speed up code +real(r8) :: cons2 +real(r8) :: cons3 +real(r8) :: cons9 +real(r8) :: cons10 +real(r8) :: cons12 +real(r8) :: cons15 +real(r8) :: cons18 +real(r8) :: cons19 +real(r8) :: cons20 + +! temporary variables for sub-stepping +real(r8) :: t1(pcols,pver) +real(r8) :: q1(pcols,pver) +real(r8) :: qc1(pcols,pver) +real(r8) :: qi1(pcols,pver) +real(r8) :: nc1(pcols,pver) +real(r8) :: ni1(pcols,pver) +real(r8) :: tlat1(pcols,pver) +real(r8) :: qvlat1(pcols,pver) +real(r8) :: qctend1(pcols,pver) +real(r8) :: qitend1(pcols,pver) +real(r8) :: nctend1(pcols,pver) +real(r8) :: nitend1(pcols,pver) +real(r8) :: prect1(pcols) +real(r8) :: preci1(pcols) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +real(r8) :: deltat ! sub-time step (s) +real(r8) :: omsm ! number near unity for round-off issues +real(r8) :: dto2 ! dt/2 (s) +real(r8) :: mincld ! minimum allowed cloud fraction +real(r8) :: q(pcols,pver) ! water vapor mixing ratio (kg/kg) +real(r8) :: t(pcols,pver) ! temperature (K) +real(r8) :: rho(pcols,pver) ! air density (kg m-3) +real(r8) :: dv(pcols,pver) ! diffusivity of water vapor in air +real(r8) :: mu(pcols,pver) ! viscocity of air +real(r8) :: sc(pcols,pver) ! schmidt number +real(r8) :: kap(pcols,pver) ! thermal conductivity of air +real(r8) :: rhof(pcols,pver) ! air density correction factor for fallspeed +real(r8) :: cldmax(pcols,pver) ! precip fraction assuming maximum overlap +real(r8) :: cldm(pcols,pver) ! cloud fraction +real(r8) :: icldm(pcols,pver) ! ice cloud fraction +real(r8) :: lcldm(pcols,pver) ! liq cloud fraction +real(r8) :: icwc(pcols) ! in cloud water content (liquid+ice) +real(r8) :: calpha(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cbeta(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cbetah(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cgamma(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cgamah(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: rcgama(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cmec1(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cmec2(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cmec3(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: cmec4(pcols) ! parameter for cond/evap (Zhang et al. 2003) +real(r8) :: qtmp ! dummy qv +real(r8) :: dum ! temporary dummy variable + +real(r8) :: cme(pcols,pver) ! total (liquid+ice) cond/evap rate of cloud + +real(r8) :: cmei(pcols,pver) ! dep/sublimation rate of cloud ice +real(r8) :: cwml(pcols,pver) ! cloud water mixing ratio +real(r8) :: cwmi(pcols,pver) ! cloud ice mixing ratio +real(r8) :: nnuccd(pver) ! ice nucleation rate from deposition/cond.-freezing +real(r8) :: mnuccd(pver) ! mass tendency from ice nucleation +real(r8) :: qcld ! total cloud water +real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud +real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud +real(r8) :: nctend_mixnuc(pcols,pver) +real(r8) :: arg ! argument of erfc + +! for calculation of rate1ord_cw2pr_st +real(r8) :: qcsinksum_rate1ord(pver) ! sum over iterations of cw to precip sink +real(r8) :: qcsum_rate1ord(pver) ! sum over iterations of cloud water + +real(r8) :: alpha + +real(r8) :: dum1,dum2 !general dummy variables + +real(r8) :: npccn(pver) ! droplet activation rate +real(r8) :: qcic(pcols,pver) ! in-cloud cloud liquid mixing ratio +real(r8) :: qiic(pcols,pver) ! in-cloud cloud ice mixing ratio +real(r8) :: qniic(pcols,pver) ! in-precip snow mixing ratio +real(r8) :: qric(pcols,pver) ! in-precip rain mixing ratio +real(r8) :: ncic(pcols,pver) ! in-cloud droplet number conc +real(r8) :: niic(pcols,pver) ! in-cloud cloud ice number conc +real(r8) :: nsic(pcols,pver) ! in-precip snow number conc +real(r8) :: nric(pcols,pver) ! in-precip rain number conc +real(r8) :: lami(pver) ! slope of cloud ice size distr +real(r8) :: n0i(pver) ! intercept of cloud ice size distr +real(r8) :: lamc(pver) ! slope of cloud liquid size distr +real(r8) :: n0c(pver) ! intercept of cloud liquid size distr +real(r8) :: lams(pver) ! slope of snow size distr +real(r8) :: n0s(pver) ! intercept of snow size distr +real(r8) :: lamr(pver) ! slope of rain size distr +real(r8) :: n0r(pver) ! intercept of rain size distr +real(r8) :: cdist1(pver) ! size distr parameter to calculate droplet freezing +! combined size of precip & cloud drops +real(r8) :: arcld(pcols,pver) ! averaging control flag +real(r8) :: Actmp !area cross section of drops +real(r8) :: Artmp !area cross section of rain + +real(r8) :: pgam(pver) ! spectral width parameter of droplet size distr +real(r8) :: lammax ! maximum allowed slope of size distr +real(r8) :: lammin ! minimum allowed slope of size distr +real(r8) :: nacnt ! number conc of contact ice nuclei +real(r8) :: mnuccc(pver) ! mixing ratio tendency due to freezing of cloud water +real(r8) :: nnuccc(pver) ! number conc tendency due to freezing of cloud water + +real(r8) :: mnucct(pver) ! mixing ratio tendency due to contact freezing of cloud water +real(r8) :: nnucct(pver) ! number conc tendency due to contact freezing of cloud water +real(r8) :: msacwi(pver) ! mixing ratio tendency due to HM ice multiplication +real(r8) :: nsacwi(pver) ! number conc tendency due to HM ice multiplication + +real(r8) :: prc(pver) ! qc tendency due to autoconversion of cloud droplets +real(r8) :: nprc(pver) ! number conc tendency due to autoconversion of cloud droplets +real(r8) :: nprc1(pver) ! qr tendency due to autoconversion of cloud droplets +real(r8) :: nsagg(pver) ! ns tendency due to self-aggregation of snow +real(r8) :: dc0 ! mean size droplet size distr +real(r8) :: ds0 ! mean size snow size distr (area weighted) +real(r8) :: eci ! collection efficiency for riming of snow by droplets +real(r8) :: psacws(pver) ! mixing rat tendency due to collection of droplets by snow +real(r8) :: npsacws(pver) ! number conc tendency due to collection of droplets by snow +real(r8) :: uni ! number-weighted cloud ice fallspeed +real(r8) :: umi ! mass-weighted cloud ice fallspeed +real(r8) :: uns(pver) ! number-weighted snow fallspeed +real(r8) :: ums(pver) ! mass-weighted snow fallspeed +real(r8) :: unr(pver) ! number-weighted rain fallspeed +real(r8) :: umr(pver) ! mass-weighted rain fallspeed +real(r8) :: unc ! number-weighted cloud droplet fallspeed +real(r8) :: umc ! mass-weighted cloud droplet fallspeed +real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow +real(r8) :: npracs(pver) ! number conc tendency due to collection of rain by snow +real(r8) :: mnuccr(pver) ! mixing rat tendency due to freezing of rain +real(r8) :: nnuccr(pver) ! number conc tendency due to freezing of rain +real(r8) :: pra(pver) ! mixing rat tendnency due to accretion of droplets by rain +real(r8) :: npra(pver) ! nc tendnency due to accretion of droplets by rain +real(r8) :: nragg(pver) ! nr tendency due to self-collection of rain +real(r8) :: prci(pver) ! mixing rat tendency due to autoconversion of cloud ice to snow +real(r8) :: nprci(pver) ! number conc tendency due to autoconversion of cloud ice to snow +real(r8) :: prai(pver) ! mixing rat tendency due to accretion of cloud ice by snow +real(r8) :: nprai(pver) ! number conc tendency due to accretion of cloud ice by snow +real(r8) :: qvs ! liquid saturation vapor mixing ratio +real(r8) :: qvi ! ice saturation vapor mixing ratio +real(r8) :: dqsdt ! change of sat vapor mixing ratio with temperature +real(r8) :: dqsidt ! change of ice sat vapor mixing ratio with temperature +real(r8) :: ab ! correction factor for rain evap to account for latent heat +real(r8) :: qclr ! water vapor mixing ratio in clear air +real(r8) :: abi ! correction factor for snow sublimation to account for latent heat +real(r8) :: epss ! 1/ sat relaxation timescale for snow +real(r8) :: epsr ! 1/ sat relaxation timescale for rain +real(r8) :: pre(pver) ! rain mixing rat tendency due to evaporation +real(r8) :: prds(pver) ! snow mixing rat tendency due to sublimation +real(r8) :: qce ! dummy qc for conservation check +real(r8) :: qie ! dummy qi for conservation check +real(r8) :: nce ! dummy nc for conservation check +real(r8) :: nie ! dummy ni for conservation check +real(r8) :: ratio ! parameter for conservation check +real(r8) :: dumc(pcols,pver) ! dummy in-cloud qc +real(r8) :: dumnc(pcols,pver) ! dummy in-cloud nc +real(r8) :: dumi(pcols,pver) ! dummy in-cloud qi +real(r8) :: dumni(pcols,pver) ! dummy in-cloud ni +real(r8) :: dums(pcols,pver) ! dummy in-cloud snow mixing rat +real(r8) :: dumns(pcols,pver) ! dummy in-cloud snow number conc +real(r8) :: dumr(pcols,pver) ! dummy in-cloud rain mixing rat +real(r8) :: dumnr(pcols,pver) ! dummy in-cloud rain number conc +! below are parameters for cloud water and cloud ice sedimentation calculations +real(r8) :: fr(pver) +real(r8) :: fnr(pver) +real(r8) :: fc(pver) +real(r8) :: fnc(pver) +real(r8) :: fi(pver) +real(r8) :: fni(pver) +real(r8) :: fs(pver) +real(r8) :: fns(pver) +real(r8) :: faloutr(pver) +real(r8) :: faloutnr(pver) +real(r8) :: faloutc(pver) +real(r8) :: faloutnc(pver) +real(r8) :: falouti(pver) +real(r8) :: faloutni(pver) +real(r8) :: falouts(pver) +real(r8) :: faloutns(pver) +real(r8) :: faltndr +real(r8) :: faltndnr +real(r8) :: faltndc +real(r8) :: faltndnc +real(r8) :: faltndi +real(r8) :: faltndni +real(r8) :: faltnds +real(r8) :: faltndns +real(r8) :: faltndqie +real(r8) :: faltndqce +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +real(r8) :: relhum(pcols,pver) ! relative humidity +real(r8) :: csigma(pcols) ! parameter for cond/evap of cloud water/ice +real(r8) :: rgvm ! max fallspeed for all species +real(r8) :: arn(pcols,pver) ! air density corrected rain fallspeed parameter +real(r8) :: asn(pcols,pver) ! air density corrected snow fallspeed parameter +real(r8) :: acn(pcols,pver) ! air density corrected cloud droplet fallspeed parameter +real(r8) :: ain(pcols,pver) ! air density corrected cloud ice fallspeed parameter +real(r8) :: nsubi(pver) ! evaporation of cloud ice number +real(r8) :: nsubc(pver) ! evaporation of droplet number +real(r8) :: nsubs(pver) ! evaporation of snow number +real(r8) :: nsubr(pver) ! evaporation of rain number +real(r8) :: mtime ! factor to account for droplet activation timescale +real(r8) :: dz(pcols,pver) ! height difference across model vertical level + + +!! add precip flux variables for sub-stepping +real(r8) :: rflx1(pcols,pver+1) +real(r8) :: sflx1(pcols,pver+1) + +! returns from function/subroutine calls +real(r8) :: tsp(pcols,pver) ! saturation temp (K) +real(r8) :: qsp(pcols,pver) ! saturation mixing ratio (kg/kg) +real(r8) :: qsphy(pcols,pver) ! saturation mixing ratio (kg/kg): hybrid rh +real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) +real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) +real(r8) :: esl(pcols,pver) ! liquid sat vapor pressure (pa) +real(r8) :: esi(pcols,pver) ! ice sat vapor pressure (pa) + +! sum of source/sink terms for diagnostic precip + +real(r8) :: qnitend(pcols,pver) ! snow mixing ratio source/sink term +real(r8) :: nstend(pcols,pver) ! snow number concentration source/sink term +real(r8) :: qrtend(pcols,pver) ! rain mixing ratio source/sink term +real(r8) :: nrtend(pcols,pver) ! rain number concentration source/sink term +real(r8) :: qrtot ! vertically-integrated rain mixing rat source/sink term +real(r8) :: nrtot ! vertically-integrated rain number conc source/sink term +real(r8) :: qstot ! vertically-integrated snow mixing rat source/sink term +real(r8) :: nstot ! vertically-integrated snow number conc source/sink term + +! new terms for Bergeron process + +real(r8) :: dumnnuc ! provisional ice nucleation rate (for calculating bergeron) +real(r8) :: ninew ! provisional cloud ice number conc (for calculating bergeron) +real(r8) :: qinew ! provisional cloud ice mixing ratio (for calculating bergeron) +real(r8) :: qvl ! liquid sat mixing ratio +real(r8) :: epsi ! 1/ sat relaxation timecale for cloud ice +real(r8) :: prd ! provisional deposition rate of cloud ice at water sat +real(r8) :: berg(pcols,pver) ! mixing rat tendency due to bergeron process for cloud ice +real(r8) :: bergs(pver) ! mixing rat tendency due to bergeron process for snow + +!bergeron terms +real(r8) :: bergtsf !bergeron timescale to remove all liquid +real(r8) :: rhin !modified RH for vapor deposition + +! diagnostic rain/snow for output to history +! values are in-precip (local) !!!! + +real(r8) :: drout(pcols,pver) ! rain diameter (m) + +!averageed rain/snow for history +real(r8) :: dumfice + +!ice nucleation, droplet activation +real(r8) :: dum2i(pcols,pver) ! number conc of ice nuclei available (1/kg) +real(r8) :: dum2l(pcols,pver) ! number conc of CCN (1/kg) +real(r8) :: ncmax +real(r8) :: nimax + +real(r8) :: qcvar ! 1/relative variance of sub-grid qc + +! loop array variables +integer i,k,nstep,n, l +integer ii,kk, m + +! loop variables for sub-step solution +integer iter,it,ltrue(pcols) + +! used in contact freezing via dust particles +real(r8) tcnt, viscosity, mfp +real(r8) slip1, slip2, slip3, slip4 +! real(r8) dfaer1, dfaer2, dfaer3, dfaer4 +! real(r8) nacon1,nacon2,nacon3,nacon4 +real(r8) ndfaer1, ndfaer2, ndfaer3, ndfaer4 +real(r8) nslip1, nslip2, nslip3, nslip4 + +! used in ice effective radius +real(r8) bbi, cci, ak, iciwc, rvi + +! used in Bergeron processe and water vapor deposition +real(r8) Tk, deles, Aprpr, Bprpr, Cice, qi0, Crate, qidep + +! mean cloud fraction over the time step +real(r8) cldmw(pcols,pver) + +! used in secondary ice production +real(r8) ni_secp + +! variabels to check for RH after rain evap + +real(r8) :: esn +real(r8) :: qsn +real(r8) :: ttmp + + + +real(r8) :: rainrt(pcols,pver) ! rain rate for reflectivity calculation +real(r8) :: rainrt1(pcols,pver) +real(r8) :: tmp + +real(r8) dmc,ssmc,dstrn ! variables for modal scheme. + +real(r8), parameter :: cdnl = 0.e6_r8 ! cloud droplet number limiter + +! heterogeneous freezing +real(r8) :: mnudep(pver) ! mixing ratio tendency due to deposition of water vapor +real(r8) :: nnudep(pver) ! number conc tendency due to deposition of water vapor +real(r8) :: con1 ! work cnstant +real(r8) :: r3lx ! Mean volume radius (m) +real(r8) :: mi0l +real(r8) :: frztmp + +logical :: do_clubb_sgs + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +! Return error message +errstring = ' ' + +call phys_getopts(do_clubb_sgs_out = do_clubb_sgs) + +! initialize output fields for number conc qand ice nucleation +ncai(1:ncol,1:pver)=0._r8 +ncal(1:ncol,1:pver)=0._r8 + +!Initialize rain size +rercld(1:ncol,1:pver)=0._r8 +arcld(1:ncol,1:pver)=0._r8 + +!initialize radiation output variables +pgamrad(1:ncol,1:pver)=0._r8 ! liquid gamma parameter for optics (radiation) +lamcrad(1:ncol,1:pver)=0._r8 ! slope of droplet distribution for optics (radiation) +deffi (1:ncol,1:pver)=0._r8 ! slope of droplet distribution for optics (radiation) +!initialize radiation output variables +!initialize water vapor tendency term output +qcsevap(1:ncol,1:pver)=0._r8 +qisevap(1:ncol,1:pver)=0._r8 +qvres (1:ncol,1:pver)=0._r8 +cmeiout (1:ncol,1:pver)=0._r8 +vtrmc (1:ncol,1:pver)=0._r8 +vtrmi (1:ncol,1:pver)=0._r8 +qcsedten (1:ncol,1:pver)=0._r8 +qisedten (1:ncol,1:pver)=0._r8 + +prao(1:ncol,1:pver)=0._r8 +prco(1:ncol,1:pver)=0._r8 +mnuccco(1:ncol,1:pver)=0._r8 +mnuccto(1:ncol,1:pver)=0._r8 +msacwio(1:ncol,1:pver)=0._r8 +psacwso(1:ncol,1:pver)=0._r8 +bergso(1:ncol,1:pver)=0._r8 +bergo(1:ncol,1:pver)=0._r8 +melto(1:ncol,1:pver)=0._r8 +homoo(1:ncol,1:pver)=0._r8 +qcreso(1:ncol,1:pver)=0._r8 +prcio(1:ncol,1:pver)=0._r8 +praio(1:ncol,1:pver)=0._r8 +qireso(1:ncol,1:pver)=0._r8 +mnuccro(1:ncol,1:pver)=0._r8 +pracso (1:ncol,1:pver)=0._r8 +meltsdt(1:ncol,1:pver)=0._r8 +frzrdt (1:ncol,1:pver)=0._r8 +mnuccdo(1:ncol,1:pver)=0._r8 + +!AL +nnuccco(1:ncol,1:pver)=0._r8 +nnuccto(1:ncol,1:pver)=0._r8 +npsacwso(1:ncol,1:pver)=0._r8 +nsubco(1:ncol,1:pver)=0._r8 +nprao(1:ncol,1:pver)=0._r8 +nprc1o(1:ncol,1:pver)=0._r8 +nqcsedten(1:ncol,1:pver)=0._r8 +nmelto(1:ncol,1:pver)=0._r8 +nhomoo(1:ncol,1:pver)=0._r8 +nqisedten(1:ncol,1:pver)=0._r8 +nimelto(1:ncol,1:pver)=0._r8 +nihomoo(1:ncol,1:pver)=0._r8 +nsacwio(1:ncol,1:pver)=0._r8 +nsubio(1:ncol,1:pver)=0._r8 +nprcio(1:ncol,1:pver)=0._r8 +npraio(1:ncol,1:pver)=0._r8 +nnudepo(1:ncol,1:pver)=0._r8 +mnudepo(1:ncol,1:pver)=0._r8 +npccno(1:ncol,1:pver)=0._r8 +nnuccdo(1:ncol,1:pver)=0._r8 +nctncons(1:ncol,1:pver)=0._r8 +nctnnbmn(1:ncol,1:pver)=0._r8 +nctnszmn(1:ncol,1:pver)=0._r8 +nctnszmx(1:ncol,1:pver)=0._r8 +nctnncld(1:ncol,1:pver)=0._r8 +nitncons(1:ncol,1:pver)=0._r8 +nitnszmn(1:ncol,1:pver)=0._r8 +nitnszmx(1:ncol,1:pver)=0._r8 +nitnncld(1:ncol,1:pver)=0._r8 + +!AL + + +rflx(:,:)=0._r8 +sflx(:,:)=0._r8 +effc(:,:)=0._r8 +effc_fn(:,:)=0._r8 +effi(:,:)=0._r8 + +! assign variable deltat for sub-stepping... +deltat=deltatin + +! parameters for scheme + +omsm=0.99999_r8 +dto2=0.5_r8*deltat +mincld=0.0001_r8 + +! initialize multi-level fields +q(1:ncol,1:pver)=qn(1:ncol,1:pver) +t(1:ncol,1:pver)=tn(1:ncol,1:pver) + +! initialize time-varying parameters + +do k=1,pver + do i=1,ncol + rho(i,k)=p(i,k)/(r*t(i,k)) + dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/p(i,k) + mu(i,k) = 1.496E-6_r8*t(i,k)**1.5_r8/(t(i,k)+120._r8) + sc(i,k) = mu(i,k)/(rho(i,k)*dv(i,k)) + kap(i,k) = 1.414e3_r8*1.496e-6_r8*t(i,k)**1.5_r8/(t(i,k)+120._r8) + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof(i,k)=(rhosu/rho(i,k))**0.54_r8 + + arn(i,k)=ar*rhof(i,k) + asn(i,k)=as*rhof(i,k) + acn(i,k)=ac*rhof(i,k) + ain(i,k)=ai*rhof(i,k) + + ! get dz from dp and hydrostatic approx + ! keep dz positive (define as layer k-1 - layer k) + + dz(i,k)= pdel(i,k)/(rho(i,k)*g) + + end do +end do + +! initialization +qc(1:ncol,1:top_lev-1) = 0._r8 +qi(1:ncol,1:top_lev-1) = 0._r8 +nc(1:ncol,1:top_lev-1) = 0._r8 +ni(1:ncol,1:top_lev-1) = 0._r8 +t1(1:ncol,1:pver) = t(1:ncol,1:pver) +q1(1:ncol,1:pver) = q(1:ncol,1:pver) +qc1(1:ncol,1:pver) = qc(1:ncol,1:pver) +qi1(1:ncol,1:pver) = qi(1:ncol,1:pver) +nc1(1:ncol,1:pver) = nc(1:ncol,1:pver) +ni1(1:ncol,1:pver) = ni(1:ncol,1:pver) + +! initialize tendencies to zero +tlat1(1:ncol,1:pver)=0._r8 +qvlat1(1:ncol,1:pver)=0._r8 +qctend1(1:ncol,1:pver)=0._r8 +qitend1(1:ncol,1:pver)=0._r8 +nctend1(1:ncol,1:pver)=0._r8 +nitend1(1:ncol,1:pver)=0._r8 + +! initialize precip output +qrout(1:ncol,1:pver)=0._r8 +qsout(1:ncol,1:pver)=0._r8 +nrout(1:ncol,1:pver)=0._r8 +nsout(1:ncol,1:pver)=0._r8 +dsout(1:ncol,1:pver)=0._r8 + +drout(1:ncol,1:pver)=0._r8 + +reff_rain(1:ncol,1:pver)=0._r8 +reff_snow(1:ncol,1:pver)=0._r8 + +! initialize variables for trop_mozart +nevapr(1:ncol,1:pver) = 0._r8 +nevapr2(1:ncol,1:pver) = 0._r8 +evapsnow(1:ncol,1:pver) = 0._r8 +prain(1:ncol,1:pver) = 0._r8 +prodsnow(1:ncol,1:pver) = 0._r8 +cmeout(1:ncol,1:pver) = 0._r8 + +am_evp_st(1:ncol,1:pver) = 0._r8 + +! for refl calc +rainrt1(1:ncol,1:pver) = 0._r8 + +! initialize precip fraction and output tendencies +cldmax(1:ncol,1:pver)=mincld + +!initialize aerosol number +! naer2(1:ncol,1:pver,:)=0._r8 +dum2l(1:ncol,1:pver)=0._r8 +dum2i(1:ncol,1:pver)=0._r8 + +! initialize avg precip rate +prect1(1:ncol)=0._r8 +preci1(1:ncol)=0._r8 + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!Get humidity and saturation vapor pressures + +do k=top_lev,pver + + do i=1,ncol + + ! find wet bulk temperature and saturation value for provisional t and q without + ! condensation + + es(i) = svp_water(t(i,k)) + qs(i) = svp_to_qsat(es(i), p(i,k)) + + ! Prevents negative values. + if (qs(i) < 0.0_r8) then + qs(i) = 1.0_r8 + es(i) = p(i,k) + end if + + esl(i,k)=svp_water(t(i,k)) + esi(i,k)=svp_ice(t(i,k)) + + ! hm fix, make sure when above freezing that esi=esl, not active yet + if (t(i,k).gt.tmelt)esi(i,k)=esl(i,k) + + relhum(i,k)=q(i,k)/qs(i) + + ! get cloud fraction, check for minimum + + cldm(i,k)=max(cldn(i,k),mincld) + cldmw(i,k)=max(cldn(i,k),mincld) + + icldm(i,k)=max(icecldf(i,k),mincld) + lcldm(i,k)=max(liqcldf(i,k),mincld) + + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors + + if (microp_uniform) then + + cldm(i,k)=mincld + cldmw(i,k)=mincld + icldm(i,k)=mincld + lcldm(i,k)=mincld + + if (qc(i,k).ge.qsmall) then + lcldm(i,k)=1._r8 + cldm(i,k)=1._r8 + cldmw(i,k)=1._r8 + end if + + if (qi(i,k).ge.qsmall) then + cldm(i,k)=1._r8 + icldm(i,k)=1._r8 + end if + + end if ! sub-columns + + ! calculate nfice based on liquid and ice mmr (no rain and snow mmr available yet) + + nfice(i,k)=0._r8 + dumfice=qc(i,k)+qi(i,k) + if (dumfice.gt.qsmall .and. qi(i,k).gt.qsmall) then + nfice(i,k)=qi(i,k)/dumfice + endif + + if (do_cldice .and. (t(i,k).lt.tmelt - 5._r8)) then + + ! if aerosols interact with ice set number of activated ice nuclei + dum2=naai(i,k) + + dumnnuc=(dum2-ni(i,k)/icldm(i,k))/deltat*icldm(i,k) + dumnnuc=max(dumnnuc,0._r8) + ! get provisional ni and qi after nucleation in order to calculate + ! Bergeron process below + ninew=ni(i,k)+dumnnuc*deltat + qinew=qi(i,k)+dumnnuc*deltat*mi0 + + !T>268 + else + ninew=ni(i,k) + qinew=qi(i,k) + end if + + ! Initialize CME components + + cme(i,k) = 0._r8 + cmei(i,k)=0._r8 + + + !------------------------------------------------------------------- + !Bergeron process + + ! make sure to initialize bergeron process to zero + berg(i,k)=0._r8 + prd = 0._r8 + + !condensation loop. + + ! get in-cloud qi and ni after nucleation + if (icldm(i,k) .gt. 0._r8) then + qiic(i,k)=qinew/icldm(i,k) + niic(i,k)=ninew/icldm(i,k) + else + qiic(i,k)=0._r8 + niic(i,k)=0._r8 + endif + + if (nicons) then + niic(i,k) = ninst/rho(i,k) + end if + + !if T < 0 C then bergeron. + if (do_cldice .and. (t(i,k).lt.273.15_r8)) then + + !if ice exists + if (qi(i,k).gt.qsmall) then + + bergtsf = 0._r8 ! bergeron time scale (fraction of timestep) + + qvi = svp_to_qsat(esi(i,k), p(i,k)) + qvl = svp_to_qsat(esl(i,k), p(i,k)) + + dqsidt = xxls*qvi/(rv*t(i,k)**2) + abi = 1._r8+dqsidt*xxls/cpp + + ! get ice size distribution parameters + + if (qiic(i,k).ge.qsmall) then + lami(k) = (cons1*ci* & + niic(i,k)/qiic(i,k))**(1._r8/di) + n0i(k) = niic(i,k)*lami(k) + + ! check for slope + ! adjust vars + if (lami(k).lt.lammini) then + + lami(k) = lammini + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + else if (lami(k).gt.lammaxi) then + lami(k) = lammaxi + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + end if + + epsi = 2._r8*pi*n0i(k)*rho(i,k)*Dv(i,k)/(lami(k)*lami(k)) + + !if liquid exists + if (qc(i,k).gt. qsmall) then + + !begin bergeron process + ! do bergeron (vapor deposition with RHw=1) + ! code to find berg (a rate) goes here + + ! calculate Bergeron process + + prd = epsi*(qvl-qvi)/abi + + else + prd = 0._r8 + end if + + ! multiply by cloud fraction + + prd = prd*min(icldm(i,k),lcldm(i,k)) + + ! transfer of existing cloud liquid to ice + + berg(i,k)=max(0._r8,prd) + + end if !end liquid exists bergeron + + if (berg(i,k).gt.0._r8) then + bergtsf=max(0._r8,(qc(i,k)/berg(i,k))/deltat) + + if(bergtsf.lt.1._r8) berg(i,k) = max(0._r8,qc(i,k)/deltat) + + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (bergtsf.lt.1._r8.or.icldm(i,k).gt.lcldm(i,k)) then + + if (qiic(i,k).ge.qsmall) then + + ! first case is for case when liquid water is present, but is completely depleted + ! in time step, i.e., bergrsf > 0 but < 1 + + if (qc(i,k).ge.qsmall) then + rhin = (1.0_r8 + relhum(i,k)) / 2._r8 + if ((rhin*esl(i,k)/esi(i,k)) > 1._r8) then + prd = epsi*(rhin*qvl-qvi)/abi + + ! multiply by cloud fraction assuming liquid/ice maximum overlap + prd = prd*min(icldm(i,k),lcldm(i,k)) + + ! add to cmei + cmei(i,k) = cmei(i,k) + (prd * (1._r8- bergtsf)) + + end if ! rhin + end if ! qc > qsmall + + ! second case is for pure ice cloud, either no liquid, or icldm > lcldm + + if (qc(i,k).lt.qsmall.or.icldm(i,k).gt.lcldm(i,k)) then + + ! note: for case of no liquid, need to set liquid cloud fraction to zero + ! store liquid cloud fraction in 'dum' + + if (qc(i,k).lt.qsmall) then + dum=0._r8 + else + dum=lcldm(i,k) + end if + + ! set RH to grid-mean value for pure ice cloud + rhin = relhum(i,k) + + if ((rhin*esl(i,k)/esi(i,k)) > 1._r8) then + + prd = epsi*(rhin*qvl-qvi)/abi + + ! multiply by relevant cloud fraction for pure ice cloud + ! assuming maximum overlap of liquid/ice + prd = prd*max((icldm(i,k)-dum),0._r8) + cmei(i,k) = cmei(i,k) + prd + + end if ! rhin + end if ! qc or icldm > lcldm + end if ! qiic + end if ! bergtsf or icldm > lcldm + + ! if deposition, it should not reduce grid mean rhi below 1.0 + if(cmei(i,k) > 0.0_r8 .and. (relhum(i,k)*esl(i,k)/esi(i,k)) > 1._r8 ) & + cmei(i,k)=min(cmei(i,k),(q(i,k)-qs(i)*esi(i,k)/esl(i,k))/abi/deltat) + + end if !end ice exists loop + !this ends temperature < 0. loop + + !------------------------------------------------------------------- + end if ! + !.............................................................. + + ! evaporation should not exceed available water + + if ((-berg(i,k)).lt.-qc(i,k)/deltat) berg(i,k) = max(qc(i,k)/deltat,0._r8) + + !sublimation process... + if (do_cldice .and. ((relhum(i,k)*esl(i,k)/esi(i,k)).lt.1._r8 .and. qiic(i,k).ge.qsmall )) then + + qvi = svp_to_qsat(esi(i,k), p(i,k)) + qvl = svp_to_qsat(esl(i,k), p(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)**2) + abi = 1._r8+dqsidt*xxls/cpp + + ! get ice size distribution parameters + + lami(k) = (cons1*ci* & + niic(i,k)/qiic(i,k))**(1._r8/di) + n0i(k) = niic(i,k)*lami(k) + + ! check for slope + ! adjust vars + if (lami(k).lt.lammini) then + + lami(k) = lammini + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + else if (lami(k).gt.lammaxi) then + lami(k) = lammaxi + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + end if + + epsi = 2._r8*pi*n0i(k)*rho(i,k)*Dv(i,k)/(lami(k)*lami(k)) + + ! modify for ice fraction below + prd = epsi*(relhum(i,k)*qvl-qvi)/abi * icldm(i,k) + cmei(i,k)=min(prd,0._r8) + + endif + + ! sublimation should not exceed available ice + if (cmei(i,k).lt.-qi(i,k)/deltat) cmei(i,k)=-qi(i,k)/deltat + + ! sublimation should not increase grid mean rhi above 1.0 + if(cmei(i,k) < 0.0_r8 .and. (relhum(i,k)*esl(i,k)/esi(i,k)) < 1._r8 ) & + cmei(i,k)=min(0._r8,max(cmei(i,k),(q(i,k)-qs(i)*esi(i,k)/esl(i,k))/abi/deltat)) + + ! limit cmei due for roundoff error + + cmei(i,k)=cmei(i,k)*omsm + + ! conditional for ice nucleation + if (do_cldice .and. (t(i,k).lt.(tmelt - 5._r8))) then + + ! using Liu et al. (2007) ice nucleation with hooks into simulated aerosol + ! ice nucleation rate (dum2) has already been calculated and read in (naai) + + dum2i(i,k)=naai(i,k) + else + dum2i(i,k)=0._r8 + end if + + end do ! i loop +end do ! k loop + + +!! initialize sub-step precip flux variables +do i=1,ncol + !! flux is zero at top interface, so these should stay as 0. + rflx1(i,1)=0._r8 + sflx1(i,1)=0._r8 + do k=top_lev,pver + + ! initialize normal and sub-step precip flux variables + rflx1(i,k+1)=0._r8 + sflx1(i,k+1)=0._r8 + end do ! i loop +end do ! k loop +!! initialize final precip flux variables. +do i=1,ncol + !! flux is zero at top interface, so these should stay as 0. + rflx(i,1)=0._r8 + sflx(i,1)=0._r8 + do k=top_lev,pver + ! initialize normal and sub-step precip flux variables + rflx(i,k+1)=0._r8 + sflx(i,k+1)=0._r8 + end do ! i loop +end do ! k loop + +do i=1,ncol + ltrue(i)=0 + do k=top_lev,pver + ! skip microphysical calculations if no cloud water + + if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall.or.cmei(i,k).ge.qsmall) ltrue(i)=1 + end do +end do + +! assign number of sub-steps to iter +! use 2 sub-steps, following tests described in MG2008 +iter = 2 + +! get sub-step time step +deltat=deltat/real(iter) + +! since activation/nucleation processes are fast, need to take into account +! factor mtime = mixing timescale in cloud / model time step +! mixing time can be interpreted as cloud depth divided by sub-grid vertical velocity +! for now mixing timescale is assumed to be 1 timestep for modal aerosols, 20 min bulk + +! note: mtime for bulk aerosols was set to: mtime=deltat/1200._r8 + +mtime=1._r8 +rate1ord_cw2pr_st(:,:)=0._r8 ! rce 2010/05/01 + +!!!! skip calculations if no cloud water +do i=1,ncol + if (ltrue(i).eq.0) then + tlat(i,1:pver)=0._r8 + qvlat(i,1:pver)=0._r8 + qctend(i,1:pver)=0._r8 + qitend(i,1:pver)=0._r8 + qnitend(i,1:pver)=0._r8 + qrtend(i,1:pver)=0._r8 + nctend(i,1:pver)=0._r8 + nitend(i,1:pver)=0._r8 + nrtend(i,1:pver)=0._r8 + nstend(i,1:pver)=0._r8 + prect(i)=0._r8 + preci(i)=0._r8 + rflx(i,1:pver+1)=0._r8 + sflx(i,1:pver+1)=0._r8 + qniic(i,1:pver)=0._r8 + qric(i,1:pver)=0._r8 + nsic(i,1:pver)=0._r8 + nric(i,1:pver)=0._r8 + rainrt(i,1:pver)=0._r8 + goto 300 + end if + + qcsinksum_rate1ord(1:pver)=0._r8 + qcsum_rate1ord(1:pver)=0._r8 + + +!!!!!!!!! begin sub-step!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !..................................................................................................... + do it=1,iter + + ! initialize sub-step microphysical tendencies + + tlat(i,1:pver)=0._r8 + qvlat(i,1:pver)=0._r8 + qctend(i,1:pver)=0._r8 + qitend(i,1:pver)=0._r8 + qnitend(i,1:pver)=0._r8 + qrtend(i,1:pver)=0._r8 + nctend(i,1:pver)=0._r8 + nitend(i,1:pver)=0._r8 + nrtend(i,1:pver)=0._r8 + nstend(i,1:pver)=0._r8 + + ! initialize diagnostic precipitation to zero + + qniic(i,1:pver)=0._r8 + qric(i,1:pver)=0._r8 + nsic(i,1:pver)=0._r8 + nric(i,1:pver)=0._r8 + + rainrt(i,1:pver)=0._r8 + + + ! begin new i,k loop, calculate new cldmax after adjustment to cldm above + + ! initialize vertically-integrated rain and snow tendencies + + qrtot = 0._r8 + nrtot = 0._r8 + qstot = 0._r8 + nstot = 0._r8 + + ! initialize precip at surface + + prect(i)=0._r8 + preci(i)=0._r8 + + ! initialize fluxes + rflx(i,1:pver+1)=0._r8 + sflx(i,1:pver+1)=0._r8 + + do k=top_lev,pver + + qcvar=relvar(i,k) + cons2=gamma(qcvar+2.47_r8) + cons3=gamma(qcvar) + cons9=gamma(qcvar+2._r8) + cons10=gamma(qcvar+1._r8) + cons12=gamma(qcvar+1.15_r8) + cons15=gamma(qcvar+bc/3._r8) + cons18=qcvar**2.47_r8 + cons19=qcvar**2 + cons20=qcvar**1.15_r8 + + ! set cwml and cwmi to current qc and qi + + cwml(i,k)=qc(i,k) + cwmi(i,k)=qi(i,k) + + ! initialize precip fallspeeds to zero + + ums(k)=0._r8 + uns(k)=0._r8 + umr(k)=0._r8 + unr(k)=0._r8 + + ! calculate precip fraction based on maximum overlap assumption + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so cldmax will be correctly set below + ! and nothing extra needs to be done here + + if (k.eq.top_lev) then + cldmax(i,k)=cldm(i,k) + else + ! if rain or snow mix ratio is smaller than + ! threshold, then set cldmax to cloud fraction at current level + + if (do_clubb_sgs) then + if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall) then + cldmax(i,k)=cldm(i,k) + else + cldmax(i,k)=cldmax(i,k-1) + end if + else + + if (qric(i,k-1).ge.qsmall.or.qniic(i,k-1).ge.qsmall) then + cldmax(i,k)=max(cldmax(i,k-1),cldm(i,k)) + else + cldmax(i,k)=cldm(i,k) + end if + endif + end if + + ! decrease in number concentration due to sublimation/evap + ! divide by cloud fraction to get in-cloud decrease + ! don't reduce Nc due to bergeron process + + if (cmei(i,k) < 0._r8 .and. qi(i,k) > qsmall .and. cldm(i,k) > mincld) then + nsubi(k)=cmei(i,k)/qi(i,k)*ni(i,k)/cldm(i,k) + else + nsubi(k)=0._r8 + end if + nsubc(k)=0._r8 + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + + if (do_cldice .and. dum2i(i,k).gt.0._r8.and.t(i,k).lt.(tmelt - 5._r8).and. & + relhum(i,k)*esl(i,k)/esi(i,k).gt. rhmini+0.05_r8) then + + !if NCAI > 0. then set numice = ncai (as before) + !note: this is gridbox averaged + + nnuccd(k)=(dum2i(i,k)-ni(i,k)/icldm(i,k))/deltat*icldm(i,k) + nnuccd(k)=max(nnuccd(k),0._r8) + nimax = dum2i(i,k)*icldm(i,k) + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd(k) = nnuccd(k) * mi0 + + ! add mnuccd to cmei.... + cmei(i,k)= cmei(i,k) + mnuccd(k) * mtime + + ! limit cmei + + qvi = svp_to_qsat(esi(i,k), p(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)**2) + abi = 1._r8+dqsidt*xxls/cpp + cmei(i,k)=min(cmei(i,k),(q(i,k)-qvi)/abi/deltat) + + ! limit for roundoff error + cmei(i,k)=cmei(i,k)*omsm + + else + nnuccd(k)=0._r8 + nimax = 0._r8 + mnuccd(k) = 0._r8 + end if + + !c............................................................................ + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + + ! limit in-cloud values to 0.005 kg/kg + + qcic(i,k)=min(cwml(i,k)/lcldm(i,k),5.e-3_r8) + qiic(i,k)=min(cwmi(i,k)/icldm(i,k),5.e-3_r8) + ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8) + niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8) + + if (nccons) then + ncic(i,k) = ncnst/rho(i,k) + end if + if (nicons) then + niic(i,k) = ninst/rho(i,k) + end if + + if (qc(i,k) - berg(i,k)*deltat.lt.qsmall) then + qcic(i,k)=0._r8 + ncic(i,k)=0._r8 + if (qc(i,k)-berg(i,k)*deltat.lt.0._r8) then + berg(i,k)=qc(i,k)/deltat*omsm + end if + end if + + if (do_cldice .and. qi(i,k)+(cmei(i,k)+berg(i,k))*deltat.lt.qsmall) then + qiic(i,k)=0._r8 + niic(i,k)=0._r8 + if (qi(i,k)+(cmei(i,k)+berg(i,k))*deltat.lt.0._r8) then + cmei(i,k)=(-qi(i,k)/deltat-berg(i,k))*omsm + end if + end if + + ! add to cme output + + cmeout(i,k) = cmeout(i,k)+cmei(i,k) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! calculate potential for droplet activation if cloud water is present + ! formulation from Abdul-Razzak and Ghan (2000) and Abdul-Razzak et al. (1998), AR98 + ! number tendency (npccnin) is read in from companion routine + + ! assume aerosols already activated are equal to number of existing droplets for simplicity + ! multiply by cloud fraction to obtain grid-average tendency + + if (qcic(i,k).ge.qsmall) then + npccn(k) = max(0._r8,npccnin(i,k)) + dum2l(i,k)=(nc(i,k)+npccn(k)*deltat)/lcldm(i,k) + dum2l(i,k)=max(dum2l(i,k),cdnl/rho(i,k)) ! sghan minimum in #/cm3 + ncmax = dum2l(i,k)*lcldm(i,k) + else + npccn(k)=0._r8 + dum2l(i,k)=0._r8 + ncmax = 0._r8 + end if + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water/ice + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + !...................................................................... + ! cloud ice + + if (qiic(i,k).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + niic(i,k)=min(niic(i,k),qiic(i,k)*1.e20_r8) + + lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**(1._r8/di) + n0i(k) = niic(i,k)*lami(k) + + ! check for slope + ! adjust vars + + if (lami(k).lt.lammini) then + + lami(k) = lammini + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + else if (lami(k).gt.lammaxi) then + lami(k) = lammaxi + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + end if + + else + lami(k) = 0._r8 + n0i(k) = 0._r8 + end if + + if (qcic(i,k).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + ncic(i,k)=min(ncic(i,k),qcic(i,k)*1.e20_r8) + + ncic(i,k)=max(ncic(i,k),cdnl/rho(i,k)) ! sghan minimum in #/cm + + ! get pgam from fit to observations of martin et al. 1994 + + pgam(k)=0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k)=1._r8/(pgam(k)**2)-1._r8 + pgam(k)=max(pgam(k),2._r8) + pgam(k)=min(pgam(k),15._r8) + + ! calculate lamc + + lamc(k) = (pi/6._r8*rhow*ncic(i,k)*gamma(pgam(k)+4._r8)/ & + (qcic(i,k)*gamma(pgam(k)+1._r8)))**(1._r8/3._r8) + + ! lammin, 50 micron diameter max mean size + + lammin = (pgam(k)+1._r8)/50.e-6_r8 + lammax = (pgam(k)+1._r8)/2.e-6_r8 + + if (lamc(k).lt.lammin) then + lamc(k) = lammin + ncic(i,k) = 6._r8*lamc(k)**3*qcic(i,k)* & + gamma(pgam(k)+1._r8)/(pi*rhow*gamma(pgam(k)+4._r8)) + else if (lamc(k).gt.lammax) then + lamc(k) = lammax + ncic(i,k) = 6._r8*lamc(k)**3*qcic(i,k)* & + gamma(pgam(k)+1._r8)/(pi*rhow*gamma(pgam(k)+4._r8)) + end if + + ! parameter to calculate droplet freezing + + cdist1(k) = ncic(i,k)/gamma(pgam(k)+1._r8) + + else + lamc(k) = 0._r8 + cdist1(k) = 0._r8 + end if + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! begin micropysical process calculations + !................................................................. + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (qcic(i,k).ge.1.e-8_r8) then + + ! nprc is increase in rain number conc due to autoconversion + ! nprc1 is decrease in cloud droplet conc due to autoconversion + + ! assume exponential sub-grid distribution of qc, resulting in additional + ! factor related to qcvar below + + ! hm switch for sub-columns, don't include sub-grid qc + if (microp_uniform) then + + prc(k) = 1350._r8*qcic(i,k)**2.47_r8* & + (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8) + nprc(k) = prc(k)/(4._r8/3._r8*pi*rhow*(25.e-6_r8)**3) + nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k)) + + else + + prc(k) = cons2/(cons3*cons18)*1350._r8*qcic(i,k)**2.47_r8* & + (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8) + nprc(k) = prc(k)/cons22 + nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k)) + + end if ! sub-column switch + + else + prc(k)=0._r8 + nprc(k)=0._r8 + nprc1(k)=0._r8 + end if + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + ! 0.45 m/s is fallspeed of new rain drop (80 micron diameter) + + dum=0.45_r8 + dum1=0.45_r8 + + if (k.eq.top_lev) then + qric(i,k)=prc(k)*lcldm(i,k)*dz(i,k)/cldmax(i,k)/dum + nric(i,k)=nprc(k)*lcldm(i,k)*dz(i,k)/cldmax(i,k)/dum + else + if (qric(i,k-1).ge.qsmall) then + dum=umr(k-1) + dum1=unr(k-1) + end if + + ! no autoconversion of rain number if rain/snow falling from above + ! this assumes that new drizzle drops formed by autoconversion are rapidly collected + ! by the existing rain/snow particles from above + + if (qric(i,k-1).ge.1.e-9_r8.or.qniic(i,k-1).ge.1.e-9_r8) then + nprc(k)=0._r8 + end if + + qric(i,k) = (rho(i,k-1)*umr(k-1)*qric(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*((pra(k-1)+prc(k))*lcldm(i,k)+(pre(k-1)-pracs(k-1)-mnuccr(k-1))*cldmax(i,k))))& + /(dum*rho(i,k)*cldmax(i,k)) + nric(i,k) = (rho(i,k-1)*unr(k-1)*nric(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*(nprc(k)*lcldm(i,k)+(nsubr(k-1)-npracs(k-1)-nnuccr(k-1)+nragg(k-1))*cldmax(i,k))))& + /(dum1*rho(i,k)*cldmax(i,k)) + + end if + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + if (t(i,k).le.273.15_r8.and.qiic(i,k).ge.qsmall) then + + ! note: assumes autoconversion timescale of 180 sec + + nprci(k) = n0i(k)/(lami(k)*180._r8)*exp(-lami(k)*dcs) + + prci(k) = pi*rhoi*n0i(k)/(6._r8*180._r8)* & + (cons23/lami(k)+3._r8*cons24/lami(k)**2+ & + 6._r8*dcs/lami(k)**3+6._r8/lami(k)**4)*exp(-lami(k)*dcs) + else + prci(k)=0._r8 + nprci(k)=0._r8 + end if + else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + prci(k) = tnd_qsnow(i, k) / cldm(i,k) + nprci(k) = tnd_nsnow(i, k) / cldm(i,k) + end if + + ! add autoconversion to flux from level above to get provisional snow mixing ratio + ! and number concentration (qniic and nsic) + + dum=(asn(i,k)*cons25) + dum1=(asn(i,k)*cons25) + + if (k.eq.top_lev) then + qniic(i,k)=prci(k)*icldm(i,k)*dz(i,k)/cldmax(i,k)/dum + nsic(i,k)=nprci(k)*icldm(i,k)*dz(i,k)/cldmax(i,k)/dum + else + if (qniic(i,k-1).ge.qsmall) then + dum=ums(k-1) + dum1=uns(k-1) + end if + + qniic(i,k) = (rho(i,k-1)*ums(k-1)*qniic(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*((prci(k)+prai(k-1)+psacws(k-1)+bergs(k-1))*icldm(i,k)+(prds(k-1)+ & + pracs(k-1)+mnuccr(k-1))*cldmax(i,k))))& + /(dum*rho(i,k)*cldmax(i,k)) + + nsic(i,k) = (rho(i,k-1)*uns(k-1)*nsic(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*(nprci(k)*icldm(i,k)+(nsubs(k-1)+nsagg(k-1)+nnuccr(k-1))*cldmax(i,k))))& + /(dum1*rho(i,k)*cldmax(i,k)) + + end if + + ! if precip mix ratio is zero so should number concentration + + if (qniic(i,k).lt.qsmall) then + qniic(i,k)=0._r8 + nsic(i,k)=0._r8 + end if + + if (qric(i,k).lt.qsmall) then + qric(i,k)=0._r8 + nric(i,k)=0._r8 + end if + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(i,k)=max(nric(i,k),0._r8) + nsic(i,k)=max(nsic(i,k),0._r8) + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + if (qric(i,k).ge.qsmall) then + lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8) + n0r(k) = nric(i,k)*lamr(k) + + ! check for slope + ! adjust vars + + if (lamr(k).lt.lamminr) then + + lamr(k) = lamminr + + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k).gt.lammaxr) then + lamr(k) = lammaxr + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + end if + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + unr(k) = min(arn(i,k)*cons4/lamr(k)**br,9.1_r8*rhof(i,k)) + umr(k) = min(arn(i,k)*cons5/(6._r8*lamr(k)**br),9.1_r8*rhof(i,k)) + + else + lamr(k) = 0._r8 + n0r(k) = 0._r8 + umr(k) = 0._r8 + unr(k) = 0._r8 + end if + + !...................................................................... + ! snow + + if (qniic(i,k).ge.qsmall) then + lams(k) = (cons6*cs*nsic(i,k)/qniic(i,k))**(1._r8/ds) + n0s(k) = nsic(i,k)*lams(k) + + ! check for slope + ! adjust vars + + if (lams(k).lt.lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + + else if (lams(k).gt.lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + end if + + ! provisional snow number and mass weighted mean fallspeed (m/s) + + ums(k) = min(asn(i,k)*cons8/(6._r8*lams(k)**bs),1.2_r8*rhof(i,k)) + uns(k) = min(asn(i,k)*cons7/lams(k)**bs,1.2_r8*rhof(i,k)) + + else + lams(k) = 0._r8 + n0s(k) = 0._r8 + ums(k) = 0._r8 + uns(k) = 0._r8 + end if + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! heterogeneous freezing of cloud water + + if (.not. use_hetfrz_classnuc) then + +!AL +!Make sure zero output for deposition freezing +!If no classnuc this is included in NNUCCD (Meyers 1992) + nnudep(k) = 0.0_r8 + mnudep(k) = 0.0_r8 +!AL + if (do_cldice .and. qcic(i,k).ge.qsmall .and. t(i,k).lt.269.15_r8) then + + ! immersion freezing (Bigg, 1953) + + + ! subcolumns + + if (microp_uniform) then + + mnuccc(k) = & + pi*pi/36._r8*rhow* & + cdist1(k)*gamma(7._r8+pgam(k))* & + bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & + lamc(k)**3/lamc(k)**3 + + nnuccc(k) = & + pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & + *bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 + + else + + mnuccc(k) = cons9/(cons3*cons19)* & + pi*pi/36._r8*rhow* & + cdist1(k)*gamma(7._r8+pgam(k))* & + bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & + lamc(k)**3/lamc(k)**3 + + nnuccc(k) = cons10/(cons3*qcvar)* & + pi/6._r8*cdist1(k)*gamma(pgam(k)+4._r8) & + *bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(k)**3 + end if ! sub-columns + + + ! contact freezing (-40= qsmall) then + con1 = 1._r8/(1.333_r8*pi)**0.333_r8 + r3lx = con1*(rho(i,k)*qcic(i,k)/(rhow*max(ncic(i,k)*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m + r3lx = max(4.e-6_r8, r3lx) + mi0l = 4._r8/3._r8*pi*rhow*r3lx**3_r8 + + nnuccc(k) = frzimm(i,k)*1.0e6_r8/rho(i,k) + mnuccc(k) = nnuccc(k)*mi0l + + nnucct(k) = frzcnt(i,k)*1.0e6_r8/rho(i,k) + mnucct(k) = nnucct(k)*mi0l + + nnudep(k) = frzdep(i,k)*1.0e6_r8/rho(i,k) + mnudep(k) = nnudep(k)*mi0 + else + nnuccc(k) = 0._r8 + mnuccc(k) = 0._r8 + + nnucct(k) = 0._r8 + mnucct(k) = 0._r8 + + nnudep(k) = 0._r8 + mnudep(k) = 0._r8 + end if + endif + + + !....................................................................... + ! snow self-aggregation from passarelli, 1978, used by reisner, 1998 + ! this is hard-wired for bs = 0.4 for now + ! ignore self-collection of cloud ice + + if (qniic(i,k).ge.qsmall .and. t(i,k).le.273.15_r8) then + nsagg(k) = -1108._r8*asn(i,k)*Eii* & + pi**((1._r8-bs)/3._r8)*rhosn**((-2._r8-bs)/3._r8)*rho(i,k)** & + ((2._r8+bs)/3._r8)*qniic(i,k)**((2._r8+bs)/3._r8)* & + (nsic(i,k)*rho(i,k))**((4._r8-bs)/3._r8)/ & + (4._r8*720._r8*rho(i,k)) + else + nsagg(k)=0._r8 + end if + + !....................................................................... + ! accretion of cloud droplets onto snow/graupel + ! here use continuous collection equation with + ! simple gravitational collection kernel + ! ignore collisions between droplets/cloud ice + ! since minimum size ice particle for accretion is 50 - 150 micron + + ! ignore collision of snow with droplets above freezing + + if (qniic(i,k).ge.qsmall .and. t(i,k).le.tmelt .and. & + qcic(i,k).ge.qsmall) then + + ! put in size dependent collection efficiency + ! mean diameter of snow is area-weighted, since + ! accretion is function of crystal geometric area + ! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) + + dc0 = (pgam(k)+1._r8)/lamc(k) + ds0 = 1._r8/lams(k) + dum = dc0*dc0*uns(k)*rhow/(9._r8*mu(i,k)*ds0) + eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8)) + + eci = max(eci,0._r8) + eci = min(eci,1._r8) + + + ! no impact of sub-grid distribution of qc since psacws + ! is linear in qc + + psacws(k) = pi/4._r8*asn(i,k)*qcic(i,k)*rho(i,k)* & + n0s(k)*Eci*cons11/ & + lams(k)**(bs+3._r8) + npsacws(k) = pi/4._r8*asn(i,k)*ncic(i,k)*rho(i,k)* & + n0s(k)*Eci*cons11/ & + lams(k)**(bs+3._r8) + else + psacws(k)=0._r8 + npsacws(k)=0._r8 + end if + + ! add secondary ice production due to accretion of droplets by snow + ! (Hallet-Mossop process) (from Cotton et al., 1986) + + if (.not. do_cldice) then + ni_secp = 0.0_r8 + nsacwi(k) = 0.0_r8 + msacwi(k) = 0.0_r8 + else if((t(i,k).lt.270.16_r8) .and. (t(i,k).ge.268.16_r8)) then + ni_secp = 3.5e8_r8*(270.16_r8-t(i,k))/2.0_r8*psacws(k) + nsacwi(k) = ni_secp + msacwi(k) = min(ni_secp*mi0,psacws(k)) + else if((t(i,k).lt.268.16_r8) .and. (t(i,k).ge.265.16_r8)) then + ni_secp = 3.5e8_r8*(t(i,k)-265.16_r8)/3.0_r8*psacws(k) + nsacwi(k) = ni_secp + msacwi(k) = min(ni_secp*mi0,psacws(k)) + else + ni_secp = 0.0_r8 + nsacwi(k) = 0.0_r8 + msacwi(k) = 0.0_r8 + endif + psacws(k) = max(0.0_r8,psacws(k)-ni_secp*mi0) + + !....................................................................... + ! accretion of rain water by snow + ! formula from ikawa and saito, 1991, used by reisner et al., 1998 + + if (qric(i,k).ge.1.e-8_r8 .and. qniic(i,k).ge.1.e-8_r8 .and. & + t(i,k).le.273.15_r8) then + + pracs(k) = pi*pi*ecr*(((1.2_r8*umr(k)-0.95_r8*ums(k))**2+ & + 0.08_r8*ums(k)*umr(k))**0.5_r8*rhow*rho(i,k)* & + n0r(k)*n0s(k)* & + (5._r8/(lamr(k)**6*lams(k))+ & + 2._r8/(lamr(k)**5*lams(k)**2)+ & + 0.5_r8/(lamr(k)**4*lams(k)**3))) + + npracs(k) = pi/2._r8*rho(i,k)*ecr*(1.7_r8*(unr(k)-uns(k))**2+ & + 0.3_r8*unr(k)*uns(k))**0.5_r8*n0r(k)*n0s(k)* & + (1._r8/(lamr(k)**3*lams(k))+ & + 1._r8/(lamr(k)**2*lams(k)**2)+ & + 1._r8/(lamr(k)*lams(k)**3)) + + else + pracs(k)=0._r8 + npracs(k)=0._r8 + end if + + !....................................................................... + ! heterogeneous freezing of rain drops + ! follows from Bigg (1953) + + if (t(i,k).lt.269.15_r8 .and. qric(i,k).ge.qsmall) then + + mnuccr(k) = 20._r8*pi*pi*rhow*nric(i,k)*bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamr(k)**3 & + /lamr(k)**3 + + nnuccr(k) = pi*nric(i,k)*bimm* & + (exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamr(k)**3 + else + mnuccr(k)=0._r8 + nnuccr(k)=0._r8 + end if + + !....................................................................... + ! accretion of cloud liquid water by rain + ! formula from Khrouditnov and Kogan (2000) + ! gravitational collection kernel, droplet fall speed neglected + + if (qric(i,k).ge.qsmall .and. qcic(i,k).ge.qsmall) then + + ! include sub-grid distribution of cloud water + + ! add sub-column switch + + if (microp_uniform) then + + pra(k) = 67._r8*(qcic(i,k)*qric(i,k))**1.15_r8 + npra(k) = pra(k)/(qcic(i,k)/ncic(i,k)) + + else + + pra(k) = accre_enhan(i,k)*(cons12/(cons3*cons20)*67._r8*(qcic(i,k)*qric(i,k))**1.15_r8) + npra(k) = pra(k)/(qcic(i,k)/ncic(i,k)) + + end if ! sub-column switch + + else + pra(k)=0._r8 + npra(k)=0._r8 + end if + + !....................................................................... + ! Self-collection of rain drops + ! from Beheng(1994) + + if (qric(i,k).ge.qsmall) then + nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k) + else + nragg(k)=0._r8 + end if + + !....................................................................... + ! Accretion of cloud ice by snow + ! For this calculation, it is assumed that the Vs >> Vi + ! and Ds >> Di for continuous collection + + if (do_cldice .and. qniic(i,k).ge.qsmall.and.qiic(i,k).ge.qsmall & + .and.t(i,k).le.273.15_r8) then + + prai(k) = pi/4._r8*asn(i,k)*qiic(i,k)*rho(i,k)* & + n0s(k)*Eii*cons11/ & + lams(k)**(bs+3._r8) + nprai(k) = pi/4._r8*asn(i,k)*niic(i,k)* & + rho(i,k)*n0s(k)*Eii*cons11/ & + lams(k)**(bs+3._r8) + else + prai(k)=0._r8 + nprai(k)=0._r8 + end if + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! calculate evaporation/sublimation of rain and snow + ! note: evaporation/sublimation occurs only in cloud-free portion of grid cell + ! in-cloud condensation/deposition of rain and snow is neglected + ! except for transfer of cloud water to snow through bergeron process + + ! initialize evap/sub tendncies + pre(k)=0._r8 + prds(k)=0._r8 + + ! evaporation of rain + ! only calculate if there is some precip fraction > cloud fraction + + if (qcic(i,k)+qiic(i,k).lt.1.e-6_r8.or.cldmax(i,k).gt.lcldm(i,k)) then + + ! set temporary cloud fraction to zero if cloud water + ice is very small + ! this will ensure that evaporation/sublimation of precip occurs over + ! entire grid cell, since min cloud fraction is specified otherwise + if (qcic(i,k)+qiic(i,k).lt.1.e-6_r8) then + dum=0._r8 + else + dum=lcldm(i,k) + end if + + ! saturation vapor pressure + esn=svp_water(t(i,k)) + qsn=svp_to_qsat(esn, p(i,k)) + + ! recalculate saturation vapor pressure for liquid and ice + esl(i,k)=esn + esi(i,k)=svp_ice(t(i,k)) + ! hm fix, make sure when above freezing that esi=esl, not active yet + if (t(i,k).gt.tmelt)esi(i,k)=esl(i,k) + + ! calculate q for out-of-cloud region + qclr=(q(i,k)-dum*qsn)/(1._r8-dum) + + if (qric(i,k).ge.qsmall) then + + qvs=svp_to_qsat(esl(i,k), p(i,k)) + dqsdt = xxlv*qvs/(rv*t(i,k)**2) + ab = 1._r8+dqsdt*xxlv/cpp + epsr = 2._r8*pi*n0r(k)*rho(i,k)*Dv(i,k)* & + (f1r/(lamr(k)*lamr(k))+ & + f2r*(arn(i,k)*rho(i,k)/mu(i,k))**0.5_r8* & + sc(i,k)**(1._r8/3._r8)*cons13/ & + (lamr(k)**(5._r8/2._r8+br/2._r8))) + + pre(k) = epsr*(qclr-qvs)/ab + + ! only evaporate in out-of-cloud region + ! and distribute across cldmax + pre(k)=min(pre(k)*(cldmax(i,k)-dum),0._r8) + pre(k)=pre(k)/cldmax(i,k) + am_evp_st(i,k) = max(cldmax(i,k)-dum, 0._r8) + end if + + ! sublimation of snow + if (qniic(i,k).ge.qsmall) then + qvi=svp_to_qsat(esi(i,k), p(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)**2) + abi = 1._r8+dqsidt*xxls/cpp + epss = 2._r8*pi*n0s(k)*rho(i,k)*Dv(i,k)* & + (f1s/(lams(k)*lams(k))+ & + f2s*(asn(i,k)*rho(i,k)/mu(i,k))**0.5_r8* & + sc(i,k)**(1._r8/3._r8)*cons14/ & + (lams(k)**(5._r8/2._r8+bs/2._r8))) + prds(k) = epss*(qclr-qvi)/abi + + ! only sublimate in out-of-cloud region and distribute over cldmax + prds(k)=min(prds(k)*(cldmax(i,k)-dum),0._r8) + prds(k)=prds(k)/cldmax(i,k) + am_evp_st(i,k) = max(cldmax(i,k)-dum, 0._r8) + end if + + ! make sure RH not pushed above 100% due to rain evaporation/snow sublimation + ! get updated RH at end of time step based on cloud water/ice condensation/evap + + qtmp=q(i,k)-(cmei(i,k)+(pre(k)+prds(k))*cldmax(i,k))*deltat + ttmp=t(i,k)+((pre(k)*cldmax(i,k))*xxlv+ & + (cmei(i,k)+prds(k)*cldmax(i,k))*xxls)*deltat/cpp + + !limit range of temperatures! + ttmp=max(180._r8,min(ttmp,323._r8)) + + esn=svp_water(ttmp) ! use rhw to allow ice supersaturation + qsn=svp_to_qsat(esn, p(i,k)) + + ! modify precip evaporation rate if q > qsat + if (qtmp.gt.qsn) then + if (pre(k)+prds(k).lt.-1.e-20_r8) then + dum1=pre(k)/(pre(k)+prds(k)) + ! recalculate q and t after cloud water cond but without precip evap + qtmp=q(i,k)-(cmei(i,k))*deltat + ttmp=t(i,k)+(cmei(i,k)*xxls)*deltat/cpp + esn=svp_water(ttmp) ! use rhw to allow ice supersaturation + qsn=svp_to_qsat(esn, p(i,k)) + dum=(qtmp-qsn)/(1._r8 + cons27*qsn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by cldmax to get local (in-precip) value + pre(k)=dum*dum1/deltat/cldmax(i,k) + + ! do separately using RHI for prds.... + esn=svp_ice(ttmp) ! use rhi to allow ice supersaturation + qsn=svp_to_qsat(esn, p(i,k)) + dum=(qtmp-qsn)/(1._r8 + cons28*qsn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by cldmax to get local (in-precip) value + prds(k)=dum*(1._r8-dum1)/deltat/cldmax(i,k) + end if + end if + end if + + ! bergeron process - evaporation of droplets and deposition onto snow + + if (qniic(i,k).ge.qsmall.and.qcic(i,k).ge.qsmall.and.t(i,k).lt.tmelt) then + qvi=svp_to_qsat(esi(i,k), p(i,k)) + qvs=svp_to_qsat(esl(i,k), p(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)**2) + abi = 1._r8+dqsidt*xxls/cpp + epss = 2._r8*pi*n0s(k)*rho(i,k)*Dv(i,k)* & + (f1s/(lams(k)*lams(k))+ & + f2s*(asn(i,k)*rho(i,k)/mu(i,k))**0.5_r8* & + sc(i,k)**(1._r8/3._r8)*cons14/ & + (lams(k)**(5._r8/2._r8+bs/2._r8))) + bergs(k)=epss*(qvs-qvi)/abi + else + bergs(k)=0._r8 + end if + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + + ! make sure and use end-of-time step values for cloud water, ice, due + ! condensation/deposition + + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! include mixing timescale (mtime) + + qce=(qc(i,k) - berg(i,k)*deltat) + nce=(nc(i,k)+npccn(k)*deltat*mtime) + qie=(qi(i,k)+(cmei(i,k)+berg(i,k))*deltat) + nie=(ni(i,k)+nnuccd(k)*deltat*mtime) + + ! conservation of qc + + dum = (prc(k)+pra(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & + psacws(k)+bergs(k))*lcldm(i,k)*deltat + + if (dum.gt.qce) then + ratio = qce/deltat/lcldm(i,k)/(prc(k)+pra(k)+mnuccc(k)+mnucct(k)+msacwi(k)+psacws(k)+bergs(k))*omsm + + prc(k) = prc(k)*ratio + pra(k) = pra(k)*ratio + mnuccc(k) = mnuccc(k)*ratio + mnucct(k) = mnucct(k)*ratio + msacwi(k) = msacwi(k)*ratio + psacws(k) = psacws(k)*ratio + bergs(k) = bergs(k)*ratio + end if + + ! conservation of nc + + dum = (nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+ & + npsacws(k)-nsubc(k))*lcldm(i,k)*deltat + + if (dum.gt.nce) then + ratio = nce/deltat/((nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+& + npsacws(k)-nsubc(k))*lcldm(i,k))*omsm + + nprc1(k) = nprc1(k)*ratio + npra(k) = npra(k)*ratio + nnuccc(k) = nnuccc(k)*ratio + nnucct(k) = nnucct(k)*ratio + npsacws(k) = npsacws(k)*ratio + nsubc(k)=nsubc(k)*ratio + end if + + ! conservation of qi + + if (do_cldice) then + + frztmp = -mnuccc(k) - mnucct(k) - msacwi(k) + if (use_hetfrz_classnuc) frztmp = -mnuccc(k)-mnucct(k)-mnudep(k)-msacwi(k) + dum = ( frztmp*lcldm(i,k) + (prci(k)+prai(k))*icldm(i,k) )*deltat + + if (dum.gt.qie) then + + frztmp = mnuccc(k) + mnucct(k) + msacwi(k) + if (use_hetfrz_classnuc) frztmp = mnuccc(k) + mnucct(k) + mnudep(k) + msacwi(k) + ratio = (qie/deltat + frztmp*lcldm(i,k))/((prci(k)+prai(k))*icldm(i,k))*omsm + prci(k) = prci(k)*ratio + prai(k) = prai(k)*ratio + end if + + ! conservation of ni + frztmp = -nnucct(k) - nsacwi(k) + if (use_hetfrz_classnuc) frztmp = -nnucct(k) - nnuccc(k) - nnudep(k) - nsacwi(k) + dum = ( frztmp*lcldm(i,k) + (nprci(k)+nprai(k)-nsubi(k))*icldm(i,k) )*deltat + + if (dum.gt.nie) then + + frztmp = nnucct(k) + nsacwi(k) + if (use_hetfrz_classnuc) frztmp = nnucct(k) + nnuccc(k) + nnudep(k) + nsacwi(k) + ratio = (nie/deltat + frztmp*lcldm(i,k))/ & + ((nprci(k)+nprai(k)-nsubi(k))*icldm(i,k))*omsm + nprci(k) = nprci(k)*ratio + nprai(k) = nprai(k)*ratio + nsubi(k) = nsubi(k)*ratio + end if + end if + + ! for precipitation conservation, use logic that vertical integral + ! of tendency from current level to top of model (i.e., qrtot) cannot be negative + + ! conservation of rain mixing rat + + if (((prc(k)+pra(k))*lcldm(i,k)+(-mnuccr(k)+pre(k)-pracs(k))*& + cldmax(i,k))*dz(i,k)*rho(i,k)+qrtot.lt.0._r8) then + + if (-pre(k)+pracs(k)+mnuccr(k).ge.qsmall) then + + ratio = (qrtot/(dz(i,k)*rho(i,k))+(prc(k)+pra(k))*lcldm(i,k))/& + ((-pre(k)+pracs(k)+mnuccr(k))*cldmax(i,k))*omsm + + pre(k) = pre(k)*ratio + pracs(k) = pracs(k)*ratio + mnuccr(k) = mnuccr(k)*ratio + end if + end if + + ! conservation of nr + ! for now neglect evaporation of nr + nsubr(k)=0._r8 + + if ((nprc(k)*lcldm(i,k)+(-nnuccr(k)+nsubr(k)-npracs(k)& + +nragg(k))*cldmax(i,k))*dz(i,k)*rho(i,k)+nrtot.lt.0._r8) then + + if (-nsubr(k)-nragg(k)+npracs(k)+nnuccr(k).ge.qsmall) then + + ratio = (nrtot/(dz(i,k)*rho(i,k))+nprc(k)*lcldm(i,k))/& + ((-nsubr(k)-nragg(k)+npracs(k)+nnuccr(k))*cldmax(i,k))*omsm + + nsubr(k) = nsubr(k)*ratio + npracs(k) = npracs(k)*ratio + nnuccr(k) = nnuccr(k)*ratio + nragg(k) = nragg(k)*ratio + end if + end if + + ! conservation of snow mix ratio + + if (((bergs(k)+psacws(k))*lcldm(i,k)+(prai(k)+prci(k))*icldm(i,k)+(pracs(k)+& + mnuccr(k)+prds(k))*cldmax(i,k))*dz(i,k)*rho(i,k)+qstot.lt.0._r8) then + + if (-prds(k).ge.qsmall) then + + ratio = (qstot/(dz(i,k)*rho(i,k))+(bergs(k)+psacws(k))*lcldm(i,k)+(prai(k)+prci(k))*icldm(i,k)+& + (pracs(k)+mnuccr(k))*cldmax(i,k))/(-prds(k)*cldmax(i,k))*omsm + + prds(k) = prds(k)*ratio + end if + end if + + ! conservation of ns + + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + nsubs(k)=0._r8 + + if ((nprci(k)*icldm(i,k)+(nnuccr(k)+nsubs(k)+nsagg(k))*cldmax(i,k))*& + dz(i,k)*rho(i,k)+nstot.lt.0._r8) then + + if (-nsubs(k)-nsagg(k).ge.qsmall) then + + ratio = (nstot/(dz(i,k)*rho(i,k))+nprci(k)*icldm(i,k)+& + nnuccr(k)*cldmax(i,k))/((-nsubs(k)-nsagg(k))*cldmax(i,k))*omsm + + nsubs(k) = nsubs(k)*ratio + nsagg(k) = nsagg(k)*ratio + end if + end if + + ! get tendencies due to microphysical conversion processes + ! note: tendencies are multiplied by appropaiate cloud/precip + ! fraction to get grid-scale values + ! note: cmei is already grid-average values + + qvlat(i,k) = qvlat(i,k)-(pre(k)+prds(k))*cldmax(i,k)-cmei(i,k) + + tlat(i,k) = tlat(i,k)+((pre(k)*cldmax(i,k)) & + *xxlv+(prds(k)*cldmax(i,k)+cmei(i,k))*xxls+ & + ((bergs(k)+psacws(k)+mnuccc(k)+mnucct(k)+msacwi(k))*lcldm(i,k)+(mnuccr(k)+ & + pracs(k))*cldmax(i,k)+berg(i,k))*xlf) + + qctend(i,k) = qctend(i,k)+ & + (-pra(k)-prc(k)-mnuccc(k)-mnucct(k)-msacwi(k)- & + psacws(k)-bergs(k))*lcldm(i,k)-berg(i,k) + + if (do_cldice) then + + frztmp = mnuccc(k) + mnucct(k) + msacwi(k) + if (use_hetfrz_classnuc) frztmp = mnuccc(k) + mnucct(k) + mnudep(k) + msacwi(k) + qitend(i,k) = qitend(i,k) + frztmp*lcldm(i,k) + & + (-prci(k)-prai(k))*icldm(i,k) + cmei(i,k) + berg(i,k) + + end if + + qrtend(i,k) = qrtend(i,k)+ & + (pra(k)+prc(k))*lcldm(i,k)+(pre(k)-pracs(k)- & + mnuccr(k))*cldmax(i,k) + + qnitend(i,k) = qnitend(i,k)+ & + (prai(k)+prci(k))*icldm(i,k)+(psacws(k)+bergs(k))*lcldm(i,k)+(prds(k)+ & + pracs(k)+mnuccr(k))*cldmax(i,k) + + ! add output for cmei (accumulate) + cmeiout(i,k) = cmeiout(i,k) + cmei(i,k) + + ! assign variables for trop_mozart, these are grid-average + ! evaporation/sublimation is stored here as positive term + + evapsnow(i,k) = evapsnow(i,k)-prds(k)*cldmax(i,k) + nevapr(i,k) = nevapr(i,k)-pre(k)*cldmax(i,k) + nevapr2(i,k) = nevapr2(i,k)-pre(k)*cldmax(i,k) + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + prain(i,k) = prain(i,k)+(pra(k)+prc(k))*lcldm(i,k)+(-pracs(k)- & + mnuccr(k))*cldmax(i,k) + prodsnow(i,k) = prodsnow(i,k)+(prai(k)+prci(k))*icldm(i,k)+(psacws(k)+bergs(k))*lcldm(i,k)+(& + pracs(k)+mnuccr(k))*cldmax(i,k) + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = sum over iterations{ rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) + ! qcsum_rate1ord = sum over iterations{ qc used in calculation of the transfer terms } + + qcsinksum_rate1ord(k) = qcsinksum_rate1ord(k) + (pra(k)+prc(k)+psacws(k))*lcldm(i,k) + qcsum_rate1ord(k) = qcsum_rate1ord(k) + qc(i,k) + + ! microphysics output, note this is grid-averaged + prao(i,k)=prao(i,k)+pra(k)*lcldm(i,k) + prco(i,k)=prco(i,k)+prc(k)*lcldm(i,k) + mnuccco(i,k)=mnuccco(i,k)+mnuccc(k)*lcldm(i,k) + mnuccto(i,k)=mnuccto(i,k)+mnucct(k)*lcldm(i,k) + mnuccdo(i,k)=mnuccdo(i,k)+mnuccd(k)*lcldm(i,k) + msacwio(i,k)=msacwio(i,k)+msacwi(k)*lcldm(i,k) + psacwso(i,k)=psacwso(i,k)+psacws(k)*lcldm(i,k) + bergso(i,k)=bergso(i,k)+bergs(k)*lcldm(i,k) + bergo(i,k)=bergo(i,k)+berg(i,k) + prcio(i,k)=prcio(i,k)+prci(k)*icldm(i,k) + praio(i,k)=praio(i,k)+prai(k)*icldm(i,k) + mnuccro(i,k)=mnuccro(i,k)+mnuccr(k)*cldmax(i,k) + pracso (i,k)=pracso (i,k)+pracs (k)*cldmax(i,k) +!AL + mnudepo(i,k)=mnudepo(i,k)+mnudep(k)*lcldm(i,k) + + ! microphysics output for number concentration tendencies + ! for liq. + nnuccco(i,k)=nnuccco(i,k)+nnuccc(k)*lcldm(i,k) + nnuccto(i,k)=nnuccto(i,k)+nnucct(k)*lcldm(i,k) + npsacwso(i,k)=npsacwso(i,k)+npsacws(k)*lcldm(i,k) + nsubco(i,k)=nsubco(i,k)+nsubc(k)*lcldm(i,k) + nprao(i,k)=nprao(i,k)+npra(k)*lcldm(i,k) + nprc1o(i,k)=nprc1o(i,k)+nprc1(k)*lcldm(i,k) + npccno(i,k)=npccno(i,k)+npccn(k)*mtime + + ! for ice + nsacwio(i,k)=nsacwio(i,k)+nsacwi(k)*lcldm(i,k) + nsubio(i,k)=nsubio(i,k)+nsubi(k)*icldm(i,k) + nprcio(i,k)=nprcio(i,k)+nprci(k)*icldm(i,k) + npraio(i,k)=npraio(i,k)+nprai(k)*icldm(i,k) + nnudepo(i,k)=nnudepo(i,k)+nnudep(k)*lcldm(i,k) + nnuccdo(i,k)=nnuccdo(i,k)+nnuccd(k)*mtime +!AL + + ! multiply activation/nucleation by mtime to account for fast timescale + + nctend(i,k) = nctend(i,k)+ npccn(k)*mtime+& + (-nnuccc(k)-nnucct(k)-npsacws(k)+nsubc(k) & + -npra(k)-nprc1(k))*lcldm(i,k) + + if (do_cldice) then + + frztmp = nnucct(k) + nsacwi(k) + if (use_hetfrz_classnuc) frztmp = nnucct(k) + nnuccc(k) + nnudep(k) + nsacwi(k) + nitend(i,k) = nitend(i,k) + nnuccd(k)*mtime + & + frztmp*lcldm(i,k) + (nsubi(k)-nprci(k)-nprai(k))*icldm(i,k) + + end if + + nstend(i,k) = nstend(i,k)+(nsubs(k)+ & + nsagg(k)+nnuccr(k))*cldmax(i,k)+nprci(k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k)+ & + nprc(k)*lcldm(i,k)+(nsubr(k)-npracs(k)-nnuccr(k) & + +nragg(k))*cldmax(i,k) + + ! make sure that nc and ni at advanced time step do not exceed + ! maximum (existing N + source terms*dt), which is possible due to + ! fast nucleation timescale + + if (nctend(i,k).gt.0._r8.and.nc(i,k)+nctend(i,k)*deltat.gt.ncmax) then + nctncons(i,k) = nctncons(i,k) + nctend(i,k)-max(0._r8,(ncmax-nc(i,k))/deltat) !AL + nctend(i,k)=max(0._r8,(ncmax-nc(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) then + nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax-ni(i,k))/deltat) !AL + nitend(i,k)=max(0._r8,(nimax-ni(i,k))/deltat) + end if + + ! get final values for precipitation q and N, based on + ! flux of precip from above, source/sink term, and terminal fallspeed + ! see eq. 15-16 in MG2008 + + ! rain + + if (qric(i,k).ge.qsmall) then + if (k.eq.top_lev) then + qric(i,k)=qrtend(i,k)*dz(i,k)/cldmax(i,k)/umr(k) + nric(i,k)=nrtend(i,k)*dz(i,k)/cldmax(i,k)/unr(k) + else + qric(i,k) = (rho(i,k-1)*umr(k-1)*qric(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*qrtend(i,k)))/(umr(k)*rho(i,k)*cldmax(i,k)) + nric(i,k) = (rho(i,k-1)*unr(k-1)*nric(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*nrtend(i,k)))/(unr(k)*rho(i,k)*cldmax(i,k)) + + end if + else + qric(i,k)=0._r8 + nric(i,k)=0._r8 + end if + + ! snow + + if (qniic(i,k).ge.qsmall) then + if (k.eq.top_lev) then + qniic(i,k)=qnitend(i,k)*dz(i,k)/cldmax(i,k)/ums(k) + nsic(i,k)=nstend(i,k)*dz(i,k)/cldmax(i,k)/uns(k) + else + qniic(i,k) = (rho(i,k-1)*ums(k-1)*qniic(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*qnitend(i,k)))/(ums(k)*rho(i,k)*cldmax(i,k)) + nsic(i,k) = (rho(i,k-1)*uns(k-1)*nsic(i,k-1)*cldmax(i,k-1)+ & + (rho(i,k)*dz(i,k)*nstend(i,k)))/(uns(k)*rho(i,k)*cldmax(i,k)) + end if + else + qniic(i,k)=0._r8 + nsic(i,k)=0._r8 + end if + + ! calculate precipitation flux at surface + ! divide by density of water to get units of m/s + + prect(i) = prect(i)+(qrtend(i,k)*dz(i,k)*rho(i,k)+& + qnitend(i,k)*dz(i,k)*rho(i,k))/rhow + preci(i) = preci(i)+qnitend(i,k)*dz(i,k)*rho(i,k)/rhow + + ! convert rain rate from m/s to mm/hr + + rainrt(i,k)=qric(i,k)*rho(i,k)*umr(k)/rhow*3600._r8*1000._r8 + + ! vertically-integrated precip source/sink terms (note: grid-averaged) + + qrtot = max(qrtot+qrtend(i,k)*dz(i,k)*rho(i,k),0._r8) + qstot = max(qstot+qnitend(i,k)*dz(i,k)*rho(i,k),0._r8) + nrtot = max(nrtot+nrtend(i,k)*dz(i,k)*rho(i,k),0._r8) + nstot = max(nstot+nstend(i,k)*dz(i,k)*rho(i,k),0._r8) + + ! calculate melting and freezing of precip + + ! melt snow at +2 C + + if (t(i,k)+tlat(i,k)/cpp*deltat > 275.15_r8) then + if (qstot > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*qstot/(dz(i,k)*rho(i,k)) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.275.15_r8) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-275.15_r8)*cpp/xlf + dum = dum/(xlf/cpp*qstot/(dz(i,k)*rho(i,k))) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qric(i,k)=qric(i,k)+dum*qniic(i,k) + nric(i,k)=nric(i,k)+dum*nsic(i,k) + qniic(i,k)=(1._r8-dum)*qniic(i,k) + nsic(i,k)=(1._r8-dum)*nsic(i,k) + ! heating tendency + tmp=-xlf*dum*qstot/(dz(i,k)*rho(i,k)) + meltsdt(i,k)=meltsdt(i,k) + tmp + + tlat(i,k)=tlat(i,k)+tmp + qrtot=qrtot+dum*qstot + nrtot=nrtot+dum*nstot + qstot=(1._r8-dum)*qstot + nstot=(1._r8-dum)*nstot + preci(i)=(1._r8-dum)*preci(i) + end if + end if + + ! freeze all rain at -5C for Arctic + + if (t(i,k)+tlat(i,k)/cpp*deltat < (tmelt - 5._r8)) then + + if (qrtot > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*qrtot/(dz(i,k)*rho(i,k)) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.(tmelt - 5._r8)) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-(tmelt-5._r8))*cpp/xlf + dum = dum/(xlf/cpp*qrtot/(dz(i,k)*rho(i,k))) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qniic(i,k)=qniic(i,k)+dum*qric(i,k) + nsic(i,k)=nsic(i,k)+dum*nric(i,k) + qric(i,k)=(1._r8-dum)*qric(i,k) + nric(i,k)=(1._r8-dum)*nric(i,k) + ! heating tendency + tmp = xlf*dum*qrtot/(dz(i,k)*rho(i,k)) + frzrdt(i,k)=frzrdt(i,k) + tmp + + tlat(i,k)=tlat(i,k)+tmp + qstot=qstot+dum*qrtot + qrtot=(1._r8-dum)*qrtot + nstot=nstot+dum*nrtot + nrtot=(1._r8-dum)*nrtot + preci(i)=preci(i)+dum*(prect(i)-preci(i)) + end if + end if + + ! Precip Flux Calculation (Diagnostic) + rflx(i,k+1)=(prect(i)-preci(i)) * rhow + sflx(i,k+1)=preci(i) * rhow + + ! if rain/snow mix ratio is zero so should number concentration + + if (qniic(i,k).lt.qsmall) then + qniic(i,k)=0._r8 + nsic(i,k)=0._r8 + end if + + if (qric(i,k).lt.qsmall) then + qric(i,k)=0._r8 + nric(i,k)=0._r8 + end if + + ! make sure number concentration is a positive number to avoid + ! taking root of negative + + nric(i,k)=max(nric(i,k),0._r8) + nsic(i,k)=max(nsic(i,k),0._r8) + + !....................................................................... + ! get size distribution parameters for fallspeed calculations + !...................................................................... + ! rain + + if (qric(i,k).ge.qsmall) then + lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8) + n0r(k) = nric(i,k)*lamr(k) + + ! check for slope + ! change lammax and lammin for rain and snow + ! adjust vars + + if (lamr(k).lt.lamminr) then + + lamr(k) = lamminr + + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k).gt.lammaxr) then + lamr(k) = lammaxr + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + end if + + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + unr(k) = min(arn(i,k)*cons4/lamr(k)**br,9.1_r8*rhof(i,k)) + umr(k) = min(arn(i,k)*cons5/(6._r8*lamr(k)**br),9.1_r8*rhof(i,k)) + + else + lamr(k) = 0._r8 + n0r(k) = 0._r8 + umr(k)=0._r8 + unr(k)=0._r8 + end if + + !calculate mean size of combined rain and snow + + if (lamr(k).gt.0._r8) then + Artmp = n0r(k) * pi / (2._r8 * lamr(k)**3._r8) + else + Artmp = 0._r8 + endif + + if (lamc(k).gt.0._r8) then + Actmp = cdist1(k) * pi * gamma(pgam(k)+3._r8)/(4._r8 * lamc(k)**2._r8) + else + Actmp = 0._r8 + endif + + if (Actmp.gt.0_r8.or.Artmp.gt.0) then + rercld(i,k)=rercld(i,k) + 3._r8 *(qric(i,k) + qcic(i,k)) / (4._r8 * rhow * (Actmp + Artmp)) + arcld(i,k)=arcld(i,k)+1._r8 + endif + + !...................................................................... + ! snow + + if (qniic(i,k).ge.qsmall) then + lams(k) = (cons6*cs*nsic(i,k)/ & + qniic(i,k))**(1._r8/ds) + n0s(k) = nsic(i,k)*lams(k) + + ! check for slope + ! adjust vars + + if (lams(k).lt.lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + + else if (lams(k).gt.lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + end if + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + + ums(k) = min(asn(i,k)*cons8/(6._r8*lams(k)**bs),1.2_r8*rhof(i,k)) + uns(k) = min(asn(i,k)*cons7/lams(k)**bs,1.2_r8*rhof(i,k)) + + else + lams(k) = 0._r8 + n0s(k) = 0._r8 + ums(k) = 0._r8 + uns(k) = 0._r8 + end if + + !c........................................................................ + ! sum over sub-step for average process rates + + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + qrout(i,k)=qrout(i,k)+qric(i,k)*cldmax(i,k) + qsout(i,k)=qsout(i,k)+qniic(i,k)*cldmax(i,k) + nrout(i,k)=nrout(i,k)+nric(i,k)*rho(i,k)*cldmax(i,k) + nsout(i,k)=nsout(i,k)+nsic(i,k)*rho(i,k)*cldmax(i,k) + + tlat1(i,k)=tlat1(i,k)+tlat(i,k) + qvlat1(i,k)=qvlat1(i,k)+qvlat(i,k) + qctend1(i,k)=qctend1(i,k)+qctend(i,k) + qitend1(i,k)=qitend1(i,k)+qitend(i,k) + nctend1(i,k)=nctend1(i,k)+nctend(i,k) + nitend1(i,k)=nitend1(i,k)+nitend(i,k) + + t(i,k)=t(i,k)+tlat(i,k)*deltat/cpp + q(i,k)=q(i,k)+qvlat(i,k)*deltat + qc(i,k)=qc(i,k)+qctend(i,k)*deltat + qi(i,k)=qi(i,k)+qitend(i,k)*deltat + nc(i,k)=nc(i,k)+nctend(i,k)*deltat + ni(i,k)=ni(i,k)+nitend(i,k)*deltat + + rainrt1(i,k)=rainrt1(i,k)+rainrt(i,k) + + !divide rain radius over substeps for average + if (arcld(i,k) .gt. 0._r8) then + rercld(i,k)=rercld(i,k)/arcld(i,k) + end if + + !! add to summing sub-stepping variable + rflx1(i,k+1)=rflx1(i,k+1)+rflx(i,k+1) + sflx1(i,k+1)=sflx1(i,k+1)+sflx(i,k+1) + + !c........................................................................ + + end do ! k loop + + prect1(i)=prect1(i)+prect(i) + preci1(i)=preci1(i)+preci(i) + + end do ! it loop, sub-step + + do k = top_lev, pver + rate1ord_cw2pr_st(i,k) = qcsinksum_rate1ord(k)/max(qcsum_rate1ord(k),1.0e-30_r8) + end do + +300 continue ! continue if no cloud water +end do ! i loop + +! convert dt from sub-step back to full time step +deltat=deltat*real(iter) + +!c............................................................................. + +do i=1,ncol + + ! skip all calculations if no cloud water + if (ltrue(i).eq.0) then + + do k=1,top_lev-1 + ! assign zero values for effective radius above 1 mbar + effc(i,k)=0._r8 + effi(i,k)=0._r8 + effc_fn(i,k)=0._r8 + lamcrad(i,k)=0._r8 + pgamrad(i,k)=0._r8 + deffi(i,k)=0._r8 + end do + + do k=top_lev,pver + ! assign default values for effective radius + effc(i,k)=10._r8 + effi(i,k)=25._r8 + effc_fn(i,k)=10._r8 + lamcrad(i,k)=0._r8 + pgamrad(i,k)=0._r8 + deffi(i,k)=0._r8 + end do + goto 500 + end if + + ! initialize nstep for sedimentation sub-steps + nstep = 1 + + ! divide precip rate by number of sub-steps to get average over time step + + prect(i)=prect1(i)/real(iter) + preci(i)=preci1(i)/real(iter) + + do k=top_lev,pver + + ! assign variables back to start-of-timestep values before updating after sub-steps + + t(i,k)=t1(i,k) + q(i,k)=q1(i,k) + qc(i,k)=qc1(i,k) + qi(i,k)=qi1(i,k) + nc(i,k)=nc1(i,k) + ni(i,k)=ni1(i,k) + + ! divide microphysical tendencies by number of sub-steps to get average over time step + + tlat(i,k)=tlat1(i,k)/real(iter) + qvlat(i,k)=qvlat1(i,k)/real(iter) + qctend(i,k)=qctend1(i,k)/real(iter) + qitend(i,k)=qitend1(i,k)/real(iter) + nctend(i,k)=nctend1(i,k)/real(iter) + nitend(i,k)=nitend1(i,k)/real(iter) + + rainrt(i,k)=rainrt1(i,k)/real(iter) + + ! divide by number of sub-steps to find final values + rflx(i,k+1)=rflx1(i,k+1)/real(iter) + sflx(i,k+1)=sflx1(i,k+1)/real(iter) + + ! divide output precip q and N by number of sub-steps to get average over time step + + qrout(i,k)=qrout(i,k)/real(iter) + qsout(i,k)=qsout(i,k)/real(iter) + nrout(i,k)=nrout(i,k)/real(iter) + nsout(i,k)=nsout(i,k)/real(iter) + + ! divide trop_mozart variables by number of sub-steps to get average over time step + + nevapr(i,k) = nevapr(i,k)/real(iter) + nevapr2(i,k) = nevapr2(i,k)/real(iter) + evapsnow(i,k) = evapsnow(i,k)/real(iter) + prain(i,k) = prain(i,k)/real(iter) + prodsnow(i,k) = prodsnow(i,k)/real(iter) + cmeout(i,k) = cmeout(i,k)/real(iter) + + cmeiout(i,k) = cmeiout(i,k)/real(iter) + meltsdt(i,k) = meltsdt(i,k)/real(iter) + frzrdt (i,k) = frzrdt (i,k)/real(iter) + + + ! microphysics output + prao(i,k)=prao(i,k)/real(iter) + prco(i,k)=prco(i,k)/real(iter) + mnuccco(i,k)=mnuccco(i,k)/real(iter) + mnuccto(i,k)=mnuccto(i,k)/real(iter) + msacwio(i,k)=msacwio(i,k)/real(iter) + psacwso(i,k)=psacwso(i,k)/real(iter) + bergso(i,k)=bergso(i,k)/real(iter) + bergo(i,k)=bergo(i,k)/real(iter) + prcio(i,k)=prcio(i,k)/real(iter) + praio(i,k)=praio(i,k)/real(iter) + + mnuccro(i,k)=mnuccro(i,k)/real(iter) + pracso (i,k)=pracso (i,k)/real(iter) + + mnuccdo(i,k)=mnuccdo(i,k)/real(iter) + +!AL + mnudepo(i,k)=mnudepo(i,k)/real(iter) + nnuccco(i,k)=nnuccco(i,k)/real(iter) + nnuccto(i,k)=nnuccto(i,k)/real(iter) + npsacwso(i,k)=npsacwso(i,k)/real(iter) + nsubco(i,k)=nsubco(i,k)/real(iter) + nprao(i,k)=nprao(i,k)/real(iter) + nprc1o(i,k)=nprc1o(i,k)/real(iter) + nsacwio(i,k)=nsacwio(i,k)/real(iter) + nsubio(i,k)=nsubio(i,k)/real(iter) + nprcio(i,k)=nprcio(i,k)/real(iter) + npraio(i,k)=npraio(i,k)/real(iter) + nnudepo(i,k)=nnudepo(i,k)/real(iter) + nnuccdo(i,k)=nnuccdo(i,k)/real(iter) + npccno(i,k)=npccno(i,k)/real(iter) + nctncons(i,k)=nctncons(i,k)/real(iter) + nitncons(i,k)=nitncons(i,k)/real(iter) +!AL + + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) + prer_evap(i,k) = nevapr2(i,k) + prain(i,k) = prain(i,k) + prodsnow(i,k) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! calculate sedimentation for cloud water and ice + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8) + + if (nccons) then + dumnc(i,k) = ncnst/rho(i,k) + end if + if (nicons) then + dumni(i,k) = ninst/rho(i,k) + end if + + ! obtain new slope parameter to avoid possible singularity + + if (dumi(i,k).ge.qsmall) then + ! add upper limit to in-cloud number concentration to prevent numerical error + dumni(i,k)=min(dumni(i,k),dumi(i,k)*1.e20_r8) + + lami(k) = (cons1*ci* & + dumni(i,k)/dumi(i,k))**(1._r8/di) + lami(k)=max(lami(k),lammini) + lami(k)=min(lami(k),lammaxi) + else + lami(k)=0._r8 + end if + + if (dumc(i,k).ge.qsmall) then + ! add upper limit to in-cloud number concentration to prevent numerical error + dumnc(i,k)=min(dumnc(i,k),dumc(i,k)*1.e20_r8) + ! add lower limit to in-cloud number concentration + dumnc(i,k)=max(dumnc(i,k),cdnl/rho(i,k)) ! sghan minimum in #/cm3 + pgam(k)=0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k)=1._r8/(pgam(k)**2)-1._r8 + pgam(k)=max(pgam(k),2._r8) + pgam(k)=min(pgam(k),15._r8) + + lamc(k) = (pi/6._r8*rhow*dumnc(i,k)*gamma(pgam(k)+4._r8)/ & + (dumc(i,k)*gamma(pgam(k)+1._r8)))**(1._r8/3._r8) + lammin = (pgam(k)+1._r8)/50.e-6_r8 + lammax = (pgam(k)+1._r8)/2.e-6_r8 + lamc(k)=max(lamc(k),lammin) + lamc(k)=min(lamc(k),lammax) + else + lamc(k)=0._r8 + end if + + ! calculate number and mass weighted fall velocity for droplets + ! include effects of sub-grid distribution of cloud water + + + if (dumc(i,k).ge.qsmall) then + unc = acn(i,k)*gamma(1._r8+bc+pgam(k))/(lamc(k)**bc*gamma(pgam(k)+1._r8)) + umc = acn(i,k)*gamma(4._r8+bc+pgam(k))/(lamc(k)**bc*gamma(pgam(k)+4._r8)) + ! fallspeed for output + vtrmc(i,k)=umc + else + umc = 0._r8 + unc = 0._r8 + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k).ge.qsmall) then + uni = ain(i,k)*cons16/lami(k)**bi + umi = ain(i,k)*cons17/(6._r8*lami(k)**bi) + uni=min(uni,1.2_r8*rhof(i,k)) + umi=min(umi,1.2_r8*rhof(i,k)) + + ! fallspeed + vtrmi(i,k)=umi + else + umi = 0._r8 + uni = 0._r8 + end if + + fi(k) = g*rho(i,k)*umi + fni(k) = g*rho(i,k)*uni + fc(k) = g*rho(i,k)*umc + fnc(k) = g*rho(i,k)*unc + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + + rgvm = max(fi(k),fc(k),fni(k),fnc(k)) + nstep = max(int(rgvm*deltat/pdel(i,k)+1._r8),nstep) + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8) + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + + end do !!! vertical loop + do n = 1,nstep !! loop over sub-time step to ensure stability + + do k = top_lev,pver + if (do_cldice) then + falouti(k) = fi(k)*dumi(i,k) + faloutni(k) = fni(k)*dumni(i,k) + else + falouti(k) = 0._r8 + faloutni(k) = 0._r8 + end if + + faloutc(k) = fc(k)*dumc(i,k) + faloutnc(k) = fnc(k)*dumnc(i,k) + end do + + ! top of model + + k = top_lev + faltndi = falouti(k)/pdel(i,k) + faltndni = faloutni(k)/pdel(i,k) + faltndc = faloutc(k)/pdel(i,k) + faltndnc = faloutnc(k)/pdel(i,k) + + ! add fallout terms to microphysical tendencies + + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendencies for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + qisedten(i,k)=qisedten(i,k)-faltndi/nstep +!AL + nqcsedten(i,k)=nqcsedten(i,k)-faltndnc/nstep + nqisedten(i,k)=nqisedten(i,k)-faltndni/nstep +!AL + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + do k = top_lev+1,pver + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + dum=lcldm(i,k)/lcldm(i,k-1) + dum=min(dum,1._r8) + dum1=icldm(i,k)/icldm(i,k-1) + dum1=min(dum1,1._r8) + + faltndqie=(falouti(k)-falouti(k-1))/pdel(i,k) + faltndi=(falouti(k)-dum1*falouti(k-1))/pdel(i,k) + faltndni=(faloutni(k)-dum1*faloutni(k-1))/pdel(i,k) + faltndqce=(faloutc(k)-faloutc(k-1))/pdel(i,k) + faltndc=(faloutc(k)-dum*faloutc(k-1))/pdel(i,k) + faltndnc=(faloutnc(k)-dum*faloutnc(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendencies for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep + qisedten(i,k)=qisedten(i,k)-faltndi/nstep +!AL + nqcsedten(i,k)=nqcsedten(i,k)-faltndnc/nstep + nqisedten(i,k)=nqisedten(i,k)-faltndni/nstep +!AL + ! add terms to to evap/sub of cloud water + + qvlat(i,k)=qvlat(i,k)-(faltndqie-faltndi)/nstep + ! for output + qisevap(i,k)=qisevap(i,k)-(faltndqie-faltndi)/nstep + qvlat(i,k)=qvlat(i,k)-(faltndqce-faltndc)/nstep + ! for output + qcsevap(i,k)=qcsevap(i,k)-(faltndqce-faltndc)/nstep + + tlat(i,k)=tlat(i,k)+(faltndqie-faltndi)*xxls/nstep + tlat(i,k)=tlat(i,k)+(faltndqce-faltndc)*xxlv/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + Fni(K)=MAX(Fni(K)/pdel(i,K),Fni(K-1)/pdel(i,K-1))*pdel(i,K) + FI(K)=MAX(FI(K)/pdel(i,K),FI(K-1)/pdel(i,K-1))*pdel(i,K) + fnc(k)=max(fnc(k)/pdel(i,k),fnc(k-1)/pdel(i,k-1))*pdel(i,k) + Fc(K)=MAX(Fc(K)/pdel(i,K),Fc(K-1)/pdel(i,K-1))*pdel(i,K) + + end do !! k loop + + ! units below are m/s + ! cloud water/ice sedimentation flux at surface + ! is added to precip flux at surface to get total precip (cloud + precip water) + ! rate + + prect(i) = prect(i)+(faloutc(pver)+falouti(pver))/g/nstep/1000._r8 + preci(i) = preci(i)+(falouti(pver))/g/nstep/1000._r8 + + ! Add fallout to Precip Flux: note unit change m/s *kg/m3 = kg/m2 + do k = top_lev,pver + rflx(i,k+1)=rflx(i,k+1)+(faloutc(k))/g/nstep/1000._r8 * rhow + sflx(i,k+1)=sflx(i,k+1)+(falouti(k))/g/nstep/1000._r8 * rhow + end do + + end do !! nstep loop + + ! end sedimentation + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=top_lev,pver + + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8) + + if (nccons) then + dumnc(i,k) = ncnst/rho(i,k)*lcldm(i,k) + end if + if (nicons) then + dumni(i,k) = ninst/rho(i,k)*icldm(i,k) + end if + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + + ! calculate instantaneous processes (melting, homogeneous freezing) + if (do_cldice) then + + if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then + if (dumi(i,k) > 0._r8) then + + ! limit so that melting does not push temperature below freezing + dum = -dumi(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf + dum = dum/dumi(i,k)*xlf/cpp + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qctend(i,k)=qctend(i,k)+dum*dumi(i,k)/deltat + + ! for output + melto(i,k)=dum*dumi(i,k)/deltat + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + nctend(i,k)=nctend(i,k)+3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) +!AL + ! for output + nmelto(i,k)=3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + nimelto(i,k)=nitend(i,k)-((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat +!AL + qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))/deltat + nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat + tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)/deltat + + end if + end if + + ! homogeneously freeze droplets at -40 C + + if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then + if (dumc(i,k) > 0._r8) then + + ! limit so that freezing does not push temperature above threshold + dum = dumc(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf + dum = dum/dumc(i,k)*xlf/cpp + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qitend(i,k)=qitend(i,k)+dum*dumc(i,k)/deltat + ! for output + homoo(i,k)=dum*dumc(i,k)/deltat + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + nitend(i,k)=nitend(i,k)+dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat + qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))/deltat +!AL + nhomoo(i,k)=nctend(i,k)-((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + nihomoo(i,k)=dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat +!AL + nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)/deltat + end if + end if + + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + ! follow code similar to old CAM scheme + + qtmp=q(i,k)+qvlat(i,k)*deltat + ttmp=t(i,k)+tlat(i,k)/cpp*deltat + + esn = svp_water(ttmp) ! use rhw to allow ice supersaturation + qsn = svp_to_qsat(esn, p(i,k)) + + if (qtmp > qsn .and. qsn > 0) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qsn)/(1._r8+cons27*qsn/(cpp*rv*ttmp**2))/deltat + ! add to output cme + cmeout(i,k) = cmeout(i,k)+dum + ! now add to tendencies, partition between liquid and ice based on temperature + if (ttmp > 268.15_r8) then + dum1=0.0_r8 + ! now add to tendencies, partition between liquid and ice based on te + else if (ttmp < 238.15_r8) then + dum1=1.0_r8 + else + dum1=(268.15_r8-ttmp)/30._r8 + end if + + dum = (qtmp-qsn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & + *qsn/(cpp*rv*ttmp**2))/deltat + qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1) + ! for output + qcreso(i,k)=dum*(1._r8-dum1) + qitend(i,k)=qitend(i,k)+dum*dum1 + qireso(i,k)=dum*dum1 + qvlat(i,k)=qvlat(i,k)-dum + ! for output + qvres(i,k)=-dum + tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls + end if + end if + + !............................................................................... + ! calculate effective radius for pass to radiation code + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k) + + if (nccons) then + dumnc(i,k) = ncnst/rho(i,k) + end if + if (nicons) then + dumni(i,k) = ninst/rho(i,k) + end if + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 + + dumc(i,k)=min(dumc(i,k),5.e-3_r8) + dumi(i,k)=min(dumi(i,k),5.e-3_r8) + + !................... + ! cloud ice effective radius + + if (dumi(i,k).ge.qsmall) then + + if (nicons) then + ! make sure ni is consistent with the constant N by adjusting + ! tendency, need to multiply by cloud fraction + ! note that nitend may be further adjusted below if mean crystal + ! size is out of bounds + nitend(i,k) = (ninst/rho(i,k)*icldm(i,k) - ni(i,k))/deltat + end if + + ! add upper limit to in-cloud number concentration to prevent numerical error + dumni(i,k)=min(dumni(i,k),dumi(i,k)*1.e20_r8) + lami(k) = (cons1*ci*dumni(i,k)/dumi(i,k))**(1._r8/di) + + if (lami(k).lt.lammini) then + lami(k) = lammini + n0i(k) = lami(k)**(di+1._r8)*dumi(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + ! adjust number conc if needed to keep mean size in reasonable range + if (do_cldice) then + nitnszmn(i,k)=nitnszmn(i,k) + nitend(i,k)-(niic(i,k)*icldm(i,k)-ni(i,k))/deltat !AL + nitend(i,k)=(niic(i,k)*icldm(i,k)-ni(i,k))/deltat + endif + else if (lami(k).gt.lammaxi) then + lami(k) = lammaxi + n0i(k) = lami(k)**(di+1._r8)*dumi(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + ! adjust number conc if needed to keep mean size in reasonable range + if (do_cldice)then + nitnszmx(i,k)=nitnszmx(i,k) + nitend(i,k)-(niic(i,k)*icldm(i,k)-ni(i,k))/deltat !AL + nitend(i,k)=(niic(i,k)*icldm(i,k)-ni(i,k))/deltat + endif + end if + effi(i,k) = 1.5_r8/lami(k)*1.e6_r8 + + else + effi(i,k) = 25._r8 + end if + + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + if (.not. do_cldice) then + effi(i,k) = re_ice(i,k) * 1e6_r8 ! m -> um + end if + + !................... + ! cloud droplet effective radius + + if (dumc(i,k).ge.qsmall) then + + if (nccons) then + ! make sure nc is consistent with the constant N by adjusting + ! tendency, need to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet + ! size is out of bounds + nctend(i,k) = (ncnst/rho(i,k)*lcldm(i,k) - nc(i,k))/deltat + end if + + ! add upper limit to in-cloud number concentration to prevent numerical error + dumnc(i,k)=min(dumnc(i,k),dumc(i,k)*1.e20_r8) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! set tendency to ensure minimum droplet concentration + ! after update by microphysics, except when lambda exceeds bounds on mean drop + ! size or if there is no cloud water + if (dumnc(i,k).lt.cdnl/rho(i,k)) then +!AL + nctnnbmn(i,k)=nctnnbmn(i,k) + nctend(i,k)-(cdnl/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat +!AL + nctend(i,k)=(cdnl/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat + end if + dumnc(i,k)=max(dumnc(i,k),cdnl/rho(i,k)) ! sghan minimum in #/cm3 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + pgam(k)=0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k)=1._r8/(pgam(k)**2)-1._r8 + pgam(k)=max(pgam(k),2._r8) + pgam(k)=min(pgam(k),15._r8) + + lamc(k) = (pi/6._r8*rhow*dumnc(i,k)*gamma(pgam(k)+4._r8)/ & + (dumc(i,k)*gamma(pgam(k)+1._r8)))**(1._r8/3._r8) + lammin = (pgam(k)+1._r8)/50.e-6_r8 + ! Multiply by omsm to fit within RRTMG's table. + lammax = (pgam(k)+1._r8)*omsm/2.e-6_r8 + if (lamc(k).lt.lammin) then + lamc(k) = lammin + ncic(i,k) = 6._r8*lamc(k)**3*dumc(i,k)* & + gamma(pgam(k)+1._r8)/ & + (pi*rhow*gamma(pgam(k)+4._r8)) + ! adjust number conc if needed to keep mean size in reasonable range +!AL + nctnszmn(i,k)=nctnszmn(i,k) + nctend(i,k)-(ncic(i,k)*lcldm(i,k)-nc(i,k))/deltat +!AL + nctend(i,k)=(ncic(i,k)*lcldm(i,k)-nc(i,k))/deltat + + else if (lamc(k).gt.lammax) then + lamc(k) = lammax + ncic(i,k) = 6._r8*lamc(k)**3*dumc(i,k)* & + gamma(pgam(k)+1._r8)/ & + (pi*rhow*gamma(pgam(k)+4._r8)) + ! adjust number conc if needed to keep mean size in reasonable range +!AL + nctnszmx(i,k)=nctnszmx(i,k) + nctend(i,k)-(ncic(i,k)*lcldm(i,k)-nc(i,k))/deltat +!AL + nctend(i,k)=(ncic(i,k)*lcldm(i,k)-nc(i,k))/deltat + end if + + effc(i,k) = & + gamma(pgam(k)+4._r8)/ & + gamma(pgam(k)+3._r8)/lamc(k)/2._r8*1.e6_r8 + !assign output fields for shape here + lamcrad(i,k)=lamc(k) + pgamrad(i,k)=pgam(k) + + else + effc(i,k) = 10._r8 + lamcrad(i,k)=0._r8 + pgamrad(i,k)=0._r8 + end if + + ! ice effective diameter for david mitchell's optics + if (do_cldice) then + deffi(i,k)=effi(i,k)*rhoi/917._r8*2._r8 + else + deffi(i,k)=effi(i,k) * 2._r8 + end if + + +!!! recalculate effective radius for constant number, in order to separate + ! first and second indirect effects + ! assume constant number of 10^8 kg-1 + + dumnc(i,k)=1.e8_r8 + + if (dumc(i,k).ge.qsmall) then + pgam(k)=0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k)=1._r8/(pgam(k)**2)-1._r8 + pgam(k)=max(pgam(k),2._r8) + pgam(k)=min(pgam(k),15._r8) + + lamc(k) = (pi/6._r8*rhow*dumnc(i,k)*gamma(pgam(k)+4._r8)/ & + (dumc(i,k)*gamma(pgam(k)+1._r8)))**(1._r8/3._r8) + lammin = (pgam(k)+1._r8)/50.e-6_r8 + lammax = (pgam(k)+1._r8)/2.e-6_r8 + if (lamc(k).lt.lammin) then + lamc(k) = lammin + else if (lamc(k).gt.lammax) then + lamc(k) = lammax + end if + effc_fn(i,k) = & + gamma(pgam(k)+4._r8)/ & + gamma(pgam(k)+3._r8)/lamc(k)/2._r8*1.e6_r8 + + else + effc_fn(i,k) = 10._r8 + end if + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1! + + end do ! vertical k loop + +500 continue + + do k=top_lev,pver + ! if updated q (after microphysics) is zero, then ensure updated n is also zero + + if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) then !AL + nctnncld(i,k) = nctnncld(i,k) + nctend(i,k) +nc(i,k)/deltat + nctend(i,k)=-nc(i,k)/deltat + endif + if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall)then !AL + nitnncld(i,k) = nitnncld(i,k) + nitend(i,k) +ni(i,k)/deltat + nitend(i,k)=-ni(i,k)/deltat + endif + end do + +end do ! i loop + +! add snow ouptut +do i = 1,ncol + do k=top_lev,pver + if (qsout(i,k).gt.1.e-7_r8.and.nsout(i,k).gt.0._r8) then + dsout(i,k)=3._r8*rhosn/917._r8*(pi * rhosn * nsout(i,k)/qsout(i,k))**(-1._r8/3._r8) + endif + end do +end do + +!calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual +do i = 1,ncol + do k=top_lev,pver + !! RAIN + if (qrout(i,k).gt.1.e-7_r8.and.nrout(i,k).gt.0._r8) then + reff_rain(i,k)=1.5_r8*(pi * rhow * nrout(i,k)/qrout(i,k))**(-1._r8/3._r8)*1.e6_r8 + endif + !! SNOW + if (qsout(i,k).gt.1.e-7_r8.and.nsout(i,k).gt.0._r8) then + reff_snow(i,k)=1.5_r8*(pi * rhosn * nsout(i,k)/qsout(i,k))**(-1._r8/3._r8)*1.e6_r8 + end if + end do +end do + +! analytic radar reflectivity +! formulas from Matthew Shupe, NOAA/CERES +! *****note: radar reflectivity is local (in-precip average) +! units of mm^6/m^3 + +do i = 1,ncol + do k=top_lev,pver + if (qc(i,k)+qctend(i,k)*deltat.ge.qsmall .and. nc(i,k)+nctend(i,k)*deltat.gt.10._r8) then + dum=((qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & + /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/cldmax(i,k) + else + dum=0._r8 + end if + if (qi(i,k)+qitend(i,k)*deltat.ge.qsmall) then + dum1=((qi(i,k)+qitend(i,k)*deltat)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/cldmax(i,k) + else + dum1=0._r8 + end if + + if (qsout(i,k).ge.qsmall) then + dum1=dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8) + end if + + refl(i,k)=dum+dum1 + + ! add rain rate, but for 37 GHz formulation instead of 94 GHz + ! formula approximated from data of Matrasov (2007) + ! rainrt is the rain rate in mm/hr + ! reflectivity (dum) is in DBz + + if (rainrt(i,k).ge.0.001_r8) then + dum=log10(rainrt(i,k)**6._r8)+16._r8 + + ! convert from DBz to mm^6/m^3 + + dum = 10._r8**(dum/10._r8) + else + ! don't include rain rate in R calculation for values less than 0.001 mm/hr + dum=0._r8 + end if + + ! add to refl + + refl(i,k)=refl(i,k)+dum + + !output reflectivity in Z. + areflz(i,k)=refl(i,k) + + ! convert back to DBz + + if (refl(i,k).gt.minrefl) then + refl(i,k)=10._r8*log10(refl(i,k)) + else + refl(i,k)=-9999._r8 + end if + + !set averaging flag + if (refl(i,k).gt.mindbz) then + arefl(i,k)=refl(i,k) + frefl(i,k)=1.0_r8 + else + arefl(i,k)=0._r8 + areflz(i,k)=0._r8 + frefl(i,k)=0._r8 + end if + + ! bound cloudsat reflectivity + + csrfl(i,k)=min(csmax,refl(i,k)) + + !set averaging flag + if (csrfl(i,k).gt.csmin) then + acsrfl(i,k)=refl(i,k) + fcsrfl(i,k)=1.0_r8 + else + acsrfl(i,k)=0._r8 + fcsrfl(i,k)=0._r8 + end if + + end do +end do + + +! averaging for snow and rain number and diameter + +qrout2(:,:)=0._r8 +qsout2(:,:)=0._r8 +nrout2(:,:)=0._r8 +nsout2(:,:)=0._r8 +drout2(:,:)=0._r8 +dsout2(:,:)=0._r8 +freqs(:,:)=0._r8 +freqr(:,:)=0._r8 +do i = 1,ncol + do k=top_lev,pver + if (qrout(i,k).gt.1.e-7_r8.and.nrout(i,k).gt.0._r8) then + qrout2(i,k)=qrout(i,k) + nrout2(i,k)=nrout(i,k) + drout2(i,k)=(pi * rhow * nrout(i,k)/qrout(i,k))**(-1._r8/3._r8) + freqr(i,k)=1._r8 + endif + if (qsout(i,k).gt.1.e-7_r8.and.nsout(i,k).gt.0._r8) then + qsout2(i,k)=qsout(i,k) + nsout2(i,k)=nsout(i,k) + dsout2(i,k)=(pi * rhosn * nsout(i,k)/qsout(i,k))**(-1._r8/3._r8) + freqs(i,k)=1._r8 + endif + end do +end do + +! output activated liquid and ice (convert from #/kg -> #/m3) +do i = 1,ncol + do k=top_lev,pver + ncai(i,k)=dum2i(i,k)*rho(i,k) + ncal(i,k)=dum2l(i,k)*rho(i,k) + end do +end do + + +!redefine fice here.... +nfice(:,:)=0._r8 +do k=top_lev,pver + do i=1,ncol + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) + dumfice=qsout(i,k) + qrout(i,k) + dumc(i,k) + dumi(i,k) + + if (dumfice.gt.qsmall.and.(qsout(i,k)+dumi(i,k).gt.qsmall)) then + nfice(i,k)=(qsout(i,k) + dumi(i,k))/dumfice + endif + + if (nfice(i,k).gt.1._r8) then + nfice(i,k)=1._r8 + endif + + enddo +enddo + + +end subroutine micro_mg_tend + +!======================================================================== +!UTILITIES +!======================================================================== + +pure subroutine micro_mg_get_cols(ncol, nlev, top_lev, qcn, qin, & + mgncol, mgcols) + + ! Determines which columns microphysics should operate over by + ! checking for non-zero cloud water/ice. + + integer, intent(in) :: ncol ! Number of columns with meaningful data + integer, intent(in) :: nlev ! Number of levels to use + integer, intent(in) :: top_lev ! Top level for microphysics + + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + + integer, intent(out) :: mgncol ! Number of columns MG will use + integer, allocatable, intent(out) :: mgcols(:) ! column indices + + integer :: lev_offset ! top_lev - 1 (defined here for consistency) + logical :: ltrue(ncol) ! store tests for each column + + integer :: i, ii ! column indices + + if (allocated(mgcols)) deallocate(mgcols) + + lev_offset = top_lev - 1 + + ! Using "any" along dimension 2 collapses across levels, but + ! not columns, so we know if water is present at any level + ! in each column. + + ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + + ! Scan for true values to get a usable list of indices. + + mgncol = count(ltrue) + allocate(mgcols(mgncol)) + i = 0 + do ii = 1,ncol + if (ltrue(ii)) then + i = i + 1 + mgcols(i) = ii + end if + end do + +end subroutine micro_mg_get_cols + +end module micro_mg1_0 diff --git a/src/NorESM/micro_mg2_0.F90 b/src/NorESM/micro_mg2_0.F90 new file mode 100644 index 0000000000..97567f491e --- /dev/null +++ b/src/NorESM/micro_mg2_0.F90 @@ -0,0 +1,3325 @@ +module micro_mg2_0 +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics version 2.0 - Update of MG microphysics with +! prognostic precipitation. +! +! Author: Andrew Gettelman, Hugh Morrison, Sean Santos +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +! Version 2 history: Sep 2011: Development begun. +! Feb 2013: Added of prognostic precipitation. +! Aug 2015: Published and released version +! +! invoked in CAM by specifying -microphys=mg2.0 +! +! References: +! +! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. +! +! Part I: Off line tests and comparisons with other schemes. +! +! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. +! +! +! +! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell +! +! Advanced Two-Moment Microphysics for Global Models. +! +! Part II: Global model solutions and Aerosol-Cloud Interactions. +! +! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. +! +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! +! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice +! microphysics in cooperation with the MG liquid microphysics. This is +! controlled by the do_cldice variable. +! +! If do_cldice is false, then MG microphysics should not update CLDICE or +! NUMICE; it is assumed that the other microphysics scheme will have updated +! CLDICE and NUMICE. The other microphysics should handle the following +! processes that would have been done by MG: +! - Detrainment (liquid and ice) +! - Homogeneous ice nucleation +! - Heterogeneous ice nucleation +! - Bergeron process +! - Melting of ice +! - Freezing of cloud drops +! - Autoconversion (ice -> snow) +! - Growth/Sublimation of ice +! - Sedimentation of ice +! +! This option has not been updated since the introduction of prognostic +! precipitation, and probably should be adjusted to cover snow as well. +! +!--------------------------------------------------------------------------------- +! Based on micro_mg (restructuring of former cldwat2m_micro) +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! Code comments added by HM, 093011 +! General code structure: +! +! Code is divided into two main subroutines: +! subroutine micro_mg_init --> initializes microphysics routine, should be called +! once at start of simulation +! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! this also calls several smaller subroutines to calculate +! microphysical processes and other utilities +! +! List of external functions: +! qsat_water --> for calculating saturation vapor pressure with respect to liquid water +! qsat_ice --> for calculating saturation vapor pressure with respect to ice +! gamma --> standard mathematical gamma function +! ......................................................................... +! List of inputs through use statement in fortran90: +! Variable Name Description Units +! ......................................................................... +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! tmelt temperature of melting point for water K +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! qsat_water external function for calculating liquid water +! saturation vapor pressure/humidity - +! qsat_ice external function for calculating ice +! saturation vapor pressure/humidity pa +! rhmini relative humidity threshold parameter for +! nucleating ice - +! ......................................................................... +! NOTE: List of all inputs/outputs passed through the call/subroutine statement +! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure and specific humidity over water +! 3) svp over ice + +#ifndef HAVE_GAMMA_INTRINSICS +use shr_spfn_mod, only: gamma => shr_spfn_gamma +#endif + +use wv_sat_methods, only: & + qsat_water => wv_sat_qsat_water, & + qsat_ice => wv_sat_qsat_ice + +! Parameters from the utilities module. +use micro_mg_utils, only: & + r8, & + pi, & + omsm, & + qsmall, & + mincld, & + rhosn, & + rhoi, & + rhow, & + rhows, & + ac, bc, & + ai, bi, & + aj, bj, & + ar, br, & + as, bs, & + mi0, & + rising_factorial + +implicit none +private +save + +public :: & + micro_mg_init, & + micro_mg_get_cols, & + micro_mg_tend + +! Switches for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used +! +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. + +logical :: nccons ! nccons = .true. to specify constant cloud droplet number +logical :: nicons ! nicons = .true. to specify constant cloud ice number + +! specified ice and droplet number concentrations +! note: these are local in-cloud values, not grid-mean +real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3) +real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3) + +!========================================================= +! Private module parameters +!========================================================= + +!Range of cloudsat reflectivities (dBz) for analytic simulator +real(r8), parameter :: csmin = -30._r8 +real(r8), parameter :: csmax = 26._r8 +real(r8), parameter :: mindbz = -99._r8 +real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) + +! autoconversion size threshold for cloud ice to snow (m) +real(r8) :: dcs + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 + +! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. + real(r8), parameter :: sublim_factor =0.0_r8 !number sublimation factor. + + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: g ! gravity +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) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. + +! flags +logical :: microp_uniform +logical :: do_cldice +logical :: use_hetfrz_classnuc + +real(r8) :: rhosu ! typical 850mn air density + +real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C + +real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C +real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1 +real(r8) :: gamma_br_plus4 +real(r8) :: gamma_bs_plus1 +real(r8) :: gamma_bs_plus4 +real(r8) :: gamma_bi_plus1 +real(r8) :: gamma_bi_plus4 +real(r8) :: gamma_bj_plus1 +real(r8) :: gamma_bj_plus4 +real(r8) :: xxlv_squared +real(r8) :: xxls_squared + +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor + +logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop +logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg_init( & + kind, gravit, rair, rh2o, cpair, & + tmelt_in, latvap, latice, & + rhmini_in, micro_mg_dcs, & + microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & + allow_sed_supersat_in, do_sb_physics_in, & + nccons_in, nicons_in, ncnst_in, ninst_in, errstring) + + use micro_mg_utils, only: micro_mg_utils_init + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize constants for MG microphysics + ! + ! Author: Andrew Gettelman Dec 2005 + ! + !----------------------------------------------------------------------- + + integer, intent(in) :: kind ! Kind used for reals + real(r8), intent(in) :: gravit + 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) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: micro_mg_dcs + + logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns + ! .false. = use w/o sub-columns (standard) + logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) + ! .false. = skip all processes affecting + ! cloud ice + logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing + + character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop + logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics + + logical, intent(in) :: nccons_in + logical, intent(in) :: nicons_in + real(r8), intent(in) :: ncnst_in + real(r8), intent(in) :: ninst_in + + character(128), intent(out) :: errstring ! Output status (non-blank for error return) + + !----------------------------------------------------------------------- + + dcs = micro_mg_dcs + + ! Initialize subordinate utilities module. + call micro_mg_utils_init(kind, rh2o, cpair, tmelt_in, latvap, latice, & + dcs, errstring) + + if (trim(errstring) /= "") return + + ! declarations for MG code (transforms variable names) + + g= gravit ! gravity + r= rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) + rv= rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + rhmini = rhmini_in + micro_mg_precip_frac_method = micro_mg_precip_frac_method_in + micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + allow_sed_supersat = allow_sed_supersat_in + do_sb_physics = do_sb_physics_in + + nccons = nccons_in + nicons = nicons_in + ncnst = ncnst_in + ninst = ninst_in + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! flags + microp_uniform = microp_uniform_in + do_cldice = do_cldice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in + + ! typical air density at 850 mb + + rhosu = 85000._r8/(rair * tmelt) + + ! Maximum temperature at which snow is allowed to exist + snowmelt = tmelt + 2._r8 + ! Minimum temperature at which rain is allowed to exist + rainfrze = tmelt - 40._r8 + + ! Ice nucleation temperature + icenuct = tmelt - 5._r8 + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_br_plus1=gamma(1._r8+br) + gamma_br_plus4=gamma(4._r8+br) + gamma_bs_plus1=gamma(1._r8+bs) + gamma_bs_plus4=gamma(4._r8+bs) + gamma_bi_plus1=gamma(1._r8+bi) + gamma_bi_plus4=gamma(4._r8+bi) + gamma_bj_plus1=gamma(1._r8+bj) + gamma_bj_plus4=gamma(4._r8+bj) + + xxlv_squared=xxlv**2 + xxls_squared=xxls**2 + +end subroutine micro_mg_init + +!=============================================================================== +!microphysics routine for each timestep goes here... + +subroutine micro_mg_tend ( & + mgncol, nlev, deltatin, & + t, q, & + qcn, qin, & + ncn, nin, & + qrn, qsn, & + nrn, nsn, & + relvar, accre_enhan, & + p, pdel, & + cldn, liqcldf, icecldf, qsatfac, & + qcsinksum_rate1ord, & + naai, npccn, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & + effc, effc_fn, effi, & + sadice, sadsnow, & + prect, preci, & + nevapr, evapsnow, & + am_evp_st, & + prain, prodsnow, & + cmeout, deffi, & + pgamrad, lamcrad, & + qsout, dsout, & + lflx, iflx, & + rflx, sflx, qrout, & + reff_rain, reff_snow, & + qcsevap, qisevap, qvres, & + cmeitot, vtrmc, vtrmi, & + umr, ums, & + qcsedten, qisedten, & + qrsedten, qssedten, & + pratot, prctot, & + mnuccctot, mnuccttot, msacwitot, & + psacwstot, bergstot, bergtot, & + melttot, homotot, & + qcrestot, prcitot, praitot, & + qirestot, mnuccrtot, pracstot, & + meltsdttot, frzrdttot, mnuccdtot, & + nrout, nsout, & + refl, arefl, areflz, & + frefl, csrfl, acsrfl, & + fcsrfl, rercld, & + ncai, ncal, & + qrout2, qsout2, & + nrout2, nsout2, & + drout2, dsout2, & + freqs, freqr, & + nfice, qcrat, & + errstring, & +!AL right names? + nnuccctot, nnuccttot, npsacwstot, nsubctot, npratot, & + nprc1tot, ncsedtentot, nisedtentot, nmelttot, nhomotot, & + nimelttot, nihomotot, nsacwitot, nsubitot, nprcitot, & + npraitot, nnudeptot, npccntot, nnuccdtot, mnudeptot, & + frzr,nfrzr, nnuccritot, mnuccritot, & +! + nctnszmx,nctnszmn, nctnncld, nitncons, nitnszmx,nitnszmn, nitnncld, & +!AL + ! Below arguments are "optional" (pass null pointers to omit). + tnd_qsnow, tnd_nsnow, re_ice, & + prer_evap, & + frzimm, frzcnt, frzdep) + + ! Constituent properties. + use micro_mg_utils, only: & + mg_liq_props, & + mg_ice_props, & + mg_rain_props, & + mg_snow_props + + ! Size calculation functions. + use micro_mg_utils, only: & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter + + ! Microphysical processes. + use micro_mg_utils, only: & + ice_deposition_sublimation, & + sb2001v2_liq_autoconversion,& + sb2001v2_accre_cld_water_rain,& + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + snow_self_aggregation, & + accrete_cloud_water_snow, & + secondary_ice_production, & + accrete_rain_snow, & + heterogeneous_rain_freezing, & + accrete_cloud_water_rain, & + self_collection_rain, & + accrete_cloud_ice_snow, & + evaporate_sublimate_precip, & + bergeron_process_snow + + !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL + ! e-mail: morrison@ucar.edu, andrew@ucar.edu + + ! input arguments + 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) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) + + ! note: all input cloud variables are grid-averaged + real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg) + real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg) + + real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg) + real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg) + + real(r8), intent(in) :: relvar(mgncol,nlev) ! cloud water relative variance (-) + real(r8), intent(in) :: accre_enhan(mgncol,nlev) ! optional accretion + ! enhancement factor (-) + + real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa) + real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa) + + real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units) + real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) + real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) + real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) + + ! used for scavenging + ! Inputs for aerosol activation + real(r8), intent(in) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + + ! Note that for these variables, the dust bin is assumed to be the last index. + ! (For example, in CAM, the last dimension is always size 4.) + real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) + + ! output arguments + + real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for + ! direct cw to precip conversion + real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) + + real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s) + real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s) + real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s)) + real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s)) + real(r8), intent(out) :: effc(mgncol,nlev) ! droplet effective radius (micron) + real(r8), intent(out) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8), intent(out) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) + real(r8), intent(out) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3) + real(r8), intent(out) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3) + real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s) + real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) + real(r8), intent(out) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) + real(r8), intent(out) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) + real(r8), intent(out) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac) + real(r8), intent(out) :: prain(mgncol,nlev) ! production of rain + snow (1/s) + real(r8), intent(out) :: prodsnow(mgncol,nlev) ! production of snow (1/s) + real(r8), intent(out) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) + real(r8), intent(out) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) + real(r8), intent(out) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) + real(r8), intent(out) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) + real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(out) :: dsout(mgncol,nlev) ! snow diameter (m) + real(r8), intent(out) :: lflx(mgncol,nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: iflx(mgncol,nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: rflx(mgncol,nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) + real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) + real(r8), intent(out) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) + real(r8), intent(out) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sublimation (1/s) + real(r8), intent(out) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) + real(r8), intent(out) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) + real(r8), intent(out) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) + real(r8), intent(out) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) + real(r8), intent(out) :: umr(mgncol,nlev) ! mass weighted rain fallspeed (m/s) + real(r8), intent(out) :: ums(mgncol,nlev) ! mass weighted snow fallspeed (m/s) + real(r8), intent(out) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) + real(r8), intent(out) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) + real(r8), intent(out) :: qrsedten(mgncol,nlev) ! qr sedimentation tendency (1/s) + real(r8), intent(out) :: qssedten(mgncol,nlev) ! qs sedimentation tendency (1/s) + + ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) + real(r8), intent(out) :: pratot(mgncol,nlev) ! accretion of cloud by rain + real(r8), intent(out) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain + real(r8), intent(out) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing + real(r8), intent(out) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing + real(r8), intent(out) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering + real(r8), intent(out) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow + real(r8), intent(out) :: bergstot(mgncol,nlev) ! bergeron process on snow + real(r8), intent(out) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice + real(r8), intent(out) :: melttot(mgncol,nlev) ! melting of cloud ice + real(r8), intent(out) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water + real(r8), intent(out) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat + real(r8), intent(out) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow + real(r8), intent(out) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow + real(r8), intent(out) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat + real(r8), intent(out) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8), intent(out) :: meltsdttot(mgncol,nlev) ! latent heating rate due to melting of snow (W/kg) + real(r8), intent(out) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8), intent(out) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation + real(r8), intent(out) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) + real(r8), intent(out) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) + real(r8), intent(out) :: refl(mgncol,nlev) ! analytic radar reflectivity + real(r8), intent(out) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range + real(r8), intent(out) :: areflz(mgncol,nlev) ! average reflectivity in z. + real(r8), intent(out) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity + real(r8), intent(out) :: csrfl(mgncol,nlev) ! cloudsat reflectivity + real(r8), intent(out) :: acsrfl(mgncol,nlev) ! cloudsat average + real(r8), intent(out) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity + real(r8), intent(out) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud + real(r8), intent(out) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) + real(r8), intent(out) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) + real(r8), intent(out) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 + real(r8), intent(out) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 + real(r8), intent(out) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 + real(r8), intent(out) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 + real(r8), intent(out) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) + real(r8), intent(out) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) + real(r8), intent(out) :: freqs(mgncol,nlev) ! fractional occurrence of snow + real(r8), intent(out) :: freqr(mgncol,nlev) ! fractional occurrence of rain + real(r8), intent(out) :: nfice(mgncol,nlev) ! fractional occurrence of ice + real(r8), intent(out) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc) + + real(r8), intent(out) :: prer_evap(mgncol,nlev) + + character(128), intent(out) :: errstring ! output status (non-blank for error return) + +!AL change these to tot? output is now called tot and packed in interface? + real(r8), intent(out) :: nnuccctot(mgncol,nlev) ! immersion freezing + real(r8), intent(out) :: nnuccttot(mgncol,nlev) ! contact freezing + real(r8), intent(out) :: npsacwstot(mgncol,nlev) ! accr. snow + real(r8), intent(out) :: nsubctot(mgncol,nlev) ! evaporation of droplet + real(r8), intent(out) :: npratot(mgncol,nlev) ! accretion + real(r8), intent(out) :: nprc1tot(mgncol,nlev) ! autoconversion + real(r8), intent(out) :: ncsedtentot(mgncol,nlev) ! nqc sedimentation tendency + real(r8), intent(out) :: nisedtentot(mgncol,nlev) ! nqi sedimentation tendency + real(r8), intent(out) :: nmelttot(mgncol,nlev) ! nc melting of cloud ice + real(r8), intent(out) :: nhomotot(mgncol,nlev) ! nc homogeneos freezign cloud water + real(r8), intent(out) :: nimelttot(mgncol,nlev) ! ni melting of cloud ice + real(r8), intent(out) :: nihomotot(mgncol,nlev) ! ni homogeneos freezign cloud water + real(r8), intent(out) :: nsacwitot(mgncol,nlev) ! numb conc tend due to HM ice multiplication + real(r8), intent(out) :: nsubitot(mgncol,nlev) ! evaporation of cloud ice number (sublimation?) + real(r8), intent(out) :: nprcitot(mgncol,nlev) ! numb conc tend due to auto of cloud ice to snow + real(r8), intent(out) :: npraitot(mgncol,nlev) ! numb conc tend due to accr of cloud ice by snow + real(r8), intent(out) :: nnudeptot(mgncol,nlev) ! deposition? + real(r8), intent(out) :: npccntot(mgncol,nlev) ! droplet activation + real(r8), intent(out) :: nnuccdtot(mgncol,nlev) ! ni nucleation + real(r8), intent(out) :: mnudeptot(mgncol,nlev) ! deposition (mass) +! + real(r8), intent(out) :: nctnszmx(mgncol,nlev) ! nc tuning: maximum slope (reduction of number) + real(r8), intent(out) :: nctnszmn(mgncol,nlev) ! nc tuning: minimum slope (increase of numer) + real(r8), intent(out) :: nctnncld(mgncol,nlev) ! nc tuning: removal of nc when qc is zero after mg + real(r8), intent(out) :: nitncons(mgncol,nlev) ! ni tuning to conserve numberi in substeps + real(r8), intent(out) :: nitnszmx(mgncol,nlev) ! ni tuning: maximum slope + real(r8), intent(out) :: nitnszmn(mgncol,nlev) ! ni tuning: minimum minimum slope + real(r8), intent(out) :: nitnncld(mgncol,nlev) ! ni tuning: removal of ni when qi is zero after mg + real(r8), intent(out) :: mnuccritot(mgncol,nlev)! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: nnuccritot(mgncol,nlev)! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: frzr(mgncol,nlev)! mixing ratio tendency due to heterogeneous freezing of rain to ice (1/s) + real(r8), intent(out) :: nfrzr(mgncol,nlev)! ni tendency due to heterogeneous freezing of rain to ice (1/s) +!AL + + + + + ! Tendencies calculated by external schemes that can replace MG's native + ! process tendencies. + + ! Used with CARMA cirrus microphysics + ! (or similar external microphysics model) + real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) + real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) + real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m) + + ! From external ice nucleation. + real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) + real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) + real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) + + ! local workspace + ! all units mks unless otherwise stated + + ! local copies of input variables + real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) + real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) + real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) + + ! general purpose variables + real(r8) :: deltat ! sub-time step (s) + real(r8) :: mtime ! the assumed ice nucleation timescale + + ! physical properties of the air at a given point + real(r8) :: rho(mgncol,nlev) ! density (kg m-3) + real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor + real(r8) :: mu(mgncol,nlev) ! viscosity + real(r8) :: sc(mgncol,nlev) ! schmidt number + real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed + + ! cloud fractions + real(r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap + real(r8) :: cldm(mgncol,nlev) ! cloud fraction + real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction + real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction + real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor + + ! mass mixing ratios + real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid + real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: qsic(mgncol,nlev) ! in-precip snow + real(r8) :: qric(mgncol,nlev) ! in-precip rain + + ! number concentrations + real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet + real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: nsic(mgncol,nlev) ! in-precip snow + real(r8) :: nric(mgncol,nlev) ! in-precip rain + ! maximum allowed ni value + real(r8) :: nimax(mgncol,nlev) + + ! Size distribution parameters for: + ! cloud ice + real(r8) :: lami(mgncol,nlev) ! slope + real(r8) :: n0i(mgncol,nlev) ! intercept + ! cloud liquid + real(r8) :: lamc(mgncol,nlev) ! slope + real(r8) :: pgam(mgncol,nlev) ! spectral width parameter + ! snow + real(r8) :: lams(mgncol,nlev) ! slope + real(r8) :: n0s(mgncol,nlev) ! intercept + ! rain + real(r8) :: lamr(mgncol,nlev) ! slope + real(r8) :: n0r(mgncol,nlev) ! intercept + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration + ! Instantaneous rain freezing + real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstrf(mgncol,nlev) ! number concentration + + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 + ! ice nucleation + real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing + real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio + ! freezing of cloud water + real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccc(mgncol,nlev) ! number concentration + ! contact freezing of cloud water + real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration + ! ice multiplication + real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio + real(r8) :: nsacwi(mgncol,nlev) ! number concentration + ! autoconversion of cloud droplets + real(r8) :: prc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) + real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) + ! self-aggregation of snow + real(r8) :: nsagg(mgncol,nlev) ! number concentration + ! self-collection of rain + real(r8) :: nragg(mgncol,nlev) ! number concentration + ! collection of droplets by snow + real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio + real(r8) :: npsacws(mgncol,nlev) ! number concentration + ! collection of rain by snow + real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio + real(r8) :: npracs(mgncol,nlev) ! number concentration + ! freezing of rain + real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccr(mgncol,nlev) ! number concentration + ! freezing of rain to form ice (mg add 4/26/13) + real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccri(mgncol,nlev) ! number concentration + ! accretion of droplets by rain + real(r8) :: pra(mgncol,nlev) ! mass mixing ratio + real(r8) :: npra(mgncol,nlev) ! number concentration + ! autoconversion of cloud ice to snow + real(r8) :: prci(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprci(mgncol,nlev) ! number concentration + ! accretion of cloud ice by snow + real(r8) :: prai(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprai(mgncol,nlev) ! number concentration + ! evaporation of rain + real(r8) :: pre(mgncol,nlev) ! mass mixing ratio + ! sublimation of snow + real(r8) :: prds(mgncol,nlev) ! mass mixing ratio + ! number evaporation + real(r8) :: nsubi(mgncol,nlev) ! cloud ice + real(r8) :: nsubc(mgncol,nlev) ! droplet + real(r8) :: nsubs(mgncol,nlev) ! snow + real(r8) :: nsubr(mgncol,nlev) ! rain + ! bergeron process + real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) + real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow + real(r8) :: acn(mgncol,nlev) ! cloud droplet + real(r8) :: ain(mgncol,nlev) ! cloud ice + real(r8) :: ajn(mgncol,nlev) ! cloud small ice + + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + + ! saturation vapor pressures + real(r8) :: esl(mgncol,nlev) ! liquid + real(r8) :: esi(mgncol,nlev) ! ice + real(r8) :: esn ! checking for RH after rain evap + + ! saturation vapor mixing ratios + real(r8) :: qvl(mgncol,nlev) ! liquid + real(r8) :: qvi(mgncol,nlev) ! ice + real(r8) :: qvn ! checking for RH after rain evap + + ! relative humidity + real(r8) :: relhum(mgncol,nlev) + + ! parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fc(mgncol,nlev) + real(r8) :: fnc(mgncol,nlev) + real(r8) :: fi(mgncol,nlev) + real(r8) :: fni(mgncol,nlev) + + real(r8) :: fr(mgncol,nlev) + real(r8) :: fnr(mgncol,nlev) + real(r8) :: fs(mgncol,nlev) + real(r8) :: fns(mgncol,nlev) + + real(r8) :: faloutc(nlev) + real(r8) :: faloutnc(nlev) + real(r8) :: falouti(nlev) + real(r8) :: faloutni(nlev) + + real(r8) :: faloutr(nlev) + real(r8) :: faloutnr(nlev) + real(r8) :: falouts(nlev) + real(r8) :: faloutns(nlev) + + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltndqie + real(r8) :: faltndqce + + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltnds + real(r8) :: faltndns + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 + real(r8) :: dumni0 + real(r8) :: dumns0 + ! dummies for checking RH + real(r8) :: qtmp + real(r8) :: ttmp + ! dummies for conservation check + real(r8) :: ratio + real(r8) :: tmpfrz + ! dummies for in-cloud variables + real(r8) :: dumc(mgncol,nlev) ! qc + real(r8) :: dumnc(mgncol,nlev) ! nc + real(r8) :: dumi(mgncol,nlev) ! qi + real(r8) :: dumni(mgncol,nlev) ! ni + real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio + real(r8) :: dumnr(mgncol,nlev) ! rain number concentration + real(r8) :: dums(mgncol,nlev) ! snow mixing ratio + real(r8) :: dumns(mgncol,nlev) ! snow number concentration + ! Array dummy variable + real(r8) :: dum_2D(mgncol,nlev) + real(r8) :: pdel_inv(mgncol,nlev) + + ! loop array variables + ! "i" and "k" are column/level iterators for internal (MG) variables + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n + + ! number of sub-steps for loops over "n" (for sedimentation) + integer nstep + integer mdust + + ! Varaibles to scale fall velocity between small and regular ice regimes. + real(r8) :: irad + real(r8) :: ifrac + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! Return error message + errstring = ' ' + + ! Process inputs + + ! assign variable deltat to deltatin + deltat = deltatin + + ! Copies of input concentrations that may be changed internally. + qc = qcn + nc = ncn + qi = qin + ni = nin + qr = qrn + nr = nrn + qs = qsn + ns = nsn + + ! cldn: used to set cldm, unused for subcolumns + ! liqcldf: used to set lcldm, unused for subcolumns + ! icecldf: used to set icldm, unused for subcolumns + + if (microp_uniform) then + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors). + + where (qc >= qsmall) + lcldm = 1._r8 + elsewhere + lcldm = mincld + end where + + where (qi >= qsmall) + icldm = 1._r8 + elsewhere + icldm = mincld + end where + + cldm = max(icldm, lcldm) + qsfm = 1._r8 + + else + ! get cloud fraction, check for minimum + cldm = max(cldn,mincld) + lcldm = max(liqcldf,mincld) + icldm = max(icecldf,mincld) + qsfm = qsatfac + end if + + ! Initialize local variables + + ! local physical properties + rho = p/(r*t) + dv = 8.794E-5_r8 * t**1.81_r8 / p + mu = 1.496E-6_r8 * t**1.5_r8 / (t + 120._r8) + sc = mu/(rho*dv) + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof=(rhosu/rho)**0.54_r8 + + arn=ar*rhof + asn=as*rhof + acn=g*rhow/(18._r8*mu) + ain=ai*(rhosu/rho)**0.35_r8 + ajn=aj*(rhosu/rho)**0.35_r8 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Get humidity and saturation vapor pressures + + do k=1,nlev + do i=1,mgncol + + call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) + + ! make sure when above freezing that esi=esl, not active yet + if (t(i,k) >= tmelt) then + esi(i,k)=esl(i,k) + qvi(i,k)=qvl(i,k) + else + call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) + + ! Scale the water saturation values to reflect subgrid scale + ! ice cloud fraction, where ice clouds begin forming at a + ! gridbox average relative humidity of rhmini (not 1). + ! + ! NOTE: For subcolumns and other non-subgrid clouds, qsfm willi + ! be 1. + qvi(i,k) = qsfm(i,k) * qvi(i,k) + esi(i,k) = qsfm(i,k) * esi(i,k) + qvl(i,k) = qsfm(i,k) * qvl(i,k) + esl(i,k) = qsfm(i,k) * esl(i,k) + end if + + end do + end do + + relhum = q / max(qvl, qsmall) + + !=============================================== + + ! set mtime here to avoid answer-changing + mtime=deltat + + ! initialize microphysics output + qcsevap=0._r8 + qisevap=0._r8 + qvres =0._r8 + cmeitot =0._r8 + vtrmc =0._r8 + vtrmi =0._r8 + qcsedten =0._r8 + qisedten =0._r8 + qrsedten =0._r8 + qssedten =0._r8 + + pratot=0._r8 + prctot=0._r8 + mnuccctot=0._r8 + mnuccttot=0._r8 + msacwitot=0._r8 + psacwstot=0._r8 + bergstot=0._r8 + bergtot=0._r8 + melttot=0._r8 + homotot=0._r8 + qcrestot=0._r8 + prcitot=0._r8 + praitot=0._r8 + qirestot=0._r8 + mnuccrtot=0._r8 + pracstot=0._r8 + meltsdttot=0._r8 + frzrdttot=0._r8 + mnuccdtot=0._r8 + +!AL this is correct since output now is tot? add new term! + nnuccctot=0._r8 + nnuccttot=0._r8 + npsacwstot=0._r8 + nsubctot=0._r8 + npratot=0._r8 + nprc1tot=0._r8 + ncsedtentot=0._r8 + nisedtentot=0._r8 + nmelttot=0._r8 + nhomotot=0._r8 + nimelttot=0._r8 + nihomotot=0._r8 + nsacwitot=0._r8 + nsubitot=0._r8 + nprcitot=0._r8 + npraitot=0._r8 + nnudeptot=0._r8 + npccntot=0._r8 + nnuccdtot=0._r8 + mnudeptot=0._r8 + mnuccritot=0._r8 + nnuccritot=0._r8 + + nctnszmx=0._r8 + nctnszmn=0._r8 + nctnncld=0._r8 + nitncons=0._r8 + nitnszmx=0._r8 + nitnszmn=0._r8 + nitnncld=0._r8 + + frzr=0._r8 + nfrzr=0._r8 + +!AL + + rflx=0._r8 + sflx=0._r8 + lflx=0._r8 + iflx=0._r8 + + ! initialize precip output + + qrout=0._r8 + qsout=0._r8 + nrout=0._r8 + nsout=0._r8 + + ! for refl calc + rainrt = 0._r8 + + ! initialize rain size + rercld=0._r8 + + qcsinksum_rate1ord = 0._r8 + + ! initialize variables for trop_mozart + nevapr = 0._r8 + prer_evap = 0._r8 + evapsnow = 0._r8 + am_evp_st = 0._r8 + prain = 0._r8 + prodsnow = 0._r8 + cmeout = 0._r8 + + precip_frac = mincld + + lamc=0._r8 + + ! initialize microphysical tendencies + + tlat=0._r8 + qvlat=0._r8 + qctend=0._r8 + qitend=0._r8 + qstend = 0._r8 + qrtend = 0._r8 + nctend=0._r8 + nitend=0._r8 + nrtend = 0._r8 + nstend = 0._r8 + + ! initialize in-cloud and in-precip quantities to zero + qcic = 0._r8 + qiic = 0._r8 + qsic = 0._r8 + qric = 0._r8 + + ncic = 0._r8 + niic = 0._r8 + nsic = 0._r8 + nric = 0._r8 + + ! initialize precip at surface + + prect = 0._r8 + preci = 0._r8 + + ! initialize precip fallspeeds to zero + ums = 0._r8 + uns = 0._r8 + umr = 0._r8 + unr = 0._r8 + + ! initialize limiter for output + qcrat = 1._r8 + + ! Many outputs have to be initialized here at the top to work around + ! ifort problems, even if they are always overwritten later. + effc = 10._r8 + lamcrad = 0._r8 + pgamrad = 0._r8 + effc_fn = 10._r8 + effi = 25._r8 + sadice = 0._r8 + sadsnow = 0._r8 + deffi = 50._r8 + + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout = 0._r8 + dsout2 = 0._r8 + + freqr = 0._r8 + freqs = 0._r8 + + reff_rain = 0._r8 + reff_snow = 0._r8 + + refl = -9999._r8 + arefl = 0._r8 + areflz = 0._r8 + frefl = 0._r8 + csrfl = 0._r8 + acsrfl = 0._r8 + fcsrfl = 0._r8 + + ncal = 0._r8 + ncai = 0._r8 + + nfice = 0._r8 + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! get provisional droplet number after activation. This is used for + ! all microphysical process calculations, for consistency with update of + ! droplet mass before microphysics + + ! calculate potential for droplet activation if cloud water is present + ! tendency from activation (npccn) is read in from companion routine + + ! output activated liquid and ice (convert from #/kg -> #/m3) + !-------------------------------------------------- + where (qc >= qsmall) + nc = max(nc + npccn*deltat, 0._r8) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + elsewhere + ncal = 0._r8 + end where + + where (t < icenuct) + ncai = naai*rho + elsewhere + ncai = 0._r8 + end where + + !=============================================== + + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + ! + ! NOTE: If using gridbox average values, condensation will not occur until rh=1, + ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid + ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus + ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. + + !------------------------------------------------------- + + if (do_cldice) then + where (naai > 0._r8 .and. t < icenuct .and. & + relhum*esl/esi > 1.05_r8) + + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + nnuccd = (naai-ni/icldm)/mtime*icldm + nnuccd = max(nnuccd,0._r8) + nimax = naai*icldm + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd = nnuccd * mi0 + + elsewhere + nnuccd = 0._r8 + nimax = 0._r8 + mnuccd = 0._r8 + end where + + end if + + + !============================================================================= + do k=1,nlev + + do i=1,mgncol + + ! calculate instantaneous precip processes (melting and homogeneous freezing) + + ! melting of snow at +2 C + + if (t(i,k) > snowmelt) then + if (qs(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*qs(i,k) + if (t(i,k)+dum < snowmelt) then + dum = (t(i,k)-snowmelt)*cpp/xlf + dum = dum/qs(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1=-xlf*minstsm(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + + qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8) + ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8) + qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8) + nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8) + end if + end if + + end do + end do + + do k=1,nlev + do i=1,mgncol + ! freezing of rain at -5 C + + if (t(i,k) < rainfrze) then + + if (qr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*qr(i,k) + if (t(i,k)+dum > rainfrze) then + dum = -(t(i,k)-rainfrze)*cpp/xlf + dum = dum/qr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + minstrf(i,k) = dum*qr(i,k) + ninstrf(i,k) = dum*nr(i,k) + + ! heating tendency + dum1 = xlf*minstrf(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + + qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8) + nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8) + qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8) + + end if + end if + end do + end do + + do k=1,nlev + do i=1,mgncol + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + !------------------------------------------------------- + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + + if (qc(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8) + ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8) + + ! specify droplet concentration + if (nccons) then + ncic(i,k)=ncnst/rho(i,k) + end if + else + qcic(i,k)=0._r8 + ncic(i,k)=0._r8 + end if + + if (qi(i,k).ge.qsmall) then + ! limit in-cloud values to 0.005 kg/kg + qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8) + niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8) + + ! switch for specification of cloud ice number + if (nicons) then + niic(i,k)=ninst/rho(i,k) + end if + else + qiic(i,k)=0._r8 + niic(i,k)=0._r8 + end if + + end do + end do + + !======================================================================== + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so precip_frac will be correctly set below + ! and nothing extra needs to be done here + + precip_frac = cldm + + micro_vert_loop: do k=1,nlev + + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + if (k /= 1) then + where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) + precip_frac(:,k) = precip_frac(:,k-1) + end where + endif + + else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then + + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave precip_frac as cloud fraction at current level + if (k /= 1) then + where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) + precip_frac(:,k)=max(precip_frac(:,k-1),precip_frac(:,k)) + end where + end if + + endif + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! cloud liquid + !------------------------------------------- + + call size_dist_param_liq(mg_liq_props, qcic(1:mgncol,k), ncic(1:mgncol,k),& + rho(1:mgncol,k), pgam(1:mgncol,k), lamc(1:mgncol,k), mgncol) + + + !======================================================================== + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (.not. do_sb_physics) then + call kk2000_liq_autoconversion(microp_uniform, qcic(1:mgncol,k), & + ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) + endif + + ! assign qric based on prognostic qr, using assumed precip fraction + ! note: this could be moved above for consistency with qcic and qiic calculations + qric(:,k) = qr(:,k)/precip_frac(:,k) + nric(:,k) = nr(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qric(:,k)=min(qric(:,k),0.01_r8) + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + where (qric(:,k).lt.qsmall) + qric(:,k)=0._r8 + nric(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(:,k)=max(nric(:,k),0._r8) + + ! Get size distribution parameters for cloud ice + + call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), mgncol, n0=n0i(:,k)) + + ! Alternative autoconversion + if (do_sb_physics) then + call sb2001v2_liq_autoconversion(pgam(:,k),qcic(1:mgncol,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) + endif + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, prci(:,k), nprci(:,k), mgncol) + else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) + nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) + end if + + ! note, currently we don't have this + ! inside the do_cldice block, should be changed later + ! assign qsic based on prognostic qs, using assumed precip fraction + qsic(:,k) = qs(:,k)/precip_frac(:,k) + nsic(:,k) = ns(:,k)/precip_frac(:,k) + + ! limit in-precip mixing ratios to 10 g/kg + qsic(:,k)=min(qsic(:,k),0.01_r8) + + ! if precip mix ratio is zero so should number concentration + + where (qsic(:,k) < qsmall) + qsic(:,k)=0._r8 + nsic(:,k)=0._r8 + end where + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nsic(:,k)=max(nsic(:,k),0._r8) + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & + lamr(:,k), mgncol, n0=n0r(:,k)) + + where (lamr(:,k) >= qsmall) + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + unr(:,k) = min(arn(:,k)*gamma_br_plus1/lamr(:,k)**br,9.1_r8*rhof(:,k)) + umr(:,k) = min(arn(:,k)*gamma_br_plus4/(6._r8*lamr(:,k)**br),9.1_r8*rhof(:,k)) + + elsewhere + umr(:,k) = 0._r8 + unr(:,k) = 0._r8 + end where + + !...................................................................... + ! snow + + call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & + lams(:,k), mgncol, n0=n0s(:,k)) + + where (lams(:,k) > 0._r8) + + ! provisional snow number and mass weighted mean fallspeed (m/s) + + ums(:,k) = min(asn(:,k)*gamma_bs_plus4/(6._r8*lams(:,k)**bs),1.2_r8*rhof(:,k)) + uns(:,k) = min(asn(:,k)*gamma_bs_plus1/lams(:,k)**bs,1.2_r8*rhof(:,k)) + + elsewhere + ums(:,k) = 0._r8 + uns(:,k) = 0._r8 + end where + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(1:mgncol,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) + + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing + + where (qcic(1:mgncol,k).ge.qsmall .and. t(:,k).lt.269.15_r8) + where (nnuccc(:,k)*lcldm(:,k).gt.nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k)=mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k)=nnuccd(:,k)/lcldm(:,k) + end where + end where + + mdust = size(rndst,3) + call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & + nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(1:mgncol,k), ncic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) + + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + + else + + ! Mass of droplets frozen is the average droplet mass, except + ! with two limiters: concentration must be at least 1/cm^3, and + ! mass must be at least the minimum defined above. + mi0l = qcic(1:mgncol,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + mi0l = max(mi0l_min, mi0l) + + where (qcic(1:mgncol,k) >= qsmall) + nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) + mnuccc(:,k) = nnuccc(:,k)*mi0l + + nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) + mnucct(:,k) = nnucct(:,k)*mi0l + + nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) + mnudep(:,k) = nnudep(:,k)*mi0 + elsewhere + nnuccc(:,k) = 0._r8 + mnuccc(:,k) = 0._r8 + + nnucct(:,k) = 0._r8 + mnucct(:,k) = 0._r8 + + nnudep(:,k) = 0._r8 + mnudep(:,k) = 0._r8 + end where + + end if + + else + mnuccc(:,k)=0._r8 + nnuccc(:,k)=0._r8 + mnucct(:,k)=0._r8 + nnucct(:,k)=0._r8 + mnudep(:,k)=0._r8 + nnudep(:,k)=0._r8 + end if + + call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & + nsagg(:,k), mgncol) + + call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & + 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 + nsacwi(:,k) = 0.0_r8 + msacwi(:,k) = 0.0_r8 + 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), & + pracs(:,k), npracs(:,k), mgncol) + + call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & + mnuccr(:,k), nnuccr(:,k), mgncol) + + if (do_sb_physics) then + call sb2001v2_accre_cld_water_rain(qcic(1:mgncol,k), ncic(:,k), qric(:,k), & + rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + else + call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(1:mgncol,k), & + ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) + endif + + call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) + + if (do_cldice) then + call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & + qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) + else + prai(:,k) = 0._r8 + nprai(:,k) = 0._r8 + end if + + call evaporate_sublimate_precip(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(1:mgncol,k), qiic(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) + + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + 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 + + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & + 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 + + 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) + + elsewhere + nsubi(:,k) = 0._r8 + end where + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(:,k) = 0._r8 + + end if !do_cldice + !---PMC 12/3/12 + + do i=1,mgncol + + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + !=================================================================== + + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! conservation of qc + !------------------------------------------------------------------- + + 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 + + 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 + prc(i,k) = prc(i,k)*ratio + pra(i,k) = pra(i,k)*ratio + mnuccc(i,k) = mnuccc(i,k)*ratio + mnucct(i,k) = mnucct(i,k)*ratio + msacwi(i,k) = msacwi(i,k)*ratio + psacws(i,k) = psacws(i,k)*ratio + bergs(i,k) = bergs(i,k)*ratio + berg(i,k) = berg(i,k)*ratio + qcrat(i,k) = ratio + else + qcrat(i,k) = 1._r8 + end if + + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) + end if + + end do + + do i=1,mgncol + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))/deltat + dum = max(dum,0._r8) + if (dum1 > dum) then + ! Allocate the limited "dum" tendency to mnuccd and vap_dep + ! processes. Don't divide by cloud fraction; these are grid- + ! mean rates. + dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) + mnuccd(i,k) = dum*dum1 + vap_dep(i,k) = dum - mnuccd(i,k) + end if + end if + + end do + + do i=1,mgncol + + !=================================================================== + ! conservation of nc + !------------------------------------------------------------------- + dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & + npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat + + if (dum.gt.nc(i,k)) then + ratio = nc(i,k)/deltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+& + npsacws(i,k)-nsubc(i,k))*lcldm(i,k))*omsm + + nprc1(i,k) = nprc1(i,k)*ratio + npra(i,k) = npra(i,k)*ratio + nnuccc(i,k) = nnuccc(i,k)*ratio + nnucct(i,k) = nnucct(i,k)*ratio + npsacws(i,k) = npsacws(i,k)*ratio + nsubc(i,k)=nsubc(i,k)*ratio + end if + + mnuccri(i,k)=0._r8 + nnuccri(i,k)=0._r8 + + if (do_cldice) then + + ! freezing of rain to produce ice if mean rain size is smaller than Dcs + if (lamr(i,k) > qsmall .and. 1._r8/lamr(i,k) < Dcs) then + mnuccri(i,k)=mnuccr(i,k) + nnuccri(i,k)=nnuccr(i,k) + mnuccr(i,k)=0._r8 + nnuccr(i,k)=0._r8 + end if + end if + + end do + + do i=1,mgncol + + ! conservation of rain mixing ratio + !------------------------------------------------------------------- + dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k)- & + (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 + 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 + 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 + end if + + end do + + do i=1,mgncol + + ! conservation of rain number + !------------------------------------------------------------------- + + ! Add evaporation of rain number. + if (pre(i,k) < 0._r8) then + !dum = pre(i,k)*deltat/qr(i,k) + !dum = max(-1._r8,dum) + !nsubr(i,k) = dum*nr(i,k)/deltat + nsubr(i,k) = pre(i,k)*nr(i,k)/qr(i,k) + else + nsubr(i,k) = 0._r8 + end if + + end do + + do i=1,mgncol + + dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k)- & + nprc(i,k)*lcldm(i,k))*deltat + + if (dum.gt.nr(i,k)) then + ratio = (nr(i,k)/deltat+nprc(i,k)*lcldm(i,k))/precip_frac(i,k)/ & + (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*omsm + + nragg(i,k)=nragg(i,k)*ratio + npracs(i,k)=npracs(i,k)*ratio + nnuccr(i,k)=nnuccr(i,k)*ratio + nsubr(i,k)=nsubr(i,k)*ratio + nnuccri(i,k)=nnuccri(i,k)*ratio + end if + + end do + + if (do_cldice) then + + do i=1,mgncol + + ! 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) & + -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))/ & + ((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 + ice_sublim(i,k) = ice_sublim(i,k)*ratio + end if + + end do + + end if + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of ni + !------------------------------------------------------------------- + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(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)+ & + 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 + nprai(i,k) = nprai(i,k)*ratio + nsubi(i,k) = nsubi(i,k)*ratio + end if + + end do + + end if + + do i=1,mgncol + + ! conservation of snow mixing ratio + !------------------------------------------------------------------- + dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) & + -(bergs(i,k)+psacws(i,k))*lcldm(i,k))*deltat + + if (dum.gt.qs(i,k).and.-prds(i,k).ge.qsmall) then + ratio = (qs(i,k)/deltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ & + (bergs(i,k)+psacws(i,k))*lcldm(i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ & + precip_frac(i,k)/(-prds(i,k))*omsm + prds(i,k)=prds(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! conservation of snow number + !------------------------------------------------------------------- + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + nsubs(i,k)=0._r8 + + dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat + + if (dum.gt.ns(i,k)) then + ratio = (ns(i,k)/deltat+nnuccr(i,k)* & + precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ & + (-nsubs(i,k)-nsagg(i,k))*omsm + nsubs(i,k)=nsubs(i,k)*ratio + nsagg(i,k)=nsagg(i,k)*ratio + end if + + end do + + do i=1,mgncol + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + + if ((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then + + qtmp=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+ & + (pre(i,k)+prds(i,k))*precip_frac(i,k))*deltat + ttmp=t(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))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + dum1=pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + dum2=prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k))*precip_frac(i,k)+ice_sublim(i,k)) + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + qtmp=q(i,k)-(vap_dep(i,k)+mnuccd(i,k))*deltat + ttmp=t(i,k)+((vap_dep(i,k)+mnuccd(i,k))*xxls)*deltat/cpp + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + xxlv_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + pre(i,k)=dum*dum1/deltat/precip_frac(i,k) + + ! do separately using RHI for prds and ice_sublim + call qsat_ice(ttmp, p(i,k), esn, qvn) + + dum=(qtmp-qvn)/(1._r8 + xxls_squared*qvn/(cpp*rv*ttmp**2)) + dum=min(dum,0._r8) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2/deltat/precip_frac(i,k) + + ! don't divide ice_sublim by cloud fraction since it is grid-averaged + dum1 = (1._r8-dum1-dum2) + ice_sublim(i,k) = dum*dum1/deltat + end if + end if + + end do + + ! Big "administration" loop enforces conservation, updates variables + ! that accumulate over substeps, and sets output variables. + + do i=1,mgncol + + ! get tendencies due to microphysical conversion processes + !========================================================== + ! note: tendencies are multiplied by appropriate cloud/precip + ! fraction to get grid-scale values + ! note: vap_dep is already grid-average values + + ! The net tendencies need to be added to rather than overwritten, + ! because they may have a value already set for instantaneous + ! melting/freezing. + + qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)-& + vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) + + 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) + + 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) + + 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)- & + 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) + 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) + + 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)+ & + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + + cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! add output for cmei (accumulate) + cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! assign variables for trop_mozart, these are grid-average + !------------------------------------------------------------------- + ! evaporation/sublimation is stored here as positive term + + evapsnow(i,k) = -prds(i,k)*precip_frac(i,k) + nevapr(i,k) = -pre(i,k)*precip_frac(i,k) + prer_evap(i,k) = -pre(i,k)*precip_frac(i,k) + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) + qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + ! Avoid zero/near-zero division. + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / & + max(qc(i,k),1.0e-30_r8) + + + ! microphysics output, note this is grid-averaged + pratot(i,k) = pra(i,k)*lcldm(i,k) + prctot(i,k) = prc(i,k)*lcldm(i,k) + mnuccctot(i,k) = mnuccc(i,k)*lcldm(i,k) + mnuccttot(i,k) = mnucct(i,k)*lcldm(i,k) + msacwitot(i,k) = msacwi(i,k)*lcldm(i,k) + psacwstot(i,k) = psacws(i,k)*lcldm(i,k) + bergstot(i,k) = bergs(i,k)*lcldm(i,k) + bergtot(i,k) = berg(i,k) + prcitot(i,k) = prci(i,k)*icldm(i,k) + praitot(i,k) = prai(i,k)*icldm(i,k) + mnuccdtot(i,k) = mnuccd(i,k)*icldm(i,k) + + pracstot(i,k) = pracs(i,k)*precip_frac(i,k) + mnuccrtot(i,k) = mnuccr(i,k)*precip_frac(i,k) +!AL + mnuccritot(i,k) = mnuccri(i,k)*precip_frac(i,k) + mnudeptot(i,k)=mnudep(i,k)*lcldm(i,k) + + ! microphysics output for number concentration tendencies + ! for liq. + nnuccctot(i,k)=nnuccc(i,k)*lcldm(i,k) + nnuccttot(i,k)=nnucct(i,k)*lcldm(i,k) + npsacwstot(i,k)=npsacws(i,k)*lcldm(i,k) + nsubctot(i,k)=nsubc(i,k)*lcldm(i,k) + 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) + 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) + nnudeptot(i,k)=nnudep(i,k)*lcldm(i,k) + nnuccdtot(i,k)=nnuccd(i,k) + nnuccritot(i,k) = nnuccri(i,k)*precip_frac(i,k) + +!AL + + + nctend(i,k) = nctend(i,k)+& + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + -npra(i,k)-nprc1(i,k))*lcldm(i,k) + + if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = 0._r8 + end if + nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ & + (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 + + nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ & + nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k)+ & + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & + -nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) + + ! make sure that ni at advanced time step does not exceed + ! maximum (existing N + source terms*dt), which is possible if mtime < deltat + ! 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 + nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) + end if + + end do + + ! End of "administration" loop + + end do micro_vert_loop ! end k loop + + !----------------------------------------------------- + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + qrout = qr + nrout = nr * rho + qsout = qs + nsout = ns * rho + + ! calculate n0r and lamr from rain mass and number + ! divide by precip fraction to get in-precip (local) values of + ! rain mass and number, divide by rhow to get rain number in kg^-1 + + do k=1,nlev + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) + + ! Calculate rercld + + ! calculate mean size of combined rain and cloud water + + call calc_rercld(lamr(:,k), n0r(:,k), lamc(:,k), pgam(:,k), qric(:,k), qcic(1:mgncol,k), ncic(:,k), & + rercld(:,k), mgncol) + + enddo + + ! Assign variables back to start-of-timestep values + ! Some state variables are changed before the main microphysics loop + ! to make "instantaneous" adjustments. Afterward, we must move those changes + ! back into the tendencies. + ! These processes: + ! - Droplet activation (npccn, impacts nc) + ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) + ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) + !================================================================================ + + ! Re-apply droplet activation tendency + nc = ncn + nctend = nctend + npccn +!AL + npccntot = npccn +!AL + + ! Re-apply rain freezing and snow melting. + dum_2D = qs + qs = qsn + qstend = qstend + (dum_2D-qs)/deltat + + dum_2D = ns + ns = nsn + nstend = nstend + (dum_2D-ns)/deltat + + dum_2D = qr + qr = qrn + qrtend = qrtend + (dum_2D-qr)/deltat + + dum_2D = nr + nr = nrn + nrtend = nrtend + (dum_2D-nr)/deltat + + !............................................................................. + + !================================================================================ + + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr = nevapr + evapsnow + prain = prain + prodsnow + + + + do k=1,nlev + + do i=1,mgncol + + ! calculate sedimentation for cloud water and ice + !================================================================================ + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8) + + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8) + + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + enddo + enddo + + do k=1,nlev + + ! obtain new slope parameter to avoid possible singularity + + call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) + + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + + if (dumc(i,k).ge.qsmall) then + + vtrmc(i,k)=acn(i,k)*gamma(4._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+4._r8)) + + fc(i,k) = g*rho(i,k)*vtrmc(i,k) + + fnc(i,k) = g*rho(i,k)* & + acn(i,k)*gamma(1._r8+bc+pgam(i,k))/ & + (lamc(i,k)**bc*gamma(pgam(i,k)+1._r8)) + else + fc(i,k) = 0._r8 + fnc(i,k)= 0._r8 + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k).ge.qsmall) then + + vtrmi(i,k)=min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), & + 1.2_r8*rhof(i,k)) + + fi(i,k) = g*rho(i,k)*vtrmi(i,k) + fni(i,k) = g*rho(i,k)* & + min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k)) + + ! adjust the ice fall velocity for smaller (r < 20 um) ice + ! particles (blend over 18-20 um) + irad = 1.5_r8 / lami(i,k) * 1e6_r8 + ifrac = min(1._r8, max(0._r8, (irad - 18._r8) / 2._r8)) + + if (ifrac .lt. 1._r8) then + vtrmi(i,k) = ifrac * vtrmi(i,k) + & + (1._r8 - ifrac) * & + min(ajn(i,k)*gamma_bj_plus4/(6._r8*lami(i,k)**bj), & + 1.2_r8*rhof(i,k)) + + fi(i,k) = g*rho(i,k)*vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + & + (1._r8 - ifrac) * & + g*rho(i,k)* & + min(ajn(i,k)*gamma_bj_plus1/lami(i,k)**bj,1.2_r8*rhof(i,k)) + end if + else + fi(i,k) = 0._r8 + fni(i,k)= 0._r8 + end if + + enddo + + enddo + + do k=1,nlev + + ! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) + enddo + + do k=1,nlev + + do i=1,mgncol + if (lamr(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + unr(i,k) = min(arn(i,k)*gamma_br_plus1/lamr(i,k)**br,9.1_r8*rhof(i,k)) + umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*lamr(i,k)**br),9.1_r8*rhof(i,k)) + + fr(i,k) = g*rho(i,k)*umr(i,k) + fnr(i,k) = g*rho(i,k)*unr(i,k) + + else + fr(i,k)=0._r8 + fnr(i,k)=0._r8 + end if + + ! fallspeed for snow + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k)) + + if (lams(i,k).ge.qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*lams(i,k)**bs),1.2_r8*rhof(i,k)) + uns(i,k) = min(asn(i,k)*gamma_bs_plus1/lams(i,k)**bs,1.2_r8*rhof(i,k)) + + fs(i,k) = g*rho(i,k)*ums(i,k) + fns(i,k) = g*rho(i,k)*uns(i,k) + + else + fs(i,k)=0._r8 + fns(i,k)=0._r8 + end if + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8) + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8) + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8) + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + enddo + end do !!! vertical loop + + do k=1,nlev + do i=1,mgncol + pdel_inv(i,k) = 1._r8/pdel(i,k) + enddo + enddo + + ! initialize nstep for sedimentation sub-steps + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + do i=1,mgncol + nstep = 1 + int(max( & + maxval( fi(i,:)*pdel_inv(i,:)), & + maxval(fni(i,:)*pdel_inv(i,:))) & + * deltat) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + if (do_cldice) then + falouti = fi(i,:) * dumi(i,:) + faloutni = fni(i,:) * dumni(i,:) + else + falouti = 0._r8 + faloutni = 0._r8 + end if + + ! top of model + + k = 1 + + ! add fallout terms to microphysical tendencies + faltndi = falouti(k)/pdel(i,k) + faltndni = faloutni(k)/pdel(i,k) + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep +!AL + nisedtentot(i,k)=nisedtentot(i,k)-faltndni/nstep +!AL + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + do k = 2,nlev + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + ! note: this is not an issue with precip, since we assume max overlap + dum1=icldm(i,k)/icldm(i,k-1) + dum1=min(dum1,1._r8) + + faltndqie=(falouti(k)-falouti(k-1))/pdel(i,k) + faltndi=(falouti(k)-dum1*falouti(k-1))/pdel(i,k) + faltndni=(faloutni(k)-dum1*faloutni(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + + qitend(i,k) = qitend(i,k)-faltndi/nstep + nitend(i,k) = nitend(i,k)-faltndni/nstep + + ! sedimentation tendency for output + qisedten(i,k)=qisedten(i,k)-faltndi/nstep +!AL + nisedtentot(i,k)=nisedtentot(i,k)-faltndni/nstep +!AL + ! add terms to to evap/sub of cloud water + + qvlat(i,k)=qvlat(i,k)-(faltndqie-faltndi)/nstep + ! for output + qisevap(i,k)=qisevap(i,k)-(faltndqie-faltndi)/nstep + + tlat(i,k)=tlat(i,k)+(faltndqie-faltndi)*xxls/nstep + + dumi(i,k) = dumi(i,k)-faltndi*deltat/nstep + dumni(i,k) = dumni(i,k)-faltndni*deltat/nstep + + end do + + ! Ice flux + do k = 1,nlev + iflx(i,k+1) = iflx(i,k+1) + falouti(k) / g / real(nstep) + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i)+falouti(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouti(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fc(i,:)*pdel_inv(i,:)), & + maxval(fnc(i,:)*pdel_inv(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutc = fc(i,:) * dumc(i,:) + faloutnc = fnc(i,:) * dumnc(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndc = faloutc(k)/pdel(i,k) + faltndnc = faloutnc(k)/pdel(i,k) + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep +!AL + ncsedtentot(i,k)=ncsedtentot(i,k)-faltndnc/nstep +!AL + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + do k = 2,nlev + + dum=lcldm(i,k)/lcldm(i,k-1) + dum=min(dum,1._r8) + faltndqce=(faloutc(k)-faloutc(k-1))/pdel(i,k) + faltndc=(faloutc(k)-dum*faloutc(k-1))/pdel(i,k) + faltndnc=(faloutnc(k)-dum*faloutnc(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qctend(i,k) = qctend(i,k)-faltndc/nstep + nctend(i,k) = nctend(i,k)-faltndnc/nstep + + ! sedimentation tendency for output + qcsedten(i,k)=qcsedten(i,k)-faltndc/nstep +!AL + ncsedtentot(i,k)=ncsedtentot(i,k)-faltndnc/nstep +!AL + ! add terms to to evap/sub of cloud water + qvlat(i,k)=qvlat(i,k)-(faltndqce-faltndc)/nstep + ! for output + qcsevap(i,k)=qcsevap(i,k)-(faltndqce-faltndc)/nstep + + tlat(i,k)=tlat(i,k)+(faltndqce-faltndc)*xxlv/nstep + + dumc(i,k) = dumc(i,k)-faltndc*deltat/nstep + dumnc(i,k) = dumnc(i,k)-faltndnc*deltat/nstep + + end do + + !Liquid condensate flux here + do k = 1,nlev + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) / g / real(nstep) + end do + + prect(i) = prect(i)+faloutc(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fr(i,:)*pdel_inv(i,:)), & + maxval(fnr(i,:)*pdel_inv(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + faloutr = fr(i,:) * dumr(i,:) + faloutnr = fnr(i,:) * dumnr(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltndr = faloutr(k)/pdel(i,k) + faltndnr = faloutnr(k)/pdel(i,k) + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + + do k = 2,nlev + + faltndr=(faloutr(k)-faloutr(k-1))/pdel(i,k) + faltndnr=(faloutnr(k)-faloutnr(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qrtend(i,k) = qrtend(i,k)-faltndr/nstep + nrtend(i,k) = nrtend(i,k)-faltndnr/nstep + + ! sedimentation tendency for output + qrsedten(i,k)=qrsedten(i,k)-faltndr/nstep + + dumr(i,k) = dumr(i,k)-faltndr*deltat/real(nstep) + dumnr(i,k) = dumnr(i,k)-faltndnr*deltat/real(nstep) + + end do + + ! Rain Flux + do k = 1,nlev + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) / g / real(nstep) + end do + + prect(i) = prect(i)+faloutr(nlev)/g/real(nstep)/1000._r8 + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( & + maxval( fs(i,:)*pdel_inv(i,:)), & + maxval(fns(i,:)*pdel_inv(i,:))) & + * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + falouts = fs(i,:) * dums(i,:) + faloutns = fns(i,:) * dumns(i,:) + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + faltnds = falouts(k)/pdel(i,k) + faltndns = faloutns(k)/pdel(i,k) + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + do k = 2,nlev + + faltnds=(falouts(k)-falouts(k-1))/pdel(i,k) + faltndns=(faloutns(k)-faloutns(k-1))/pdel(i,k) + + ! add fallout terms to eulerian tendencies + qstend(i,k) = qstend(i,k)-faltnds/nstep + nstend(i,k) = nstend(i,k)-faltndns/nstep + + ! sedimentation tendency for output + qssedten(i,k)=qssedten(i,k)-faltnds/nstep + + dums(i,k) = dums(i,k)-faltnds*deltat/real(nstep) + dumns(i,k) = dumns(i,k)-faltndns*deltat/real(nstep) + + end do !! k loop + + ! Snow Flux + do k = 1,nlev + sflx(i,k+1) = sflx(i,k+1) + falouts(k) / g / real(nstep) + end do + + prect(i) = prect(i)+falouts(nlev)/g/real(nstep)/1000._r8 + preci(i) = preci(i)+falouts(nlev)/g/real(nstep)/1000._r8 + + end do !! nstep loop + + enddo + ! end sedimentation + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k)*lcldm(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k)*icldm(i,k) + end if + + if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8 + if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8 + if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8 + if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8 + + enddo + + enddo + + ! calculate instantaneous processes (melting, homogeneous freezing) + !==================================================================== + + ! melting of snow at +2 C + do k=1,nlev + + do i=1,mgncol + + if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then + if (dums(i,k) > 0._r8) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*dums(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf + dum = dum/dums(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qstend(i,k)=qstend(i,k)-dum*dums(i,k)/deltat + nstend(i,k)=nstend(i,k)-dum*dumns(i,k)/deltat + qrtend(i,k)=qrtend(i,k)+dum*dums(i,k)/deltat + nrtend(i,k)=nrtend(i,k)+dum*dumns(i,k)/deltat + + dum1=-xlf*dum*dums(i,k)/deltat + tlat(i,k)=tlat(i,k)+dum1 + meltsdttot(i,k)=meltsdttot(i,k) + dum1 + end if + end if + enddo + enddo + do k=1,nlev + do i=1,mgncol + + ! freezing of rain at -5 C + + if (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) then + + if (dumr(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*dumr(i,k) + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf + dum = dum/dumr(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qrtend(i,k)=qrtend(i,k)-dum*dumr(i,k)/deltat + nrtend(i,k)=nrtend(i,k)-dum*dumnr(i,k)/deltat + + ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice + ! depending on mean rain size + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), & + lamr(i,k)) + + if (lamr(i,k) < 1._r8/Dcs) then + qstend(i,k)=qstend(i,k)+dum*dumr(i,k)/deltat + nstend(i,k)=nstend(i,k)+dum*dumnr(i,k)/deltat + else + qitend(i,k)=qitend(i,k)+dum*dumr(i,k)/deltat + nitend(i,k)=nitend(i,k)+dum*dumnr(i,k)/deltat +!AL + frzr(i,k)=frzr(i,k)+dum*dumr(i,k)/deltat + nfrzr(i,k)=nfrzr(i,k)+dum*dumnr(i,k)/deltat +!AL + end if + + ! heating tendency + dum1 = xlf*dum*dumr(i,k)/deltat + frzrdttot(i,k)=frzrdttot(i,k) + dum1 + tlat(i,k)=tlat(i,k)+dum1 + + end if + end if + + enddo + enddo + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then + if (dumi(i,k) > 0._r8) then + + ! limit so that melting does not push temperature below freezing + !----------------------------------------------------------------- + dum = -dumi(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then + dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf + dum = dum/dumi(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qctend(i,k)=qctend(i,k)+dum*dumi(i,k)/deltat + + ! for output + melttot(i,k)=dum*dumi(i,k)/deltat + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + nctend(i,k)=nctend(i,k)+3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + +!AL + ! for output + nmelttot(i,k)=3._r8*dum*dumi(i,k)/deltat/ & + (4._r8*pi*5.12e-16_r8*rhow) + nimelttot(i,k)=nitend(i,k)-((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat +!AL + + qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))/deltat + nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))/deltat + tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)/deltat + end if + end if + enddo + enddo + + ! homogeneously freeze droplets at -40 C + !----------------------------------------------------------------- + + do k=1,nlev + do i=1,mgncol + if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then + if (dumc(i,k) > 0._r8) then + + ! limit so that freezing does not push temperature above threshold + dum = dumc(i,k)*xlf/cpp + if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then + dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf + dum = dum/dumc(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + + qitend(i,k)=qitend(i,k)+dum*dumc(i,k)/deltat + ! for output + homotot(i,k)=dum*dumc(i,k)/deltat + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + nitend(i,k)=nitend(i,k)+dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat + qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))/deltat + +!AL + nhomotot(i,k)=nctend(i,k)-((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + nihomotot(i,k)=dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*1.563e-14_r8* & + 500._r8)/deltat +!AL + nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))/deltat + tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)/deltat + end if + end if + enddo + enddo + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + !----------------------------------------------------------------- + ! follow code similar to old CAM scheme + do k=1,nlev + do i=1,mgncol + + qtmp=q(i,k)+qvlat(i,k)*deltat + ttmp=t(i,k)+tlat(i,k)/cpp*deltat + + ! use rhw to allow ice supersaturation + call qsat_water(ttmp, p(i,k), esn, qvn) + + if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qvn)/(1._r8+xxlv_squared*qvn/(cpp*rv*ttmp**2))/deltat + ! add to output cme + cmeout(i,k) = cmeout(i,k)+dum + ! now add to tendencies, partition between liquid and ice based on temperature + if (ttmp > 268.15_r8) then + dum1=0.0_r8 + ! now add to tendencies, partition between liquid and ice based on te + !------------------------------------------------------- + else if (ttmp < 238.15_r8) then + dum1=1.0_r8 + else + dum1=(268.15_r8-ttmp)/30._r8 + end if + + dum = (qtmp-qvn)/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 & + *qvn/(cpp*rv*ttmp**2))/deltat + qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1) + ! for output + qcrestot(i,k)=dum*(1._r8-dum1) + qitend(i,k)=qitend(i,k)+dum*dum1 + qirestot(i,k)=dum*dum1 + qvlat(i,k)=qvlat(i,k)-dum + ! for output + qvres(i,k)=-dum + tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls + end if + enddo + enddo + end if + + ! calculate effective radius for pass to radiation code + !========================================================= + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k)=ncnst/rho(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k)=ninst/rho(i,k) + end if + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 + dumc(i,k)=min(dumc(i,k),5.e-3_r8) + dumi(i,k)=min(dumi(i,k),5.e-3_r8) + ! limit in-precip mixing ratios + dumr(i,k)=min(dumr(i,k),10.e-3_r8) + dums(i,k)=min(dums(i,k),10.e-3_r8) + enddo + enddo + ! cloud ice effective radius + !----------------------------------------------------------------- + + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (dumi(i,k).ge.qsmall) then + + dum_2D(i,k) = dumni(i,k) + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k), dumni0) + + if (dumni(i,k) /=dum_2D(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + if (dumni(i,k) cm2/cm3 + + else + effi(i,k) = 25._r8 + sadice(i,k) = 0._r8 + end if + + ! ice effective diameter for david mitchell's optics + deffi(i,k)=effi(i,k)*rhoi/rhows*2._r8 + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um + deffi(i,k)=effi(i,k) * 2._r8 + sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 + enddo + enddo + end if + + ! cloud droplet effective radius + !----------------------------------------------------------------- + do k=1,nlev + do i=1,mgncol + if (dumc(i,k).ge.qsmall) then + + + ! switch for specification of droplet and crystal number + if (nccons) then + ! make sure nc is consistence with the constant N by adjusting tendency, need + ! to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet size is + ! out of bounds + + nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))/deltat + + end if + + dum = dumnc(i,k) + + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + if (dum /= dumnc(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + if (dumnc(i,k) cm2/cm3 + + end if + + + end do ! vertical k loop + enddo + do k=1,nlev + do i=1,mgncol + ! if updated q (after microphysics) is zero, then ensure updated n is also zero + !================================================================================= + if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) then !AL + nctnncld(i,k) = nctnncld(i,k) + nctend(i,k) +nc(i,k)/deltat !AL + nctend(i,k)=-nc(i,k)/deltat + endif + if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall)then !AL + nitnncld(i,k) = nitnncld(i,k) + nitend(i,k) +ni(i,k)/deltat + nitend(i,k)=-ni(i,k)/deltat + endif + if (qr(i,k)+qrtend(i,k)*deltat.lt.qsmall) nrtend(i,k)=-nr(i,k)/deltat + if (qs(i,k)+qstend(i,k)*deltat.lt.qsmall) nstend(i,k)=-ns(i,k)/deltat + + end do + + end do + + ! DO STUFF FOR OUTPUT: + !================================================== + + ! qc and qi are only used for output calculations past here, + ! so add qctend and qitend back in one more time + qc = qc + qctend*deltat + qi = qi + qitend*deltat + + ! averaging for snow and rain number and diameter + !-------------------------------------------------- + + ! drout2/dsout2: + ! diameter of rain and snow + ! dsout: + ! scaled diameter of snow (passed to radiation in CAM) + ! reff_rain/reff_snow: + ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual + + where (qrout .gt. 1.e-7_r8 & + .and. nrout.gt.0._r8) + qrout2 = qrout * precip_frac + nrout2 = nrout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just drout2 times constants. + drout2 = avg_diameter(qrout, nrout, rho, rhow) + freqr = precip_frac + + reff_rain=1.5_r8*drout2*1.e6_r8 + elsewhere + qrout2 = 0._r8 + nrout2 = 0._r8 + drout2 = 0._r8 + freqr = 0._r8 + reff_rain = 0._r8 + end where + + where (qsout .gt. 1.e-7_r8 & + .and. nsout.gt.0._r8) + qsout2 = qsout * precip_frac + nsout2 = nsout * precip_frac + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just dsout2 times constants. + dsout2 = avg_diameter(qsout, nsout, rho, rhosn) + freqs = precip_frac + + dsout=3._r8*rhosn/rhows*dsout2 + + reff_snow=1.5_r8*dsout2*1.e6_r8 + elsewhere + dsout = 0._r8 + qsout2 = 0._r8 + nsout2 = 0._r8 + dsout2 = 0._r8 + freqs = 0._r8 + reff_snow=0._r8 + end where + + ! analytic radar reflectivity + !-------------------------------------------------- + ! formulas from Matthew Shupe, NOAA/CERES + ! *****note: radar reflectivity is local (in-precip average) + ! units of mm^6/m^3 + + do i = 1,mgncol + do k=1,nlev + if (qc(i,k).ge.qsmall .and. (nc(i,k)+nctend(i,k)*deltat).gt.10._r8) then + dum=(qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & + /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) + else + dum=0._r8 + end if + if (qi(i,k).ge.qsmall) then + dum1=(qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/precip_frac(i,k) + else + dum1=0._r8 + end if + + if (qsout(i,k).ge.qsmall) then + dum1=dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8) + end if + + refl(i,k)=dum+dum1 + + ! add rain rate, but for 37 GHz formulation instead of 94 GHz + ! formula approximated from data of Matrasov (2007) + ! rainrt is the rain rate in mm/hr + ! reflectivity (dum) is in DBz + + if (rainrt(i,k).ge.0.001_r8) then + dum=log10(rainrt(i,k)**6._r8)+16._r8 + + ! convert from DBz to mm^6/m^3 + + dum = 10._r8**(dum/10._r8) + else + ! don't include rain rate in R calculation for values less than 0.001 mm/hr + dum=0._r8 + end if + + ! add to refl + + refl(i,k)=refl(i,k)+dum + + !output reflectivity in Z. + areflz(i,k)=refl(i,k) * precip_frac(i,k) + + ! convert back to DBz + + if (refl(i,k).gt.minrefl) then + refl(i,k)=10._r8*log10(refl(i,k)) + else + refl(i,k)=-9999._r8 + end if + + !set averaging flag + if (refl(i,k).gt.mindbz) then + arefl(i,k)=refl(i,k) * precip_frac(i,k) + frefl(i,k)=precip_frac(i,k) + else + arefl(i,k)=0._r8 + areflz(i,k)=0._r8 + frefl(i,k)=0._r8 + end if + + ! bound cloudsat reflectivity + + csrfl(i,k)=min(csmax,refl(i,k)) + + !set averaging flag + if (csrfl(i,k).gt.csmin) then + acsrfl(i,k)=refl(i,k) * precip_frac(i,k) + fcsrfl(i,k)=precip_frac(i,k) + else + acsrfl(i,k)=0._r8 + fcsrfl(i,k)=0._r8 + end if + + end do + end do + + !redefine fice here.... + dum_2D = qsout + qrout + qc + qi + dumi = qsout + qi + where (dumi .gt. qsmall .and. dum_2D .gt. qsmall) + nfice=min(dumi/dum_2D,1._r8) + elsewhere + nfice=0._r8 + end where + +end subroutine micro_mg_tend + +!======================================================================== +!OUTPUT CALCULATIONS +!======================================================================== + +subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol) + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: lamr ! rain size parameter (slope) + real(r8), dimension(mgncol), intent(in) :: n0r ! rain size parameter (intercept) + real(r8), dimension(mgncol), intent(in) :: lamc ! size distribution parameter (slope) + real(r8), dimension(mgncol), intent(in) :: pgam ! droplet size parameter + real(r8), dimension(mgncol), intent(in) :: qric ! in-cloud rain mass mixing ratio + real(r8), dimension(mgncol), intent(in) :: qcic ! in-cloud cloud liquid + real(r8), dimension(mgncol), intent(in) :: ncic ! in-cloud droplet number concentration + + real(r8), dimension(mgncol), intent(inout) :: rercld ! effective radius calculation for rain + cloud + + ! combined size of precip & cloud drops + real(r8) :: Atmp + + integer :: i + + do i=1,mgncol + ! Rain drops + if (lamr(i) > 0._r8) then + Atmp = n0r(i) * pi / (2._r8 * lamr(i)**3._r8) + else + Atmp = 0._r8 + end if + + ! Add cloud drops + if (lamc(i) > 0._r8) then + Atmp = Atmp + & + ncic(i) * pi * rising_factorial(pgam(i)+1._r8, 2)/(4._r8 * lamc(i)**2._r8) + end if + + if (Atmp > 0._r8) then + rercld(i) = rercld(i) + 3._r8 *(qric(i) + qcic(i)) / (4._r8 * rhow * Atmp) + end if + enddo +end subroutine calc_rercld + +!======================================================================== +!UTILITIES +!======================================================================== + +pure subroutine micro_mg_get_cols(ncol, nlev, top_lev, qcn, qin, & + qrn, qsn, mgncol, mgcols) + + ! Determines which columns microphysics should operate over by + ! checking for non-zero cloud water/ice. + + integer, intent(in) :: ncol ! Number of columns with meaningful data + integer, intent(in) :: nlev ! Number of levels to use + integer, intent(in) :: top_lev ! Top level for microphysics + + real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg) + + integer, intent(out) :: mgncol ! Number of columns MG will use + integer, allocatable, intent(out) :: mgcols(:) ! column indices + + integer :: lev_offset ! top_lev - 1 (defined here for consistency) + logical :: ltrue(ncol) ! store tests for each column + + integer :: i, ii ! column indices + + if (allocated(mgcols)) deallocate(mgcols) + + lev_offset = top_lev - 1 + + ! Using "any" along dimension 2 collapses across levels, but + ! not columns, so we know if water is present at any level + ! in each column. + + ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qrn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + ltrue = ltrue .or. any(qsn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2) + + ! Scan for true values to get a usable list of indices. + + mgncol = count(ltrue) + allocate(mgcols(mgncol)) + i = 0 + do ii = 1,ncol + if (ltrue(ii)) then + i = i + 1 + mgcols(i) = ii + end if + end do + +end subroutine micro_mg_get_cols + +end module micro_mg2_0 diff --git a/src/NorESM/micro_mg_cam.F90 b/src/NorESM/micro_mg_cam.F90 new file mode 100644 index 0000000000..bbae68e378 --- /dev/null +++ b/src/NorESM/micro_mg_cam.F90 @@ -0,0 +1,3375 @@ +module micro_mg_cam + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for MG microphysics +! +!--------------------------------------------------------------------------------- +! +! How to add new packed MG inputs to micro_mg_cam_tend: +! +! If you have an input with first dimension [psetcols, pver], the procedure +! for adding inputs is as follows: +! +! 1) In addition to any variables you need to declare for the "unpacked" +! (CAM format) version, you must declare an array for the "packed" +! (MG format) version. +! +! 2) Add a call similar to the following line (look before the +! micro_mg_tend calls to see similar lines): +! +! packed_array = packer%pack(original_array) +! +! The packed array can then be passed into any of the MG schemes. +! +! This same procedure will also work for 1D arrays of size psetcols, 3-D +! arrays with psetcols and pver as the first dimensions, and for arrays of +! dimension [psetcols, pverp]. You only have to modify the allocation of +! the packed array before the "pack" call. +! +!--------------------------------------------------------------------------------- +! +! How to add new packed MG outputs to micro_mg_cam_tend: +! +! 1) As with inputs, in addition to the unpacked outputs you must declare +! an array for packed data. The unpacked and packed arrays must *also* +! be targets or pointers (but cannot be both). +! +! 2) Add the field to post-processing as in the following line (again, +! there are many examples before the micro_mg_tend calls): +! +! call post_proc%add_field(p(final_array),p(packed_array)) +! +! *** IMPORTANT ** If the fields are only being passed to a certain version of +! MG, you must only add them if that version is being called (see +! the "if (micro_mg_version >1)" sections below +! +! This registers the field for post-MG averaging, and to scatter to the +! final, unpacked version of the array. +! +! By default, any columns/levels that are not operated on by MG will be +! set to 0 on output; this value can be adjusted using the "fillvalue" +! optional argument to post_proc%add_field. +! +! Also by default, outputs from multiple substeps will be averaged after +! MG's substepping is complete. Passing the optional argument +! "accum_method=accum_null" will change this behavior so that the last +! substep is always output. +! +! This procedure works on 1-D and 2-D outputs. Note that the final, +! unpacked arrays are not set until the call to +! "post_proc%process_and_unpack", which sets every single field that was +! added with post_proc%add_field. +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp, psubcols +use physconst, only: gravit, rair, tmelt, cpair, rh2o, rhoh2o, & + latvap, latice, mwh2o +use phys_control, only: phys_getopts, use_hetfrz_classnuc + + +use physics_types, only: physics_state, physics_ptend, & + physics_ptend_init, physics_state_copy, & + physics_update, physics_state_dealloc, & + physics_ptend_sum, physics_ptend_scale + +use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dyn_time_lvls, & + pbuf_old_tim_idx, pbuf_get_index, dtype_r8, dtype_i4, & + pbuf_get_field, pbuf_set_field, col_type_subcol, & + pbuf_register_subcol +use constituents, only: cnst_add, cnst_get_ind, & + cnst_name, cnst_longname, sflxnam, apcnst, bpcnst, pcnst + +use cldfrc2m, only: rhmini=>rhmini_const + +use cam_history, only: addfld, add_default, outfld, horiz_only + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use scamMod, only: single_column +use error_messages, only: handle_errmsg +use ref_pres, only: top_lev=>trop_cloud_top_lev + +use subcol_utils, only: subcol_get_scheme + +implicit none +private +save + +public :: & + micro_mg_cam_readnl, & + micro_mg_cam_register, & + micro_mg_cam_init_cnst, & + micro_mg_cam_implements_cnst, & + micro_mg_cam_init, & + micro_mg_cam_tend, & + micro_mg_version + +integer :: micro_mg_version = 1 ! Version number for MG. +integer :: micro_mg_sub_version = 0 ! Second part of version number. + +real(r8) :: micro_mg_dcs = -1._r8 + +logical :: microp_uniform = .false. +logical :: micro_mg_adjust_cpt = .false. + +character(len=16) :: micro_mg_precip_frac_method = 'max_overlap' ! type of precipitation fraction method + +real(r8) :: micro_mg_berg_eff_factor = 1.0_r8 ! berg efficiency factor + +logical, public :: do_cldliq ! Prognose cldliq flag +logical, public :: do_cldice ! Prognose cldice flag + +integer :: num_steps ! Number of MG substeps + +integer :: ncnst = 4 ! Number of constituents + +! Namelist variables for option to specify constant cloud droplet/ice number +logical :: micro_mg_nccons = .false. ! set .true. to specify constant cloud droplet number +logical :: micro_mg_nicons = .false. ! set .true. to specify constant cloud ice number +! parameters for specified ice and droplet number concentration +! note: these are local in-cloud values, not grid-mean +real(r8) :: micro_mg_ncnst = 100.e6_r8 ! constant droplet num concentration (m-3) +real(r8) :: micro_mg_ninst = 0.1e6_r8 ! constant ice num concentration (m-3) + +character(len=8), parameter :: & ! Constituent names + cnst_names(8) = (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE', & + 'RAINQM', 'SNOWQM','NUMRAI','NUMSNO'/) + +integer :: & + ixcldliq = -1, &! cloud liquid amount index + ixcldice = -1, &! cloud ice amount index + ixnumliq = -1, &! cloud liquid number index + ixnumice = -1, &! cloud ice water index + ixrain = -1, &! rain index + ixsnow = -1, &! snow index + ixnumrain = -1, &! rain number index + ixnumsnow = -1 ! snow number index + +! Physics buffer indices for fields registered by this module +integer :: & + cldo_idx, & + qme_idx, & + prain_idx, & + nevapr_idx, & + wsedl_idx, & + rei_idx, & + sadice_idx, & + sadsnow_idx, & + rel_idx, & + dei_idx, & + mu_idx, & + prer_evap_idx, & + lambdac_idx, & + iciwpst_idx, & + iclwpst_idx, & + des_idx, & + icswp_idx, & + cldfsnow_idx, & + rate1_cw2pr_st_idx = -1, & + ls_flxprc_idx, & + ls_flxsnw_idx, & + relvar_idx, & + cmeliq_idx, & + accre_enhan_idx + +! Fields for UNICON +integer :: & + am_evp_st_idx, &! Evaporation area of stratiform precipitation + evprain_st_idx, &! Evaporation rate of stratiform rain [kg/kg/s]. >= 0. + evpsnow_st_idx ! Evaporation rate of stratiform snow [kg/kg/s]. >= 0. + +! Fields needed as inputs to COSP +integer :: & + ls_mrprc_idx, ls_mrsnw_idx, & + ls_reffrain_idx, ls_reffsnow_idx, & + cv_reffliq_idx, cv_reffice_idx + +! Fields needed by Park macrophysics +integer :: & + cc_t_idx, cc_qv_idx, & + cc_ql_idx, cc_qi_idx, & + cc_nl_idx, cc_ni_idx, & + cc_qlst_idx + +! Used to replace aspects of MG microphysics +! (e.g. by CARMA) +integer :: & + tnd_qsnow_idx = -1, & + tnd_nsnow_idx = -1, & + re_ice_idx = -1 + +! Index fields for precipitation efficiency. +integer :: & + acpr_idx = -1, & + acgcme_idx = -1, & + acnum_idx = -1 + +! Physics buffer indices for fields registered by other modules +integer :: & + ast_idx = -1, & + cld_idx = -1, & + concld_idx = -1, & + qsatfac_idx = -1 + +! Pbuf fields needed for subcol_SILHS +integer :: & + qrain_idx=-1, qsnow_idx=-1, & + nrain_idx=-1, nsnow_idx=-1 + +integer :: & + naai_idx = -1, & + naai_hom_idx = -1, & + npccn_idx = -1, & + rndst_idx = -1, & + nacon_idx = -1, & + prec_str_idx = -1, & + snow_str_idx = -1, & + prec_pcw_idx = -1, & + snow_pcw_idx = -1, & + prec_sed_idx = -1, & + snow_sed_idx = -1 + +! pbuf fields for heterogeneous freezing +integer :: & + frzimm_idx = -1, & + frzcnt_idx = -1, & + frzdep_idx = -1 + + logical :: allow_sed_supersat ! allow supersaturated conditions after sedimentation loop + logical :: micro_do_sb_physics = .false. ! do SB 2001 autoconversion and accretion + +interface p + module procedure p1 + module procedure p2 +end interface p + + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg_cam_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_real8, & + mpi_logical, mpi_character + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Namelist variables + logical :: micro_mg_do_cldice = .true. ! do_cldice = .true., MG microphysics is prognosing cldice + logical :: micro_mg_do_cldliq = .true. ! do_cldliq = .true., MG microphysics is prognosing cldliq + integer :: micro_mg_num_steps = 1 ! Number of substepping iterations done by MG (1.5 only for now). + + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'micro_mg_cam_readnl' + + namelist /micro_mg_nl/ micro_mg_version, micro_mg_sub_version, & + micro_mg_do_cldice, micro_mg_do_cldliq, micro_mg_num_steps, & + microp_uniform, micro_mg_dcs, micro_mg_precip_frac_method, & + micro_mg_berg_eff_factor, micro_do_sb_physics, micro_mg_adjust_cpt, & + micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, micro_mg_ninst + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'micro_mg_nl', status=ierr) + if (ierr == 0) then + read(unitn, micro_mg_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + ! set local variables + do_cldice = micro_mg_do_cldice + do_cldliq = micro_mg_do_cldliq + num_steps = micro_mg_num_steps + + ! Verify that version numbers are valid. + select case (micro_mg_version) + case (1) + select case (micro_mg_sub_version) + case(0) + ! MG version 1.0 + case default + call bad_version_endrun() + end select + case (2) + select case (micro_mg_sub_version) + case(0) + ! MG version 2.0 + case default + call bad_version_endrun() + end select + case default + call bad_version_endrun() + end select + + if (micro_mg_dcs < 0._r8) call endrun( "micro_mg_cam_readnl: & + µ_mg_dcs has not been set to a valid value.") + end if + + ! Broadcast namelist variables + call mpi_bcast(micro_mg_version, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_version") + + call mpi_bcast(micro_mg_sub_version, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_sub_version") + + call mpi_bcast(do_cldice, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldice") + + call mpi_bcast(do_cldliq, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: do_cldliq") + + call mpi_bcast(num_steps, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: num_steps") + + call mpi_bcast(microp_uniform, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: microp_uniform") + + call mpi_bcast(micro_mg_dcs, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_dcs") + + call mpi_bcast(micro_mg_berg_eff_factor, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_berg_eff_factor") + + call mpi_bcast(micro_mg_precip_frac_method, 16, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_precip_frac_method") + + call mpi_bcast(micro_do_sb_physics, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_do_sb_physics") + + call mpi_bcast(micro_mg_adjust_cpt, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_adjust_cpt") + + call mpi_bcast(micro_mg_nccons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nccons") + + call mpi_bcast(micro_mg_nicons, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_nicons") + + call mpi_bcast(micro_mg_ncnst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ncnst") + + call mpi_bcast(micro_mg_ninst, 1, mpi_real8, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: micro_mg_ninst") + + if (masterproc) then + + write(iulog,*) 'MG microphysics namelist:' + write(iulog,*) ' micro_mg_version = ', micro_mg_version + write(iulog,*) ' micro_mg_sub_version = ', micro_mg_sub_version + write(iulog,*) ' micro_mg_do_cldice = ', do_cldice + write(iulog,*) ' micro_mg_do_cldliq = ', do_cldliq + write(iulog,*) ' micro_mg_num_steps = ', num_steps + write(iulog,*) ' microp_uniform = ', microp_uniform + write(iulog,*) ' micro_mg_dcs = ', micro_mg_dcs + write(iulog,*) ' micro_mg_berg_eff_factor = ', micro_mg_berg_eff_factor + write(iulog,*) ' micro_mg_precip_frac_method = ', micro_mg_precip_frac_method + write(iulog,*) ' micro_do_sb_physics = ', micro_do_sb_physics + write(iulog,*) ' micro_mg_adjust_cpt = ', micro_mg_adjust_cpt + write(iulog,*) ' micro_mg_nccons = ', micro_mg_nccons + write(iulog,*) ' micro_mg_nicons = ', micro_mg_nicons + write(iulog,*) ' micro_mg_ncnst = ', micro_mg_ncnst + write(iulog,*) ' micro_mg_ninst = ', micro_mg_ninst + end if + +contains + + subroutine bad_version_endrun + ! Endrun wrapper with a more useful error message. + character(len=128) :: errstring + write(errstring,*) "Invalid version number specified for MG microphysics: ", & + micro_mg_version,".",micro_mg_sub_version + call endrun(errstring) + end subroutine bad_version_endrun + +end subroutine micro_mg_cam_readnl + +!================================================================================================ + +subroutine micro_mg_cam_register + + ! Register microphysics constituents and fields in the physics buffer. + !----------------------------------------------------------------------- + + logical :: prog_modal_aero + logical :: use_subcol_microp ! If true, then are using subcolumns in microphysics + + call phys_getopts(use_subcol_microp_out = use_subcol_microp, & + prog_modal_aero_out = prog_modal_aero) + + ! Register microphysics constituents and save indices. + + call cnst_add(cnst_names(1), mwh2o, cpair, 0._r8, ixcldliq, & + longname='Grid box averaged cloud liquid amount', is_convtran1=.true.) + call cnst_add(cnst_names(2), mwh2o, cpair, 0._r8, ixcldice, & + longname='Grid box averaged cloud ice amount', is_convtran1=.true.) + + call cnst_add(cnst_names(3), mwh2o, cpair, 0._r8, ixnumliq, & + longname='Grid box averaged cloud liquid number', is_convtran1=.true.) + call cnst_add(cnst_names(4), mwh2o, cpair, 0._r8, ixnumice, & + longname='Grid box averaged cloud ice number', is_convtran1=.true.) + + ! Note is_convtran1 is set to .true. + if (micro_mg_version > 1) then + call cnst_add(cnst_names(5), mwh2o, cpair, 0._r8, ixrain, & + longname='Grid box averaged rain amount', is_convtran1=.true.) + call cnst_add(cnst_names(6), mwh2o, cpair, 0._r8, ixsnow, & + longname='Grid box averaged snow amount', is_convtran1=.true.) + call cnst_add(cnst_names(7), mwh2o, cpair, 0._r8, ixnumrain, & + longname='Grid box averaged rain number', is_convtran1=.true.) + call cnst_add(cnst_names(8), mwh2o, cpair, 0._r8, ixnumsnow, & + longname='Grid box averaged snow number', is_convtran1=.true.) + end if + + ! Request physics buffer space for fields that persist across timesteps. + + call pbuf_add_field('CLDO','global',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldo_idx) + + ! Physics buffer variables for convective cloud properties. + + call pbuf_add_field('QME', 'physpkg',dtype_r8,(/pcols,pver/), qme_idx) + call pbuf_add_field('PRAIN', 'physpkg',dtype_r8,(/pcols,pver/), prain_idx) + call pbuf_add_field('NEVAPR', 'physpkg',dtype_r8,(/pcols,pver/), nevapr_idx) + call pbuf_add_field('PRER_EVAP', 'global', dtype_r8,(/pcols,pver/), prer_evap_idx) + + call pbuf_add_field('WSEDL', 'physpkg',dtype_r8,(/pcols,pver/), wsedl_idx) + + call pbuf_add_field('REI', 'physpkg',dtype_r8,(/pcols,pver/), rei_idx) + call pbuf_add_field('SADICE', 'physpkg',dtype_r8,(/pcols,pver/), sadice_idx) + call pbuf_add_field('SADSNOW', 'physpkg',dtype_r8,(/pcols,pver/), sadsnow_idx) + call pbuf_add_field('REL', 'physpkg',dtype_r8,(/pcols,pver/), rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_add_field('DEI', 'physpkg',dtype_r8,(/pcols,pver/), dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('MU', 'physpkg',dtype_r8,(/pcols,pver/), mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_add_field('LAMBDAC', 'physpkg',dtype_r8,(/pcols,pver/), lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_add_field('ICIWPST', 'physpkg',dtype_r8,(/pcols,pver/), iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_add_field('ICLWPST', 'physpkg',dtype_r8,(/pcols,pver/), iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_add_field('DES', 'physpkg',dtype_r8,(/pcols,pver/), des_idx) + ! In cloud snow water path for radiation + call pbuf_add_field('ICSWP', 'physpkg',dtype_r8,(/pcols,pver/), icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_add_field('CLDFSNOW ', 'physpkg',dtype_r8,(/pcols,pver,dyn_time_lvls/), cldfsnow_idx) + + if (prog_modal_aero) then + call pbuf_add_field('RATE1_CW2PR_ST','physpkg',dtype_r8,(/pcols,pver/), rate1_cw2pr_st_idx) + endif + + call pbuf_add_field('LS_FLXPRC', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxprc_idx) + call pbuf_add_field('LS_FLXSNW', 'physpkg',dtype_r8,(/pcols,pverp/), ls_flxsnw_idx) + + + ! Fields needed as inputs to COSP + call pbuf_add_field('LS_MRPRC', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrprc_idx) + call pbuf_add_field('LS_MRSNW', 'physpkg',dtype_r8,(/pcols,pver/), ls_mrsnw_idx) + call pbuf_add_field('LS_REFFRAIN','physpkg',dtype_r8,(/pcols,pver/), ls_reffrain_idx) + call pbuf_add_field('LS_REFFSNOW','physpkg',dtype_r8,(/pcols,pver/), ls_reffsnow_idx) + call pbuf_add_field('CV_REFFLIQ', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffliq_idx) + call pbuf_add_field('CV_REFFICE', 'physpkg',dtype_r8,(/pcols,pver/), cv_reffice_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_add_field('CC_T', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_t_idx) + call pbuf_add_field('CC_qv', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qv_idx) + call pbuf_add_field('CC_ql', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ql_idx) + call pbuf_add_field('CC_qi', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qi_idx) + call pbuf_add_field('CC_nl', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_nl_idx) + call pbuf_add_field('CC_ni', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_ni_idx) + call pbuf_add_field('CC_qlst', 'global', dtype_r8, (/pcols,pver,dyn_time_lvls/), cc_qlst_idx) + + ! Fields for UNICON + call pbuf_add_field('am_evp_st', 'global', dtype_r8, (/pcols,pver/), am_evp_st_idx) + call pbuf_add_field('evprain_st', 'global', dtype_r8, (/pcols,pver/), evprain_st_idx) + call pbuf_add_field('evpsnow_st', 'global', dtype_r8, (/pcols,pver/), evpsnow_st_idx) + + ! Register subcolumn pbuf fields + if (use_subcol_microp) then + ! Global pbuf fields + call pbuf_register_subcol('CLDO', 'micro_mg_cam_register', cldo_idx) + + ! CC_* Fields needed by Park macrophysics + call pbuf_register_subcol('CC_T', 'micro_mg_cam_register', cc_t_idx) + call pbuf_register_subcol('CC_qv', 'micro_mg_cam_register', cc_qv_idx) + call pbuf_register_subcol('CC_ql', 'micro_mg_cam_register', cc_ql_idx) + call pbuf_register_subcol('CC_qi', 'micro_mg_cam_register', cc_qi_idx) + call pbuf_register_subcol('CC_nl', 'micro_mg_cam_register', cc_nl_idx) + call pbuf_register_subcol('CC_ni', 'micro_mg_cam_register', cc_ni_idx) + call pbuf_register_subcol('CC_qlst', 'micro_mg_cam_register', cc_qlst_idx) + + ! Physpkg pbuf fields + ! Physics buffer variables for convective cloud properties. + + call pbuf_register_subcol('QME', 'micro_mg_cam_register', qme_idx) + call pbuf_register_subcol('PRAIN', 'micro_mg_cam_register', prain_idx) + call pbuf_register_subcol('NEVAPR', 'micro_mg_cam_register', nevapr_idx) + call pbuf_register_subcol('PRER_EVAP', 'micro_mg_cam_register', prer_evap_idx) + + call pbuf_register_subcol('WSEDL', 'micro_mg_cam_register', wsedl_idx) + + call pbuf_register_subcol('REI', 'micro_mg_cam_register', rei_idx) + call pbuf_register_subcol('SADICE', 'micro_mg_cam_register', sadice_idx) + call pbuf_register_subcol('SADSNOW', 'micro_mg_cam_register', sadsnow_idx) + call pbuf_register_subcol('REL', 'micro_mg_cam_register', rel_idx) + + ! Mitchell ice effective diameter for radiation + call pbuf_register_subcol('DEI', 'micro_mg_cam_register', dei_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('MU', 'micro_mg_cam_register', mu_idx) + ! Size distribution shape parameter for radiation + call pbuf_register_subcol('LAMBDAC', 'micro_mg_cam_register', lambdac_idx) + + ! Stratiform only in cloud ice water path for radiation + call pbuf_register_subcol('ICIWPST', 'micro_mg_cam_register', iciwpst_idx) + ! Stratiform in cloud liquid water path for radiation + call pbuf_register_subcol('ICLWPST', 'micro_mg_cam_register', iclwpst_idx) + + ! Snow effective diameter for radiation + call pbuf_register_subcol('DES', 'micro_mg_cam_register', des_idx) + ! In cloud snow water path for radiation + call pbuf_register_subcol('ICSWP', 'micro_mg_cam_register', icswp_idx) + ! Cloud fraction for liquid drops + snow + call pbuf_register_subcol('CLDFSNOW ', 'micro_mg_cam_register', cldfsnow_idx) + + if (prog_modal_aero) then + call pbuf_register_subcol('RATE1_CW2PR_ST', 'micro_mg_cam_register', rate1_cw2pr_st_idx) + end if + + call pbuf_register_subcol('LS_FLXPRC', 'micro_mg_cam_register', ls_flxprc_idx) + call pbuf_register_subcol('LS_FLXSNW', 'micro_mg_cam_register', ls_flxsnw_idx) + + ! Fields needed as inputs to COSP + call pbuf_register_subcol('LS_MRPRC', 'micro_mg_cam_register', ls_mrprc_idx) + call pbuf_register_subcol('LS_MRSNW', 'micro_mg_cam_register', ls_mrsnw_idx) + call pbuf_register_subcol('LS_REFFRAIN', 'micro_mg_cam_register', ls_reffrain_idx) + call pbuf_register_subcol('LS_REFFSNOW', 'micro_mg_cam_register', ls_reffsnow_idx) + call pbuf_register_subcol('CV_REFFLIQ', 'micro_mg_cam_register', cv_reffliq_idx) + call pbuf_register_subcol('CV_REFFICE', 'micro_mg_cam_register', cv_reffice_idx) + end if + + ! Additional pbuf for CARMA interface + if (.not. do_cldice) then + call pbuf_add_field('TND_QSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_qsnow_idx) + call pbuf_add_field('TND_NSNOW', 'physpkg',dtype_r8,(/pcols,pver/), tnd_nsnow_idx) + call pbuf_add_field('RE_ICE', 'physpkg',dtype_r8,(/pcols,pver/), re_ice_idx) + end if + + ! Precipitation efficiency fields across timesteps. + call pbuf_add_field('ACPRECL', 'global',dtype_r8,(/pcols/), acpr_idx) ! accumulated precip + call pbuf_add_field('ACGCME', 'global',dtype_r8,(/pcols/), acgcme_idx) ! accumulated condensation + call pbuf_add_field('ACNUM', 'global',dtype_i4,(/pcols/), acnum_idx) ! counter for accumulated # timesteps + + ! SGS variability -- These could be reset by CLUBB so they need to be grid only + call pbuf_add_field('RELVAR', 'global',dtype_r8,(/pcols,pver/), relvar_idx) + call pbuf_add_field('ACCRE_ENHAN','global',dtype_r8,(/pcols,pver/), accre_enhan_idx) + + ! Diagnostic fields needed for subcol_SILHS, need to be grid-only + if (subcol_get_scheme() == 'SILHS') then + call pbuf_add_field('QRAIN', 'global',dtype_r8,(/pcols,pver/), qrain_idx) + call pbuf_add_field('QSNOW', 'global',dtype_r8,(/pcols,pver/), qsnow_idx) + call pbuf_add_field('NRAIN', 'global',dtype_r8,(/pcols,pver/), nrain_idx) + call pbuf_add_field('NSNOW', 'global',dtype_r8,(/pcols,pver/), nsnow_idx) + end if + +end subroutine micro_mg_cam_register + +!=============================================================================== + +function micro_mg_cam_implements_cnst(name) + + ! Return true if specified constituent is implemented by the + ! microphysics package + + character(len=*), intent(in) :: name ! constituent name + logical :: micro_mg_cam_implements_cnst ! return value + + !----------------------------------------------------------------------- + + micro_mg_cam_implements_cnst = any(name == cnst_names) + +end function micro_mg_cam_implements_cnst + +!=============================================================================== + +subroutine micro_mg_cam_init_cnst(name, latvals, lonvals, mask, q) + + ! Initialize the microphysics constituents, if they are + ! not read from the initial file. + + 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 + + if (micro_mg_cam_implements_cnst(name)) then + do k = 1, size(q, 2) + where(mask) + q(:, k) = 0.0_r8 + end where + end do + end if + +end subroutine micro_mg_cam_init_cnst + +!=============================================================================== + +subroutine micro_mg_cam_init(pbuf2d) + use time_manager, only: is_first_step + use micro_mg_utils, only: micro_mg_utils_init + use micro_mg1_0, only: micro_mg_init1_0 => micro_mg_init + use micro_mg2_0, only: micro_mg_init2_0 => micro_mg_init + + !----------------------------------------------------------------------- + ! + ! Initialization for MG microphysics + ! + !----------------------------------------------------------------------- + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + integer :: m, mm + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_budget ! Output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + logical :: use_subcol_microp + logical :: do_clubb_sgs + integer :: budget_histfile ! output history file number for budget fields + integer :: ierr + character(128) :: errstring ! return status (non-blank for error return) + + !----------------------------------------------------------------------- + + call phys_getopts(use_subcol_microp_out=use_subcol_microp, & + do_clubb_sgs_out =do_clubb_sgs) + + if (do_clubb_sgs) then + allow_sed_supersat = .false. + else + allow_sed_supersat = .true. + endif + + if (masterproc) then + write(iulog,"(A,I2,A,I2)") "Initializing MG version ",micro_mg_version,".",micro_mg_sub_version + if (.not. do_cldliq) & + write(iulog,*) "MG prognostic cloud liquid has been turned off via namelist." + if (.not. do_cldice) & + write(iulog,*) "MG prognostic cloud ice has been turned off via namelist." + write(iulog,*) "Number of microphysics substeps is: ",num_steps + end if + + select case (micro_mg_version) + case (1) + ! Set constituent number for later loops. + ncnst = 4 + + select case (micro_mg_sub_version) + case (0) + ! MG 1 does not initialize micro_mg_utils, so have to do it here. + call micro_mg_utils_init(r8, rh2o, cpair, tmelt, latvap, latice, & + micro_mg_dcs, errstring) + call handle_errmsg(errstring, subname="micro_mg_utils_init") + + call micro_mg_init1_0( & + r8, gravit, rair, rh2o, cpair, & + rhoh2o, tmelt, latvap, latice, & + rhmini, micro_mg_dcs, use_hetfrz_classnuc, & + micro_mg_precip_frac_method, micro_mg_berg_eff_factor, & + micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, & + micro_mg_ninst, errstring) + end select + case (2) + ! Set constituent number for later loops. + ncnst = 8 + + select case (micro_mg_sub_version) + case (0) + call micro_mg_init2_0( & + r8, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, rhmini, & + micro_mg_dcs, & + microp_uniform, do_cldice, use_hetfrz_classnuc, & + micro_mg_precip_frac_method, micro_mg_berg_eff_factor, & + allow_sed_supersat, micro_do_sb_physics, & + micro_mg_nccons, micro_mg_nicons, micro_mg_ncnst, & + micro_mg_ninst, errstring) + end select + end select + + call handle_errmsg(errstring, subname="micro_mg_init") + + ! Register history variables + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + if ( any(mm == (/ ixcldliq, ixcldice, ixrain, ixsnow /)) ) then + ! mass mixing ratios + call addfld(cnst_name(mm), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(mm) ) + call addfld(sflxnam(mm), horiz_only, 'A', 'kg/m2/s', trim(cnst_name(mm))//' surface flux') + else if ( any(mm == (/ ixnumliq, ixnumice, ixnumrain, ixnumsnow /)) ) then + ! number concentrations + call addfld(cnst_name(mm), (/ 'lev' /), 'A', '1/kg', cnst_longname(mm) ) + call addfld(sflxnam(mm), horiz_only, 'A', '1/m2/s', trim(cnst_name(mm))//' surface flux') + else + call endrun( "micro_mg_cam_init: & + &Could not call addfld for constituent with unknown units.") + endif + end do + + call addfld(apcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' after physics' ) + call addfld(apcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' after physics' ) + call addfld(bpcnst(ixcldliq), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldliq))//' before physics' ) + call addfld(bpcnst(ixcldice), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixcldice))//' before physics' ) + + if (micro_mg_version > 1) then + call addfld(apcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' after physics' ) + call addfld(apcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' after physics' ) + call addfld(bpcnst(ixrain), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixrain))//' before physics' ) + call addfld(bpcnst(ixsnow), (/ 'lev' /), 'A', 'kg/kg', trim(cnst_name(ixsnow))//' before physics' ) + end if + + call addfld ('CME', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of cond-evap within the cloud' ) + call addfld ('PRODPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of conversion of condensate to precip' ) + call addfld ('EVAPPREC', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling precip' ) + call addfld ('EVAPSNOW', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling snow' ) + call addfld ('HPROGCLD', (/ 'lev' /), 'A', 'W/kg' , 'Heating from prognostic clouds' ) + call addfld ('FICE', (/ 'lev' /), 'A', 'fraction', 'Fractional ice content within cloud' ) + call addfld ('CLDFSNOW', (/ 'lev' /), 'A', '1', 'Cloud fraction adjusted for snow' ) + call addfld ('ICWMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus water mixing ratio' ) + call addfld ('ICIMRST', (/ 'lev' /), 'A', 'kg/kg', 'Prognostic in-stratus ice mixing ratio' ) + + ! MG microphysics diagnostics + call addfld ('QCSEVAP', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of evaporation of falling cloud water' ) + call addfld ('QISEVAP', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of sublimation of falling cloud ice' ) + call addfld ('QVRES', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of residual condensation term' ) + call addfld ('CMEIOUT', (/ 'lev' /), 'A', 'kg/kg/s', 'Rate of deposition/sublimation of cloud ice' ) + call addfld ('VTRMC', (/ 'lev' /), 'A', 'm/s', 'Mass-weighted cloud water fallspeed' ) + call addfld ('VTRMI', (/ 'lev' /), 'A', 'm/s', 'Mass-weighted cloud ice fallspeed' ) + call addfld ('QCSEDTEN', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud water mixing ratio tendency from sedimentation' ) + call addfld ('QISEDTEN', (/ 'lev' /), 'A', 'kg/kg/s', 'Cloud ice mixing ratio tendency from sedimentation' ) + call addfld ('PRAO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by rain' ) + call addfld ('PRCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud water' ) + call addfld ('MNUCCCO', (/ 'lev' /), 'A', 'kg/kg/s', 'Immersion freezing of cloud water' ) + call addfld ('MNUCCTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Contact freezing of cloud water' ) + call addfld ('MNUCCDO', (/ 'lev' /), 'A', 'kg/kg/s', 'Homogeneous and heterogeneous nucleation from vapor' ) + call addfld ('MNUCCDOhet', (/ 'lev' /), 'A', 'kg/kg/s', 'Heterogeneous nucleation from vapor' ) + call addfld ('MSACWIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water from rime-splintering' ) + call addfld ('PSACWSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud water by snow' ) + call addfld ('BERGSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to snow from bergeron' ) + call addfld ('BERGO', (/ 'lev' /), 'A', 'kg/kg/s', 'Conversion of cloud water to cloud ice from bergeron' ) + call addfld ('MELTO', (/ 'lev' /), 'A', 'kg/kg/s', 'Melting of cloud ice' ) + call addfld ('HOMOO', (/ 'lev' /), 'A', 'kg/kg/s', 'Homogeneous freezing of cloud water' ) + call addfld ('QCRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual condensation term for cloud water' ) + call addfld ('PRCIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Autoconversion of cloud ice' ) + call addfld ('PRAIO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of cloud ice by rain' ) + call addfld ('QIRESO', (/ 'lev' /), 'A', 'kg/kg/s', 'Residual deposition term for cloud ice' ) + call addfld ('MNUCCRO', (/ 'lev' /), 'A', 'kg/kg/s', 'Heterogeneous freezing of rain to snow' ) + call addfld ('PRACSO', (/ 'lev' /), 'A', 'kg/kg/s', 'Accretion of rain by snow' ) + call addfld ('MELTSDT', (/ 'lev' /), 'A', 'W/kg', 'Latent heating rate due to melting of snow' ) + call addfld ('FRZRDT', (/ 'lev' /), 'A', 'W/kg', 'Latent heating rate due to homogeneous freezing of rain' ) + if (micro_mg_version > 1) then + call addfld ('QRSEDTEN', (/ 'lev' /), 'A', 'kg/kg/s', 'Rain mixing ratio tendency from sedimentation' ) + call addfld ('QSSEDTEN', (/ 'lev' /), 'A', 'kg/kg/s', 'Snow mixing ratio tendency from sedimentation' ) + end if + +!AL MG microphysics diagnostics number tendencies + call addfld ('NNUCCCO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency immersion freezing' ) + call addfld ('NNUCCTO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency contact freezing' ) + call addfld ('NPSACWSO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency accretion by snow' ) + call addfld ('NSUBCO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency evaporation of droplet' ) + call addfld ('NPRAO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency accretion' ) + call addfld ('NPRC1O ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency autoconversion' ) + call addfld ('NQCSEDTEN',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency sedimentation' ) + call addfld ('NQISEDTEN',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency sedimentation' ) + call addfld ('NMELTO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency melting' ) + call addfld ('NIMELTO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency melting' ) + call addfld ('NHOMOO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tendency homogeneous freezing' ) + call addfld ('NIHOMOO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency homogeneous freezing' ) + call addfld ('NSACWIO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency from HM' ) + call addfld ('NSUBIO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency evaporation' ) + call addfld ('NPRCIO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency autoconversion snow' ) + call addfld ('NPRAIO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tendency accretion snow' ) + call addfld ('NNUDEPO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI deposition' ) + call addfld ('NPCCNO ',(/ 'lev' /), 'A', '1/kg/s ', 'NC activation' ) + call addfld ('NPCCNO2 ',(/ 'lev' /), 'A', '1/kg/s ', 'NC activation' ) + call addfld ('NNUCCDO ',(/ 'lev' /), 'A', '1/kg/s ', 'NI nuccleation' ) + call addfld ('NCTNCONS ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tuning: conservation of nc ' ) + call addfld ('NCTNNBMN ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tuning: minimum nc' ) + call addfld ('NCTNSZMN ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tuning: minimum slope parameter' ) + call addfld ('NCTNSZMX ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tuning: maximum slope parameter' ) + call addfld ('NCTNNCLD ',(/ 'lev' /), 'A', '1/kg/s ', 'NC tuning: removal of nc for zero cloud water' ) + call addfld ('NITNCONS ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tuning: conservation of ni ' ) + call addfld ('NITNSZMN ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tuning: minimum slope parameter' ) + call addfld ('NITNSZMX ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tuning: maximum slope parameter' ) + call addfld ('NITNNCLD ',(/ 'lev' /), 'A', '1/kg/s ', 'NI tuning: removal of nI for zero cloud ice' ) + call addfld ('MNUDEPO ',(/ 'lev' /), 'A', 'kg/kg/s ', 'Mixing ratio deposition' ) + call addfld ('MPDNLIQ ',(/ 'lev' /), 'A', '1/kg/s ', 'CLDLIQ number tendency - Morrison microphysics' ) + call addfld ('MPDNICE ',(/ 'lev' /), 'A', '1/kg/s ', 'CLDICE number tendency - Morrison microphysics' ) + call addfld ('FRZR ',(/ 'lev' /), 'A', 'kg/kg/s ', 'Mass freezing rain to snow' ) + call addfld ('NFRZR ',(/ 'lev' /), 'A', '1/kg/s ', 'Number freezing rain to snow' ) + call addfld ('MNUCCRI ',(/ 'lev' /), 'A', 'kg/kg/s ', 'Mass freezing rain to ice' ) + call addfld ('NNUCCRI ',(/ 'lev' /), 'A', '1/kg/s ', 'Number freezing rain to ice' ) + + ! History variables for CAM5 microphysics + call addfld ('MPDT', (/ 'lev' /), 'A', 'W/kg', 'Heating tendency - Morrison microphysics' ) + call addfld ('MPDQ', (/ 'lev' /), 'A', 'kg/kg/s', 'Q tendency - Morrison microphysics' ) + call addfld ('MPDLIQ', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDLIQ tendency - Morrison microphysics' ) + call addfld ('MPDICE', (/ 'lev' /), 'A', 'kg/kg/s', 'CLDICE tendency - Morrison microphysics' ) + call addfld ('MPDW2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Vapor tendency - Morrison microphysics' ) + call addfld ('MPDW2I', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Ice tendency - Morrison microphysics' ) + call addfld ('MPDW2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Water <--> Precip tendency - Morrison microphysics' ) + call addfld ('MPDI2V', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Vapor tendency - Morrison microphysics' ) + call addfld ('MPDI2W', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Water tendency - Morrison microphysics' ) + call addfld ('MPDI2P', (/ 'lev' /), 'A', 'kg/kg/s', 'Ice <--> Precip tendency - Morrison microphysics' ) + call addfld ('ICWNC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud water number conc' ) + call addfld ('ICINC', (/ 'lev' /), 'A', 'm-3', 'Prognostic in-cloud ice number conc' ) + call addfld ('EFFLIQ_IND', (/ 'lev' /), 'A','Micron', 'Prognostic droplet effective radius (indirect effect)' ) + call addfld ('CDNUMC', horiz_only, 'A', '1/m2', 'Vertically-integrated droplet concentration' ) + call addfld ('MPICLWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & + &in-cloud Initial Liquid WP (Before Micro)' ) + call addfld ('MPICIWPI', horiz_only, 'A', 'kg/m2', 'Vertically-integrated & + &in-cloud Initial Ice WP (Before Micro)' ) + + ! This is provided as an example on how to write out subcolumn output + ! NOTE -- only 'I' should be used for sub-column fields as subc-columns could shift from time-step to time-step + if (use_subcol_microp) then + call addfld('FICE_SCOL', (/'psubcols','lev '/), 'I', 'fraction', & + 'Sub-column fractional ice content within cloud', flag_xyfill=.true., fill_value=1.e30_r8) + end if + + + ! This is only if the coldpoint temperatures are being adjusted. + ! NOTE: Some fields related to these and output later are added in tropopause.F90. + if (micro_mg_adjust_cpt) then + call addfld ('TROPF_TADJ', (/ 'lev' /), 'A', 'K', 'Temperatures after cold point adjustment' ) + call addfld ('TROPF_RHADJ', (/ 'lev' /), 'A', 'K', 'Relative Hunidity after cold point adjustment' ) + call addfld ('TROPF_CDT', horiz_only, 'A', 'K', 'Cold point temperature adjustment' ) + call addfld ('TROPF_CDZ', horiz_only, 'A', 'm', 'Distance of coldpoint from coldest model level' ) + end if + + + ! Averaging for cloud particle number and size + call addfld ('AWNC', (/ 'lev' /), 'A', 'm-3', 'Average cloud water number conc' ) + call addfld ('AWNI', (/ 'lev' /), 'A', 'm-3', 'Average cloud ice number conc' ) + call addfld ('AREL', (/ 'lev' /), 'A', 'Micron', 'Average droplet effective radius' ) + call addfld ('AREI', (/ 'lev' /), 'A', 'Micron', 'Average ice effective radius' ) + ! Frequency arrays for above + call addfld ('FREQL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of liquid' ) + call addfld ('FREQI', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of ice' ) + + ! Average cloud top particle size and number (liq, ice) and frequency + call addfld ('ACTREL', horiz_only, 'A', 'Micron', 'Average Cloud Top droplet effective radius' ) + call addfld ('ACTREI', horiz_only, 'A', 'Micron', 'Average Cloud Top ice effective radius' ) + call addfld ('ACTNL', horiz_only, 'A', 'm-3', 'Average Cloud Top droplet number' ) + call addfld ('ACTNI', horiz_only, 'A', 'm-3', 'Average Cloud Top ice number' ) + + call addfld ('FCTL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top liquid' ) + call addfld ('FCTI', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top ice' ) + !++IH + !For comparing to Bernartz CDNC concentrations +!akc6 call addfld ('ACTNL_B ', horiz_only, 'A', 'Micron ', 'Average Cloud Top droplet number (Bennartz)' ) + call addfld ('ACTNL_B ', horiz_only, 'A', 'm-3', 'Average Cloud Top droplet number (Bennartz)' ) + call addfld ('FCTL_B ', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top liquid (Bennartz)' ) +!ak6+ + call addfld ('CCN_B ', horiz_only, 'A', 'm-3', 'Average Cloud Top liquid CCN (Bennartz)' ) +!ak6- + !--IH + + ! New frequency arrays for mixed phase and supercooled liquid (only and mixed) for (a) Cloud Top and (b) everywhere.. + call addfld ('FREQM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of mixed phase' ) + call addfld ('FREQSL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of only supercooled liquid' ) + call addfld ('FREQSLM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of super cooled liquid with ice' ) + call addfld ('FCTM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top mixed phase' ) + call addfld ('FCTSL', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top only supercooled liquid' ) + call addfld ('FCTSLM', horiz_only, 'A', 'fraction', 'Fractional occurrence of cloud top super cooled liquid with ice' ) + + call addfld ('LS_FLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface rain+snow flux' ) + call addfld ('LS_FLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'ls stratiform gbm interface snow flux' ) + + call addfld ('REL', (/ 'lev' /), 'A', 'micron', 'MG REL stratiform cloud effective radius liquid' ) + call addfld ('REI', (/ 'lev' /), 'A', 'micron', 'MG REI stratiform cloud effective radius ice' ) + call addfld ('LS_REFFRAIN', (/ 'lev' /), 'A', 'micron', 'ls stratiform rain effective radius' ) + call addfld ('LS_REFFSNOW', (/ 'lev' /), 'A', 'micron', 'ls stratiform snow effective radius' ) + call addfld ('CV_REFFLIQ', (/ 'lev' /), 'A', 'micron', 'convective cloud liq effective radius' ) + call addfld ('CV_REFFICE', (/ 'lev' /), 'A', 'micron', 'convective cloud ice effective radius' ) + call addfld ('MG_SADICE', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density ice' ) + call addfld ('MG_SADSNOW', (/ 'lev' /), 'A', 'cm2/cm3', 'MG surface area density snow' ) + + ! diagnostic precip + call addfld ('QRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean rain mixing ratio' ) + call addfld ('QSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Diagnostic grid-mean snow mixing ratio' ) + call addfld ('NRAIN', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean rain number conc' ) + call addfld ('NSNOW', (/ 'lev' /), 'A', 'm-3', 'Diagnostic grid-mean snow number conc' ) + + ! size of precip + call addfld ('RERCLD', (/ 'lev' /), 'A', 'm', 'Diagnostic effective radius of Liquid Cloud and Rain' ) + call addfld ('DSNOW', (/ 'lev' /), 'A', 'm', 'Diagnostic grid-mean snow diameter' ) + + ! diagnostic radar reflectivity, cloud-averaged + call addfld ('REFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity' ) + call addfld ('AREFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity' ) + call addfld ('FREFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity' ) + + call addfld ('CSRFL', (/ 'lev' /), 'A', 'DBz', '94 GHz radar reflectivity (CloudSat thresholds)' ) + call addfld ('ACSRFL', (/ 'lev' /), 'A', 'DBz', 'Average 94 GHz radar reflectivity (CloudSat thresholds)' ) + call addfld ('FCSRFL', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of radar reflectivity (CloudSat thresholds)' ) + + call addfld ('AREFLZ', (/ 'lev' /), 'A', 'mm^6/m^3', 'Average 94 GHz radar reflectivity' ) + + ! Aerosol information + call addfld ('NCAL', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Liquid' ) + call addfld ('NCAI', (/ 'lev' /), 'A', '1/m3', 'Number Concentation Activated for Ice' ) + + ! Average rain and snow mixing ratio (Q), number (N) and diameter (D), with frequency + call addfld ('AQRAIN', (/ 'lev' /), 'A', 'kg/kg', 'Average rain mixing ratio' ) + call addfld ('AQSNOW', (/ 'lev' /), 'A', 'kg/kg', 'Average snow mixing ratio' ) + call addfld ('ANRAIN', (/ 'lev' /), 'A', 'm-3', 'Average rain number conc' ) + call addfld ('ANSNOW', (/ 'lev' /), 'A', 'm-3', 'Average snow number conc' ) + call addfld ('ADRAIN', (/ 'lev' /), 'A', 'Micron', 'Average rain effective Diameter' ) + call addfld ('ADSNOW', (/ 'lev' /), 'A', 'Micron', 'Average snow effective Diameter' ) + call addfld ('FREQR', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of rain' ) + call addfld ('FREQS', (/ 'lev' /), 'A', 'fraction', 'Fractional occurrence of snow' ) + + ! precipitation efficiency & other diagnostic fields + call addfld('PE' , horiz_only, 'A', '1', 'Stratiform Precipitation Efficiency (precip/cmeliq)' ) + call addfld('APRL' , horiz_only, 'A', 'm/s', 'Average Stratiform Precip Rate over efficiency calculation' ) + call addfld('PEFRAC', horiz_only, 'A', '1', 'Fraction of timesteps precip efficiency reported' ) + call addfld('VPRCO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of autoconversion rate' ) + call addfld('VPRAO' , horiz_only, 'A', 'kg/kg/s', 'Vertical average of accretion rate' ) + call addfld('RACAU' , horiz_only, 'A', 'kg/kg/s', 'Accretion/autoconversion ratio from vertical average' ) + + if (micro_mg_version > 1) then + call addfld('UMR', (/ 'lev' /), 'A', 'm/s', 'Mass-weighted rain fallspeed' ) + call addfld('UMS', (/ 'lev' /), 'A', 'm/s', 'Mass-weighted snow fallspeed' ) + end if + + ! qc limiter (only output in versions 1.5 and later) + if (.not. (micro_mg_version == 1 .and. micro_mg_sub_version == 0)) then + call addfld('QCRAT', (/ 'lev' /), 'A', 'fraction', 'Qc Limiter: Fraction of qc tendency applied') + end if + + ! determine the add_default fields + call phys_getopts(history_amwg_out = history_amwg , & + history_budget_out = history_budget , & + history_budget_histfile_num_out = budget_histfile) + + if (history_amwg) then + call add_default ('FICE ', 1, ' ') + call add_default ('AQRAIN ', 1, ' ') + call add_default ('AQSNOW ', 1, ' ') + call add_default ('ANRAIN ', 1, ' ') + call add_default ('ANSNOW ', 1, ' ') + call add_default ('ADRAIN ', 1, ' ') + call add_default ('ADSNOW ', 1, ' ') + call add_default ('AREI ', 1, ' ') + call add_default ('AREL ', 1, ' ') + call add_default ('AWNC ', 1, ' ') + call add_default ('AWNI ', 1, ' ') + call add_default ('CDNUMC ', 1, ' ') + call add_default ('FREQR ', 1, ' ') + call add_default ('FREQS ', 1, ' ') + call add_default ('FREQL ', 1, ' ') + call add_default ('FREQI ', 1, ' ') + !++IH (Bennartz CDNC comparison) and extra clouds diags + ! made default for NorESM + call add_default ('ACTNL ', 1, ' ') + call add_default ('ACTREL ', 1, ' ') + call add_default ('FCTL ', 1, ' ') + call add_default ('ACTNI ', 1, ' ') + call add_default ('ACTREI ', 1, ' ') + call add_default ('FCTI ', 1, ' ') + !These are for comparing to Bennartz + call add_default ('FCTL_B ', 1, ' ') + call add_default ('ACTNL_B ', 1, ' ') + !--IH +!akc6+ + call add_default ('CCN_B ', 1, ' ') +!akc6- + do m = 1, ncnst + call cnst_get_ind(cnst_names(m), mm) + call add_default(cnst_name(mm), 1, ' ') + ! call add_default(sflxnam(mm), 1, ' ') + end do + end if + + if ( history_budget ) then + call add_default ('EVAPSNOW ', budget_histfile, ' ') + call add_default ('EVAPPREC ', budget_histfile, ' ') + call add_default ('QVRES ', budget_histfile, ' ') + call add_default ('QISEVAP ', budget_histfile, ' ') + call add_default ('QCSEVAP ', budget_histfile, ' ') + call add_default ('QISEDTEN ', budget_histfile, ' ') + call add_default ('QCSEDTEN ', budget_histfile, ' ') + call add_default ('QIRESO ', budget_histfile, ' ') + call add_default ('QCRESO ', budget_histfile, ' ') + if (micro_mg_version > 1) then + call add_default ('QRSEDTEN ', budget_histfile, ' ') + call add_default ('QSSEDTEN ', budget_histfile, ' ') + end if + call add_default ('PSACWSO ', budget_histfile, ' ') + call add_default ('PRCO ', budget_histfile, ' ') + call add_default ('PRCIO ', budget_histfile, ' ') + call add_default ('PRAO ', budget_histfile, ' ') + call add_default ('PRAIO ', budget_histfile, ' ') + call add_default ('PRACSO ', budget_histfile, ' ') + call add_default ('MSACWIO ', budget_histfile, ' ') + call add_default ('MPDW2V ', budget_histfile, ' ') + call add_default ('MPDW2P ', budget_histfile, ' ') + call add_default ('MPDW2I ', budget_histfile, ' ') + call add_default ('MPDT ', budget_histfile, ' ') + call add_default ('MPDQ ', budget_histfile, ' ') + call add_default ('MPDLIQ ', budget_histfile, ' ') + call add_default ('MPDICE ', budget_histfile, ' ') + call add_default ('MPDI2W ', budget_histfile, ' ') + call add_default ('MPDI2V ', budget_histfile, ' ') + call add_default ('MPDI2P ', budget_histfile, ' ') + call add_default ('MNUCCTO ', budget_histfile, ' ') + call add_default ('MNUCCRO ', budget_histfile, ' ') + call add_default ('MNUCCCO ', budget_histfile, ' ') + call add_default ('MELTSDT ', budget_histfile, ' ') + call add_default ('MELTO ', budget_histfile, ' ') + call add_default ('HOMOO ', budget_histfile, ' ') + call add_default ('FRZRDT ', budget_histfile, ' ') + call add_default ('CMEIOUT ', budget_histfile, ' ') + call add_default ('BERGSO ', budget_histfile, ' ') + call add_default ('BERGO ', budget_histfile, ' ') +!AL + call add_default ('NNUCCCO ', budget_histfile, ' ') + call add_default ('NNUCCTO ', budget_histfile, ' ') + call add_default ('NPSACWSO ', budget_histfile, ' ') + call add_default ('NSUBCO ', budget_histfile, ' ') + call add_default ('NPRAO ', budget_histfile, ' ') + call add_default ('NPRC1O ', budget_histfile, ' ') + call add_default ('NQCSEDTEN', budget_histfile, ' ') + call add_default ('NQISEDTEN', budget_histfile, ' ') + call add_default ('NMELTO ', budget_histfile, ' ') + call add_default ('NIMELTO ', budget_histfile, ' ') + call add_default ('NHOMOO ', budget_histfile, ' ') + call add_default ('NIHOMOO ', budget_histfile, ' ') + call add_default ('NSACWIO ', budget_histfile, ' ') + call add_default ('NSUBIO ', budget_histfile, ' ') + call add_default ('NPRCIO ', budget_histfile, ' ') + call add_default ('NPRAIO ', budget_histfile, ' ') + call add_default ('NNUDEPO ', budget_histfile, ' ') + call add_default ('MNUDEPO ', budget_histfile, ' ') + call add_default ('NPCCNO ', budget_histfile, ' ') + call add_default ('NPCCNO2 ', budget_histfile, ' ') + call add_default ('NNUCCDO ', budget_histfile, ' ') + + call add_default ('NCTNNCLD ', budget_histfile, ' ') + call add_default ('NITNCONS ', budget_histfile, ' ') + call add_default ('NITNNCLD ', budget_histfile, ' ') + call add_default ('NCTNSZMN ', budget_histfile,' ') + call add_default ('NCTNSZMX ', budget_histfile,' ') + call add_default ('NITNSZMN ', budget_histfile,' ') + call add_default ('NITNSZMX ', budget_histfile,' ') + select case (micro_mg_version) + case (1) + call add_default ('NCTNCONS ', budget_histfile, ' ') + call add_default ('NCTNNBMN ', budget_histfile, ' ') + case (2) + call add_default ('FRZR ', budget_histfile, ' ') + call add_default ('NFRZR ', budget_histfile, ' ') + call add_default ('MNUCCRI ', budget_histfile, ' ') + call add_default ('NNUCCRI ', budget_histfile, ' ') + end select + call add_default ('MPDNLIQ ', budget_histfile, ' ') + call add_default ('MPDNICE ', budget_histfile, ' ') +!AL + + call add_default(cnst_name(ixcldliq), budget_histfile, ' ') + call add_default(cnst_name(ixcldice), budget_histfile, ' ') + call add_default(apcnst (ixcldliq), budget_histfile, ' ') + call add_default(apcnst (ixcldice), budget_histfile, ' ') + call add_default(bpcnst (ixcldliq), budget_histfile, ' ') + call add_default(bpcnst (ixcldice), budget_histfile, ' ') + if (micro_mg_version > 1) then + call add_default(cnst_name(ixrain), budget_histfile, ' ') + call add_default(cnst_name(ixsnow), budget_histfile, ' ') + call add_default(apcnst (ixrain), budget_histfile, ' ') + call add_default(apcnst (ixsnow), budget_histfile, ' ') + call add_default(bpcnst (ixrain), budget_histfile, ' ') + call add_default(bpcnst (ixsnow), budget_histfile, ' ') + end if + + end if + + ! physics buffer indices + ast_idx = pbuf_get_index('AST') + cld_idx = pbuf_get_index('CLD') + concld_idx = pbuf_get_index('CONCLD') + + naai_idx = pbuf_get_index('NAAI') + naai_hom_idx = pbuf_get_index('NAAI_HOM') + npccn_idx = pbuf_get_index('NPCCN') + rndst_idx = pbuf_get_index('RNDST') + nacon_idx = pbuf_get_index('NACON') + + prec_str_idx = pbuf_get_index('PREC_STR') + snow_str_idx = pbuf_get_index('SNOW_STR') + prec_sed_idx = pbuf_get_index('PREC_SED') + snow_sed_idx = pbuf_get_index('SNOW_SED') + prec_pcw_idx = pbuf_get_index('PREC_PCW') + snow_pcw_idx = pbuf_get_index('SNOW_PCW') + + cmeliq_idx = pbuf_get_index('CMELIQ') + + ! These fields may have been added, so don't abort if they have not been + qsatfac_idx = pbuf_get_index('QSATFAC', ierr) + qrain_idx = pbuf_get_index('QRAIN', ierr) + qsnow_idx = pbuf_get_index('QSNOW', ierr) + nrain_idx = pbuf_get_index('NRAIN', ierr) + nsnow_idx = pbuf_get_index('NSNOW', ierr) + + ! fields for heterogeneous freezing + frzimm_idx = pbuf_get_index('FRZIMM', ierr) + frzcnt_idx = pbuf_get_index('FRZCNT', ierr) + frzdep_idx = pbuf_get_index('FRZDEP', ierr) + + ! Initialize physics buffer grid fields for accumulating precip and condensation + if (is_first_step()) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8) + call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8) + call pbuf_set_field(pbuf2d, acpr_idx, 0._r8) + call pbuf_set_field(pbuf2d, acgcme_idx, 0._r8) + call pbuf_set_field(pbuf2d, acnum_idx, 0) + call pbuf_set_field(pbuf2d, relvar_idx, 2._r8) + call pbuf_set_field(pbuf2d, accre_enhan_idx, 1._r8) + call pbuf_set_field(pbuf2d, am_evp_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evprain_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, evpsnow_st_idx, 0._r8) + call pbuf_set_field(pbuf2d, prer_evap_idx, 0._r8) + + if (qrain_idx > 0) call pbuf_set_field(pbuf2d, qrain_idx, 0._r8) + if (qsnow_idx > 0) call pbuf_set_field(pbuf2d, qsnow_idx, 0._r8) + if (nrain_idx > 0) call pbuf_set_field(pbuf2d, nrain_idx, 0._r8) + if (nsnow_idx > 0) call pbuf_set_field(pbuf2d, nsnow_idx, 0._r8) + + ! If sub-columns turned on, need to set the sub-column fields as well + if (use_subcol_microp) then + call pbuf_set_field(pbuf2d, cldo_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_t_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qv_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ql_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qi_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_nl_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_ni_idx, 0._r8, col_type=col_type_subcol) + call pbuf_set_field(pbuf2d, cc_qlst_idx,0._r8, col_type=col_type_subcol) + end if + + end if + +end subroutine micro_mg_cam_init + +!=============================================================================== + +subroutine micro_mg_cam_tend(state, ptend, dtime, pbuf) + + use micro_mg1_0, only: micro_mg_get_cols1_0 => micro_mg_get_cols + use micro_mg2_0, only: micro_mg_get_cols2_0 => micro_mg_get_cols + + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtime + type(physics_buffer_desc), pointer :: pbuf(:) + + ! Local variables + integer :: ncol, nlev, mgncol + integer, allocatable :: mgcols(:) ! Columns with microphysics performed + + ! Find the number of levels used in the microphysics. + nlev = pver - top_lev + 1 + ncol = state%ncol + + select case (micro_mg_version) + case (1) + call micro_mg_get_cols1_0(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & + state%q(:,:,ixcldice), mgncol, mgcols) + case (2) + call micro_mg_get_cols2_0(ncol, nlev, top_lev, state%q(:,:,ixcldliq), & + state%q(:,:,ixcldice), state%q(:,:,ixrain), state%q(:,:,ixsnow), & + mgncol, mgcols) + end select + + call micro_mg_cam_tend_pack(state, ptend, dtime, pbuf, mgncol, mgcols, nlev) + +end subroutine micro_mg_cam_tend + +subroutine micro_mg_cam_tend_pack(state, ptend, dtime, pbuf, mgncol, mgcols, nlev) + + use micro_mg_utils, only: size_dist_param_basic, size_dist_param_liq, & + mg_liq_props, mg_ice_props, avg_diameter, rhoi, rhosn, rhow, rhows, & + qsmall, mincld + + use micro_mg_data, only: MGPacker, MGPostProc, accum_null, accum_mean + + use micro_mg1_0, only: micro_mg_tend1_0 => micro_mg_tend + use micro_mg2_0, only: micro_mg_tend2_0 => micro_mg_tend + + use physics_buffer, only: pbuf_col_type_index + use subcol, only: subcol_field_avg + use tropopause, only: tropopause_find, TROP_ALG_CPP, TROP_ALG_NONE, NOTFOUND + use wv_saturation, only: qsat + + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtime + type(physics_buffer_desc), pointer :: pbuf(:) + + integer, intent(in) :: nlev + integer, intent(in) :: mgncol + integer, intent(in) :: mgcols(:) + + ! Local variables + integer :: lchnk, ncol, psetcols, ngrdcol + + integer :: i, k, itim_old, it + + real(r8), pointer :: naai(:,:) ! ice nucleation number + real(r8), pointer :: naai_hom(:,:) ! ice nucleation number (homogeneous) + real(r8), pointer :: npccn(:,:) ! liquid activation number tendency + real(r8), pointer :: rndst(:,:,:) + real(r8), pointer :: nacon(:,:,:) + real(r8), pointer :: am_evp_st_grid(:,:) ! Evaporation area of stratiform precipitation. 0<= am_evp_st <=1. + real(r8), pointer :: evprain_st_grid(:,:) ! Evaporation rate of stratiform rain [kg/kg/s] + real(r8), pointer :: evpsnow_st_grid(:,:) ! Evaporation rate of stratiform snow [kg/kg/s] + + real(r8), pointer :: prec_str(:) ! [Total] Sfc flux of precip from stratiform [ m/s ] + real(r8), pointer :: snow_str(:) ! [Total] Sfc flux of snow from stratiform [ m/s ] + real(r8), pointer :: prec_sed(:) ! Surface flux of total cloud water from sedimentation + real(r8), pointer :: snow_sed(:) ! Surface flux of cloud ice from sedimentation + real(r8), pointer :: prec_pcw(:) ! Sfc flux of precip from microphysics [ m/s ] + real(r8), pointer :: snow_pcw(:) ! Sfc flux of snow from microphysics [ m/s ] + + real(r8), pointer :: ast(:,:) ! Relative humidity cloud fraction + real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. + real(r8), pointer :: alst_mic(:,:) + real(r8), pointer :: aist_mic(:,:) + real(r8), pointer :: cldo(:,:) ! Old cloud fraction + real(r8), pointer :: nevapr(:,:) ! Evaporation of total precipitation (rain + snow) + real(r8), pointer :: prer_evap(:,:) ! precipitation evaporation rate + real(r8), pointer :: relvar(:,:) ! relative variance of cloud water + real(r8), pointer :: accre_enhan(:,:) ! optional accretion enhancement for experimentation + real(r8), pointer :: prain(:,:) ! Total precipitation (rain + snow) + real(r8), pointer :: dei(:,:) ! Ice effective diameter (meters) (AG: microns?) + real(r8), pointer :: mu(:,:) ! Size distribution shape parameter for radiation + real(r8), pointer :: lambdac(:,:) ! Size distribution slope parameter for radiation + real(r8), pointer :: des(:,:) ! Snow effective diameter (m) + + real(r8) :: rho(state%psetcols,pver) + real(r8) :: cldmax(state%psetcols,pver) + + real(r8), target :: rate1cld(state%psetcols,pver) ! array to hold rate1ord_cw2pr_st from microphysics + + real(r8), target :: tlat(state%psetcols,pver) + real(r8), target :: qvlat(state%psetcols,pver) + real(r8), target :: qcten(state%psetcols,pver) + real(r8), target :: qiten(state%psetcols,pver) + real(r8), target :: ncten(state%psetcols,pver) + real(r8), target :: niten(state%psetcols,pver) + + real(r8), target :: qrten(state%psetcols,pver) + real(r8), target :: qsten(state%psetcols,pver) + real(r8), target :: nrten(state%psetcols,pver) + real(r8), target :: nsten(state%psetcols,pver) + + real(r8), target :: prect(state%psetcols) + real(r8), target :: preci(state%psetcols) + real(r8), target :: am_evp_st(state%psetcols,pver) ! Area over which precip evaporates + real(r8), target :: evapsnow(state%psetcols,pver) ! Local evaporation of snow + real(r8), target :: prodsnow(state%psetcols,pver) ! Local production of snow + real(r8), target :: cmeice(state%psetcols,pver) ! Rate of cond-evap of ice within the cloud + real(r8), target :: qsout(state%psetcols,pver) ! Snow mixing ratio + real(r8), target :: cflx(state%psetcols,pverp) ! grid-box avg liq condensate flux (kg m^-2 s^-1) + real(r8), target :: iflx(state%psetcols,pverp) ! grid-box avg ice condensate flux (kg m^-2 s^-1) + real(r8), target :: rflx(state%psetcols,pverp) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), target :: sflx(state%psetcols,pverp) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), target :: qrout(state%psetcols,pver) ! Rain mixing ratio + real(r8), target :: qcsevap(state%psetcols,pver) ! Evaporation of falling cloud water + real(r8), target :: qisevap(state%psetcols,pver) ! Sublimation of falling cloud ice + real(r8), target :: qvres(state%psetcols,pver) ! Residual condensation term to remove excess saturation + real(r8), target :: cmeiout(state%psetcols,pver) ! Deposition/sublimation rate of cloud ice + real(r8), target :: vtrmc(state%psetcols,pver) ! Mass-weighted cloud water fallspeed + real(r8), target :: vtrmi(state%psetcols,pver) ! Mass-weighted cloud ice fallspeed + real(r8), target :: umr(state%psetcols,pver) ! Mass-weighted rain fallspeed + real(r8), target :: ums(state%psetcols,pver) ! Mass-weighted snow fallspeed + real(r8), target :: qcsedten(state%psetcols,pver) ! Cloud water mixing ratio tendency from sedimentation + real(r8), target :: qisedten(state%psetcols,pver) ! Cloud ice mixing ratio tendency from sedimentation + real(r8), target :: qrsedten(state%psetcols,pver) ! Rain mixing ratio tendency from sedimentation + real(r8), target :: qssedten(state%psetcols,pver) ! Snow mixing ratio tendency from sedimentation + + real(r8), target :: prao(state%psetcols,pver) + real(r8), target :: prco(state%psetcols,pver) + real(r8), target :: mnuccco(state%psetcols,pver) + real(r8), target :: mnuccto(state%psetcols,pver) + real(r8), target :: msacwio(state%psetcols,pver) + real(r8), target :: psacwso(state%psetcols,pver) + real(r8), target :: bergso(state%psetcols,pver) + real(r8), target :: bergo(state%psetcols,pver) + real(r8), target :: melto(state%psetcols,pver) + real(r8), target :: homoo(state%psetcols,pver) + real(r8), target :: qcreso(state%psetcols,pver) + real(r8), target :: prcio(state%psetcols,pver) + real(r8), target :: praio(state%psetcols,pver) + real(r8), target :: qireso(state%psetcols,pver) + real(r8), target :: mnuccro(state%psetcols,pver) + real(r8), target :: pracso (state%psetcols,pver) + real(r8), target :: meltsdt(state%psetcols,pver) + real(r8), target :: frzrdt (state%psetcols,pver) + real(r8), target :: mnuccdo(state%psetcols,pver) + real(r8), target :: nrout(state%psetcols,pver) + real(r8), target :: nsout(state%psetcols,pver) + real(r8), target :: refl(state%psetcols,pver) ! analytic radar reflectivity + real(r8), target :: arefl(state%psetcols,pver) ! average reflectivity will zero points outside valid range + real(r8), target :: areflz(state%psetcols,pver) ! average reflectivity in z. + real(r8), target :: frefl(state%psetcols,pver) + real(r8), target :: csrfl(state%psetcols,pver) ! cloudsat reflectivity + real(r8), target :: acsrfl(state%psetcols,pver) ! cloudsat average + real(r8), target :: fcsrfl(state%psetcols,pver) + real(r8), target :: rercld(state%psetcols,pver) ! effective radius calculation for rain + cloud + real(r8), target :: ncai(state%psetcols,pver) ! output number conc of ice nuclei available (1/m3) + real(r8), target :: ncal(state%psetcols,pver) ! output number conc of CCN (1/m3) + real(r8), target :: qrout2(state%psetcols,pver) + real(r8), target :: qsout2(state%psetcols,pver) + real(r8), target :: nrout2(state%psetcols,pver) + real(r8), target :: nsout2(state%psetcols,pver) + real(r8), target :: freqs(state%psetcols,pver) + real(r8), target :: freqr(state%psetcols,pver) + real(r8), target :: nfice(state%psetcols,pver) + real(r8), target :: qcrat(state%psetcols,pver) ! qc limiter ratio (1=no limit) + +!AL + real(r8), target :: nnuccco(state%psetcols,pver) ! immersion freezing + real(r8), target :: nnuccto(state%psetcols,pver) ! contact freezing + real(r8), target :: npsacwso(state%psetcols,pver) ! accr. snow + real(r8), target :: nsubco(state%psetcols,pver) ! evaporation of droplet + real(r8), target :: nprao(state%psetcols,pver) ! accretion + real(r8), target :: nprc1o(state%psetcols,pver) ! autoconversion + real(r8), target :: nqcsedten(state%psetcols,pver) ! nqc sedimentation tendency + real(r8), target :: nqisedten(state%psetcols,pver) ! nqc sedimentation tendency + real(r8), target :: nmelto(state%psetcols,pver) ! melting of cloud ice + real(r8), target :: nhomoo(state%psetcols,pver) ! homogeneos freezign cloud water + real(r8), target :: nimelto(state%psetcols,pver) ! melting of cloud ice + real(r8), target :: nihomoo(state%psetcols,pver) ! homogeneos freezign cloud water + real(r8), target :: nsacwio(state%psetcols,pver) ! numb conc tend due to HM ice multiplication + real(r8), target :: nsubio(state%psetcols,pver) ! evaporation of cloud ice number (sublimation?) + real(r8), target :: nprcio(state%psetcols,pver) ! numb conc tend due to auto of cloud ice to snow + real(r8), target :: npraio(state%psetcols,pver) ! numb conc tend due to accr of cloud ice by snow + real(r8), target :: nnudepo(state%psetcols,pver) ! deposition? + real(r8), target :: npccno(state%psetcols,pver) ! activation + real(r8), target :: nnuccdo(state%psetcols,pver) ! nucleation (ice) + real(r8), target :: mnudepo(state%psetcols,pver) ! deposition + real(r8), target :: nctncons(state%psetcols,pver) ! correction term + real(r8), target :: nctnnbmn(state%psetcols,pver) ! correction if below minimum number + real(r8), target :: nctnszmn(state%psetcols,pver) ! gamma adjustment (liquid) + real(r8), target :: nctnszmx(state%psetcols,pver) ! gamma adjustment (liquid) + real(r8), target :: nctnncld(state%psetcols,pver) ! correction for no cloud + real(r8), target :: nitncons(state%psetcols,pver) ! numerical conservation check in sub-time step + real(r8), target :: nitnszmn(state%psetcols,pver) ! gamma-adjustment (ice) + real(r8), target :: nitnszmx(state%psetcols,pver) ! gamma-adjustment (ice) + real(r8), target :: nitnncld(state%psetcols,pver) ! corrrection for no cloud + real(r8), target :: frzr(state%psetcols,pver) ! mass freezing rain ==>snow + real(r8), target :: nfrzr(state%psetcols,pver) ! number freezing rain ==> snow + real(r8), target :: mnuccri(state%psetcols,pver) ! mass freezing rain ==> ice + real(r8), target :: nnuccri(state%psetcols,pver) ! number freezing rain ==> ice +!AL + ! Object that packs columns with clouds/precip. + type(MGPacker) :: packer + + ! Packed versions of inputs. + real(r8) :: packed_t(mgncol,nlev) + real(r8) :: packed_q(mgncol,nlev) + real(r8) :: packed_qc(mgncol,nlev) + real(r8) :: packed_nc(mgncol,nlev) + real(r8) :: packed_qi(mgncol,nlev) + real(r8) :: packed_ni(mgncol,nlev) + real(r8) :: packed_qr(mgncol,nlev) + real(r8) :: packed_nr(mgncol,nlev) + real(r8) :: packed_qs(mgncol,nlev) + real(r8) :: packed_ns(mgncol,nlev) + + real(r8) :: packed_relvar(mgncol,nlev) + real(r8) :: packed_accre_enhan(mgncol,nlev) + + real(r8) :: packed_p(mgncol,nlev) + real(r8) :: packed_pdel(mgncol,nlev) + + real(r8) :: packed_cldn(mgncol,nlev) + real(r8) :: packed_liqcldf(mgncol,nlev) + real(r8) :: packed_icecldf(mgncol,nlev) + real(r8), allocatable :: packed_qsatfac(:,:) + + real(r8) :: packed_naai(mgncol,nlev) + real(r8) :: packed_npccn(mgncol,nlev) + + real(r8), allocatable :: packed_rndst(:,:,:) + real(r8), allocatable :: packed_nacon(:,:,:) + + ! Optional outputs. + real(r8) :: packed_tnd_qsnow(mgncol,nlev) + real(r8) :: packed_tnd_nsnow(mgncol,nlev) + real(r8) :: packed_re_ice(mgncol,nlev) + + real(r8) :: packed_frzimm(mgncol,nlev) + real(r8) :: packed_frzcnt(mgncol,nlev) + real(r8) :: packed_frzdep(mgncol,nlev) + + ! Output field post-processing. + type(MGPostProc) :: post_proc + + ! Packed versions of outputs. + real(r8), target :: packed_rate1ord_cw2pr_st(mgncol,nlev) + real(r8), target :: packed_tlat(mgncol,nlev) + real(r8), target :: packed_qvlat(mgncol,nlev) + real(r8), target :: packed_qctend(mgncol,nlev) + real(r8), target :: packed_qitend(mgncol,nlev) + real(r8), target :: packed_nctend(mgncol,nlev) + real(r8), target :: packed_nitend(mgncol,nlev) + + real(r8), target :: packed_qrtend(mgncol,nlev) + real(r8), target :: packed_qstend(mgncol,nlev) + real(r8), target :: packed_nrtend(mgncol,nlev) + real(r8), target :: packed_nstend(mgncol,nlev) + + real(r8), target :: packed_prect(mgncol) + real(r8), target :: packed_preci(mgncol) + real(r8), target :: packed_nevapr(mgncol,nlev) + real(r8), target :: packed_am_evp_st(mgncol,nlev) + real(r8), target :: packed_evapsnow(mgncol,nlev) + real(r8), target :: packed_prain(mgncol,nlev) + real(r8), target :: packed_prodsnow(mgncol,nlev) + real(r8), target :: packed_cmeout(mgncol,nlev) + real(r8), target :: packed_qsout(mgncol,nlev) + real(r8), target :: packed_cflx(mgncol,nlev+1) + real(r8), target :: packed_iflx(mgncol,nlev+1) + real(r8), target :: packed_rflx(mgncol,nlev+1) + real(r8), target :: packed_sflx(mgncol,nlev+1) + real(r8), target :: packed_qrout(mgncol,nlev) + real(r8), target :: packed_qcsevap(mgncol,nlev) + real(r8), target :: packed_qisevap(mgncol,nlev) + real(r8), target :: packed_qvres(mgncol,nlev) + real(r8), target :: packed_cmei(mgncol,nlev) + real(r8), target :: packed_vtrmc(mgncol,nlev) + real(r8), target :: packed_vtrmi(mgncol,nlev) + real(r8), target :: packed_qcsedten(mgncol,nlev) + real(r8), target :: packed_qisedten(mgncol,nlev) + real(r8), target :: packed_qrsedten(mgncol,nlev) + real(r8), target :: packed_qssedten(mgncol,nlev) + real(r8), target :: packed_umr(mgncol,nlev) + real(r8), target :: packed_ums(mgncol,nlev) + real(r8), target :: packed_pra(mgncol,nlev) + real(r8), target :: packed_prc(mgncol,nlev) + real(r8), target :: packed_mnuccc(mgncol,nlev) + real(r8), target :: packed_mnucct(mgncol,nlev) + real(r8), target :: packed_msacwi(mgncol,nlev) + real(r8), target :: packed_psacws(mgncol,nlev) + real(r8), target :: packed_bergs(mgncol,nlev) + real(r8), target :: packed_berg(mgncol,nlev) + real(r8), target :: packed_melt(mgncol,nlev) + real(r8), target :: packed_homo(mgncol,nlev) + real(r8), target :: packed_qcres(mgncol,nlev) + real(r8), target :: packed_prci(mgncol,nlev) + real(r8), target :: packed_prai(mgncol,nlev) + real(r8), target :: packed_qires(mgncol,nlev) + real(r8), target :: packed_mnuccr(mgncol,nlev) + real(r8), target :: packed_pracs(mgncol,nlev) + real(r8), target :: packed_meltsdt(mgncol,nlev) + real(r8), target :: packed_frzrdt(mgncol,nlev) + real(r8), target :: packed_mnuccd(mgncol,nlev) + real(r8), target :: packed_nrout(mgncol,nlev) + real(r8), target :: packed_nsout(mgncol,nlev) + real(r8), target :: packed_refl(mgncol,nlev) + real(r8), target :: packed_arefl(mgncol,nlev) + real(r8), target :: packed_areflz(mgncol,nlev) + real(r8), target :: packed_frefl(mgncol,nlev) + real(r8), target :: packed_csrfl(mgncol,nlev) + real(r8), target :: packed_acsrfl(mgncol,nlev) + real(r8), target :: packed_fcsrfl(mgncol,nlev) + real(r8), target :: packed_rercld(mgncol,nlev) + real(r8), target :: packed_ncai(mgncol,nlev) + real(r8), target :: packed_ncal(mgncol,nlev) + real(r8), target :: packed_qrout2(mgncol,nlev) + real(r8), target :: packed_qsout2(mgncol,nlev) + real(r8), target :: packed_nrout2(mgncol,nlev) + real(r8), target :: packed_nsout2(mgncol,nlev) + real(r8), target :: packed_freqs(mgncol,nlev) + real(r8), target :: packed_freqr(mgncol,nlev) + real(r8), target :: packed_nfice(mgncol,nlev) + real(r8), target :: packed_prer_evap(mgncol,nlev) + real(r8), target :: packed_qcrat(mgncol,nlev) + + real(r8), target :: packed_rel(mgncol,nlev) + real(r8), target :: packed_rei(mgncol,nlev) + real(r8), target :: packed_sadice(mgncol,nlev) + real(r8), target :: packed_sadsnow(mgncol,nlev) + real(r8), target :: packed_lambdac(mgncol,nlev) + real(r8), target :: packed_mu(mgncol,nlev) + real(r8), target :: packed_des(mgncol,nlev) + real(r8), target :: packed_dei(mgncol,nlev) + + ! Dummy arrays for cases where we throw away the MG version and + ! recalculate sizes on the CAM grid to avoid time/subcolumn averaging + ! issues. + real(r8) :: rel_fn_dum(mgncol,nlev) + real(r8) :: dsout2_dum(mgncol,nlev) + real(r8) :: drout_dum(mgncol,nlev) + real(r8) :: reff_rain_dum(mgncol,nlev) + real(r8) :: reff_snow_dum(mgncol,nlev) + + ! Heterogeneous-only version of mnuccdo. + real(r8) :: mnuccdohet(state%psetcols,pver) + +!AL + real(r8), target :: packed_nnuccco(mgncol,nlev) ! immersion freezing + real(r8), target :: packed_nnuccto(mgncol,nlev) ! contact freezing + real(r8), target :: packed_npsacwso(mgncol,nlev) ! accr. snow + real(r8), target :: packed_nsubco(mgncol,nlev) ! evaporation of droplet + real(r8), target :: packed_nprao(mgncol,nlev) ! accretion + real(r8), target :: packed_nprc1o(mgncol,nlev) ! autoconversion + real(r8), target :: packed_nqcsedten(mgncol,nlev) ! nqc sedimentation tendency + real(r8), target :: packed_nqisedten(mgncol,nlev) ! nqc sedimentation tendency + real(r8), target :: packed_nmelto(mgncol,nlev) ! melting of cloud ice + real(r8), target :: packed_nhomoo(mgncol,nlev) ! homogeneos freezign cloud water + real(r8), target :: packed_nimelto(mgncol,nlev) ! melting of cloud ice + real(r8), target :: packed_nihomoo(mgncol,nlev) ! homogeneos freezign cloud water + real(r8), target :: packed_nsacwio(mgncol,nlev) ! numb conc tend due to HM ice multiplication + real(r8), target :: packed_nsubio(mgncol,nlev) ! evaporation of cloud ice number (sublimation?) + real(r8), target :: packed_nprcio(mgncol,nlev) ! numb conc tend due to auto of cloud ice to snow + real(r8), target :: packed_npraio(mgncol,nlev) ! numb conc tend due to accr of cloud ice by snow + real(r8), target :: packed_nnudepo(mgncol,nlev) ! deposition? + real(r8), target :: packed_npccno(mgncol,nlev) ! activation + real(r8), target :: packed_nnuccdo(mgncol,nlev) ! nucleation (ice) + real(r8), target :: packed_mnudepo(mgncol,nlev) ! deposition + real(r8), target :: packed_nctncons(mgncol,nlev) ! correction term + real(r8), target :: packed_nctnnbmn(mgncol,nlev) ! correction if below minimum number + real(r8), target :: packed_nctnszmn(mgncol,nlev) ! gamma adjustment (liquid) + real(r8), target :: packed_nctnszmx(mgncol,nlev) ! gamma adjustment (liquid) + real(r8), target :: packed_nctnncld(mgncol,nlev) ! correction for no cloud + real(r8), target :: packed_nitncons(mgncol,nlev) ! numerical conservation check in sub-time step + real(r8), target :: packed_nitnszmn(mgncol,nlev) ! gamma-adjustment (ice) + real(r8), target :: packed_nitnszmx(mgncol,nlev) ! gamma-adjustment (ice) + real(r8), target :: packed_nitnncld(mgncol,nlev) ! corrrection for no cloud + real(r8), target :: packed_frzr(mgncol,nlev) ! mass freezing rain ==> snow + real(r8), target :: packed_nfrzr(mgncol,nlev) ! number freezing rain ==> snow + real(r8), target :: packed_mnuccri(mgncol,nlev) ! mass freezing rain ==> ice + real(r8), target :: packed_nnuccri(mgncol,nlev) ! number freezing rain ==>ice +!AL + + ! physics buffer fields for COSP simulator + real(r8), pointer :: mgflxprc(:,:) ! MG grid-box mean flux_large_scale_cloud_rain+snow at interfaces (kg/m2/s) + real(r8), pointer :: mgflxsnw(:,:) ! MG grid-box mean flux_large_scale_cloud_snow at interfaces (kg/m2/s) + real(r8), pointer :: mgmrprc(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_rain+snow at interfaces (kg/kg) + real(r8), pointer :: mgmrsnw(:,:) ! MG grid-box mean mixingratio_large_scale_cloud_snow at interfaces (kg/kg) + real(r8), pointer :: mgreffrain_grid(:,:) ! MG diagnostic rain effective radius (um) + real(r8), pointer :: mgreffsnow_grid(:,:) ! MG diagnostic snow effective radius (um) + real(r8), pointer :: cvreffliq(:,:) ! convective cloud liquid effective radius (um) + real(r8), pointer :: cvreffice(:,:) ! convective cloud ice effective radius (um) + + ! physics buffer fields used with CARMA + real(r8), pointer, dimension(:,:) :: tnd_qsnow ! external tendency on snow mass (kg/kg/s) + real(r8), pointer, dimension(:,:) :: tnd_nsnow ! external tendency on snow number(#/kg/s) + real(r8), pointer, dimension(:,:) :: re_ice ! ice effective radius (m) + + real(r8), pointer :: rate1ord_cw2pr_st(:,:) ! 1st order rate for direct conversion of + ! strat. cloud water to precip (1/s) ! rce 2010/05/01 + real(r8), pointer :: wsedl(:,:) ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ] + + + real(r8), pointer :: CC_T(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qv(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ql(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qi(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_nl(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_ni(:,:) ! Grid-mean microphysical tendency + real(r8), pointer :: CC_qlst(:,:) ! In-liquid stratus microphysical tendency + + ! variables for heterogeneous freezing + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + real(r8), pointer :: qme(:,:) + + ! A local copy of state is used for diagnostic calculations + type(physics_state) :: state_loc + type(physics_ptend) :: ptend_loc + + real(r8) :: icecldf(state%psetcols,pver) ! Ice cloud fraction + real(r8) :: liqcldf(state%psetcols,pver) ! Liquid cloud fraction (combined into cloud) + + real(r8), pointer :: rel(:,:) ! Liquid effective drop radius (microns) + real(r8), pointer :: rei(:,:) ! Ice effective drop size (microns) + real(r8), pointer :: sadice(:,:) ! Ice surface area density (cm2/cm3) + real(r8), pointer :: sadsnow(:,:) ! Snow surface area density (cm2/cm3) + + + real(r8), pointer :: cmeliq(:,:) + + real(r8), pointer :: cld(:,:) ! Total cloud fraction + real(r8), pointer :: concld(:,:) ! Convective cloud fraction + real(r8), pointer :: iciwpst(:,:) ! Stratiform in-cloud ice water path for radiation + real(r8), pointer :: iclwpst(:,:) ! Stratiform in-cloud liquid water path for radiation + real(r8), pointer :: cldfsnow(:,:) ! Cloud fraction for liquid+snow + real(r8), pointer :: icswp(:,:) ! In-cloud snow water path + + real(r8) :: icimrst(state%psetcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst(state%psetcols,pver) ! In stratus water mixing ratio + real(r8) :: icinc(state%psetcols,pver) ! In cloud ice number conc + real(r8) :: icwnc(state%psetcols,pver) ! In cloud water number conc + + real(r8) :: iclwpi(state%psetcols) ! Vertically-integrated in-cloud Liquid WP before microphysics + real(r8) :: iciwpi(state%psetcols) ! Vertically-integrated in-cloud Ice WP before microphysics + + ! Averaging arrays for effective radius and number.... + real(r8) :: efiout_grid(pcols,pver) + real(r8) :: efcout_grid(pcols,pver) + real(r8) :: ncout_grid(pcols,pver) + real(r8) :: niout_grid(pcols,pver) + real(r8) :: freqi_grid(pcols,pver) + real(r8) :: freql_grid(pcols,pver) + +! Averaging arrays for supercooled liquid + real(r8) :: freqm_grid(pcols,pver) + real(r8) :: freqsl_grid(pcols,pver) + real(r8) :: freqslm_grid(pcols,pver) + real(r8) :: fctm_grid(pcols) + real(r8) :: fctsl_grid(pcols) + real(r8) :: fctslm_grid(pcols) + + real(r8) :: cdnumc_grid(pcols) ! Vertically-integrated droplet concentration + real(r8) :: icimrst_grid_out(pcols,pver) ! In stratus ice mixing ratio + real(r8) :: icwmrst_grid_out(pcols,pver) ! In stratus water mixing ratio + + ! Cloud fraction used for precipitation. + real(r8) :: cldmax_grid(pcols,pver) + + ! Average cloud top radius & number + real(r8) :: ctrel_grid(pcols) + real(r8) :: ctrei_grid(pcols) + real(r8) :: ctnl_grid(pcols) + real(r8) :: ctni_grid(pcols) + real(r8) :: fcti_grid(pcols) + real(r8) :: fctl_grid(pcols) + + real(r8) :: ftem_grid(pcols,pver) + !++IH: + real(r8) :: fctl_b(pcols) !frequency of occurrence for Bennartz + real(r8) :: ctnl_b(pcols) !cdnc [/m3] for Bennartz +!akc6+ + real(r8) :: ccn_b(pcols) !ccm [/m3] defined as for cdnc for Bennartz +!akc6- + !--IH + + ! Variables for precip efficiency calculation + real(r8) :: minlwp ! LWP threshold + + real(r8), pointer, dimension(:) :: acprecl_grid ! accumulated precip across timesteps + real(r8), pointer, dimension(:) :: acgcme_grid ! accumulated condensation across timesteps + integer, pointer, dimension(:) :: acnum_grid ! counter for # timesteps accumulated + + ! Variables for liquid water path and column condensation + real(r8) :: tgliqwp_grid(pcols) ! column liquid + real(r8) :: tgcmeliq_grid(pcols) ! column condensation rate (units) + + real(r8) :: pe_grid(pcols) ! precip efficiency for output + real(r8) :: pefrac_grid(pcols) ! fraction of time precip efficiency is written out + real(r8) :: tpr_grid(pcols) ! average accumulated precipitation rate in pe calculation + + ! variables for autoconversion and accretion vertical averages + real(r8) :: vprco_grid(pcols) ! vertical average autoconversion + real(r8) :: vprao_grid(pcols) ! vertical average accretion + real(r8) :: racau_grid(pcols) ! ratio of vertical averages + integer :: cnt_grid(pcols) ! counters + + logical :: lq(pcnst) + + real(r8) :: icimrst_grid(pcols,pver) ! stratus ice mixing ratio - on grid + real(r8) :: icwmrst_grid(pcols,pver) ! stratus water mixing ratio - on grid + + real(r8), pointer :: lambdac_grid(:,:) + real(r8), pointer :: mu_grid(:,:) + real(r8), pointer :: rel_grid(:,:) + real(r8), pointer :: rei_grid(:,:) + real(r8), pointer :: sadice_grid(:,:) + real(r8), pointer :: sadsnow_grid(:,:) + real(r8), pointer :: dei_grid(:,:) + real(r8), pointer :: des_grid(:,:) + real(r8), pointer :: iclwpst_grid(:,:) + + real(r8) :: rho_grid(pcols,pver) + real(r8) :: liqcldf_grid(pcols,pver) + real(r8) :: qsout_grid(pcols,pver) + real(r8) :: ncic_grid(pcols,pver) + real(r8) :: niic_grid(pcols,pver) + real(r8) :: rel_fn_grid(pcols,pver) ! Ice effective drop size at fixed number (indirect effect) (microns) - on grid + real(r8) :: qrout_grid(pcols,pver) + real(r8) :: drout2_grid(pcols,pver) + real(r8) :: dsout2_grid(pcols,pver) + real(r8) :: nsout_grid(pcols,pver) + real(r8) :: nrout_grid(pcols,pver) + real(r8) :: reff_rain_grid(pcols,pver) + real(r8) :: reff_snow_grid(pcols,pver) + real(r8) :: cld_grid(pcols,pver) + real(r8) :: pdel_grid(pcols,pver) + real(r8) :: prco_grid(pcols,pver) + real(r8) :: prao_grid(pcols,pver) + real(r8) :: icecldf_grid(pcols,pver) + real(r8) :: icwnc_grid(pcols,pver) + real(r8) :: icinc_grid(pcols,pver) + real(r8) :: qcreso_grid(pcols,pver) + real(r8) :: melto_grid(pcols,pver) + real(r8) :: mnuccco_grid(pcols,pver) + real(r8) :: mnuccto_grid(pcols,pver) + real(r8) :: bergo_grid(pcols,pver) + real(r8) :: homoo_grid(pcols,pver) + real(r8) :: msacwio_grid(pcols,pver) + real(r8) :: psacwso_grid(pcols,pver) + real(r8) :: bergso_grid(pcols,pver) + real(r8) :: cmeiout_grid(pcols,pver) + real(r8) :: qireso_grid(pcols,pver) + real(r8) :: prcio_grid(pcols,pver) + real(r8) :: praio_grid(pcols,pver) + + real(r8) :: nc_grid(pcols,pver) + real(r8) :: ni_grid(pcols,pver) + real(r8) :: qr_grid(pcols,pver) + real(r8) :: nr_grid(pcols,pver) + real(r8) :: qs_grid(pcols,pver) + real(r8) :: ns_grid(pcols,pver) + + real(r8) :: cp_rh(pcols,pver) + real(r8) :: cp_t(pcols) + real(r8) :: cp_z(pcols) + real(r8) :: cp_dt(pcols) + real(r8) :: cp_dz(pcols) + integer :: troplev(pcols) + real(r8) :: es + real(r8) :: qs + + real(r8), pointer :: cmeliq_grid(:,:) + + real(r8), pointer :: prec_str_grid(:) + real(r8), pointer :: snow_str_grid(:) + real(r8), pointer :: prec_pcw_grid(:) + real(r8), pointer :: snow_pcw_grid(:) + real(r8), pointer :: prec_sed_grid(:) + real(r8), pointer :: snow_sed_grid(:) + real(r8), pointer :: cldo_grid(:,:) + real(r8), pointer :: nevapr_grid(:,:) + real(r8), pointer :: prain_grid(:,:) + real(r8), pointer :: mgflxprc_grid(:,:) + real(r8), pointer :: mgflxsnw_grid(:,:) + real(r8), pointer :: mgmrprc_grid(:,:) + real(r8), pointer :: mgmrsnw_grid(:,:) + real(r8), pointer :: cvreffliq_grid(:,:) + real(r8), pointer :: cvreffice_grid(:,:) + real(r8), pointer :: rate1ord_cw2pr_st_grid(:,:) + real(r8), pointer :: wsedl_grid(:,:) + real(r8), pointer :: CC_t_grid(:,:) + real(r8), pointer :: CC_qv_grid(:,:) + real(r8), pointer :: CC_ql_grid(:,:) + real(r8), pointer :: CC_qi_grid(:,:) + real(r8), pointer :: CC_nl_grid(:,:) + real(r8), pointer :: CC_ni_grid(:,:) + real(r8), pointer :: CC_qlst_grid(:,:) + real(r8), pointer :: qme_grid(:,:) + real(r8), pointer :: iciwpst_grid(:,:) + real(r8), pointer :: icswp_grid(:,:) + real(r8), pointer :: ast_grid(:,:) + real(r8), pointer :: cldfsnow_grid(:,:) + + real(r8), pointer :: qrout_grid_ptr(:,:) + real(r8), pointer :: qsout_grid_ptr(:,:) + real(r8), pointer :: nrout_grid_ptr(:,:) + real(r8), pointer :: nsout_grid_ptr(:,:) + + + logical :: use_subcol_microp + integer :: col_type ! Flag to store whether accessing grid or sub-columns in pbuf_get_field + + character(128) :: errstring ! return status (non-blank for error return) + + ! For rrtmg optics. specified distribution. + real(r8), parameter :: dcon = 25.e-6_r8 ! Convective size distribution effective radius (meters) + real(r8), parameter :: mucon = 5.3_r8 ! Convective size distribution shape parameter + real(r8), parameter :: deicon = 50._r8 ! Convective ice effective diameter (meters) + + real(r8), pointer :: pckdptr(:,:) + + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + psetcols = state%psetcols + ngrdcol = state%ngrdcol + + itim_old = pbuf_old_tim_idx() + + call phys_getopts(use_subcol_microp_out=use_subcol_microp) + + ! Set the col_type flag to grid or subcolumn dependent on the value of use_subcol_microp + call pbuf_col_type_index(use_subcol_microp, col_type=col_type) + + !----------------------- + ! These physics buffer fields are read only and not set in this parameterization + ! If these fields do not have subcolumn data, copy the grid to the subcolumn if subcolumns is turned on + ! If subcolumns is not turned on, then these fields will be grid data + + call pbuf_get_field(pbuf, naai_idx, naai, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, npccn_idx, npccn, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, rndst_idx, rndst, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, nacon_idx, nacon, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, relvar_idx, relvar, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, accre_enhan_idx, accre_enhan, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq, col_type=col_type, copy_if_needed=use_subcol_microp) + + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, concld_idx, concld, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), & + col_type=col_type, copy_if_needed=use_subcol_microp) + + if (.not. do_cldice) then + call pbuf_get_field(pbuf, tnd_qsnow_idx, tnd_qsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, tnd_nsnow_idx, tnd_nsnow, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, re_ice_idx, re_ice, col_type=col_type, copy_if_needed=use_subcol_microp) + end if + + if (use_hetfrz_classnuc) then + call pbuf_get_field(pbuf, frzimm_idx, frzimm, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzcnt_idx, frzcnt, col_type=col_type, copy_if_needed=use_subcol_microp) + call pbuf_get_field(pbuf, frzdep_idx, frzdep, col_type=col_type, copy_if_needed=use_subcol_microp) + end if + + if (qsatfac_idx > 0) call pbuf_get_field(pbuf, qsatfac_idx, qsatfac, col_type=col_type, copy_if_needed=use_subcol_microp) + + !----------------------- + ! These physics buffer fields are calculated and set in this parameterization + ! If subcolumns is turned on, then these fields will be calculated on a subcolumn grid, otherwise they will be a normal grid + + call pbuf_get_field(pbuf, prec_str_idx, prec_str, col_type=col_type) + call pbuf_get_field(pbuf, snow_str_idx, snow_str, col_type=col_type) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw, col_type=col_type) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw, col_type=col_type) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed, col_type=col_type) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed, col_type=col_type) + call pbuf_get_field(pbuf, nevapr_idx, nevapr, col_type=col_type) + call pbuf_get_field(pbuf, prer_evap_idx, prer_evap, col_type=col_type) + call pbuf_get_field(pbuf, prain_idx, prain, col_type=col_type) + call pbuf_get_field(pbuf, dei_idx, dei, col_type=col_type) + call pbuf_get_field(pbuf, mu_idx, mu, col_type=col_type) + call pbuf_get_field(pbuf, lambdac_idx, lambdac, col_type=col_type) + call pbuf_get_field(pbuf, des_idx, des, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc, col_type=col_type) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq, col_type=col_type) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice, col_type=col_type) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst, col_type=col_type) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst, col_type=col_type) + call pbuf_get_field(pbuf, icswp_idx, icswp, col_type=col_type) + call pbuf_get_field(pbuf, rel_idx, rel, col_type=col_type) + call pbuf_get_field(pbuf, rei_idx, rei, col_type=col_type) + call pbuf_get_field(pbuf, sadice_idx, sadice, col_type=col_type) + call pbuf_get_field(pbuf, sadsnow_idx, sadsnow, col_type=col_type) + call pbuf_get_field(pbuf, wsedl_idx, wsedl, col_type=col_type) + call pbuf_get_field(pbuf, qme_idx, qme, col_type=col_type) + + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_t_idx, CC_t, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst, start=(/1,1,itim_old/), kount=(/psetcols,pver,1/), col_type=col_type) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st, col_type=col_type) + end if + + if (qrain_idx > 0) call pbuf_get_field(pbuf, qrain_idx, qrout_grid_ptr) + if (qsnow_idx > 0) call pbuf_get_field(pbuf, qsnow_idx, qsout_grid_ptr) + if (nrain_idx > 0) call pbuf_get_field(pbuf, nrain_idx, nrout_grid_ptr) + if (nsnow_idx > 0) call pbuf_get_field(pbuf, nsnow_idx, nsout_grid_ptr) + + !----------------------- + ! If subcolumns is turned on, all calculated fields which are on subcolumns + ! need to be retrieved on the grid as well for storing averaged values + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_grid) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_grid) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw_grid) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw_grid) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed_grid) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed_grid) + call pbuf_get_field(pbuf, nevapr_idx, nevapr_grid) + call pbuf_get_field(pbuf, prain_idx, prain_grid) + call pbuf_get_field(pbuf, dei_idx, dei_grid) + call pbuf_get_field(pbuf, mu_idx, mu_grid) + call pbuf_get_field(pbuf, lambdac_idx, lambdac_grid) + call pbuf_get_field(pbuf, des_idx, des_grid) + call pbuf_get_field(pbuf, ls_flxprc_idx, mgflxprc_grid) + call pbuf_get_field(pbuf, ls_flxsnw_idx, mgflxsnw_grid) + call pbuf_get_field(pbuf, ls_mrprc_idx, mgmrprc_grid) + call pbuf_get_field(pbuf, ls_mrsnw_idx, mgmrsnw_grid) + call pbuf_get_field(pbuf, cv_reffliq_idx, cvreffliq_grid) + call pbuf_get_field(pbuf, cv_reffice_idx, cvreffice_grid) + call pbuf_get_field(pbuf, iciwpst_idx, iciwpst_grid) + call pbuf_get_field(pbuf, iclwpst_idx, iclwpst_grid) + call pbuf_get_field(pbuf, icswp_idx, icswp_grid) + call pbuf_get_field(pbuf, rel_idx, rel_grid) + call pbuf_get_field(pbuf, rei_idx, rei_grid) + call pbuf_get_field(pbuf, sadice_idx, sadice_grid) + call pbuf_get_field(pbuf, sadsnow_idx, sadsnow_grid) + call pbuf_get_field(pbuf, wsedl_idx, wsedl_grid) + call pbuf_get_field(pbuf, qme_idx, qme_grid) + + call pbuf_get_field(pbuf, cldo_idx, cldo_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_t_idx, CC_t_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qv_idx, CC_qv_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ql_idx, CC_ql_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qi_idx, CC_qi_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_nl_idx, CC_nl_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_ni_idx, CC_ni_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, cc_qlst_idx, CC_qlst_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (rate1_cw2pr_st_idx > 0) then + call pbuf_get_field(pbuf, rate1_cw2pr_st_idx, rate1ord_cw2pr_st_grid) + end if + + end if + + !----------------------- + ! These are only on the grid regardless of whether subcolumns are turned on or not + call pbuf_get_field(pbuf, ls_reffrain_idx, mgreffrain_grid) + call pbuf_get_field(pbuf, ls_reffsnow_idx, mgreffsnow_grid) + call pbuf_get_field(pbuf, acpr_idx, acprecl_grid) + call pbuf_get_field(pbuf, acgcme_idx, acgcme_grid) + call pbuf_get_field(pbuf, acnum_idx, acnum_grid) + call pbuf_get_field(pbuf, cmeliq_idx, cmeliq_grid) + call pbuf_get_field(pbuf, ast_idx, ast_grid, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, evprain_st_idx, evprain_st_grid) + call pbuf_get_field(pbuf, evpsnow_st_idx, evpsnow_st_grid) + call pbuf_get_field(pbuf, am_evp_st_idx, am_evp_st_grid) + + !------------------------------------------------------------------------------------- + ! Microphysics assumes 'liquid stratus frac = ice stratus frac + ! = max( liquid stratus frac, ice stratus frac )'. + alst_mic => ast + aist_mic => ast + + ! Output initial in-cloud LWP (before microphysics) + + iclwpi = 0._r8 + iciwpi = 0._r8 + + do i = 1, ncol + do k = top_lev, pver + iclwpi(i) = iclwpi(i) + & + min(state%q(i,k,ixcldliq) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + iciwpi(i) = iciwpi(i) + & + min(state%q(i,k,ixcldice) / max(mincld,ast(i,k)),0.005_r8) & + * state%pdel(i,k) / gravit + end do + end do + + cldo(:ncol,top_lev:pver)=ast(:ncol,top_lev:pver) + + ! Initialize local state from input. + call physics_state_copy(state, state_loc) + + ! Because of the of limited vertical resolution, there can be a signifcant + ! warm bias at the cold point tropopause, which can create a wet bias in the + ! stratosphere. For the microphysics only, update the cold point temperature, with + ! an estimate of the coldest point between the model layers. + if (micro_mg_adjust_cpt) then + cp_rh(:ncol, :pver) = 0._r8 + cp_dt(:ncol) = 0._r8 + cp_dz(:ncol) = 0._r8 + + call tropopause_find(state_loc, troplev, primary=TROP_ALG_CPP, backup=TROP_ALG_NONE, & + tropZ=cp_z, tropT=cp_t) + + do i = 1, ncol + + ! Update statistics and output results. + if (troplev(i) .ne. NOTFOUND) then + cp_dt(i) = cp_t(i) - state_loc%t(i,troplev(i)) + cp_dz(i) = cp_z(i) - state_loc%zm(i,troplev(i)) + + ! NOTE: This change in temperature is just for the microphysics + ! and should not be added to any tendencies or used to update + ! any states + state_loc%t(i,troplev(i)) = state_loc%t(i,troplev(i)) + cp_dt(i) + end if + end do + + ! Output all of the statistics related to the cold point + ! tropopause adjustment. Th cold point information itself is + ! output in tropopause.F90. + call outfld("TROPF_TADJ", state_loc%t, pcols, lchnk) + call outfld("TROPF_CDT", cp_dt, pcols, lchnk) + call outfld("TROPF_CDZ", cp_dz, pcols, lchnk) + end if + + ! Initialize ptend for output. + lq = .false. + lq(1) = .true. + lq(ixcldliq) = .true. + lq(ixcldice) = .true. + lq(ixnumliq) = .true. + lq(ixnumice) = .true. + if (micro_mg_version > 1) then + lq(ixrain) = .true. + lq(ixsnow) = .true. + lq(ixnumrain) = .true. + lq(ixnumsnow) = .true. + end if + + ! the name 'cldwat' triggers special tests on cldliq + ! and cldice in physics_update + call physics_ptend_init(ptend, psetcols, "cldwat", ls=.true., lq=lq) + + packer = MGPacker(psetcols, pver, mgcols, top_lev) + post_proc = MGPostProc(packer) + + pckdptr => packed_rate1ord_cw2pr_st ! workaround an apparent pgi compiler bug + call post_proc%add_field(p(rate1cld), pckdptr) + call post_proc%add_field(p(tlat) , p(packed_tlat)) + call post_proc%add_field(p(qvlat), p(packed_qvlat)) + call post_proc%add_field(p(qcten), p(packed_qctend)) + call post_proc%add_field(p(qiten), p(packed_qitend)) + call post_proc%add_field(p(ncten), p(packed_nctend)) + call post_proc%add_field(p(niten), p(packed_nitend)) + + if (micro_mg_version > 1) then + call post_proc%add_field(p(qrten), p(packed_qrtend)) + call post_proc%add_field(p(qsten), p(packed_qstend)) + call post_proc%add_field(p(nrten), p(packed_nrtend)) + call post_proc%add_field(p(nsten), p(packed_nstend)) + call post_proc%add_field(p(umr), p(packed_umr)) + call post_proc%add_field(p(ums), p(packed_ums)) + call post_proc%add_field(p(cflx), p(packed_cflx)) + call post_proc%add_field(p(iflx), p(packed_iflx)) + end if + + call post_proc%add_field(p(am_evp_st), p(packed_am_evp_st)) + + call post_proc%add_field(p(prect), p(packed_prect)) + call post_proc%add_field(p(preci), p(packed_preci)) + call post_proc%add_field(p(nevapr), p(packed_nevapr)) + call post_proc%add_field(p(evapsnow), p(packed_evapsnow)) + call post_proc%add_field(p(prain), p(packed_prain)) + call post_proc%add_field(p(prodsnow), p(packed_prodsnow)) + call post_proc%add_field(p(cmeice), p(packed_cmeout)) + call post_proc%add_field(p(qsout), p(packed_qsout)) + call post_proc%add_field(p(rflx), p(packed_rflx)) + call post_proc%add_field(p(sflx), p(packed_sflx)) + call post_proc%add_field(p(qrout), p(packed_qrout)) + call post_proc%add_field(p(qcsevap), p(packed_qcsevap)) + call post_proc%add_field(p(qisevap), p(packed_qisevap)) + call post_proc%add_field(p(qvres), p(packed_qvres)) + call post_proc%add_field(p(cmeiout), p(packed_cmei)) + call post_proc%add_field(p(vtrmc), p(packed_vtrmc)) + call post_proc%add_field(p(vtrmi), p(packed_vtrmi)) + call post_proc%add_field(p(qcsedten), p(packed_qcsedten)) + call post_proc%add_field(p(qisedten), p(packed_qisedten)) + if (micro_mg_version > 1) then + call post_proc%add_field(p(qrsedten), p(packed_qrsedten)) + call post_proc%add_field(p(qssedten), p(packed_qssedten)) + end if + + call post_proc%add_field(p(prao), p(packed_pra)) + call post_proc%add_field(p(prco), p(packed_prc)) + call post_proc%add_field(p(mnuccco), p(packed_mnuccc)) + call post_proc%add_field(p(mnuccto), p(packed_mnucct)) + call post_proc%add_field(p(msacwio), p(packed_msacwi)) + call post_proc%add_field(p(psacwso), p(packed_psacws)) + call post_proc%add_field(p(bergso), p(packed_bergs)) + call post_proc%add_field(p(bergo), p(packed_berg)) + call post_proc%add_field(p(melto), p(packed_melt)) + call post_proc%add_field(p(homoo), p(packed_homo)) + call post_proc%add_field(p(qcreso), p(packed_qcres)) + call post_proc%add_field(p(prcio), p(packed_prci)) + call post_proc%add_field(p(praio), p(packed_prai)) + call post_proc%add_field(p(qireso), p(packed_qires)) + call post_proc%add_field(p(mnuccro), p(packed_mnuccr)) + call post_proc%add_field(p(pracso), p(packed_pracs)) + call post_proc%add_field(p(meltsdt), p(packed_meltsdt)) + call post_proc%add_field(p(frzrdt), p(packed_frzrdt)) + call post_proc%add_field(p(mnuccdo), p(packed_mnuccd)) + call post_proc%add_field(p(nrout), p(packed_nrout)) + call post_proc%add_field(p(nsout), p(packed_nsout)) + + call post_proc%add_field(p(refl), p(packed_refl), fillvalue=-9999._r8) + call post_proc%add_field(p(arefl), p(packed_arefl)) + call post_proc%add_field(p(areflz), p(packed_areflz)) + call post_proc%add_field(p(frefl), p(packed_frefl)) + call post_proc%add_field(p(csrfl), p(packed_csrfl), fillvalue=-9999._r8) + call post_proc%add_field(p(acsrfl), p(packed_acsrfl)) + call post_proc%add_field(p(fcsrfl), p(packed_fcsrfl)) + + call post_proc%add_field(p(rercld), p(packed_rercld)) + call post_proc%add_field(p(ncai), p(packed_ncai)) + call post_proc%add_field(p(ncal), p(packed_ncal)) + call post_proc%add_field(p(qrout2), p(packed_qrout2)) + call post_proc%add_field(p(qsout2), p(packed_qsout2)) + call post_proc%add_field(p(nrout2), p(packed_nrout2)) + call post_proc%add_field(p(nsout2), p(packed_nsout2)) + call post_proc%add_field(p(freqs), p(packed_freqs)) + call post_proc%add_field(p(freqr), p(packed_freqr)) + call post_proc%add_field(p(nfice), p(packed_nfice)) + if (micro_mg_version /= 1) then + call post_proc%add_field(p(qcrat), p(packed_qcrat), fillvalue=1._r8) + end if + +!AL + call post_proc%add_field(p(nnuccco), p(packed_nnuccco)) + call post_proc%add_field(p(nnuccto), p(packed_nnuccto)) + call post_proc%add_field(p(npsacwso), p(packed_npsacwso)) + call post_proc%add_field(p(nsubco), p(packed_nsubco)) + call post_proc%add_field(p(nprao), p(packed_nprao)) + call post_proc%add_field(p(nprc1o), p(packed_nprc1o)) + call post_proc%add_field(p(nqcsedten), p(packed_nqcsedten)) + call post_proc%add_field(p(nqisedten), p(packed_nqisedten)) + call post_proc%add_field(p(nmelto), p(packed_nmelto)) + call post_proc%add_field(p(nhomoo), p(packed_nhomoo)) + call post_proc%add_field(p(nimelto), p(packed_nimelto)) + call post_proc%add_field(p(nihomoo), p(packed_nihomoo)) + call post_proc%add_field(p(nsacwio), p(packed_nsacwio)) + call post_proc%add_field(p(nsubio), p(packed_nsubio)) + call post_proc%add_field(p(nprcio), p(packed_nprcio)) + call post_proc%add_field(p(npraio), p(packed_npraio)) + call post_proc%add_field(p(nnudepo), p(packed_nnudepo)) + call post_proc%add_field(p(npccno), p(packed_npccno)) + call post_proc%add_field(p(nnuccdo), p(packed_nnuccdo)) + call post_proc%add_field(p(mnudepo), p(packed_mnudepo)) + call post_proc%add_field(p(nctncons), p(packed_nctncons)) + call post_proc%add_field(p(nctnnbmn), p(packed_nctnnbmn)) + call post_proc%add_field(p(nctnszmn), p(packed_nctnszmn)) + call post_proc%add_field(p(nctnszmx), p(packed_nctnszmx)) + call post_proc%add_field(p(nctnncld), p(packed_nctnncld)) + call post_proc%add_field(p(nitncons), p(packed_nitncons)) + call post_proc%add_field(p(nitnszmn), p(packed_nitnszmn)) + call post_proc%add_field(p(nitnszmx), p(packed_nitnszmx)) + call post_proc%add_field(p(nitnncld), p(packed_nitnncld)) + call post_proc%add_field(p(frzr), p(packed_frzr)) + call post_proc%add_field(p(nfrzr), p(packed_nfrzr)) + call post_proc%add_field(p(mnuccri), p(packed_mnuccri)) + call post_proc%add_field(p(nnuccri), p(packed_nnuccri)) +!AL + + ! The following are all variables related to sizes, where it does not + ! necessarily make sense to average over time steps. Instead, we keep + ! the value from the last substep, which is what "accum_null" does. + call post_proc%add_field(p(rel), p(packed_rel), & + fillvalue=10._r8, accum_method=accum_null) + call post_proc%add_field(p(rei), p(packed_rei), & + fillvalue=25._r8, accum_method=accum_null) + call post_proc%add_field(p(sadice), p(packed_sadice), & + accum_method=accum_null) + call post_proc%add_field(p(sadsnow), p(packed_sadsnow), & + accum_method=accum_null) + call post_proc%add_field(p(lambdac), p(packed_lambdac), & + accum_method=accum_null) + call post_proc%add_field(p(mu), p(packed_mu), & + accum_method=accum_null) + call post_proc%add_field(p(des), p(packed_des), & + accum_method=accum_null) + call post_proc%add_field(p(dei), p(packed_dei), & + accum_method=accum_null) + call post_proc%add_field(p(prer_evap), p(packed_prer_evap), & + accum_method=accum_null) + + ! Pack input variables that are not updated during substeps. + packed_relvar = packer%pack(relvar) + packed_accre_enhan = packer%pack(accre_enhan) + + packed_p = packer%pack(state_loc%pmid) + packed_pdel = packer%pack(state_loc%pdel) + + packed_cldn = packer%pack(ast) + packed_liqcldf = packer%pack(alst_mic) + packed_icecldf = packer%pack(aist_mic) + allocate(packed_qsatfac(mgncol,nlev)) + if (qsatfac_idx > 0) then + packed_qsatfac = packer%pack(qsatfac) + else + packed_qsatfac = 1._r8 + endif + packed_naai = packer%pack(naai) + packed_npccn = packer%pack(npccn) + + allocate(packed_rndst(mgncol,nlev,size(rndst, 3))) + packed_rndst = packer%pack(rndst) + + allocate(packed_nacon(mgncol,nlev,size(nacon, 3))) + packed_nacon = packer%pack(nacon) + + if (.not. do_cldice) then + packed_tnd_qsnow = packer%pack(tnd_qsnow) + packed_tnd_nsnow = packer%pack(tnd_nsnow) + packed_re_ice = packer%pack(re_ice) + end if + + if (use_hetfrz_classnuc) then + packed_frzimm = packer%pack(frzimm) + packed_frzcnt = packer%pack(frzcnt) + packed_frzdep = packer%pack(frzdep) + end if + + do it = 1, num_steps + + ! Pack input variables that are updated during substeps. + packed_t = packer%pack(state_loc%t) + packed_q = packer%pack(state_loc%q(:,:,1)) + packed_qc = packer%pack(state_loc%q(:,:,ixcldliq)) + packed_nc = packer%pack(state_loc%q(:,:,ixnumliq)) + packed_qi = packer%pack(state_loc%q(:,:,ixcldice)) + packed_ni = packer%pack(state_loc%q(:,:,ixnumice)) + if (micro_mg_version > 1) then + packed_qr = packer%pack(state_loc%q(:,:,ixrain)) + packed_nr = packer%pack(state_loc%q(:,:,ixnumrain)) + packed_qs = packer%pack(state_loc%q(:,:,ixsnow)) + packed_ns = packer%pack(state_loc%q(:,:,ixnumsnow)) + end if + + select case (micro_mg_version) + case (1) + select case (micro_mg_sub_version) + case (0) + call micro_mg_tend1_0( & + microp_uniform, mgncol, nlev, mgncol, 1, dtime/num_steps, & + packed_t, packed_q, packed_qc, packed_qi, packed_nc, & + packed_ni, packed_p, packed_pdel, packed_cldn, packed_liqcldf,& + packed_relvar, packed_accre_enhan, & + packed_icecldf, packed_rate1ord_cw2pr_st, packed_naai, packed_npccn, & + packed_rndst, packed_nacon, packed_tlat, packed_qvlat, packed_qctend, & + packed_qitend, packed_nctend, packed_nitend, packed_rel, rel_fn_dum, & + packed_rei, packed_prect, packed_preci, packed_nevapr, packed_evapsnow, packed_am_evp_st, & + packed_prain, packed_prodsnow, packed_cmeout, packed_dei, packed_mu, & + packed_lambdac, packed_qsout, packed_des, packed_rflx, packed_sflx, & + packed_qrout, reff_rain_dum, reff_snow_dum, packed_qcsevap, packed_qisevap, & + packed_qvres, packed_cmei, packed_vtrmc, packed_vtrmi, packed_qcsedten, & + packed_qisedten, packed_pra, packed_prc, packed_mnuccc, packed_mnucct, & + packed_msacwi, packed_psacws, packed_bergs, packed_berg, packed_melt, & + packed_homo, packed_qcres, packed_prci, packed_prai, packed_qires, & + packed_mnuccr, packed_pracs, packed_meltsdt, packed_frzrdt, packed_mnuccd, & + packed_nrout, packed_nsout, packed_refl, packed_arefl, packed_areflz, & + packed_frefl, packed_csrfl, packed_acsrfl, packed_fcsrfl, packed_rercld, & + packed_ncai, packed_ncal, packed_qrout2, packed_qsout2, packed_nrout2, & + packed_nsout2, drout_dum, dsout2_dum, packed_freqs,packed_freqr, & + packed_nfice, packed_prer_evap, do_cldice, errstring, & + packed_tnd_qsnow, packed_tnd_nsnow, packed_re_ice, & + packed_frzimm, packed_frzcnt, packed_frzdep, & +!AL + packed_nnuccco, packed_nnuccto, packed_npsacwso, packed_nsubco, packed_nprao, & + packed_nprc1o, packed_nqcsedten, packed_nqisedten, packed_nmelto, packed_nhomoo, & + packed_nimelto, packed_nihomoo, packed_nsacwio, packed_nsubio, packed_nprcio, & + packed_npraio, packed_nnudepo, packed_npccno, packed_nnuccdo, packed_mnudepo, & + packed_nctncons, packed_nctnnbmn, packed_nctnszmn, & + packed_nctnszmx, packed_nctnncld, packed_nitncons, packed_nitnszmn, & + packed_nitnszmx, packed_nitnncld) + + +!AL + + end select + case(2) + select case (micro_mg_sub_version) + case (0) + + call micro_mg_tend2_0( & + mgncol, nlev, dtime/num_steps,& + packed_t, packed_q, & + packed_qc, packed_qi, & + packed_nc, packed_ni, & + packed_qr, packed_qs, & + packed_nr, packed_ns, & + packed_relvar, packed_accre_enhan, & + packed_p, packed_pdel, & + packed_cldn, packed_liqcldf, packed_icecldf, packed_qsatfac, & + packed_rate1ord_cw2pr_st, & + packed_naai, packed_npccn, & + packed_rndst, packed_nacon, & + packed_tlat, packed_qvlat, & + packed_qctend, packed_qitend, & + packed_nctend, packed_nitend, & + packed_qrtend, packed_qstend, & + packed_nrtend, packed_nstend, & + packed_rel, rel_fn_dum, packed_rei, & + packed_sadice, packed_sadsnow, & + packed_prect, packed_preci, & + packed_nevapr, packed_evapsnow, & + packed_am_evp_st, & + packed_prain, packed_prodsnow, & + packed_cmeout, packed_dei, & + packed_mu, packed_lambdac, & + packed_qsout, packed_des, & + packed_cflx, packed_iflx, & + packed_rflx, packed_sflx, packed_qrout, & + reff_rain_dum, reff_snow_dum, & + packed_qcsevap, packed_qisevap, packed_qvres, & + packed_cmei, packed_vtrmc, packed_vtrmi, & + packed_umr, packed_ums, & + packed_qcsedten, packed_qisedten, & + packed_qrsedten, packed_qssedten, & + packed_pra, packed_prc, & + packed_mnuccc, packed_mnucct, packed_msacwi, & + packed_psacws, packed_bergs, packed_berg, & + packed_melt, packed_homo, & + packed_qcres, packed_prci, packed_prai, & + packed_qires, packed_mnuccr, packed_pracs, & + packed_meltsdt, packed_frzrdt, packed_mnuccd, & + packed_nrout, packed_nsout, & + packed_refl, packed_arefl, packed_areflz, & + packed_frefl, packed_csrfl, packed_acsrfl, & + packed_fcsrfl, packed_rercld, & + packed_ncai, packed_ncal, & + packed_qrout2, packed_qsout2, & + packed_nrout2, packed_nsout2, & + drout_dum, dsout2_dum, & + packed_freqs, packed_freqr, & + packed_nfice, packed_qcrat, & + errstring, & +!AL right names? + packed_nnuccco, packed_nnuccto, & + packed_npsacwso, packed_nsubco, packed_nprao, & + packed_nprc1o, packed_nqcsedten, & + packed_nqisedten, packed_nmelto, packed_nhomoo, & + packed_nimelto, packed_nihomoo, packed_nsacwio, & + packed_nsubio, packed_nprcio, & + packed_npraio, packed_nnudepo, & + packed_npccno, packed_nnuccdo, packed_mnudepo, & + packed_frzr,packed_nfrzr, & + packed_nnuccri, packed_mnuccri, & + packed_nctnszmx,packed_nctnszmn, & + packed_nctnncld, packed_nitncons, & + packed_nitnszmx, packed_nitnszmn, packed_nitnncld, & +!AL + packed_tnd_qsnow,packed_tnd_nsnow,packed_re_ice,& + packed_prer_evap, & + packed_frzimm, packed_frzcnt, packed_frzdep ) + end select + end select + + call handle_errmsg(errstring, subname="micro_mg_tend") + + call physics_ptend_init(ptend_loc, psetcols, "micro_mg", & + ls=.true., lq=lq) + + ! Set local tendency. + ptend_loc%s = packer%unpack(packed_tlat, 0._r8) + ptend_loc%q(:,:,1) = packer%unpack(packed_qvlat, 0._r8) + ptend_loc%q(:,:,ixcldliq) = packer%unpack(packed_qctend, 0._r8) + ptend_loc%q(:,:,ixcldice) = packer%unpack(packed_qitend, 0._r8) + ptend_loc%q(:,:,ixnumliq) = packer%unpack(packed_nctend, & + -state_loc%q(:,:,ixnumliq)/(dtime/num_steps)) + if (do_cldice) then + ptend_loc%q(:,:,ixnumice) = packer%unpack(packed_nitend, & + -state_loc%q(:,:,ixnumice)/(dtime/num_steps)) + else + ! In this case, the tendency should be all 0. + if (any(packed_nitend /= 0._r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice number tendencies.") + ptend_loc%q(:,:,ixnumice) = 0._r8 + end if + + if (micro_mg_version > 1) then + ptend_loc%q(:,:,ixrain) = packer%unpack(packed_qrtend, 0._r8) + ptend_loc%q(:,:,ixsnow) = packer%unpack(packed_qstend, 0._r8) + ptend_loc%q(:,:,ixnumrain) = packer%unpack(packed_nrtend, & + -state_loc%q(:,:,ixnumrain)/(dtime/num_steps)) + ptend_loc%q(:,:,ixnumsnow) = packer%unpack(packed_nstend, & + -state_loc%q(:,:,ixnumsnow)/(dtime/num_steps)) + end if + + ! Sum into overall ptend + call physics_ptend_sum(ptend_loc, ptend, ncol) + + ! Update local state + call physics_update(state_loc, ptend_loc, dtime/num_steps) + + ! Sum all outputs for averaging. + call post_proc%accumulate() + + end do + + ! Divide ptend by substeps. + call physics_ptend_scale(ptend, 1._r8/num_steps, ncol) + + ! Use summed outputs to produce averages + call post_proc%process_and_unpack() + + call post_proc%finalize() + + ! Check to make sure that the microphysics code is respecting the flags that control + ! whether MG should be prognosing cloud ice and cloud liquid or not. + if (.not. do_cldice) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldice) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumice) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud ice,"// & + " but micro_mg_tend has ice number tendencies.") + end if + if (.not. do_cldliq) then + if (any(ptend%q(:ncol,top_lev:pver,ixcldliq) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_mg_tend has liquid mass tendencies.") + if (any(ptend%q(:ncol,top_lev:pver,ixnumliq) /= 0.0_r8)) & + call endrun("micro_mg_cam:ERROR - MG microphysics is configured not to prognose cloud liquid,"// & + " but micro_mg_tend has liquid number tendencies.") + end if + + mnuccdohet = 0._r8 + do k=top_lev,pver + do i=1,ncol + if (naai(i,k) > 0._r8) then + mnuccdohet(i,k) = mnuccdo(i,k) - (naai_hom(i,k)/naai(i,k))*mnuccdo(i,k) + end if + end do + end do + + mgflxprc(:ncol,top_lev:pverp) = rflx(:ncol,top_lev:pverp) + sflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = sflx(:ncol,top_lev:pverp) + + !add condensate fluxes for MG2 (ice and snow already added for MG1) + if (micro_mg_version >= 2) then + mgflxprc(:ncol,top_lev:pverp) = mgflxprc(:ncol,top_lev:pverp)+ iflx(:ncol,top_lev:pverp) + cflx(:ncol,top_lev:pverp) + mgflxsnw(:ncol,top_lev:pverp) = mgflxsnw(:ncol,top_lev:pverp) + iflx(:ncol,top_lev:pverp) + end if + + + mgmrprc(:ncol,top_lev:pver) = qrout(:ncol,top_lev:pver) + qsout(:ncol,top_lev:pver) + mgmrsnw(:ncol,top_lev:pver) = qsout(:ncol,top_lev:pver) + + !! calculate effective radius of convective liquid and ice using dcon and deicon (not used by code, not useful for COSP) + !! hard-coded as average of hard-coded values used for deep/shallow convective detrainment (near line 1502/1505) + cvreffliq(:ncol,top_lev:pver) = 9.0_r8 + cvreffice(:ncol,top_lev:pver) = 37.0_r8 + + ! Reassign rate1 if modal aerosols + if (rate1_cw2pr_st_idx > 0) then + rate1ord_cw2pr_st(:ncol,top_lev:pver) = rate1cld(:ncol,top_lev:pver) + end if + + ! Sedimentation velocity for liquid stratus cloud droplet + wsedl(:ncol,top_lev:pver) = vtrmc(:ncol,top_lev:pver) + + ! Microphysical tendencies for use in the macrophysics at the next time step + CC_T(:ncol,top_lev:pver) = tlat(:ncol,top_lev:pver)/cpair + CC_qv(:ncol,top_lev:pver) = qvlat(:ncol,top_lev:pver) + CC_ql(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver) + CC_qi(:ncol,top_lev:pver) = qiten(:ncol,top_lev:pver) + CC_nl(:ncol,top_lev:pver) = ncten(:ncol,top_lev:pver) + CC_ni(:ncol,top_lev:pver) = niten(:ncol,top_lev:pver) + CC_qlst(:ncol,top_lev:pver) = qcten(:ncol,top_lev:pver)/max(0.01_r8,alst_mic(:ncol,top_lev:pver)) + + ! Net micro_mg_cam condensation rate + qme(:ncol,:top_lev-1) = 0._r8 + qme(:ncol,top_lev:pver) = cmeliq(:ncol,top_lev:pver) + cmeiout(:ncol,top_lev:pver) + + ! For precip, accumulate only total precip in prec_pcw and snow_pcw variables. + ! Other precip output variables are set to 0 + ! Do not subscript by ncol here, because in physpkg we divide the whole + ! array and need to avoid an FPE due to uninitialized data. + prec_pcw = prect + snow_pcw = preci + prec_sed = 0._r8 + snow_sed = 0._r8 + prec_str = prec_pcw + prec_sed + snow_str = snow_pcw + snow_sed + + icecldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + liqcldf(:ncol,top_lev:pver) = ast(:ncol,top_lev:pver) + + ! ------------------------------------------------------------ ! + ! Compute in cloud ice and liquid mixing ratios ! + ! Note that 'iclwp, iciwp' are used for radiation computation. ! + ! ------------------------------------------------------------ ! + + icinc = 0._r8 + icwnc = 0._r8 + iciwpst = 0._r8 + iclwpst = 0._r8 + icswp = 0._r8 + cldfsnow = 0._r8 + + do k = top_lev, pver + do i = 1, ncol + ! Limits for in-cloud mixing ratios consistent with MG microphysics + ! in-cloud mixing ratio maximum limit of 0.005 kg/kg + icimrst(i,k) = min( state_loc%q(i,k,ixcldice) / max(mincld,icecldf(i,k)),0.005_r8 ) + icwmrst(i,k) = min( state_loc%q(i,k,ixcldliq) / max(mincld,liqcldf(i,k)),0.005_r8 ) + icinc(i,k) = state_loc%q(i,k,ixnumice) / max(mincld,icecldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + icwnc(i,k) = state_loc%q(i,k,ixnumliq) / max(mincld,liqcldf(i,k)) * & + state_loc%pmid(i,k) / (287.15_r8*state_loc%t(i,k)) + ! Calculate micro_mg_cam cloud water paths in each layer + ! Note: uses stratiform cloud fraction! + iciwpst(i,k) = min(state_loc%q(i,k,ixcldice)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + iclwpst(i,k) = min(state_loc%q(i,k,ixcldliq)/max(mincld,ast(i,k)),0.005_r8) * state_loc%pdel(i,k) / gravit + + ! ------------------------------ ! + ! Adjust cloud fraction for snow ! + ! ------------------------------ ! + cldfsnow(i,k) = cld(i,k) + ! If cloud and only ice ( no convective cloud or ice ), then set to 0. + if( ( cldfsnow(i,k) .gt. 1.e-4_r8 ) .and. & + ( concld(i,k) .lt. 1.e-4_r8 ) .and. & + ( state_loc%q(i,k,ixcldliq) .lt. 1.e-10_r8 ) ) then + cldfsnow(i,k) = 0._r8 + end if + ! If no cloud and snow, then set to 0.25 + if( ( cldfsnow(i,k) .le. 1.e-4_r8 ) .and. ( qsout(i,k) .gt. 1.e-6_r8 ) ) then + cldfsnow(i,k) = 0.25_r8 + end if + ! Calculate in-cloud snow water path + icswp(i,k) = qsout(i,k) / max( mincld, cldfsnow(i,k) ) * state_loc%pdel(i,k) / gravit + end do + end do + + ! Calculate cloud fraction for prognostic precip sizes. + if (micro_mg_version > 1) then + ! Cloud fraction for purposes of precipitation is maximum cloud + ! fraction out of all the layers that the precipitation may be + ! falling down from. + cldmax(:ncol,:) = max(mincld, ast(:ncol,:)) + do k = top_lev+1, pver + where (state_loc%q(:ncol,k-1,ixrain) >= qsmall .or. & + state_loc%q(:ncol,k-1,ixsnow) >= qsmall) + cldmax(:ncol,k) = max(cldmax(:ncol,k-1), cldmax(:ncol,k)) + end where + end do + end if + + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + ! All code from here to the end is on grid columns only ! + ! ------------------------------------------------------ ! + ! ------------------------------------------------------ ! + + ! Average the fields which are needed later in this paramterization to be on the grid + if (use_subcol_microp) then + call subcol_field_avg(prec_str, ngrdcol, lchnk, prec_str_grid) + call subcol_field_avg(iclwpst, ngrdcol, lchnk, iclwpst_grid) + call subcol_field_avg(cvreffliq, ngrdcol, lchnk, cvreffliq_grid) + call subcol_field_avg(cvreffice, ngrdcol, lchnk, cvreffice_grid) + call subcol_field_avg(mgflxprc, ngrdcol, lchnk, mgflxprc_grid) + call subcol_field_avg(mgflxsnw, ngrdcol, lchnk, mgflxsnw_grid) + call subcol_field_avg(qme, ngrdcol, lchnk, qme_grid) + call subcol_field_avg(nevapr, ngrdcol, lchnk, nevapr_grid) + call subcol_field_avg(prain, ngrdcol, lchnk, prain_grid) + call subcol_field_avg(evapsnow, ngrdcol, lchnk, evpsnow_st_grid) + + call subcol_field_avg(am_evp_st, ngrdcol, lchnk, am_evp_st_grid) + + ! Average fields which are not in pbuf + call subcol_field_avg(qrout, ngrdcol, lchnk, qrout_grid) + call subcol_field_avg(qsout, ngrdcol, lchnk, qsout_grid) + call subcol_field_avg(nsout, ngrdcol, lchnk, nsout_grid) + call subcol_field_avg(nrout, ngrdcol, lchnk, nrout_grid) + call subcol_field_avg(cld, ngrdcol, lchnk, cld_grid) + call subcol_field_avg(qcreso, ngrdcol, lchnk, qcreso_grid) + call subcol_field_avg(melto, ngrdcol, lchnk, melto_grid) + call subcol_field_avg(mnuccco, ngrdcol, lchnk, mnuccco_grid) + call subcol_field_avg(mnuccto, ngrdcol, lchnk, mnuccto_grid) + call subcol_field_avg(bergo, ngrdcol, lchnk, bergo_grid) + call subcol_field_avg(homoo, ngrdcol, lchnk, homoo_grid) + call subcol_field_avg(msacwio, ngrdcol, lchnk, msacwio_grid) + call subcol_field_avg(psacwso, ngrdcol, lchnk, psacwso_grid) + call subcol_field_avg(bergso, ngrdcol, lchnk, bergso_grid) + call subcol_field_avg(cmeiout, ngrdcol, lchnk, cmeiout_grid) + call subcol_field_avg(qireso, ngrdcol, lchnk, qireso_grid) + call subcol_field_avg(prcio, ngrdcol, lchnk, prcio_grid) + call subcol_field_avg(praio, ngrdcol, lchnk, praio_grid) + call subcol_field_avg(icwmrst, ngrdcol, lchnk, icwmrst_grid) + call subcol_field_avg(icimrst, ngrdcol, lchnk, icimrst_grid) + call subcol_field_avg(liqcldf, ngrdcol, lchnk, liqcldf_grid) + call subcol_field_avg(icecldf, ngrdcol, lchnk, icecldf_grid) + call subcol_field_avg(icwnc, ngrdcol, lchnk, icwnc_grid) + call subcol_field_avg(icinc, ngrdcol, lchnk, icinc_grid) + call subcol_field_avg(state_loc%pdel, ngrdcol, lchnk, pdel_grid) + call subcol_field_avg(prao, ngrdcol, lchnk, prao_grid) + call subcol_field_avg(prco, ngrdcol, lchnk, prco_grid) + + call subcol_field_avg(state_loc%q(:,:,ixnumliq), ngrdcol, lchnk, nc_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumice), ngrdcol, lchnk, ni_grid) + + if (micro_mg_version > 1) then + call subcol_field_avg(cldmax, ngrdcol, lchnk, cldmax_grid) + + call subcol_field_avg(state_loc%q(:,:,ixrain), ngrdcol, lchnk, qr_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumrain), ngrdcol, lchnk, nr_grid) + call subcol_field_avg(state_loc%q(:,:,ixsnow), ngrdcol, lchnk, qs_grid) + call subcol_field_avg(state_loc%q(:,:,ixnumsnow), ngrdcol, lchnk, ns_grid) + end if + + else + ! These pbuf fields need to be assigned. There is no corresponding subcol_field_avg + ! as they are reset before being used, so it would be a needless calculation + lambdac_grid => lambdac + mu_grid => mu + rel_grid => rel + rei_grid => rei + sadice_grid => sadice + sadsnow_grid => sadsnow + dei_grid => dei + des_grid => des + + ! fields already on grids, so just assign + prec_str_grid => prec_str + iclwpst_grid => iclwpst + cvreffliq_grid => cvreffliq + cvreffice_grid => cvreffice + mgflxprc_grid => mgflxprc + mgflxsnw_grid => mgflxsnw + qme_grid => qme + nevapr_grid => nevapr + prain_grid => prain + + am_evp_st_grid = am_evp_st + + evpsnow_st_grid = evapsnow + qrout_grid = qrout + qsout_grid = qsout + nsout_grid = nsout + nrout_grid = nrout + cld_grid = cld + qcreso_grid = qcreso + melto_grid = melto + mnuccco_grid = mnuccco + mnuccto_grid = mnuccto + bergo_grid = bergo + homoo_grid = homoo + msacwio_grid = msacwio + psacwso_grid = psacwso + bergso_grid = bergso + cmeiout_grid = cmeiout + qireso_grid = qireso + prcio_grid = prcio + praio_grid = praio + icwmrst_grid = icwmrst + icimrst_grid = icimrst + liqcldf_grid = liqcldf + icecldf_grid = icecldf + icwnc_grid = icwnc + icinc_grid = icinc + pdel_grid = state_loc%pdel + prao_grid = prao + prco_grid = prco + + nc_grid = state_loc%q(:,:,ixnumliq) + ni_grid = state_loc%q(:,:,ixnumice) + + if (micro_mg_version > 1) then + cldmax_grid = cldmax + + qr_grid = state_loc%q(:,:,ixrain) + nr_grid = state_loc%q(:,:,ixnumrain) + qs_grid = state_loc%q(:,:,ixsnow) + ns_grid = state_loc%q(:,:,ixnumsnow) + end if + + end if + + ! If on subcolumns, average the rest of the pbuf fields which were modified on subcolumns but are not used further in + ! this parameterization (no need to assign in the non-subcolumn case -- the else step) + if (use_subcol_microp) then + call subcol_field_avg(snow_str, ngrdcol, lchnk, snow_str_grid) + call subcol_field_avg(prec_pcw, ngrdcol, lchnk, prec_pcw_grid) + call subcol_field_avg(snow_pcw, ngrdcol, lchnk, snow_pcw_grid) + call subcol_field_avg(prec_sed, ngrdcol, lchnk, prec_sed_grid) + call subcol_field_avg(snow_sed, ngrdcol, lchnk, snow_sed_grid) + call subcol_field_avg(cldo, ngrdcol, lchnk, cldo_grid) + call subcol_field_avg(mgmrprc, ngrdcol, lchnk, mgmrprc_grid) + call subcol_field_avg(mgmrsnw, ngrdcol, lchnk, mgmrsnw_grid) + call subcol_field_avg(wsedl, ngrdcol, lchnk, wsedl_grid) + call subcol_field_avg(cc_t, ngrdcol, lchnk, cc_t_grid) + call subcol_field_avg(cc_qv, ngrdcol, lchnk, cc_qv_grid) + call subcol_field_avg(cc_ql, ngrdcol, lchnk, cc_ql_grid) + call subcol_field_avg(cc_qi, ngrdcol, lchnk, cc_qi_grid) + call subcol_field_avg(cc_nl, ngrdcol, lchnk, cc_nl_grid) + call subcol_field_avg(cc_ni, ngrdcol, lchnk, cc_ni_grid) + call subcol_field_avg(cc_qlst, ngrdcol, lchnk, cc_qlst_grid) + call subcol_field_avg(iciwpst, ngrdcol, lchnk, iciwpst_grid) + call subcol_field_avg(icswp, ngrdcol, lchnk, icswp_grid) + call subcol_field_avg(cldfsnow, ngrdcol, lchnk, cldfsnow_grid) + + if (rate1_cw2pr_st_idx > 0) then + call subcol_field_avg(rate1ord_cw2pr_st, ngrdcol, lchnk, rate1ord_cw2pr_st_grid) + end if + + end if + + ! ------------------------------------- ! + ! Size distribution calculation ! + ! ------------------------------------- ! + + ! Calculate rho (on subcolumns if turned on) for size distribution + ! parameter calculations and average it if needed + ! + ! State instead of state_loc to preserve answers for MG1 (and in any + ! case, it is unlikely to make much difference). + rho(:ncol,top_lev:) = state%pmid(:ncol,top_lev:) / & + (rair*state%t(:ncol,top_lev:)) + if (use_subcol_microp) then + call subcol_field_avg(rho, ngrdcol, lchnk, rho_grid) + else + rho_grid = rho + end if + + ! Effective radius for cloud liquid, fixed number. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_fn_grid = 10._r8 + + ncic_grid = 1.e8_r8 + + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & + ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & + mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) + + where (icwmrst_grid(:ngrdcol,top_lev:) > qsmall) + rel_fn_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8)/ & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + end where + + ! Effective radius for cloud liquid, and size parameters + ! mu_grid and lambdac_grid. + mu_grid = 0._r8 + lambdac_grid = 0._r8 + rel_grid = 10._r8 + + ! Calculate ncic on the grid + ncic_grid(:ngrdcol,top_lev:) = nc_grid(:ngrdcol,top_lev:) / & + max(mincld,liqcldf_grid(:ngrdcol,top_lev:)) + + call size_dist_param_liq(mg_liq_props, icwmrst_grid(:ngrdcol,top_lev:), & + ncic_grid(:ngrdcol,top_lev:), rho_grid(:ngrdcol,top_lev:), & + mu_grid(:ngrdcol,top_lev:), lambdac_grid(:ngrdcol,top_lev:)) + + where (icwmrst_grid(:ngrdcol,top_lev:) >= qsmall) + rel_grid(:ngrdcol,top_lev:) = & + (mu_grid(:ngrdcol,top_lev:) + 3._r8) / & + lambdac_grid(:ngrdcol,top_lev:)/2._r8 * 1.e6_r8 + elsewhere + ! Deal with the fact that size_dist_param_liq sets mu_grid to -100 + ! wherever there is no cloud. + mu_grid(:ngrdcol,top_lev:) = 0._r8 + end where + + ! Rain/Snow effective diameter. + drout2_grid = 0._r8 + reff_rain_grid = 0._r8 + des_grid = 0._r8 + dsout2_grid = 0._r8 + reff_snow_grid = 0._r8 + + if (micro_mg_version > 1) then + ! Prognostic precipitation + + where (qr_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qr_grid(:ngrdcol,top_lev:), & + nr_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhow) + + reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + where (qs_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qs_grid(:ngrdcol,top_lev:), & + ns_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhosn) + + des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) *& + 3._r8 * rhosn/rhows + + reff_snow_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + else + ! Diagnostic precipitation + + where (qrout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + drout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qrout_grid(:ngrdcol,top_lev:), & + nrout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhow) + + reff_rain_grid(:ngrdcol,top_lev:) = drout2_grid(:ngrdcol,top_lev:) * & + 1.5_r8 * 1.e6_r8 + end where + + where (qsout_grid(:ngrdcol,top_lev:) >= 1.e-7_r8) + dsout2_grid(:ngrdcol,top_lev:) = avg_diameter( & + qsout_grid(:ngrdcol,top_lev:), & + nsout_grid(:ngrdcol,top_lev:) * rho_grid(:ngrdcol,top_lev:), & + rho_grid(:ngrdcol,top_lev:), rhosn) + + des_grid(:ngrdcol,top_lev:) = dsout2_grid(:ngrdcol,top_lev:) & + * 3._r8 * rhosn/rhows + + reff_snow_grid(:ngrdcol,top_lev:) = & + dsout2_grid(:ngrdcol,top_lev:) * 1.5_r8 * 1.e6_r8 + end where + + end if + + ! Effective radius and diameter for cloud ice. + rei_grid = 25._r8 + + niic_grid(:ngrdcol,top_lev:) = ni_grid(:ngrdcol,top_lev:) / & + max(mincld,icecldf_grid(:ngrdcol,top_lev:)) + + call size_dist_param_basic(mg_ice_props, icimrst_grid(:ngrdcol,top_lev:), & + niic_grid(:ngrdcol,top_lev:), rei_grid(:ngrdcol,top_lev:)) + + where (icimrst_grid(:ngrdcol,top_lev:) >= qsmall) + rei_grid(:ngrdcol,top_lev:) = 1.5_r8/rei_grid(:ngrdcol,top_lev:) & + * 1.e6_r8 + elsewhere + rei_grid(:ngrdcol,top_lev:) = 25._r8 + end where + + dei_grid = rei_grid * rhoi/rhows * 2._r8 + + ! Limiters for low cloud fraction. + do k = top_lev, pver + do i = 1, ngrdcol + ! Convert snow effective diameter to microns + des_grid(i,k) = des_grid(i,k) * 1.e6_r8 + if ( ast_grid(i,k) < 1.e-4_r8 ) then + mu_grid(i,k) = mucon + lambdac_grid(i,k) = (mucon + 1._r8)/dcon + dei_grid(i,k) = deicon + end if + end do + end do + + mgreffrain_grid(:ngrdcol,top_lev:pver) = reff_rain_grid(:ngrdcol,top_lev:pver) + mgreffsnow_grid(:ngrdcol,top_lev:pver) = reff_snow_grid(:ngrdcol,top_lev:pver) + + ! ------------------------------------- ! + ! Precipitation efficiency Calculation ! + ! ------------------------------------- ! + + !----------------------------------------------------------------------- + ! Liquid water path + + ! Compute liquid water paths, and column condensation + tgliqwp_grid(:ngrdcol) = 0._r8 + tgcmeliq_grid(:ngrdcol) = 0._r8 + do k = top_lev, pver + do i = 1, ngrdcol + tgliqwp_grid(i) = tgliqwp_grid(i) + iclwpst_grid(i,k)*cld_grid(i,k) + + if (cmeliq_grid(i,k) > 1.e-12_r8) then + !convert cmeliq to right units: kgh2o/kgair/s * kgair/m2 / kgh2o/m3 = m/s + tgcmeliq_grid(i) = tgcmeliq_grid(i) + cmeliq_grid(i,k) * & + (pdel_grid(i,k) / gravit) / rhoh2o + end if + end do + end do + + ! note: 1e-6 kgho2/kgair/s * 1000. pa / (9.81 m/s2) / 1000 kgh2o/m3 = 1e-7 m/s + ! this is 1ppmv of h2o in 10hpa + ! alternatively: 0.1 mm/day * 1.e-4 m/mm * 1/86400 day/s = 1.e-9 + + !----------------------------------------------------------------------- + ! precipitation efficiency calculation (accumulate cme and precip) + + minlwp = 0.01_r8 !minimum lwp threshold (kg/m3) + + ! zero out precip efficiency and total averaged precip + pe_grid(:ngrdcol) = 0._r8 + tpr_grid(:ngrdcol) = 0._r8 + pefrac_grid(:ngrdcol) = 0._r8 + + ! accumulate precip and condensation + do i = 1, ngrdcol + + acgcme_grid(i) = acgcme_grid(i) + tgcmeliq_grid(i) + acprecl_grid(i) = acprecl_grid(i) + prec_str_grid(i) + acnum_grid(i) = acnum_grid(i) + 1 + + ! if LWP is zero, then 'end of cloud': calculate precip efficiency + if (tgliqwp_grid(i) < minlwp) then + if (acprecl_grid(i) > 5.e-8_r8) then + tpr_grid(i) = max(acprecl_grid(i)/acnum_grid(i), 1.e-15_r8) + if (acgcme_grid(i) > 1.e-10_r8) then + pe_grid(i) = min(max(acprecl_grid(i)/acgcme_grid(i), 1.e-15_r8), 1.e5_r8) + pefrac_grid(i) = 1._r8 + end if + end if + + ! reset counters +! if (pe_grid(i) /= 0._r8 .and. (pe_grid(i) < 1.e-8_r8 .or. pe_grid(i) > 1.e3_r8)) then +! write (iulog,*) 'PE_grid:ANOMALY pe_grid, acprecl_grid, acgcme_grid, tpr_grid, acnum_grid ', & +! pe_grid(i),acprecl_grid(i), acgcme_grid(i), tpr_grid(i), acnum_grid(i) +! endif + + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + acnum_grid(i) = 0 + end if ! end LWP zero conditional + + ! if never find any rain....(after 10^3 timesteps...) + if (acnum_grid(i) > 1000) then + acnum_grid(i) = 0 + acprecl_grid(i) = 0._r8 + acgcme_grid(i) = 0._r8 + end if + + end do + + !----------------------------------------------------------------------- + ! vertical average of non-zero accretion, autoconversion and ratio. + ! vars: vprco_grid(i),vprao_grid(i),racau_grid(i),cnt_grid + + vprao_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprao_grid(:ngrdcol) = vprao_grid(:ngrdcol) + prao_grid(:ngrdcol,k) + where (prao_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) vprao_grid = vprao_grid/cnt_grid + + vprco_grid = 0._r8 + cnt_grid = 0 + do k = top_lev, pver + vprco_grid(:ngrdcol) = vprco_grid(:ngrdcol) + prco_grid(:ngrdcol,k) + where (prco_grid(:ngrdcol,k) /= 0._r8) cnt_grid(:ngrdcol) = cnt_grid(:ngrdcol) + 1 + end do + + where (cnt_grid > 0) + vprco_grid = vprco_grid/cnt_grid + racau_grid = vprao_grid/vprco_grid + elsewhere + racau_grid = 0._r8 + end where + + racau_grid = min(racau_grid, 1.e10_r8) + + ! --------------------- ! + ! History Output Fields ! + ! --------------------- ! + + ! Column droplet concentration + cdnumc_grid(:ngrdcol) = sum(nc_grid(:ngrdcol,top_lev:pver) * & + pdel_grid(:ngrdcol,top_lev:pver)/gravit, dim=2) + + ! Averaging for new output fields + efcout_grid = 0._r8 + efiout_grid = 0._r8 + ncout_grid = 0._r8 + niout_grid = 0._r8 + freql_grid = 0._r8 + freqi_grid = 0._r8 + icwmrst_grid_out = 0._r8 + icimrst_grid_out = 0._r8 + freqm_grid = 0._r8 + freqsl_grid = 0._r8 + freqslm_grid = 0._r8 + + do k = top_lev, pver + do i = 1, ngrdcol + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 5.e-5_r8 ) then + efcout_grid(i,k) = rel_grid(i,k) * liqcldf_grid(i,k) + ncout_grid(i,k) = icwnc_grid(i,k) * liqcldf_grid(i,k) + freql_grid(i,k) = liqcldf_grid(i,k) + icwmrst_grid_out(i,k) = icwmrst_grid(i,k) + end if + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-6_r8 ) then + efiout_grid(i,k) = rei_grid(i,k) * icecldf_grid(i,k) + niout_grid(i,k) = icinc_grid(i,k) * icecldf_grid(i,k) + freqi_grid(i,k) = icecldf_grid(i,k) + icimrst_grid_out(i,k) = icimrst_grid(i,k) + end if + + ! Supercooled liquid + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 ) then + freqm_grid(i,k)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) + end if + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + freqsl_grid(i,k)=liqcldf_grid(i,k) + end if + if (freql_grid(i,k) > 0.01_r8 .and. freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + freqslm_grid(i,k)=liqcldf_grid(i,k) + end if + + end do + end do + + ! Cloud top effective radius and number. + fcti_grid = 0._r8 + fctl_grid = 0._r8 + ctrel_grid = 0._r8 + ctrei_grid = 0._r8 + ctnl_grid = 0._r8 + ctni_grid = 0._r8 + fctm_grid = 0._r8 + fctsl_grid = 0._r8 + fctslm_grid= 0._r8 + !++IH for comparign to Bennartz CDNC concentrations + fctl_b = 0._r8 + ctnl_b = 0._r8 +!akc6+ + ccn_b = 0._r8 +!akc6- + + do i = 1, ngrdcol + do k = top_lev, pver + if ( liqcldf_grid(i,k) > 0.01_r8 .and. icwmrst_grid(i,k) > 1.e-7_r8 ) then + ctrel_grid(i) = rel_grid(i,k) * liqcldf_grid(i,k) + ctnl_grid(i) = icwnc_grid(i,k) * liqcldf_grid(i,k) + fctl_grid(i) = liqcldf_grid(i,k) + + ! Cloud Top Mixed phase, supercooled liquid only and supercooled liquid mixed + if (freqi_grid(i,k) > 0.01_r8) then + fctm_grid(i)=min(liqcldf_grid(i,k),icecldf_grid(i,k)) + end if + if (freqi_grid(i,k) < 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + fctsl_grid(i)=liqcldf_grid(i,k) + end if + if (freqi_grid(i,k) > 0.01_r8 .and. state_loc%t(i,k) < tmelt ) then + fctslm_grid(i)=liqcldf_grid(i,k) + end if + + exit + end if + + if ( icecldf_grid(i,k) > 0.01_r8 .and. icimrst_grid(i,k) > 1.e-7_r8 ) then + ctrei_grid(i) = rei_grid(i,k) * icecldf_grid(i,k) + ctni_grid(i) = icinc_grid(i,k) * icecldf_grid(i,k) + fcti_grid(i) = icecldf_grid(i,k) + exit + end if + end do + end do + + ! Evaporation of stratiform precipitation fields for UNICON + evprain_st_grid(:ngrdcol,:pver) = nevapr_grid(:ngrdcol,:pver) - evpsnow_st_grid(:ngrdcol,:pver) + do k = top_lev, pver + do i = 1, ngrdcol + evprain_st_grid(i,k) = max(evprain_st_grid(i,k), 0._r8) + evpsnow_st_grid(i,k) = max(evpsnow_st_grid(i,k), 0._r8) + end do + end do + + ! Assign the values to the pbuf pointers if they exist in pbuf + if (qrain_idx > 0) qrout_grid_ptr = qrout_grid + if (qsnow_idx > 0) qsout_grid_ptr = qsout_grid + if (nrain_idx > 0) nrout_grid_ptr = nrout_grid + if (nsnow_idx > 0) nsout_grid_ptr = nsout_grid + + !Calculate values for comparing with Bennartz 2017 + do i = 1, ncol + do k = top_lev, pver + !Criterions for Bennartz (2017) to use values from a column + !1) 268 < T < 300 [K] + !2) liquid cloud fraction > 10 % + if ( liqcldf(i,k) > 0.1_r8 & + .and. state_loc%t(i,k) > 268.0_r8 & + .and. state_loc%t(i,k) < 300.0_r8 ) then + !Save cloud fraction and in-cloud number conc + ctnl_b(i) = icwnc(i,k) * liqcldf(i,k) + fctl_b(i) = liqcldf(i,k) +!akc6+ + ccn_b(i) = ncal(i,k) * liqcldf(i,k) +!akc6- + exit !==> Go out to i=1,ncol-loop + end if + !--IH + end do + end do + + call outfld( 'ACTREL' , ctrel_grid, pcols, lchnk ) + call outfld( 'ACTREI' , ctrei_grid, pcols, lchnk ) + call outfld( 'ACTNL' , ctnl_grid, pcols, lchnk ) + call outfld( 'ACTNI' , ctni_grid, pcols, lchnk ) + call outfld( 'FCTL' , fctl_grid, pcols, lchnk ) + call outfld( 'FCTI' , fcti_grid, pcols, lchnk ) + !++IH + call outfld( 'FCTL_B' , fctl_b, pcols, lchnk ) + call outfld( 'ACTNL_B' , ctnl_b, pcols, lchnk ) +!akc6+ + call outfld( 'CCN_B' , ccn_b, pcols, lchnk ) +!akc6- + !--IH + + ! --------------------------------------------- ! + ! General outfield calls for microphysics ! + ! --------------------------------------------- ! + + ! Output a handle of variables which are calculated on the fly + ftem_grid = 0._r8 + + ftem_grid(:ngrdcol,top_lev:pver) = qcreso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2V', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = melto_grid(:ngrdcol,top_lev:pver) - mnuccco_grid(:ngrdcol,top_lev:pver)& + - mnuccto_grid(:ngrdcol,top_lev:pver) - bergo_grid(:ngrdcol,top_lev:pver) - homoo_grid(:ngrdcol,top_lev:pver)& + - msacwio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2I', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -prao_grid(:ngrdcol,top_lev:pver) - prco_grid(:ngrdcol,top_lev:pver)& + - psacwso_grid(:ngrdcol,top_lev:pver) - bergso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDW2P', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = cmeiout_grid(:ngrdcol,top_lev:pver) + qireso_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2V', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -melto_grid(:ngrdcol,top_lev:pver) + mnuccco_grid(:ngrdcol,top_lev:pver) & + + mnuccto_grid(:ngrdcol,top_lev:pver) + bergo_grid(:ngrdcol,top_lev:pver) + homoo_grid(:ngrdcol,top_lev:pver)& + + msacwio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2W', ftem_grid, pcols, lchnk) + + ftem_grid(:ngrdcol,top_lev:pver) = -prcio_grid(:ngrdcol,top_lev:pver) - praio_grid(:ngrdcol,top_lev:pver) + call outfld( 'MPDI2P', ftem_grid, pcols, lchnk) + + ! Output fields which have not been averaged already, averaging if use_subcol_microp is true + call outfld('MPICLWPI', iclwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPICIWPI', iciwpi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('REFL', refl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFL', arefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AREFLZ', areflz, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREFL', frefl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CSRFL', csrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ACSRFL', acsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FCSRFL', fcsrfl, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('RERCLD', rercld, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAL', ncal, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('NCAI', ncai, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQRAIN', qrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('AQSNOW', qsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANRAIN', nrout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('ANSNOW', nsout2, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQR', freqr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FREQS', freqs, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDT', tlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDQ', qvlat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDLIQ', qcten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MPDICE', qiten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('EVAPSNOW', evapsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEVAP', qcsevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEVAP', qisevap, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QVRES', qvres, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMC', vtrmc, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('VTRMI', vtrmi, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QCSEDTEN', qcsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QISEDTEN', qisedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + if (micro_mg_version > 1) then + call outfld('QRSEDTEN', qrsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('QSSEDTEN', qssedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + call outfld('MNUCCDO', mnuccdo, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCDOhet', mnuccdohet, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MNUCCRO', mnuccro, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('PRACSO', pracso , psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('MELTSDT', meltsdt, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FRZRDT', frzrdt , psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('FICE', nfice, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('CLDFSNOW', cldfsnow, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + +!AL + call outfld ('NNUCCCO ', nnuccco, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NNUCCTO ', nnuccto, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPSACWSO ', npsacwso, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NSUBCO ', nsubco, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPRAO ', nprao, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPRC1O ', nprc1o, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NQCSEDTEN', nqcsedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NQISEDTEN', nqisedten, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NMELTO ', nmelto, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NIMELTO ', nimelto, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NHOMOO ', nhomoo, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NIHOMOO ', nihomoo, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NSACWIO ', nsacwio, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NSUBIO ', nsubio, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPRCIO ', nprcio, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPRAIO ', npraio, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NNUDEPO ', nnudepo, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPCCNO ', npccno, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NPCCNO2 ', npccn, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NNUCCDO ', nnuccdo, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('MNUDEPO ', mnudepo, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NCTNCONS ', nctncons, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NCTNNBMN ', nctnnbmn, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NCTNSZMN ', nctnszmn, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NCTNSZMX ', nctnszmx, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NCTNNCLD ', nctnncld, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NITNCONS ', nitncons, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NITNSZMN ', nitnszmn, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NITNSZMX ', nitnszmx, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NITNNCLD ', nitnncld, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + if (micro_mg_version > 1) then + call outfld ('FRZR ', frzr, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NFRZR ', nfrzr, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('MNUCCRI', mnuccri, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld ('NNUCCRI', nnuccri, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + end if + + call outfld( 'MPDNLIQ ', ncten, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) + call outfld( 'MPDNICE ', niten, psetcols, lchnk, avg_subcol_field=use_subcol_microp ) +!AL + + + if (micro_mg_version > 1) then + call outfld('UMR', umr, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + call outfld('UMS', ums, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + + if (.not. (micro_mg_version == 1 .and. micro_mg_sub_version == 0)) then + call outfld('QCRAT', qcrat, psetcols, lchnk, avg_subcol_field=use_subcol_microp) + end if + + ! Example subcolumn outfld call + if (use_subcol_microp) then + call outfld('FICE_SCOL', nfice, psubcols*pcols, lchnk) + end if + + ! Output fields which are already on the grid + call outfld('QRAIN', qrout_grid, pcols, lchnk) + call outfld('QSNOW', qsout_grid, pcols, lchnk) + call outfld('NRAIN', nrout_grid, pcols, lchnk) + call outfld('NSNOW', nsout_grid, pcols, lchnk) + call outfld('CV_REFFLIQ', cvreffliq_grid, pcols, lchnk) + call outfld('CV_REFFICE', cvreffice_grid, pcols, lchnk) + call outfld('LS_FLXPRC', mgflxprc_grid, pcols, lchnk) + call outfld('LS_FLXSNW', mgflxsnw_grid, pcols, lchnk) + call outfld('CME', qme_grid, pcols, lchnk) + call outfld('PRODPREC', prain_grid, pcols, lchnk) + call outfld('EVAPPREC', nevapr_grid, pcols, lchnk) + call outfld('QCRESO', qcreso_grid, pcols, lchnk) + call outfld('LS_REFFRAIN', mgreffrain_grid, pcols, lchnk) + call outfld('LS_REFFSNOW', mgreffsnow_grid, pcols, lchnk) + call outfld('DSNOW', des_grid, pcols, lchnk) + call outfld('ADRAIN', drout2_grid, pcols, lchnk) + call outfld('ADSNOW', dsout2_grid, pcols, lchnk) + call outfld('PE', pe_grid, pcols, lchnk) + call outfld('PEFRAC', pefrac_grid, pcols, lchnk) + call outfld('APRL', tpr_grid, pcols, lchnk) + call outfld('VPRAO', vprao_grid, pcols, lchnk) + call outfld('VPRCO', vprco_grid, pcols, lchnk) + call outfld('RACAU', racau_grid, pcols, lchnk) + call outfld('AREL', efcout_grid, pcols, lchnk) + call outfld('AREI', efiout_grid, pcols, lchnk) + call outfld('AWNC' , ncout_grid, pcols, lchnk) + call outfld('AWNI' , niout_grid, pcols, lchnk) + call outfld('FREQL', freql_grid, pcols, lchnk) + call outfld('FREQI', freqi_grid, pcols, lchnk) + call outfld('ACTREL', ctrel_grid, pcols, lchnk) + call outfld('ACTREI', ctrei_grid, pcols, lchnk) + call outfld('ACTNL', ctnl_grid, pcols, lchnk) + call outfld('ACTNI', ctni_grid, pcols, lchnk) + call outfld('FCTL', fctl_grid, pcols, lchnk) + call outfld('FCTI', fcti_grid, pcols, lchnk) + call outfld('ICINC', icinc_grid, pcols, lchnk) + call outfld('ICWNC', icwnc_grid, pcols, lchnk) + call outfld('EFFLIQ_IND', rel_fn_grid, pcols, lchnk) + call outfld('CDNUMC', cdnumc_grid, pcols, lchnk) + call outfld('REL', rel_grid, pcols, lchnk) + call outfld('REI', rei_grid, pcols, lchnk) + call outfld('MG_SADICE', sadice_grid, pcols, lchnk) + call outfld('MG_SADSNOW', sadsnow_grid, pcols, lchnk) + call outfld('ICIMRST', icimrst_grid_out, pcols, lchnk) + call outfld('ICWMRST', icwmrst_grid_out, pcols, lchnk) + call outfld('CMEIOUT', cmeiout_grid, pcols, lchnk) + call outfld('PRAO', prao_grid, pcols, lchnk) + call outfld('PRCO', prco_grid, pcols, lchnk) + call outfld('MNUCCCO', mnuccco_grid, pcols, lchnk) + call outfld('MNUCCTO', mnuccto_grid, pcols, lchnk) + call outfld('MSACWIO', msacwio_grid, pcols, lchnk) + call outfld('PSACWSO', psacwso_grid, pcols, lchnk) + call outfld('BERGSO', bergso_grid, pcols, lchnk) + call outfld('BERGO', bergo_grid, pcols, lchnk) + call outfld('MELTO', melto_grid, pcols, lchnk) + call outfld('HOMOO', homoo_grid, pcols, lchnk) + call outfld('PRCIO', prcio_grid, pcols, lchnk) + call outfld('PRAIO', praio_grid, pcols, lchnk) + call outfld('QIRESO', qireso_grid, pcols, lchnk) + call outfld('FREQM', freqm_grid, pcols, lchnk) + call outfld('FREQSL', freqsl_grid, pcols, lchnk) + call outfld('FREQSLM', freqslm_grid, pcols, lchnk) + call outfld('FCTM', fctm_grid, pcols, lchnk) + call outfld('FCTSL', fctsl_grid, pcols, lchnk) + call outfld('FCTSLM', fctslm_grid, pcols, lchnk) + + if (micro_mg_adjust_cpt) then + cp_rh(:ncol, :pver) = 0._r8 + + do i = 1, ncol + + ! Calculate the RH including any T change that we make. + do k = top_lev, pver + call qsat(state_loc%t(i,k), state_loc%pmid(i,k), es, qs) + cp_rh(i,k) = state_loc%q(i, k, 1) / qs * 100._r8 + end do + end do + + call outfld("TROPF_RHADJ", cp_rh, pcols, lchnk) + end if + + ! ptend_loc is deallocated in physics_update above + call physics_state_dealloc(state_loc) + +end subroutine micro_mg_cam_tend_pack + +function p1(tin) result(pout) + real(r8), target, intent(in) :: tin(:) + real(r8), pointer :: pout(:) + pout => tin +end function p1 + +function p2(tin) result(pout) + real(r8), target, intent(in) :: tin(:,:) + real(r8), pointer :: pout(:,:) + pout => tin +end function p2 + +end module micro_mg_cam diff --git a/src/NorESM/phys_control.F90 b/src/NorESM/phys_control.F90 new file mode 100644 index 0000000000..06efcdde10 --- /dev/null +++ b/src/NorESM/phys_control.F90 @@ -0,0 +1,411 @@ +module phys_control +!----------------------------------------------------------------------- +! Purpose: +! +! Provides a control interface to CAM physics packages +! +! Revision history: +! 2006-05-01 D. B. Coleman, Creation of module +! 2009-02-13 Eaton Replace *_{default,set}opts methods with module namelist. +! Add vars to indicate physics version and chemistry type. +!----------------------------------------------------------------------- + +use spmd_utils, only: masterproc +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use shr_kind_mod, only: r8 => shr_kind_r8 + +implicit none +private +save + +public :: & + phys_ctl_readnl, &! read namelist from file + phys_getopts, &! generic query method + phys_setopts, &! generic set method + phys_deepconv_pbl, &! return true if deep convection is allowed in the PBL + phys_do_flux_avg, &! return true to average surface fluxes + cam_physpkg_is, &! query for the name of the physics package + cam_chempkg_is, &! query for the name of the chemistry package + waccmx_is + +! Private module data + +character(len=16), parameter :: unset_str = 'UNSET' +integer, parameter :: unset_int = huge(1) + +! Namelist variables: +character(len=16) :: cam_physpkg = unset_str ! CAM physics package +character(len=32) :: cam_chempkg = unset_str ! CAM chemistry package +character(len=16) :: waccmx_opt = unset_str ! WACCMX run option [ionosphere | neutral | off +character(len=16) :: deep_scheme = unset_str ! deep convection package +character(len=16) :: shallow_scheme = unset_str ! shallow convection package +character(len=16) :: eddy_scheme = unset_str ! vertical diffusion package +character(len=16) :: microp_scheme = unset_str ! microphysics package +character(len=16) :: macrop_scheme = unset_str ! macrophysics package +character(len=16) :: radiation_scheme = unset_str ! radiation package +integer :: srf_flux_avg = unset_int ! 1 => smooth surface fluxes, 0 otherwise + +logical :: use_subcol_microp = .false. ! if .true. then use sub-columns in microphysics + +logical :: atm_dep_flux = .true. ! true => deposition fluxes will be provided + ! to the coupler +logical :: history_amwg = .true. ! output the variables used by the AMWG diag package +logical :: history_vdiag = .false. ! output the variables used by the AMWG variability diag package +logical :: history_aerosol = .false. ! output the MAM aerosol variables and tendencies +logical :: history_aero_optics = .false. ! output the aerosol +logical :: history_eddy = .false. ! output the eddy variables +logical :: history_budget = .false. ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. +logical :: convproc_do_aer = .false. ! switch for new convective scavenging treatment for modal aerosols + +integer :: history_budget_histfile_num = 1 ! output history file number for budget fields +logical :: history_waccm = .false. ! output variables of interest for WACCM runs +logical :: history_waccmx = .false. ! output variables of interest for WACCM-X runs +logical :: history_chemistry = .true. ! output default chemistry-related variables +logical :: history_carma = .false. ! output default CARMA-related variables +logical :: history_clubb = .true. ! output default CLUBB-related variables +logical :: history_dust = .false. +logical :: history_cesm_forcing = .false. +logical :: history_scwaccm_forcing = .false. +logical :: history_chemspecies_srf = .false. + +logical :: do_clubb_sgs +! Check validity of physics_state objects in physics_update. +logical :: state_debug_checks = .false. + +! Macro/micro-physics co-substeps +integer :: cld_macmic_num_steps = 1 + +logical :: offline_driver = .false. ! true => offline driver is being used + + +logical, public, protected :: use_simple_phys = .false. ! true => simple physics configuration + +logical :: use_spcam ! true => use super parameterized CAM + +logical :: prog_modal_aero ! determines whether prognostic modal aerosols are present in the run. + +! Option to use heterogeneous freezing +logical, public, protected :: use_hetfrz_classnuc = .false. + +! Which gravity wave sources are used? +logical, public, protected :: use_gw_oro = .true. ! Orography. +logical, public, protected :: use_gw_front = .false. ! Frontogenesis. +logical, public, protected :: use_gw_front_igw = .false. ! Frontogenesis to inertial spectrum. +logical, public, protected :: use_gw_convect_dp = .false. ! Deep convection. +logical, public, protected :: use_gw_convect_sh = .false. ! Shallow convection. + +! FV dycore angular momentum correction +logical, public, protected :: fv_am_correction = .false. + +!tht: energy adjustment in dry mass adjustment +logical, public, protected :: dme_energy_adjust = .false. + +!======================================================================= +contains +!======================================================================= + +subroutine phys_ctl_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpi_character, mpi_integer, mpi_logical, masterprocid, mpicom + use cam_control_mod, only: cam_ctrl_set_physics_type + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'phys_ctl_readnl' + + namelist /phys_ctl_nl/ cam_physpkg, use_simple_phys, cam_chempkg, waccmx_opt, & + deep_scheme, shallow_scheme, & + eddy_scheme, microp_scheme, macrop_scheme, radiation_scheme, srf_flux_avg, & + use_subcol_microp, atm_dep_flux, history_amwg, history_vdiag, history_aerosol, history_aero_optics, & + history_eddy, history_budget, history_budget_histfile_num, history_waccm, & + history_waccmx, history_chemistry, history_carma, history_clubb, history_dust, & + history_cesm_forcing, history_scwaccm_forcing, history_chemspecies_srf, & + do_clubb_sgs, state_debug_checks, use_hetfrz_classnuc, use_gw_oro, use_gw_front, & + use_gw_front_igw, use_gw_convect_dp, use_gw_convect_sh, cld_macmic_num_steps, & + offline_driver, convproc_do_aer, dme_energy_adjust !+tht + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'phys_ctl_nl', status=ierr) + if (ierr == 0) then + read(unitn, phys_ctl_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(deep_scheme, len(deep_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(cam_physpkg, len(cam_physpkg), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(use_simple_phys, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(cam_chempkg, len(cam_chempkg), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(waccmx_opt, len(waccmx_opt), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(shallow_scheme, len(shallow_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(eddy_scheme, len(eddy_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(microp_scheme, len(microp_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(radiation_scheme, len(radiation_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(macrop_scheme, len(macrop_scheme), mpi_character, masterprocid, mpicom, ierr) + call mpi_bcast(srf_flux_avg, 1, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(use_subcol_microp, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(atm_dep_flux, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_amwg, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_vdiag, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_eddy, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_aerosol, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_aero_optics, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_budget, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_budget_histfile_num, 1, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(history_waccm, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_waccmx, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_chemistry, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_carma, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_clubb, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_dust, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_cesm_forcing, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_chemspecies_srf, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_scwaccm_forcing, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(do_clubb_sgs, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(state_debug_checks, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_hetfrz_classnuc, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_gw_oro, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_gw_front, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_gw_front_igw, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_gw_convect_dp, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(use_gw_convect_sh, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(cld_macmic_num_steps, 1, mpi_integer, masterprocid, mpicom, ierr) + call mpi_bcast(offline_driver, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(convproc_do_aer, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(dme_energy_adjust, 1, mpi_logical, masterprocid, mpicom, ierr) !+tht + + use_spcam = ( cam_physpkg_is('spcam_sam1mom') & + .or. cam_physpkg_is('spcam_m2005')) + + call cam_ctrl_set_physics_type(cam_physpkg) + + ! Error checking: + + ! Check compatibility of eddy & shallow schemes + if (( shallow_scheme .eq. 'UW' ) .and. ( eddy_scheme .ne. 'diag_TKE' )) then + write(iulog,*)'Do you really want to run UW shallow scheme without diagnostic TKE eddy scheme? Quiting' + call endrun('shallow convection and eddy scheme may be incompatible') + endif + + if (( shallow_scheme .eq. 'Hack' ) .and. ( ( eddy_scheme .ne. 'HB' ) .and. ( eddy_scheme .ne. 'HBR' ))) then + write(iulog,*)'Do you really want to run Hack shallow scheme with a non-standard eddy scheme? Quiting.' + call endrun('shallow convection and eddy scheme may be incompatible') + endif + + ! Check compatibility of PBL and Microphysics schemes + if (( eddy_scheme .eq. 'diag_TKE' ) .and. ( microp_scheme .eq. 'RK' )) then + write(iulog,*)'UW PBL is not compatible with RK microphysics. Quiting' + call endrun('PBL and Microphysics schemes incompatible') + endif + + ! Add a check to make sure CLUBB and MG are used together + if ( do_clubb_sgs .and. ( microp_scheme .ne. 'MG') .and. .not. use_spcam) then + write(iulog,*)'CLUBB is only compatible with MG microphysics. Quiting' + call endrun('CLUBB and microphysics schemes incompatible') + endif + + ! Check that eddy_scheme, macrop_scheme, shallow_scheme are all set to CLUBB_SGS if do_clubb_sgs is true + if (do_clubb_sgs .and. .not. use_spcam) then + if (eddy_scheme .ne. 'CLUBB_SGS' .or. macrop_scheme .ne. 'CLUBB_SGS' .or. shallow_scheme .ne. 'CLUBB_SGS') then + write(iulog,*)'eddy_scheme, macrop_scheme and shallow_scheme must all be CLUBB_SGS. Quiting' + call endrun('CLUBB and eddy, macrop or shallow schemes incompatible') + endif + endif + + ! Macro/micro co-substepping support. + if (cld_macmic_num_steps > 1) then + if (microp_scheme /= "MG" .or. (macrop_scheme /= "park" .and. macrop_scheme /= "CLUBB_SGS")) then + call endrun ("Setting cld_macmic_num_steps > 1 is only & + &supported with Park or CLUBB macrophysics and MG microphysics.") + end if + end if + + ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. + prog_modal_aero = index(cam_chempkg,'_mam')>0 +#ifdef OSLO_AERO + prog_modal_aero = .FALSE. +#endif +end subroutine phys_ctl_readnl + +!=============================================================================== + +logical function cam_physpkg_is(name) + + ! query for the name of the physics package + + character(len=*) :: name + + cam_physpkg_is = (trim(name) == trim(cam_physpkg)) +end function cam_physpkg_is + +!=============================================================================== + +logical function cam_chempkg_is(name) + + ! query for the name of the chemics package + + character(len=*) :: name + + cam_chempkg_is = (trim(name) == trim(cam_chempkg)) +end function cam_chempkg_is + +!=============================================================================== + +logical function waccmx_is(name) + + ! query for the name of the waccmx run option + + character(len=*) :: name + + waccmx_is = (trim(name) == trim(waccmx_opt)) +end function waccmx_is + +!=============================================================================== + +subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, microp_scheme_out, & + radiation_scheme_out, use_subcol_microp_out, atm_dep_flux_out, & + history_amwg_out, history_vdiag_out, history_aerosol_out, history_aero_optics_out, history_eddy_out, & + history_budget_out, history_budget_histfile_num_out, & + history_waccm_out, history_waccmx_out, history_chemistry_out, & + history_carma_out, history_clubb_out, history_dust_out, & + history_cesm_forcing_out, history_scwaccm_forcing_out, history_chemspecies_srf_out, & + cam_chempkg_out, prog_modal_aero_out, macrop_scheme_out, & + do_clubb_sgs_out, use_spcam_out, state_debug_checks_out, cld_macmic_num_steps_out, & + offline_driver_out, convproc_do_aer_out, dme_energy_adjust_out) !+tht +!----------------------------------------------------------------------- +! Purpose: Return runtime settings +! deep_scheme_out : deep convection scheme +! shallow_scheme_out: shallow convection scheme +! eddy_scheme_out : vertical diffusion scheme +! microp_scheme_out : microphysics scheme +! radiation_scheme_out : radiation_scheme +! SPCAM_microp_scheme_out : SPCAM microphysics scheme +!----------------------------------------------------------------------- + + character(len=16), intent(out), optional :: deep_scheme_out + character(len=16), intent(out), optional :: shallow_scheme_out + character(len=16), intent(out), optional :: eddy_scheme_out + character(len=16), intent(out), optional :: microp_scheme_out + character(len=16), intent(out), optional :: radiation_scheme_out + character(len=16), intent(out), optional :: macrop_scheme_out + logical, intent(out), optional :: use_subcol_microp_out + logical, intent(out), optional :: use_spcam_out + logical, intent(out), optional :: atm_dep_flux_out + logical, intent(out), optional :: history_amwg_out + logical, intent(out), optional :: history_vdiag_out + logical, intent(out), optional :: history_eddy_out + logical, intent(out), optional :: history_aerosol_out + logical, intent(out), optional :: history_aero_optics_out + logical, intent(out), optional :: history_budget_out + integer, intent(out), optional :: history_budget_histfile_num_out + logical, intent(out), optional :: history_waccm_out + logical, intent(out), optional :: history_waccmx_out + logical, intent(out), optional :: history_chemistry_out + logical, intent(out), optional :: history_carma_out + logical, intent(out), optional :: history_clubb_out + logical, intent(out), optional :: history_dust_out + logical, intent(out), optional :: history_cesm_forcing_out + logical, intent(out), optional :: history_chemspecies_srf_out + logical, intent(out), optional :: history_scwaccm_forcing_out + logical, intent(out), optional :: do_clubb_sgs_out + character(len=32), intent(out), optional :: cam_chempkg_out + logical, intent(out), optional :: prog_modal_aero_out + logical, intent(out), optional :: state_debug_checks_out + integer, intent(out), optional :: cld_macmic_num_steps_out + logical, intent(out), optional :: offline_driver_out + logical, intent(out), optional :: convproc_do_aer_out + logical, intent(out), optional :: dme_energy_adjust_out !+tht + + if ( present(deep_scheme_out ) ) deep_scheme_out = deep_scheme + if ( present(shallow_scheme_out ) ) shallow_scheme_out = shallow_scheme + if ( present(eddy_scheme_out ) ) eddy_scheme_out = eddy_scheme + if ( present(microp_scheme_out ) ) microp_scheme_out = microp_scheme + if ( present(radiation_scheme_out ) ) radiation_scheme_out = radiation_scheme + if ( present(use_subcol_microp_out ) ) use_subcol_microp_out = use_subcol_microp + if ( present(use_spcam_out ) ) use_spcam_out = use_spcam + + if ( present(macrop_scheme_out ) ) macrop_scheme_out = macrop_scheme + if ( present(atm_dep_flux_out ) ) atm_dep_flux_out = atm_dep_flux + if ( present(history_aerosol_out ) ) history_aerosol_out = history_aerosol + if ( present(history_aero_optics_out ) ) history_aero_optics_out = history_aero_optics + if ( present(history_budget_out ) ) history_budget_out = history_budget + if ( present(history_amwg_out ) ) history_amwg_out = history_amwg + if ( present(history_vdiag_out ) ) history_vdiag_out = history_vdiag + if ( present(history_eddy_out ) ) history_eddy_out = history_eddy + if ( present(history_budget_histfile_num_out ) ) history_budget_histfile_num_out = history_budget_histfile_num + if ( present(history_waccm_out ) ) history_waccm_out = history_waccm + if ( present(history_waccmx_out ) ) history_waccmx_out = history_waccmx + if ( present(history_chemistry_out ) ) history_chemistry_out = history_chemistry + if ( present(history_cesm_forcing_out) ) history_cesm_forcing_out = history_cesm_forcing + if ( present(history_chemspecies_srf_out) ) history_chemspecies_srf_out = history_chemspecies_srf + if ( present(history_scwaccm_forcing_out) ) history_scwaccm_forcing_out = history_scwaccm_forcing + if ( present(history_carma_out ) ) history_carma_out = history_carma + if ( present(history_clubb_out ) ) history_clubb_out = history_clubb + if ( present(history_dust_out ) ) history_dust_out = history_dust + if ( present(do_clubb_sgs_out ) ) do_clubb_sgs_out = do_clubb_sgs + if ( present(cam_chempkg_out ) ) cam_chempkg_out = cam_chempkg + if ( present(prog_modal_aero_out ) ) prog_modal_aero_out = prog_modal_aero + if ( present(state_debug_checks_out ) ) state_debug_checks_out = state_debug_checks + if ( present(cld_macmic_num_steps_out) ) cld_macmic_num_steps_out = cld_macmic_num_steps + if ( present(offline_driver_out ) ) offline_driver_out = offline_driver + if ( present(convproc_do_aer_out ) ) convproc_do_aer_out = convproc_do_aer + if ( present(dme_energy_adjust_out ) ) dme_energy_adjust_out = dme_energy_adjust !+tht + +end subroutine phys_getopts + +!=============================================================================== + +subroutine phys_setopts(fv_am_correction_in) + + logical, intent(in), optional :: fv_am_correction_in + + if ( present(fv_am_correction_in) ) fv_am_correction = fv_am_correction_in + +end subroutine phys_setopts + +!=============================================================================== + +function phys_deepconv_pbl() + + logical phys_deepconv_pbl + + ! Don't allow deep convection in PBL if running UW PBL scheme + if ( (eddy_scheme .eq. 'diag_TKE' ) .or. (shallow_scheme .eq. 'UW' ) ) then + phys_deepconv_pbl = .true. + else + phys_deepconv_pbl = .false. + endif + + return + +end function phys_deepconv_pbl + +!=============================================================================== + +function phys_do_flux_avg() + + logical :: phys_do_flux_avg + !---------------------------------------------------------------------- + + phys_do_flux_avg = .false. + if (srf_flux_avg == 1) phys_do_flux_avg = .true. + +end function phys_do_flux_avg + +!=============================================================================== +end module phys_control diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 new file mode 100644 index 0000000000..7bc17bdba5 --- /dev/null +++ b/src/NorESM/physpkg.F90 @@ -0,0 +1,2629 @@ +module physpkg + !----------------------------------------------------------------------- + ! Purpose: + ! + ! Provides the interface to CAM physics package + ! + ! Revision history: + ! Aug 2005, E. B. Kluzek, Creation of module from physpkg subroutine + ! 2005-10-17 B. Eaton Add contents of inti.F90 to phys_init(). Add + ! initialization of grid info in phys_state. + ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines + !----------------------------------------------------------------------- + +#ifdef OSLO_AERO +#include +#endif + + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use physconst, only: latvap, latice, rh2o + use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & + physics_ptend, physics_tend_init, physics_update, & + physics_type_alloc, physics_ptend_dealloc,& + physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc + use phys_grid, only: get_ncols_p + use phys_gmean, only: gmean_mass + use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols + use constituents, only: pcnst, cnst_name, cnst_get_ind + use camsrfexch, only: cam_out_t, cam_in_t + + use cam_control_mod, only: ideal_phys, adiabatic + use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is + use scamMod, only: single_column, scm_crm_mode + use flux_avg, only: flux_avg_init + use perf_mod + use cam_logfile, only: iulog + use camsrfexch, only: cam_export + + use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg + use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg + + implicit none + private + save + + ! Public methods + public phys_register ! was initindx - register physics methods + public phys_init ! Public initialization method + public phys_run1 ! First phase of the public run method + public phys_run2 ! Second phase of the public run method + public phys_final ! Public finalization method + + ! Private module data + + ! Physics package options + character(len=16) :: shallow_scheme + character(len=16) :: macrop_scheme + character(len=16) :: microp_scheme + integer :: cld_macmic_num_steps ! Number of macro/micro substeps + logical :: do_clubb_sgs + logical :: use_subcol_microp ! if true, use subcolumns in microphysics + logical :: state_debug_checks ! Debug physics_state. + logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols + logical :: prog_modal_aero ! Prognostic modal aerosols present + + ! Physics buffer index + integer :: teout_idx = 0 + + integer :: landm_idx = 0 + integer :: sgh_idx = 0 + integer :: sgh30_idx = 0 + + integer :: qini_idx = 0 + integer :: cldliqini_idx = 0 + integer :: cldiceini_idx = 0 +!AL + integer :: cldncini_idx = 0 + integer :: cldniini_idx = 0 +!AK + integer :: prec_str_idx = 0 + integer :: snow_str_idx = 0 + integer :: prec_sed_idx = 0 + integer :: snow_sed_idx = 0 + integer :: prec_pcw_idx = 0 + integer :: snow_pcw_idx = 0 + integer :: prec_dp_idx = 0 + integer :: snow_dp_idx = 0 + integer :: prec_sh_idx = 0 + integer :: snow_sh_idx = 0 + integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. + +!======================================================================= +contains +!======================================================================= + + subroutine phys_register + !----------------------------------------------------------------------- + ! + ! Purpose: Register constituents and physics buffer fields. + ! + ! Author: CSM Contact: M. Vertenstein, Aug. 1997 + ! B.A. Boville, Oct 2001 + ! A. Gettelman, Nov 2010 - put micro/macro physics into separate routines + ! + !----------------------------------------------------------------------- + use cam_abortutils, only: endrun + use physics_buffer, only: pbuf_init_time + use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use constituents, only: pcnst, cnst_add, cnst_chk_dim, cnst_name + + use cam_control_mod, only: moist_physics + use chemistry, only: chem_register + use cloud_fraction, only: cldfrc_register + use rk_stratiform, only: rk_stratiform_register + use microp_driver, only: microp_driver_register + use microp_aero, only: microp_aero_register + use macrop_driver, only: macrop_driver_register + use clubb_intr, only: clubb_register_cam + use conv_water, only: conv_water_register + use physconst, only: mwdry, cpair, mwh2o, cpwv + use tracers, only: tracers_register + use check_energy, only: check_energy_register + use carma_intr, only: carma_register + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_register + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_register + use ghg_data, only: ghg_data_register + use vertical_diffusion, only: vd_register + use convect_deep, only: convect_deep_register + use convect_shallow, only: convect_shallow_register + use radiation, only: radiation_register + use co2_cycle, only: co2_register + use flux_avg, only: flux_avg_register + use iondrag, only: iondrag_register + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_reg + use string_utils, only: to_lower + use prescribed_ozone, only: prescribed_ozone_register + use prescribed_volcaero,only: prescribed_volcaero_register + use prescribed_strataero,only: prescribed_strataero_register + use prescribed_aero, only: prescribed_aero_register + use prescribed_ghg, only: prescribed_ghg_register + use sslt_rebin, only: sslt_rebin_register + use aoa_tracers, only: aoa_tracers_register + use aircraft_emit, only: aircraft_emit_register + use cam_diagnostics, only: diag_register + use cloud_diagnostics, only: cloud_diagnostics_register + use cospsimulator_intr, only: cospsimulator_intr_register + use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not + use subcol, only: subcol_register + use subcol_utils, only: is_subcol_on + use dyn_comp, only: dyn_register + use spcam_drivers, only: spcam_register + use offline_driver, only: offline_driver_reg + + !---------------------------Local variables----------------------------- + ! + integer :: m ! loop index + integer :: mm ! constituent index + integer :: nmodes + !----------------------------------------------------------------------- + + ! Get physics options + call phys_getopts(shallow_scheme_out = shallow_scheme, & + macrop_scheme_out = macrop_scheme, & + microp_scheme_out = microp_scheme, & + cld_macmic_num_steps_out = cld_macmic_num_steps, & + do_clubb_sgs_out = do_clubb_sgs, & + use_subcol_microp_out = use_subcol_microp, & + state_debug_checks_out = state_debug_checks) + + ! Initialize dyn_time_lvls + call pbuf_init_time() + + ! Register the subcol scheme + call subcol_register() + + ! Register water vapor. + ! ***** N.B. ***** This must be the first call to cnst_add so that + ! water vapor is constituent 1. + if (moist_physics) then + call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & + longname='Specific humidity', readiv=.true., is_convtran1=.true.) + else + call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & + longname='Specific humidity', readiv=.false., is_convtran1=.true.) + end if + + ! Topography file fields. + call pbuf_add_field('LANDM', 'global', dtype_r8, (/pcols/), landm_idx) + call pbuf_add_field('SGH', 'global', dtype_r8, (/pcols/), sgh_idx) + call pbuf_add_field('SGH30', 'global', dtype_r8, (/pcols/), sgh30_idx) + + ! Fields for physics package diagnostics + call pbuf_add_field('QINI', 'physpkg', dtype_r8, (/pcols,pver/), qini_idx) + call pbuf_add_field('CLDLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), cldliqini_idx) + call pbuf_add_field('CLDICEINI', 'physpkg', dtype_r8, (/pcols,pver/), cldiceini_idx) +!AL + call pbuf_add_field('CLDNCINI', 'physpkg', dtype_r8, (/pcols,pver/), cldncini_idx) + call pbuf_add_field('CLDNIINI', 'physpkg', dtype_r8, (/pcols,pver/), cldniini_idx) +!AL + ! check energy package + call check_energy_register + + ! If using a simple physics option (e.g., held_suarez, adiabatic), + ! the normal CAM physics parameterizations are not called. + if (moist_physics) then + + ! register fluxes for saving across time + if (phys_do_flux_avg()) call flux_avg_register() + + call cldfrc_register() + + ! cloud water + if( microp_scheme == 'RK' ) then + call rk_stratiform_register() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_register() + call microp_aero_register() + call microp_driver_register() + end if + + ! Register CLUBB_SGS here + if (do_clubb_sgs) call clubb_register_cam() + + + call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) + call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) + call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) + call pbuf_add_field('SNOW_PCW', 'physpkg',dtype_r8,(/pcols/),snow_pcw_idx) + call pbuf_add_field('PREC_SED', 'physpkg',dtype_r8,(/pcols/),prec_sed_idx) + call pbuf_add_field('SNOW_SED', 'physpkg',dtype_r8,(/pcols/),snow_sed_idx) + if (is_subcol_on()) then + call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) + call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) + call pbuf_register_subcol('PREC_PCW', 'phys_register', prec_pcw_idx) + call pbuf_register_subcol('SNOW_PCW', 'phys_register', snow_pcw_idx) + call pbuf_register_subcol('PREC_SED', 'phys_register', prec_sed_idx) + call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) + end if + + ! Who should add FRACIS? + ! -- It does not seem that aero_intr should add it since FRACIS is used in convection + ! even if there are no prognostic aerosols ... so do it here for now + call pbuf_add_field('FRACIS','physpkg',dtype_r8,(/pcols,pver,pcnst/),m) + + call conv_water_register() + + ! Determine whether its a 'modal' aerosol simulation or not + call rad_cnst_get_info(0, nmodes=nmodes) + clim_modal_aero = (nmodes > 0) + + if (clim_modal_aero) then + call modal_aero_calcsize_reg() + call modal_aero_wateruptake_reg() + endif + + ! register chemical constituents including aerosols ... + call chem_register() + + ! co2 constituents + call co2_register() + + ! register data model ozone with pbuf + if (cam3_ozone_data_on) then + call cam3_ozone_data_register() + end if + call prescribed_volcaero_register() + call prescribed_strataero_register() + call prescribed_ozone_register() + call prescribed_aero_register() + call prescribed_ghg_register() + call sslt_rebin_register + + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) then + call cam3_aero_data_register() + end if + + ! register various data model gasses with pbuf + call ghg_data_register() + + ! carma microphysics + ! + call carma_register() + + ! Register iondrag variables with pbuf + call iondrag_register() + + ! Register ionosphere variables with pbuf if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_reg() + endif + + call aircraft_emit_register() + + ! deep convection + call convect_deep_register + + ! shallow convection + call convect_shallow_register + + + call spcam_register + + ! radiation + call radiation_register + call cloud_diagnostics_register + + ! COSP + call cospsimulator_intr_register + + ! vertical diffusion + call vd_register() + else + ! held_suarez/adiabatic physics option should be in simple_physics + call endrun('phys_register: moist_physics configuration error') + end if + + ! Register diagnostics PBUF + call diag_register() + + ! Register age of air tracers + call aoa_tracers_register() + + ! Register test tracers + call tracers_register() + + call dyn_register() + + ! All tracers registered, check that the dimensions are correct + call cnst_chk_dim() + + ! ***NOTE*** No registering constituents after the call to cnst_chk_dim. + + call offline_driver_reg() + + end subroutine phys_register + + + + !======================================================================= + + subroutine phys_inidat( cam_out, pbuf2d ) + use cam_abortutils, only: endrun + + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field, dyn_time_lvls + + + use cam_initfiles, only: initial_file_get_id, topo_file_get_id + use cam_grid_support, only: cam_grid_check, cam_grid_id + use cam_grid_support, only: cam_grid_get_dim_names + use pio, only: file_desc_t + use ncdio_atm, only: infld + use dycore, only: dycore_is + use polar_avg, only: polar_average + use short_lived_species, only: initialize_short_lived_species + use cam_control_mod, only: aqua_planet + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_inidat + + type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + integer :: lchnk, m, n, i, k, ncol + type(file_desc_t), pointer :: fh_ini, fh_topo + character(len=8) :: fieldname + real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) + real(r8), pointer :: qpert(:,:) + + character(len=11) :: subname='phys_inidat' ! subroutine name + integer :: tpert_idx, qpert_idx, pblh_idx + + logical :: found=.false., found2=.false. + integer :: ierr + character(len=8) :: dim1name, dim2name + integer :: ixcldice, ixcldliq + integer :: grid_id ! grid ID for data mapping + + nullify(tptr,tptr_2,tptr3d,tptr3d_2) + + fh_ini => initial_file_get_id() + fh_topo => topo_file_get_id() + + ! dynamics variables are handled in dyn_init - here we read variables needed for physics + ! but not dynamics + + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + + allocate(tptr(1:pcols,begchunk:endchunk)) + + if (associated(fh_topo) .and. .not. aqua_planet) then + call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not. found) call endrun('ERROR: SGH not found on topo file') + + call pbuf_set_field(pbuf2d, sgh_idx, tptr) + + allocate(tptr_2(1:pcols,begchunk:endchunk)) + call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr_2, found, gridname='physgrid') + if(found) then + call pbuf_set_field(pbuf2d, sgh30_idx, tptr_2) + else + if (masterproc) write(iulog,*) 'Warning: Error reading SGH30 from topo file.' + if (masterproc) write(iulog,*) 'The field SGH30 will be filled using data from SGH.' + call pbuf_set_field(pbuf2d, sgh30_idx, tptr) + end if + + deallocate(tptr_2) + + call infld('LANDM_COSLAT', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + + if(.not.found) call endrun(' ERROR: LANDM_COSLAT not found on topo dataset.') + + call pbuf_set_field(pbuf2d, landm_idx, tptr) + + else + call pbuf_set_field(pbuf2d, sgh_idx, 0._r8) + call pbuf_set_field(pbuf2d, sgh30_idx, 0._r8) + call pbuf_set_field(pbuf2d, landm_idx, 0._r8) + end if + + call infld('PBLH', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'PBLH initialized to 0.' + end if + pblh_idx = pbuf_get_index('pblh') + + call pbuf_set_field(pbuf2d, pblh_idx, tptr) + + call infld('TPERT', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'TPERT initialized to 0.' + end if + tpert_idx = pbuf_get_index( 'tpert') + call pbuf_set_field(pbuf2d, tpert_idx, tptr) + + fieldname='QPERT' + qpert_idx = pbuf_get_index( 'qpert',ierr) + if (qpert_idx > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not. found) then + tptr=0_r8 + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk)) + tptr3d_2 = 0_r8 + tptr3d_2(:,1,:) = tptr(:,:) + + call pbuf_set_field(pbuf2d, qpert_idx, tptr3d_2) + deallocate(tptr3d_2) + end if + + fieldname='CUSH' + m = pbuf_get_index('cush', ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not.found) then + if(masterproc) write(iulog,*) trim(fieldname), ' initialized to 1000.' + tptr=1000._r8 + end if + do n=1,dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr, start=(/1,n/), kount=(/pcols,1/)) + end do + deallocate(tptr) + end if + + ! + ! 3-D fields + ! + + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname='CLOUD' + m = pbuf_get_index('CLD') + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + fieldname='QCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not. found) then + call infld('Q',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with Q' + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' + tptr3d = huge(1.0_r8) + end if + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + fieldname = 'ICCWAT' + m = pbuf_get_index(fieldname, ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call cnst_get_ind('CLDICE', ixcldice) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + end if + if (masterproc) then + if (found) then + write(iulog,*) trim(fieldname), ' initialized with CLDICE' + else + write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + end if + end if + end if + + fieldname = 'LCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + allocate(tptr3d_2(pcols,pver,begchunk:endchunk)) + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + call infld('CLDLIQ',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d_2, found2, gridname='physgrid') + if(found .and. found2) then + do lchnk = begchunk, endchunk + ncol = get_ncols_p(lchnk) + tptr3d(:ncol,:,lchnk)=tptr3d(:ncol,:,lchnk)+tptr3d_2(:ncol,:,lchnk) + end do + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE + CLDLIQ' + else if (found) then ! Data already loaded in tptr3d + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE only' + else if (found2) then + tptr3d(:,:,:)=tptr3d_2(:,:,:) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDLIQ only' + end if + + if (found .or. found2) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + deallocate(tptr3d_2) + end if + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname = 'TCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not.found) then + call infld('T', fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + if(dycore_is('LR')) call polar_average(pver, tptr3d) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with T' + else + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to huge()' + tptr3d = huge(1._r8) + end if + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pverp,begchunk:endchunk)) + + fieldname = 'TKE' + m = pbuf_get_index( 'tke') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0.01_r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.01' + end if + + + fieldname = 'KVM' + m = pbuf_get_index('kvm') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + + fieldname = 'KVH' + m = pbuf_get_index('kvh') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname = 'CONCLD' + m = pbuf_get_index('CONCLD',ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + deallocate (tptr3d) + end if + + call initialize_short_lived_species(fh_ini, pbuf2d) + + !--------------------------------------------------------------------------------- + ! If needed, get ion and electron temperature fields from initial condition file + !--------------------------------------------------------------------------------- + + call waccmx_phys_ion_elec_temp_inidat(fh_ini,pbuf2d) + + end subroutine phys_inidat + + + subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) + + !----------------------------------------------------------------------- + ! + ! Initialization of physics package. + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index + use physconst, only: rair, cpair, gravit, stebol, tmelt, & + latvap, latice, rh2o, rhoh2o, pstd, zvir, & + karman, rhodair, physconst_init + use ref_pres, only: pref_edge, pref_mid + + use carma_intr, only: carma_init + use cam_control_mod, only: initial_run + use check_energy, only: check_energy_init + use chemistry, only: chem_init + use prescribed_ozone, only: prescribed_ozone_init + use prescribed_ghg, only: prescribed_ghg_init + use prescribed_aero, only: prescribed_aero_init + use aerodep_flx, only: aerodep_flx_init + use aircraft_emit, only: aircraft_emit_init + use prescribed_volcaero,only: prescribed_volcaero_init + use prescribed_strataero,only: prescribed_strataero_init + use cloud_fraction, only: cldfrc_init + use cldfrc2m, only: cldfrc2m_init + use co2_cycle, only: co2_init, co2_transport + use convect_deep, only: convect_deep_init + use convect_shallow, only: convect_shallow_init + use cam_diagnostics, only: diag_init + use gw_drag, only: gw_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_init + use radheat, only: radheat_init + use radiation, only: radiation_init + use cloud_diagnostics, only: cloud_diagnostics_init + use rk_stratiform, only: rk_stratiform_init + use wv_saturation, only: wv_sat_init + use microp_driver, only: microp_driver_init + use microp_aero, only: microp_aero_init + use macrop_driver, only: macrop_driver_init + use conv_water, only: conv_water_init + use spcam_drivers, only: spcam_init + use tracers, only: tracers_init + use aoa_tracers, only: aoa_tracers_init + use rayleigh_friction, only: rayleigh_friction_init + use pbl_utils, only: pbl_utils_init + use vertical_diffusion, only: vertical_diffusion_init + use phys_debug_util, only: phys_debug_init + use phys_debug, only: phys_debug_state_init + use rad_constituents, only: rad_cnst_init + use aer_rad_props, only: aer_rad_props_init + use subcol, only: subcol_init + use qbo, only: qbo_init + use qneg_module, only: qneg_init + use iondrag, only: iondrag_init, do_waccm_ions +#if ( defined OFFLINE_DYN ) + use metdata, only: metdata_phys_init +#endif + use epp_ionization, only: epp_ionization_init, epp_ionization_active + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) + use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) + use clubb_intr, only: clubb_ini_cam + use sslt_rebin, only: sslt_rebin_init + use tropopause, only: tropopause_init + use solar_data, only: solar_data_init + use dadadj_cam, only: dadadj_init + use cam_abortutils, only: endrun + use nudging, only: Nudge_Model, nudging_init + + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) + + ! local variables + integer :: lchnk + integer :: ierr + + !----------------------------------------------------------------------- + + call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) + + do lchnk = begchunk, endchunk + call physics_state_set_grid(lchnk, phys_state(lchnk)) + end do + + !------------------------------------------------------------------------------------------- + ! Initialize any variables in physconst which are not temporally and/or spatially constant + !------------------------------------------------------------------------------------------- + call physconst_init() + + ! Initialize debugging a physics column + call phys_debug_init() + + call pbuf_initialize(pbuf2d) + + ! Initialize subcol scheme + call subcol_init(pbuf2d) + + ! diag_init makes addfld calls for dynamics fields that are output from + ! the physics decomposition + call diag_init(pbuf2d) + + call check_energy_init() + + call tracers_init() + + ! age of air tracers + call aoa_tracers_init() + + teout_idx = pbuf_get_index( 'TEOUT') + + ! adiabatic or ideal physics should be only used if in simple_physics + if (adiabatic .or. ideal_phys) then + if (adiabatic) then + call endrun('phys_init: adiabatic configuration error') + else + call endrun('phys_init: ideal_phys configuration error') + end if + end if + + if (initial_run) then + call phys_inidat(cam_out, pbuf2d) + end if + + ! wv_saturation is relatively independent of everything else and + ! low level, so init it early. Must at least do this before radiation. + call wv_sat_init + + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) + + ! Initialize rad constituents and their properties + call rad_cnst_init() + call aer_rad_props_init() + + ! initialize carma + call carma_init() + + ! solar irradiance data modules + call solar_data_init() + + ! Prognostic chemistry. + call chem_init(phys_state,pbuf2d) + + ! Prescribed tracers + call prescribed_ozone_init() + call prescribed_ghg_init() + call prescribed_aero_init() + call aerodep_flx_init() + call aircraft_emit_init() + call prescribed_volcaero_init() + call prescribed_strataero_init() + + ! co2 cycle + if (co2_transport()) then + call co2_init() + end if + + ! CAM3 prescribed ozone + if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) + + call gw_init() + + call rayleigh_friction_init() + + call pbl_utils_init(gravit, karman, cpair, rair, zvir) + call vertical_diffusion_init(pbuf2d) + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_init () + ! Initialization of ionosphere module if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_init(pbuf2d) + endif + endif + + call radiation_init(pbuf2d) + + call cloud_diagnostics_init() + + call radheat_init(pref_mid) + + call convect_shallow_init(pref_edge, pbuf2d) + + call cldfrc_init() + call cldfrc2m_init() + + call convect_deep_init(pref_edge) + + if( microp_scheme == 'RK' ) then + call rk_stratiform_init() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) + call microp_aero_init() + call microp_driver_init(pbuf2d) + call conv_water_init + elseif( microp_scheme == 'SPCAM_m2005') then + call conv_water_init + end if + + + ! initiate CLUBB within CAM + if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) + + call spcam_init(pbuf2d) + + call qbo_init + + call iondrag_init(pref_mid) + ! Geomagnetic module -- after iondrag_init + if (epp_ionization_active) then + call epp_ionization_init() + endif + +#if ( defined OFFLINE_DYN ) + call metdata_phys_init() +#endif + call sslt_rebin_init() + call tropopause_init() + call dadadj_init() + + prec_dp_idx = pbuf_get_index('PREC_DP') + snow_dp_idx = pbuf_get_index('SNOW_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') + snow_sh_idx = pbuf_get_index('SNOW_SH') + + dlfzm_idx = pbuf_get_index('DLFZM', ierr) + + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + + ! Initialize Nudging Parameters + !-------------------------------- + if(Nudge_Model) call nudging_init + + if (clim_modal_aero) then + + ! If climate calculations are affected by prescribed modal aerosols, the + ! the initialization routine for the dry mode radius calculation is called + ! here. For prognostic MAM the initialization is called from + ! modal_aero_initialize + if (.not. prog_modal_aero) then + call modal_aero_calcsize_init(pbuf2d) + endif + + call modal_aero_wateruptake_init(pbuf2d) + + end if + + ! Initialize qneg3 and qneg4 + call qneg_init() + + end subroutine phys_init + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! First part of atmospheric physics package before updating of surface models + ! + !----------------------------------------------------------------------- + use time_manager, only: get_nstep + use cam_diagnostics,only: diag_allocate, diag_physvar_ic + use check_energy, only: check_energy_gmean + use phys_control, only: phys_getopts + use spcam_drivers, only: tphysbc_spcam + use spmd_utils, only: mpicom + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate +#if (defined BFB_CAM_SCAM_IOP ) + use cam_history, only: outfld +#endif + use cam_abortutils, only: endrun +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf1 +#endif + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + + type(physics_buffer_desc), pointer, dimension(:,:) :: pbuf2d + type(cam_in_t), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), dimension(begchunk:endchunk) :: cam_out + !----------------------------------------------------------------------- + ! + !---------------------------Local workspace----------------------------- + ! + integer :: c ! indices + integer :: ncol ! number of columns + integer :: nstep ! current timestep number + logical :: use_spcam + type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) + + call t_startf ('physpkg_st1') + nstep = get_nstep() + +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SNOWH and TS for micro-phys + ! + call get_met_srf1( cam_in ) +#endif + + ! The following initialization depends on the import state (cam_in) + ! being initialized. This isn't true when cam_init is called, so need + ! to postpone this initialization to here. + if (nstep == 0 .and. phys_do_flux_avg()) call flux_avg_init(cam_in, pbuf2d) + + ! Compute total energy of input state and previous output state + call t_startf ('chk_en_gmean') + call check_energy_gmean(phys_state, pbuf2d, ztodt, nstep) + call t_stopf ('chk_en_gmean') + + call t_stopf ('physpkg_st1') + + call t_startf ('physpkg_st1') + + call pbuf_allocate(pbuf2d, 'physpkg') + call diag_allocate() + + !----------------------------------------------------------------------- + ! Advance time information + !----------------------------------------------------------------------- + + call phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) + + call t_stopf ('physpkg_st1') + +#ifdef TRACER_CHECK + call gmean_mass ('before tphysbc DRY', phys_state) +#endif + + + !----------------------------------------------------------------------- + ! Tendency physics before flux coupler invocation + !----------------------------------------------------------------------- + ! + +#if (defined BFB_CAM_SCAM_IOP ) + do c=begchunk, endchunk + call outfld('Tg',cam_in(c)%ts,pcols ,c ) + end do +#endif + + call t_barrierf('sync_bc_physics', mpicom) + call t_startf ('bc_physics') + call t_adj_detailf(+1) + + call phys_getopts( use_spcam_out = use_spcam) + +!$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) + do c=begchunk, endchunk + ! + ! Output physics terms to IC file + ! + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + + call t_startf ('diag_physvar_ic') + call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) + call t_stopf ('diag_physvar_ic') + + if (use_spcam) then + call tphysbc_spcam (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + else + call tphysbc (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + end if + + end do + + call t_adj_detailf(-1) + call t_stopf ('bc_physics') + + ! Don't call the rest in CRM mode + if(single_column.and.scm_crm_mode) return + +#ifdef TRACER_CHECK + call gmean_mass ('between DRY', phys_state) +#endif + + end subroutine phys_run1 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & + cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Second part of atmospheric physics package after updating of surface models + ! + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_deallocate, pbuf_update_tim_idx + use mo_lightning, only: lightning_no_prod + use cam_diagnostics, only: diag_deallocate, diag_surf + use physconst, only: stebol, latvap + use carma_intr, only: carma_accumulate_stats + use spmd_utils, only: mpicom +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf2 +#endif + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + type(physics_buffer_desc),pointer, dimension(:,:) :: pbuf2d + + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + ! + !----------------------------------------------------------------------- + !---------------------------Local workspace----------------------------- + ! + integer :: c ! chunk index + integer :: ncol ! number of columns + type(physics_buffer_desc),pointer, dimension(:) :: phys_buffer_chunk + ! + ! If exit condition just return + ! + + if(single_column.and.scm_crm_mode) return + + !----------------------------------------------------------------------- + ! Tendency physics after coupler + ! Not necessary at terminal timestep. + !----------------------------------------------------------------------- + ! +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SHFLX QFLX TAUX TAUY for vert diffusion + ! + call get_met_srf2( cam_in ) +#endif + ! Set lightning production of NO + call t_startf ('lightning_no_prod') + call lightning_no_prod( phys_state, pbuf2d, cam_in ) + call t_stopf ('lightning_no_prod') + + call t_barrierf('sync_ac_physics', mpicom) + call t_startf ('ac_physics') + call t_adj_detailf(+1) + +!$OMP PARALLEL DO PRIVATE (C, NCOL, phys_buffer_chunk) + + do c=begchunk,endchunk + ncol = get_ncols_p(c) + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + ! + ! surface diagnostics for history files + ! + call t_startf('diag_surf') + call diag_surf(cam_in(c), cam_out(c), phys_state(c), phys_buffer_chunk) + call t_stopf('diag_surf') + + call tphysac(ztodt, cam_in(c), & + cam_out(c), & + phys_state(c), phys_tend(c), phys_buffer_chunk) + end do ! Chunk loop + + call t_adj_detailf(-1) + call t_stopf('ac_physics') + +#ifdef TRACER_CHECK + call gmean_mass ('after tphysac FV:WET)', phys_state) +#endif + + call t_startf ('carma_accumulate_stats') + call carma_accumulate_stats() + call t_stopf ('carma_accumulate_stats') + + call t_startf ('physpkg_st2') + call pbuf_deallocate(pbuf2d, 'physpkg') + + call pbuf_update_tim_idx() + call diag_deallocate() + call t_stopf ('physpkg_st2') + + end subroutine phys_run2 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_final( phys_state, phys_tend, pbuf2d ) + use physics_buffer, only : physics_buffer_desc, pbuf_deallocate + use chemistry, only : chem_final + use carma_intr, only : carma_final + use wv_saturation, only : wv_sat_final + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Finalization of physics package + ! + !----------------------------------------------------------------------- + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + if(associated(pbuf2d)) then + call pbuf_deallocate(pbuf2d,'global') + deallocate(pbuf2d) + end if + deallocate(phys_state) + deallocate(phys_tend) + call chem_final + call carma_final + call wv_sat_final + + end subroutine phys_final + + + subroutine tphysac (ztodt, cam_in, & + cam_out, state, tend, pbuf) + !----------------------------------------------------------------------- + ! + ! Tendency physics after coupling to land, sea, and ice models. + ! + ! Computes the following: + ! + ! o Aerosol Emission at Surface + ! o Source-Sink for Advected Tracers + ! o Symmetric Turbulence Scheme - Vertical Diffusion + ! o Rayleigh Friction + ! o Dry Deposition of Aerosol + ! o Enforce Charge Neutrality ( Only for WACCM ) + ! o Gravity Wave Drag + ! o QBO Relaxation ( Only for WACCM ) + ! o Ion Drag ( Only for WACCM ) + ! o Scale Dry Mass Energy + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx + use shr_kind_mod, only: r8 => shr_kind_r8 + use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions + use cam_diagnostics, only: diag_phys_tend_writeout + use gw_drag, only: gw_tend + use vertical_diffusion, only: vertical_diffusion_tend + use rayleigh_friction, only: rayleigh_friction_tend + use constituents, only: cnst_get_ind + use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & + physics_dme_adjust, set_dry_to_wet, physics_state_check + use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X + use aoa_tracers, only: aoa_tracers_timestep_tend + use physconst, only: rhoh2o, latvap,latice + use aero_model, only: aero_model_drydep + use carma_intr, only: carma_emission_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_aerosol, carma_do_emission + use check_energy, only: check_energy_chng, calc_te_and_aam_budgets + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use time_manager, only: get_nstep + use cam_abortutils, only: endrun + use dycore, only: dycore_is + use cam_control_mod, only: aqua_planet + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_set + use charge_neutrality, only: charge_balance + use qbo, only: qbo_relax + use iondrag, only: iondrag_calc, do_waccm_ions + use perf_mod + use flux_avg, only: flux_avg_run + use unicon_cam, only: unicon_cam_org_diags + use cam_history, only: hist_fld_active + use qneg_module, only: qneg4 + use co2_cycle, only: co2_cycle_set_ptend + use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend + + ! + ! Arguments + ! + real(r8), intent(in) :: ztodt ! Two times model timestep (2 delta-t) + + type(cam_in_t), intent(inout) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + + type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes + + ! + !---------------------------Local workspace----------------------------- + ! + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + + integer :: nstep ! current timestep number + real(r8) :: zero(pcols) ! array of zeros + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer i,k,m ! Longitude, level indices + integer :: yr, mon, day, tod ! components of a date + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. +!AL + integer :: ixnumice, ixnumliq +!AL + logical :: labort ! abort flag + + real(r8) tvm(pcols,pver) ! virtual temperature + real(r8) prect(pcols) ! total precipitation + real(r8) surfric(pcols) ! surface friction velocity + real(r8) obklen(pcols) ! Obukhov length + real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. + real(r8) :: tmp_q (pcols,pver) ! tmp space + real(r8) :: tmp_cldliq(pcols,pver) ! tmp space + real(r8) :: tmp_cldice(pcols,pver) ! tmp space + real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space + real(r8) :: tmp_pdel (pcols,pver) ! tmp space + real(r8) :: tmp_t (pcols,pver) !+tht tmp space + real(r8) :: tmp_ps (pcols) ! tmp space + + ! physics buffer fields for total energy and mass adjustment + integer itim_old, ifld + + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction +!AL + real(r8), pointer, dimension(:,:) :: cldncini + real(r8), pointer, dimension(:,:) :: cldniini + real(r8) :: tmp_cldnc(pcols,pver) ! tmp space + real(r8) :: tmp_cldni(pcols,pver) ! tmp space +!AL + + !tht: variables for dme_energy_adjust + real(r8):: eflx(pcols), dsema(pcols) + logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy + + !----------------------------------------------------------------------- + lchnk = state%lchnk + ncol = state%ncol + + nstep = get_nstep() + + ! Adjust the surface fluxes to reduce instabilities in near sfc layer + if (phys_do_flux_avg()) then + call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) + endif + + ! Validate the physics state. + if (state_debug_checks) & + call physics_state_check(state, name="before tphysac") + + call t_startf('tphysac_init') + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + + + ifld = pbuf_get_index('DTCORE') + call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) +!AL + call pbuf_get_field(pbuf, cldncini_idx, cldncini) + call pbuf_get_field(pbuf, cldniini_idx, cldniini) +!AL + + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, start=(/1,1,itim_old/),kount=(/pcols,pver,1/)) + + ifld = pbuf_get_index('AST') + call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ! + ! accumulate fluxes into net flux array for spectral dycores + ! jrm Include latent heat of fusion for snow + ! + do i=1,ncol + tend%flx_net(i) = tend%flx_net(i) + cam_in%shf(i) + (cam_out%precc(i) & + + cam_out%precl(i))*latvap*rhoh2o & + + (cam_out%precsc(i) + cam_out%precsl(i))*latice*rhoh2o + end do + + ! emissions of aerosols and gas-phase chemistry constituents at surface + call chem_emissions( state, cam_in ) + + if (carma_do_emission) then + ! carma emissions + call carma_emission_tend (state, ptend, cam_in, ztodt) + call physics_update(state, ptend, ztodt, tend) + end if + + ! get nstep and zero array for energy checker + zero = 0._r8 + nstep = get_nstep() + call check_tracers_init(state, tracerint) + + ! Check if latent heat flux exceeds the total moisture content of the + ! lowest model layer, thereby creating negative moisture. + + call qneg4('TPHYSAC', lchnk, ncol, ztodt , & + state%q(1,pver,1), state%rpdel(1,pver), & + cam_in%shf, cam_in%lhf, cam_in%cflx) + + call t_stopf('tphysac_init') + !=================================================== + ! Source/sink terms for advected tracers. + !=================================================== + call t_startf('adv_tracer_src_snk') + ! Test tracers + + call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) + call physics_update(state, ptend, ztodt, tend) + call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & + cam_in%cflx) + + call co2_cycle_set_ptend(state, pbuf, ptend) + call physics_update(state, ptend, ztodt, tend) + + !=================================================== + ! Chemistry and MAM calculation + ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. + ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and + ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before + ! Gas chemistry and MAM core aerosol conversion. + ! Note that surface flux is not added into the atmosphere, but elevated emission is + ! added into the atmosphere as tendency. + !=================================================== + if (chem_is_active()) then + call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & + pbuf, fh2o=fh2o) + + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) + call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & + cam_in%cflx) + end if + call t_stopf('adv_tracer_src_snk') + + !=================================================== + ! Vertical diffusion/pbl calculation + ! Call vertical diffusion code (pbl, free atmosphere and molecular) + !=================================================== + + call t_startf('vertical_diffusion_tend') + call vertical_diffusion_tend (ztodt ,state , cam_in, & + surfric ,obklen ,ptend ,ast ,pbuf ) + + !------------------------------------------ + ! Call major diffusion for extended model + !------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_tend (ztodt ,state ,ptend) + endif + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf ('vertical_diffusion_tend') + + !=================================================== + ! Rayleigh friction calculation + !=================================================== + call t_startf('rayleigh_friction') + call rayleigh_friction_tend( ztodt, state, ptend) + call physics_update(state, ptend, ztodt, tend) + call t_stopf('rayleigh_friction') + + if (do_clubb_sgs) then + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) + else + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & + zero, cam_in%shf) + endif + + call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) + + ! aerosol dry deposition processes + call t_startf('aero_drydep') + call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf('aero_drydep') + + ! CARMA microphysics + ! + ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing the dry + ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, so that + ! obklen and surfric have been calculated. It needs to follow aero_model_drydep, so + ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and cam_out + ! can be added to for CARMA aerosols. + if (carma_do_aerosol) then + call t_startf('carma_timestep_tend') + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) + call physics_update(state, ptend, ztodt, tend) + + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('carma_timestep_tend') + end if + + + !--------------------------------------------------------------------------------- + ! ... enforce charge neutrality + !--------------------------------------------------------------------------------- + call charge_balance(state, pbuf) + + !=================================================== + ! Gravity wave drag + !=================================================== + call t_startf('gw_tend') + + call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) + + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & + zero, zero, flx_heat) + call t_stopf('gw_tend') + + ! QBO relaxation + call qbo_relax(state, pbuf, ptend) + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) + + ! Ion drag calculation + call t_startf ( 'iondrag' ) + + if ( do_waccm_ions ) then + call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + else + call iondrag_calc( lchnk, ncol, state, ptend) + endif + !---------------------------------------------------------------------------- + ! Call ionosphere routines for extended model if mode is set to ionosphere + !---------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) + endif + + call physics_update(state, ptend, ztodt, tend) + call calc_te_and_aam_budgets(state, 'pAP') + + !--------------------------------------------------------------------------------- + ! Enforce charge neutrality after O+ change from ionos_tend + !--------------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call charge_balance(state, pbuf) + endif + + ! Check energy integrals + call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) + + call t_stopf ( 'iondrag' ) + + ! Update Nudging values, if needed + !---------------------------------- + if((Nudge_Model).and.(Nudge_ON)) then + call nudging_timestep_tend(state,ptend) + call physics_update(state,ptend,ztodt,tend) + call check_energy_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) + endif + + !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + + ! Save total energy for global fixer in next timestep (FV and SE dycores) + call pbuf_set_field(pbuf, teout_idx, state%te_cur, (/1,itim_old/),(/pcols,1/)) + + if (shallow_scheme .eq. 'UNICON') then + + ! ------------------------------------------------------------------------ + ! Insert the organization-related heterogeneities computed inside the + ! UNICON into the tracer arrays here before performing advection. + ! This is necessary to prevent any modifications of organization-related + ! heterogeneities by non convection-advection process, such as + ! dry and wet deposition of aerosols, MAM, etc. + ! Again, note that only UNICON and advection schemes are allowed to + ! changes to organization at this stage, although we can include the + ! effects of other physical processes in future. + ! ------------------------------------------------------------------------ + + call unicon_cam_org_diags(state, pbuf) + + end if + ! + ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust + ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. + if ( dycore_is('LR')) call set_dry_to_wet(state) ! Physics had dry, dynamics wants moist + + ! Scale dry mass and energy (does nothing if dycore is EUL or SLD) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + tmp_t (:ncol,:pver) = state%t(:ncol,:pver) !+tht + tmp_q (:ncol,:pver) = state%q(:ncol,:pver,1) + tmp_cldliq(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + tmp_cldice(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) +!AL + call cnst_get_ind('NUMLIQ', ixnumliq) + call cnst_get_ind('NUMICE', ixnumice) + tmp_cldnc(:ncol,:pver) = state%q(:ncol,:pver,ixnumliq) + tmp_cldni(:ncol,:pver) = state%q(:ncol,:pver,ixnumice) +!AL + ! For 'SE', physics_dme_adjust is called for energy diagnostic purposes only. So, save off tracers + if (dycore_is('SE').and.hist_fld_active('SE_pAM').or.hist_fld_active('KE_pAM').or.hist_fld_active('WV_pAM').or.& + hist_fld_active('WL_pAM').or.hist_fld_active('WI_pAM')) then + tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) + tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) + tmp_ps(:ncol) = state%ps(:ncol) + ! + ! pint, lnpint,rpdel are altered by dme_adjust but not used for tendencies in dynamics of SE + ! we do not reset them to pre-dme_adjust values + ! + if (dycore_is('SE')) call set_dry_to_wet(state) + call physics_dme_adjust(state, tend, qini, ztodt) + call calc_te_and_aam_budgets(state, 'pAM') + ! Restore pre-"physics_dme_adjust" tracers + state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) + state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) + state%ps(:ncol) = tmp_ps(:ncol) + end if + +!+tht + !if (dycore_is('LR')) call physics_dme_adjust(state, tend, qini, ztodt) + if (dycore_is('LR')) & + call physics_dme_adjust(state, tend, qini, ztodt, eflx, dsema, & + ohf_adjust, cam_in%ocnfrac, cam_in%sst, cam_in%ts) +!-tht + +!!! REMOVE THIS CALL, SINCE ONLY Q IS BEING ADJUSTED. WON'T BALANCE ENERGY. TE IS SAVED BEFORE THIS +!!! call check_energy_chng(state, tend, "drymass", nstep, ztodt, zero, zero, zero, zero) + + ! store T in buffer for use in computing dynamics T-tendency in next timestep + do k = 1,pver + dtcore(:ncol,k) = state%t(:ncol,k) + end do + + !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (aqua_planet) then + labort = .false. + do i=1,ncol + if (cam_in%ocnfrac(i) /= 1._r8) labort = .true. + end do + if (labort) then + call endrun ('TPHYSAC error: grid contains non-ocean point') + endif + endif + +!AL+tht + !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & + ! qini, cldliqini, cldiceini) + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & + tmp_cldnc,tmp_cldni,qini, cldliqini, cldiceini, cldncini, cldniini, eflx, dsema ) +!AL-tht + + call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) + + end subroutine tphysac + + subroutine tphysbc (ztodt, state, & + tend, pbuf, & + cam_out, cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Evaluate and apply physical processes that are calculated BEFORE + ! coupling to land, sea, and ice models. + ! + ! Processes currently included are: + ! + ! o Resetting Negative Tracers to Positive + ! o Global Mean Total Energy Fixer + ! o Dry Adjustment + ! o Asymmetric Turbulence Scheme : Deep Convection & Shallow Convection + ! o Stratiform Macro-Microphysics + ! o Wet Scavenging of Aerosol + ! o Radiation + ! + ! Method: + ! + ! Each parameterization should be implemented with this sequence of calls: + ! 1) Call physics interface + ! 2) Check energy + ! 3) Call physics_update + ! See Interface to Column Physics and Chemistry Packages + ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_get_field + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx + use physics_buffer, only: col_type_subcol, dyn_time_lvls + use shr_kind_mod, only: r8 => shr_kind_r8 + + use dadadj_cam, only: dadadj_tend + use rk_stratiform, only: rk_stratiform_tend + use microp_driver, only: microp_driver_tend + use microp_aero, only: microp_aero_run + use macrop_driver, only: macrop_driver_tend + use physics_types, only: physics_state, physics_tend, physics_ptend, & + physics_update, physics_ptend_init, physics_ptend_sum, & + physics_state_check, physics_ptend_scale + use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write + use cam_history, only: outfld + use physconst, only: cpair, latvap + use constituents, only: pcnst, qmin, cnst_get_ind + use convect_deep, only: convect_deep_tend, convect_deep_tend_2, deep_scheme_does_scav_trans + use time_manager, only: is_first_step, get_nstep + use convect_shallow, only: convect_shallow_tend + use check_energy, only: check_energy_chng, check_energy_fix, check_energy_timestep_init + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use check_energy, only: calc_te_and_aam_budgets + use dycore, only: dycore_is + use aero_model, only: aero_model_wetdep + use carma_intr, only: carma_wetdep_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep + use radiation, only: radiation_tend + use cloud_diagnostics, only: cloud_diagnostics_calc + use perf_mod + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_adj + use clubb_intr, only: clubb_tend_cam + use sslt_rebin, only: sslt_rebin_adv + use tropopause, only: tropopause_output + use cam_abortutils, only: endrun + use subcol, only: subcol_gen, subcol_ptend_avg + use subcol_utils, only: subcol_ptend_copy, is_subcol_on + use qneg_module, only: qneg3 + +#ifdef OSLO_AERO + use commondefinitions + use aerosoldef !, only: nmodes +#endif + + implicit none + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + + + ! + !---------------------------Local workspace----------------------------- + ! + + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_state) :: state_sc ! state for sub-columns + type(physics_ptend) :: ptend_sc ! ptend for sub-columns + type(physics_ptend) :: ptend_aero ! ptend for microp_aero + type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns + type(physics_tend) :: tend_sc ! tend for sub-columns + + integer :: nstep ! current timestep number + + real(r8) :: net_flx(pcols) + + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + integer :: i,k,m ! Longitude, level, constituent indices + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. +!AL + integer :: ixcldni, ixcldnc ! constituent indices for cloud liquid and ice water. +!AL + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep +#ifdef OSLO_AERO + integer kcomp ! mode number (1-14) +#endif + + ! physics buffer fields to compute tendencies for stratiform package + integer itim_old, ifld + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction + + + ! physics buffer fields for total energy and mass adjustment + real(r8), pointer, dimension(: ) :: teout + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: dtcore +!AL + real(r8), pointer, dimension(:,:) :: cldncini + real(r8), pointer, dimension(:,:) :: cldniini +!AL + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + + ! convective precipitation variables + real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8),pointer :: snow_dp(:) ! snow from ZM convection + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection + + ! carma precipitation variables + real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) + real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) + + ! energy checking variables + real(r8) :: zero(pcols) ! array of zeros + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: flx_cnd(pcols) + real(r8) :: flx_heat(pcols) + type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes + real(r8) :: zero_tracers(pcols,pcnst) + + logical :: lq(pcnst) + +#ifdef AEROCOM + real(r8) :: logsig3d(pcols,pver,nmodes) ! Log (log10) of standard deviation for lognormal modes, method 2. + real(r8) :: rnew3d(pcols,pver,nmodes) ! New modal radius from look-up tables, method 2. + real(r8) :: logsig1(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 1, method 2. + real(r8) :: rnew1(pcols,pver) ! New modal radius, mode 1, from look-up tables, method 2. + real(r8) :: logsig2(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 2, method 2. + real(r8) :: rnew2(pcols,pver) ! New modal radius, mode 2, from look-up tables, method 2. + real(r8) :: logsig4(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 4, method 2. + real(r8) :: rnew4(pcols,pver) ! New modal radius, mode 4, from look-up tables, method 2. + real(r8) :: logsig5(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 5, method 2. + real(r8) :: rnew5(pcols,pver) ! New modal radius, mode 5, from look-up tables, method 2. + real(r8) :: logsig6(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 6, method 2. + real(r8) :: rnew6(pcols,pver) ! New modal radius, mode 6, from look-up tables, method 2. + real(r8) :: logsig7(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 7, method 2. + real(r8) :: rnew7(pcols,pver) ! New modal radius, mode 7, from look-up tables, method 2. + real(r8) :: logsig8(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 8, method 2. + real(r8) :: rnew8(pcols,pver) ! New modal radius, mode 8, from look-up tables, method 2. + real(r8) :: logsig9(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 9, method 2. + real(r8) :: rnew9(pcols,pver) ! New modal radius, mode 9, from look-up tables, method 2. + real(r8) :: logsig10(pcols,pver)! Log (log10) of standard deviation for lognormal modes 10, method 2. + real(r8) :: rnew10(pcols,pver) ! New modal radius, mode 10, from look-up tables, method 2. + real(r8) :: logsig11(pcols,pver)! Log (log10) of standard deviation for lognormal modes 11, method 2. + real(r8) :: rnew11(pcols,pver) ! New modal radius, mode 11, from look-up tables, method 2. + real(r8) :: logsig13(pcols,pver)! Log (log10) of standard deviation for lognormal modes 13, method 2. + real(r8) :: rnew13(pcols,pver) ! New modal radius, mode 13, from look-up tables, method 2. + real(r8) :: logsig14(pcols,pver)! Log (log10) of standard deviation for lognormal modes 14, method 2. + real(r8) :: rnew14(pcols,pver) ! New modal radius, mode 14, from look-up tables, method 2. + real(r8) :: rnewdry1(pcols,pver) ! New dry modal radius, mode 1, from look-up tables, method 2. + real(r8) :: rnewdry2(pcols,pver) ! New dry modal radius, mode 2, from look-up tables, method 2. + real(r8) :: rnewdry4(pcols,pver) ! New dry modal radius, mode 4, from look-up tables, method 2. + real(r8) :: rnewdry5(pcols,pver) ! New dry modal radius, mode 5, from look-up tables, method 2. + real(r8) :: rnewdry6(pcols,pver) ! New dry modal radius, mode 6, from look-up tables, method 2. + real(r8) :: rnewdry7(pcols,pver) ! New dry modal radius, mode 7, from look-up tables, method 2. + real(r8) :: rnewdry8(pcols,pver) ! New dry modal radius, mode 8, from look-up tables, method 2. + real(r8) :: rnewdry9(pcols,pver) ! New dry modal radius, mode 9, from look-up tables, method 2. + real(r8) :: rnewdry10(pcols,pver) ! New dry modal radius, mode 10, from look-up tables, method 2. + real(r8) :: rnewdry11(pcols,pver) ! New dry modal radius, mode 11, from look-up tables, method 2. + real(r8) :: rnewdry13(pcols,pver) ! New dry modal radius, mode 13, from look-up tables, method 2. + real(r8) :: rnewdry14(pcols,pver) ! New dry modal radius, mode 14, from look-up tables, method 2. + real(r8) :: relhum(pcols,pver) ! Ambient relative humidity (fraction) + real(r8) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate + real(r8) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust + real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) + real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt + real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor +#endif ! aerocom + !----------------------------------------------------------------------- + + call t_startf('bc_init') + + zero = 0._r8 + zero_tracers(:,:) = 0._r8 + zero_sc(:) = 0._r8 + + lchnk = state%lchnk + ncol = state%ncol + + nstep = get_nstep() + + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) +!AL + call pbuf_get_field(pbuf, cldncini_idx, cldncini) + call pbuf_get_field(pbuf, cldniini_idx, cldniini) +!AL + + ifld = pbuf_get_index('DTCORE') + call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ifld = pbuf_get_index('FRACIS') + call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + fracis (:ncol,:,1:pcnst) = 1._r8 + + ! Set physics tendencies to 0 + tend %dTdt(:ncol,:pver) = 0._r8 + tend %dudt(:ncol,:pver) = 0._r8 + tend %dvdt(:ncol,:pver) = 0._r8 + + ! Verify state coming from the dynamics + if (state_debug_checks) & + call physics_state_check(state, name="before tphysbc (dycore?)") + + call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) + + ! Since clybry_fam_adj operates directly on the tracers, and has no + ! physics_update call, re-run qneg3. + + call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,state%q ) + + ! Validate output of clybry_fam_adj. + if (state_debug_checks) & + call physics_state_check(state, name="clybry_fam_adj") + + ! + ! Dump out "before physics" state + ! + call diag_state_b4_phys_write (state) + + ! compute mass integrals of input tracers state + call check_tracers_init(state, tracerint) + + call t_stopf('bc_init') + + !=================================================== + ! Global mean total energy fixer + !=================================================== + call t_startf('energy_fixer') + + call calc_te_and_aam_budgets(state, 'pBF') + if (dycore_is('LR') .or. dycore_is('SE')) then + call check_energy_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) + end if + call calc_te_and_aam_budgets(state, 'pBP') + ! Save state for convective tendency calculations. + call diag_conv_tend_ini(state, pbuf) + + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + qini (:ncol,:pver) = state%q(:ncol,:pver, 1) + cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) +!AL + call cnst_get_ind('NUMLIQ', ixcldnc) + call cnst_get_ind('NUMICE', ixcldni) + cldncini(:ncol,:pver) = state%q(:ncol,:pver,ixcldnc) + cldniini(:ncol,:pver) = state%q(:ncol,:pver,ixcldni) +!AL + + call outfld('TEOUT', teout , pcols, lchnk ) + call outfld('TEINP', state%te_ini, pcols, lchnk ) + call outfld('TEFIX', state%te_cur, pcols, lchnk ) + + ! T tendency due to dynamics + if( nstep > dyn_time_lvls-1 ) then + dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt + call outfld( 'DTCORE', dtcore, pcols, lchnk ) + end if + + call t_stopf('energy_fixer') + ! + !=================================================== + ! Dry adjustment + !=================================================== + call t_startf('dry_adjustment') + + call dadadj_tend(ztodt, state, ptend) + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf('dry_adjustment') + + !=================================================== + ! Moist convection + !=================================================== + call t_startf('moist_convection') + + call t_startf ('convect_deep_tend') + + call convect_deep_tend( & + cmfmc, cmfcme, & + pflx, zdu, & + rliq, rice, & + ztodt, & + state, ptend, cam_in%landfrac, pbuf) + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf('convect_deep_tend') + + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + ! Check energy integrals, including "reserved liquid" + flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) + snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) + call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) + snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) + + ! + ! Call Hack (1994) convection scheme to deal with shallow/mid-level convection + ! + call t_startf ('convect_shallow_tend') + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + call convect_shallow_tend (ztodt , cmfmc, & + dlf , dlf2 , rliq , rliq2, & + state , ptend , pbuf, cam_in) + call t_stopf ('convect_shallow_tend') + + call physics_update(state, ptend, ztodt, tend) + + flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) + call check_energy_chng(state, tend, "convect_shallow", nstep, ztodt, zero, flx_cnd, snow_sh, zero) + + call check_tracers_chng(state, tracerint, "convect_shallow", nstep, ztodt, zero_tracers) + + call t_stopf('moist_convection') + + ! Rebin the 4-bin version of sea salt into bins for coarse and accumulation + ! modes that correspond to the available optics data. This is only necessary + ! for CAM-RT. But it's done here so that the microphysics code which is called + ! from the stratiform interface has access to the same aerosols as the radiation + ! code. + call sslt_rebin_adv(pbuf, state) + +#ifdef DIRIND +! do i=1,ncol +! precc (i) = prec_zmc(i) + prec_cmf(i) +! if(precc(i).lt.0.) precc(i)=0. +! end do +#ifdef AEROCOM + do kcomp=1,14 + do k=1,pver + do i=1,ncol + rnew3d(i,k,kcomp) =0.0_r8 + logsig3d(i,k,kcomp)=0.0_r8 + enddo + enddo + enddo +#endif ! aerocom +#endif ! dirind + + + !=================================================== + ! Calculate tendencies from CARMA bin microphysics. + !=================================================== + ! + ! If CARMA is doing detrainment, then on output, rliq no longer represents water reserved + ! for detrainment, but instead represents potential snow fall. The mass and number of the + ! snow are stored in the physics buffer and will be incorporated by the MG microphysics. + ! + ! Currently CARMA cloud microphysics is only supported with the MG microphysics. + call t_startf('carma_timestep_tend') + + if (carma_do_cldice .or. carma_do_cldliq) then + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & + prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) + call physics_update(state, ptend, ztodt, tend) + + ! Before the detrainment, the reserved condensate is all liquid, but if CARMA is doing + ! detrainment, then the reserved condensate is snow. + if (carma_do_detrain) then + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) + else + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + end if + end if + + call t_stopf('carma_timestep_tend') + + if( microp_scheme == 'RK' ) then + + !=================================================== + ! Calculate stratiform tendency (sedimentation, detrain, cloud fraction and microphysics ) + !=================================================== + call t_startf('rk_stratiform_tend') + + call rk_stratiform_tend(state, ptend, pbuf, ztodt, & + cam_in%icefrac, cam_in%landfrac, cam_in%ocnfrac, & + cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + rliq , & ! check energy after detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu) + + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "cldwat_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + + call t_stopf('rk_stratiform_tend') + + elseif( microp_scheme == 'MG' ) then + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps + + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 + + do macmic_it = 1, cld_macmic_num_steps + + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== + + call t_startf('macrop_tend') + + ! don't call Park macrophysics if CLUBB is called + if (macrop_scheme .ne. 'CLUBB_SGS') then + + call macrop_driver_tend( & + state, ptend, cld_macmic_ztodt, & + cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu, & + pbuf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & + zero, flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + + else ! Calculate CLUBB macrophysics + + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== + + call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + call physics_update(state, ptend, ztodt, tend) + + ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code + call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + + endif + + call t_stopf('macrop_tend') + + !=================================================== + ! Calculate cloud microphysics + !=================================================== + + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) + + ! Generate sub-columns using the requested scheme + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if + + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') + + call t_startf('microp_tend') + + if (use_subcol_microp) then + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) + + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) + + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, & + prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & + snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) + + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update (state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & + zero, prec_str(:ncol)/cld_macmic_num_steps, & + snow_str(:ncol)/cld_macmic_num_steps, zero) + + call t_stopf('microp_tend') + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + + end do ! end substepping over macrophysics/microphysics + + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + + endif + + ! Add the precipitation from CARMA to the precipitation from stratiform. + if (carma_do_cldice .or. carma_do_cldliq) then + prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) + snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) + end if + + if ( .not. deep_scheme_does_scav_trans() ) then + + ! ------------------------------------------------------------------------------- + ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. + ! 2. Convective Transport of Non-Water Aerosol Species. + ! + ! . Aerosol wet chemistry determines scavenging fractions, and transformations + ! . Then do convective transport of all trace species except qv,ql,qi. + ! . We needed to do the scavenging first to determine the interstitial fraction. + ! . When UNICON is used as unified convection, we should still perform + ! wet scavenging but not 'convect_deep_tend2'. + ! ------------------------------------------------------------------------------- + + call t_startf('bc_aerosols') + if (clim_modal_aero .and. .not. prog_modal_aero) then + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + endif + call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) + call physics_update(state, ptend, ztodt, tend) + +#ifdef DIRIND +#ifdef AEROCOM +! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass +! fractions of each internally mixed component for each mode (kcomp). +! + call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) +! + do k=1,pver + do i=1,ncol + rnewdry1(i,k) = rnew3d(i,k,1) + rnewdry2(i,k) = rnew3d(i,k,2) + rnewdry4(i,k) = rnew3d(i,k,4) + rnewdry5(i,k) = rnew3d(i,k,5) + rnewdry6(i,k) = rnew3d(i,k,6) + rnewdry7(i,k) = rnew3d(i,k,7) + rnewdry8(i,k) = rnew3d(i,k,8) + rnewdry9(i,k) = rnew3d(i,k,9) + rnewdry10(i,k) = rnew3d(i,k,10) + rnewdry11(i,k) = rnew3d(i,k,11) + rnewdry13(i,k) = rnew3d(i,k,13) + rnewdry14(i,k) = rnew3d(i,k,14) + rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) + rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) + rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) + rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) + rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) + rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) + rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) + rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) + rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) + rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) + rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) + rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) + logsig1(i,k) = logsig3d(i,k,1) + logsig2(i,k) = logsig3d(i,k,2) + logsig4(i,k) = logsig3d(i,k,4) + logsig5(i,k) = logsig3d(i,k,5) + logsig6(i,k) = logsig3d(i,k,6) + logsig7(i,k) = logsig3d(i,k,7) + logsig8(i,k) = logsig3d(i,k,8) + logsig9(i,k) = logsig3d(i,k,9) + logsig10(i,k)= logsig3d(i,k,10) + logsig11(i,k)= logsig3d(i,k,11) + logsig13(i,k)= logsig3d(i,k,13) + logsig14(i,k)= logsig3d(i,k,14) +!test-output++ +! logsig1(i,k) = frh(i,k,1) +! logsig2(i,k) = frh(i,k,2) +! logsig4(i,k) = frh(i,k,4) +! logsig5(i,k) = frh(i,k,5) +! logsig6(i,k) = frh(i,k,6) +! logsig7(i,k) = frh(i,k,7) +! logsig8(i,k) = frh(i,k,8) +! logsig9(i,k) = frh(i,k,9) +! logsig10(i,k) = frh(i,k,10) +!test-output-- + end do + end do +! kommenterer ut disse foreløpig: +! call outfld('RNEWD1 ',rnewdry1,pcols,lchnk) +! call outfld('RNEWD2 ',rnewdry2,pcols,lchnk) +! call outfld('RNEWD4 ',rnewdry4,pcols,lchnk) +! call outfld('RNEWD5 ',rnewdry5,pcols,lchnk) +! call outfld('RNEWD6 ',rnewdry6,pcols,lchnk) +! call outfld('RNEWD7 ',rnewdry7,pcols,lchnk) +! call outfld('RNEWD8 ',rnewdry8,pcols,lchnk) +! call outfld('RNEWD9 ',rnewdry9,pcols,lchnk) +! call outfld('RNEWD10 ',rnewdry10,pcols,lchnk) +!! call outfld('RNEWD11 ',rnewdry11,pcols,lchnk) ! always = 0.0118 +!! call outfld('RNEWD13 ',rnewdry13,pcols,lchnk) ! always = 0.04 +!! call outfld('RNEWD14 ',rnewdry14,pcols,lchnk) ! always = 0.04 +! call outfld('RNEW1 ',rnew1,pcols,lchnk) +! call outfld('RNEW2 ',rnew2,pcols,lchnk) +! call outfld('RNEW4 ',rnew4,pcols,lchnk) +! call outfld('RNEW5 ',rnew5,pcols,lchnk) +! call outfld('RNEW6 ',rnew6,pcols,lchnk) +! call outfld('RNEW7 ',rnew7,pcols,lchnk) +! call outfld('RNEW8 ',rnew8,pcols,lchnk) +! call outfld('RNEW9 ',rnew9,pcols,lchnk) +! call outfld('RNEW10 ',rnew10,pcols,lchnk) +! call outfld('RNEW11 ',rnew11,pcols,lchnk) +! call outfld('RNEW13 ',rnew13,pcols,lchnk) +! call outfld('RNEW14 ',rnew14,pcols,lchnk) +! call outfld('LOGSIG1 ',logsig1,pcols,lchnk) +! call outfld('LOGSIG2 ',logsig2,pcols,lchnk) +! call outfld('LOGSIG4 ',logsig4,pcols,lchnk) +! call outfld('LOGSIG5 ',logsig5,pcols,lchnk) +! call outfld('LOGSIG6 ',logsig6,pcols,lchnk) +! call outfld('LOGSIG7 ',logsig7,pcols,lchnk) +! call outfld('LOGSIG8 ',logsig8,pcols,lchnk) +! call outfld('LOGSIG9 ',logsig9,pcols,lchnk) +! call outfld('LOGSIG10',logsig10,pcols,lchnk) +!! call outfld('LOGSIG11',logsig11,pcols,lchnk) ! always = 0.2553 +!! call outfld('LOGSIG13',logsig13,pcols,lchnk) ! always = 0.2553 +!! call outfld('LOGSIG14',logsig14,pcols,lchnk) ! always = 0.2553 +#endif ! aerocom +#endif ! dirind + + if (carma_do_wetdep) then + ! CARMA wet deposition + ! + ! NOTE: It needs to follow aero_model_wetdep, so that cam_out%xxxwetxxx + ! fields have already been set for CAM aerosols and cam_out can be added + ! to for CARMA aerosols. + call t_startf ('carma_wetdep_tend') + call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('carma_wetdep_tend') + end if + + call t_startf ('convect_deep_tend2') + call convect_deep_tend_2( state, ptend, ztodt, pbuf ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('convect_deep_tend2') + + ! check tracer integrals + call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) + + call t_stopf('bc_aerosols') + + endif + + !=================================================== + ! Moist physical parameteriztions complete: + ! send dynamical variables, and derived variables to history file + !=================================================== + + call t_startf('bc_history_write') + call diag_phys_writeout(state, pbuf) + call diag_conv(state, ztodt, pbuf) + + call t_stopf('bc_history_write') + + !=================================================== + ! Write cloud diagnostics on history file + !=================================================== + + call t_startf('bc_cld_diag_history_write') + + call cloud_diagnostics_calc(state, pbuf) + + call t_stopf('bc_cld_diag_history_write') + + !=================================================== + ! Radiation computations + !=================================================== + call t_startf('radiation') + + + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) + + ! Set net flux used by spectral dycores + do i=1,ncol + tend%flx_net(i) = net_flx(i) + end do + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) + + call t_stopf('radiation') + + ! Diagnose the location of the tropopause and its location to the history file(s). + call t_startf('tropopause') + call tropopause_output(state) + call t_stopf('tropopause') + + ! Save atmospheric fields to force surface models + call t_startf('cam_export') + call cam_export (state,cam_out,pbuf) + call t_stopf('cam_export') + + ! Write export state to history file + call t_startf('diag_export') + call diag_export(cam_out) + call t_stopf('diag_export') + + end subroutine tphysbc + +subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) +!----------------------------------------------------------------------------------- +! +! Purpose: The place for parameterizations to call per timestep initializations. +! Generally this is used to update time interpolated fields from boundary +! datasets. +! +!----------------------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use chemistry, only: chem_timestep_init + use chem_surfvals, only: chem_surfvals_set + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc + use carma_intr, only: carma_timestep_init + use ghg_data, only: ghg_data_timestep_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_timestep_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_timestep_init + use aoa_tracers, only: aoa_tracers_timestep_init + use vertical_diffusion, only: vertical_diffusion_ts_init + use radheat, only: radheat_timestep_init + use solar_data, only: solar_data_advance + use qbo, only: qbo_timestep_init + use iondrag, only: do_waccm_ions, iondrag_timestep_init + use perf_mod + + use prescribed_ozone, only: prescribed_ozone_adv + use prescribed_ghg, only: prescribed_ghg_adv + use prescribed_aero, only: prescribed_aero_adv + use aerodep_flx, only: aerodep_flx_adv + use aircraft_emit, only: aircraft_emit_adv + use prescribed_volcaero, only: prescribed_volcaero_adv + use prescribed_strataero,only: prescribed_strataero_adv + use mo_apex, only: mo_apex_init + use epp_ionization, only: epp_ionization_active + use iop_forcing, only: scam_use_iop_srf + use nudging, only: Nudge_Model, nudging_timestep_init +#ifdef OSLO_AERO + use oslo_ocean_intr, only: oslo_ocean_time +#endif + + implicit none + + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------------- + + if (single_column) call scam_use_iop_srf(cam_in) + + ! update geomagnetic coordinates + if (epp_ionization_active .or. do_waccm_ions) then + call mo_apex_init(phys_state) + endif + + ! Chemistry surface values + call chem_surfvals_set() + + ! Solar irradiance + call solar_data_advance() + + ! Time interpolate for chemistry. + call chem_timestep_init(phys_state, pbuf2d) + + ! Prescribed tracers + call prescribed_ozone_adv(phys_state, pbuf2d) + call prescribed_ghg_adv(phys_state, pbuf2d) + call prescribed_aero_adv(phys_state, pbuf2d) + call aircraft_emit_adv(phys_state, pbuf2d) + call prescribed_volcaero_adv(phys_state, pbuf2d) + call prescribed_strataero_adv(phys_state, pbuf2d) +#ifdef OSLO_AERO + call oslo_ocean_time(phys_state, pbuf2d) +#endif + + ! prescribed aerosol deposition fluxes + call aerodep_flx_adv(phys_state, pbuf2d, cam_out) + + ! CAM3 prescribed aerosol masses + if (cam3_aero_data_on) call cam3_aero_data_timestep_init(pbuf2d, phys_state) + + ! CAM3 prescribed ozone data + if (cam3_ozone_data_on) call cam3_ozone_data_timestep_init(pbuf2d, phys_state) + + ! Time interpolate data models of gasses in pbuf2d + call ghg_data_timestep_init(pbuf2d, phys_state) + + ! Upper atmosphere radiative processes + call radheat_timestep_init(phys_state, pbuf2d) + + ! Time interpolate for vertical diffusion upper boundary condition + call vertical_diffusion_ts_init(pbuf2d, phys_state) + + !---------------------------------------------------------------------- + ! update QBO data for this time step + !---------------------------------------------------------------------- + call qbo_timestep_init + + call iondrag_timestep_init() + + call carma_timestep_init() + + ! age of air tracers + call aoa_tracers_timestep_init(phys_state) + + ! Update Nudging values, if needed + !---------------------------------- + if(Nudge_Model) call nudging_timestep_init(phys_state) + +end subroutine phys_timestep_init + +end module physpkg diff --git a/src/NorESM/zm_conv.F90 b/src/NorESM/zm_conv.F90 new file mode 100755 index 0000000000..7b52311a86 --- /dev/null +++ b/src/NorESM/zm_conv.F90 @@ -0,0 +1,5403 @@ +module zm_conv + +!--------------------------------------------------------------------------------- +! Purpose: +! +! Interface from Zhang-McFarlane convection scheme, includes evaporation of convective +! precip from the ZM scheme +! +! Apr 2006: RBN: Code added to perform a dilute ascent for closure of the CM mass flux +! based on an entraining plume a la Raymond and Blythe (1992) +! +! Author: Byron Boville, from code in tphysbc +! +!--------------------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use cloud_fraction, only: cldfrc_fice + use physconst, only: cpair, epsilo, gravit, latice, latvap, tmelt, rair, & + cpwv, cpliq, rh2o, cpvir, zvir + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use zm_microphysics, only: zm_mphy, zm_aero_t, zm_conv_t + + implicit none + + save + private ! Make default type private to the module +! +! PUBLIC: interfaces +! + public zm_convi ! ZM schemea + public zm_convr ! ZM schemea + public zm_conv_evap ! evaporation of precip from ZM schemea + public convtran ! convective transport + public momtran ! convective momentum transport + +! +! Private data +! + real(r8) rl ! wg latent heat of vaporization. + real(r8) cpres ! specific heat at constant pressure in j/kg-degk. + real(r8) :: ke ! Tunable evaporation efficiency set from namelist input zmconv_ke + real(r8) :: ke_lnd + real(r8) :: c0_lnd ! set from namelist input zmconv_c0_lnd + real(r8) :: c0_ocn ! set from namelist input zmconv_c0_ocn + integer :: num_cin ! set from namelist input zmconv_num_cin + ! The number of negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + logical :: zm_org + real(r8) tau ! convective time scale + real(r8),parameter :: c1 = 6.112_r8 + real(r8),parameter :: c2 = 17.67_r8 + real(r8),parameter :: c3 = 243.5_r8 + real(r8) :: tfreez + real(r8) :: eps1 + real(r8) :: momcu + real(r8) :: momcd + + logical :: zmconv_microp + + logical :: no_deep_pbl ! default = .false. + ! no_deep_pbl = .true. eliminates deep convection entirely within PBL + + +!moved from moistconvection.F90 + real(r8) :: rgrav ! reciprocal of grav + real(r8) :: rgas ! gas constant for dry air + real(r8) :: grav ! = gravit + real(r8) :: cp ! = cpres = cpair + + integer limcnv ! top interface level limit for convection + + logical, parameter:: second_call=.true. & !+tht iterate parcel-plume calculation... + ,retrigger =.true. & !+tht ...and also iterate trigger condition + ,use_cin =.true. & !+tht use CIN + ,tht_tweaks =.true. !+tht enthalpy mixing, dmpdz into buoyan_dilute, others + + real(r8),parameter :: & +! standard parameters: + capelmt = 70._r8 & ! threshold value for cape for deep convection. + ,capelmt_lnd= 70._r8 & ! ...and over land + ,tiedke_add = 0.5_r8 & !"Tiedke parameter" = launching buoyancy of plume ens. + ,tiedke_lnd = 1.0_r8 & ! ...and over land + ,cape_tau = 3.6e3_r8& !+tht CAPE closure time-scale [s] + ,entrmn = 2e-4_r8 & !+tht maximum convective entrainment rate + ,alfadet = 0.1_r8 & !+tht convective detrainment/entrainment ratio + ,tentrm = 1e-3_r8 & !+tht (initial) entrainment rate for test parcel + ,tentr_lnd = 1e-3_r8 & !+tht entrainment rate over land (ignored if tht_tweaks) + ,plclmin = 6.e2_r8 & !+tht don't convect if LCL above this level (pno cin; ignored if use_cin=F) + +!tht moist thermo, additional parameter (must be evaluated in runtime) + !real(r8), parameter :: dcol=(cpliq-cpwv)/latvap + real(r8) dcol +!-tht + +contains + + +subroutine zm_convi(limcnv_in, zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & + zmconv_microp_in, no_deep_pbl_in) + + integer, intent(in) :: limcnv_in ! top interface level limit for convection + integer, intent(in) :: zmconv_num_cin ! Number negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + real(r8),intent(in) :: zmconv_c0_lnd + real(r8),intent(in) :: zmconv_c0_ocn + real(r8),intent(in) :: zmconv_ke + real(r8),intent(in) :: zmconv_ke_lnd + real(r8),intent(in) :: zmconv_momcu + real(r8),intent(in) :: zmconv_momcd + logical :: zmconv_org + logical, intent(in) :: zmconv_microp_in + logical, intent(in), optional :: no_deep_pbl_in ! no_deep_pbl = .true. eliminates ZM convection entirely within PBL + + + ! Initialization of ZM constants + limcnv = limcnv_in + tfreez = tmelt + eps1 = epsilo + rl = latvap + cpres = cpair + rgrav = 1.0_r8/gravit + rgas = rair + grav = gravit + cp = cpres +!+tht moist thermo + dcol=(cpliq-cpwv)/latvap +!-tht + + c0_lnd = zmconv_c0_lnd + c0_ocn = zmconv_c0_ocn + num_cin = zmconv_num_cin + ke = zmconv_ke + ke_lnd = zmconv_ke_lnd + zm_org = zmconv_org + momcu = zmconv_momcu + momcd = zmconv_momcd + + zmconv_microp = zmconv_microp_in + + if ( present(no_deep_pbl_in) ) then + no_deep_pbl = no_deep_pbl_in + else + no_deep_pbl = .false. + endif + + tau = cape_tau + + if ( masterproc ) then + write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****' +!+tht give a honest and transparent list of ALL parameters + write(iulog,*) 'ZM formulation parameters:' + write(iulog,*) ' Don''t allow convection entirely within PBL : no_deep_pbl',no_deep_pbl + write(iulog,*) ' USE ORG tracer to reduce entrainment in CAPE : zmconv_org ',zm_org + write(iulog,*) ' (tht) Iterate CAPE calculation using diagnosed entrnm: second_call',second_call + write(iulog,*) ' (tht) Retrigger ZM convection usinf diagnosed entrnm : retrigger ',retrigger + write(iulog,*) ' (tht) Apply CIN threshold condition to allow convect.: use_cin ',use_cin + write(iulog,*) ' (tht) Conservatively mix plume enthalpy not entropy : tht_tweaks ',tht_tweaks + if (.not.tht_tweaks .and. (second_call.or.retrigger)) & + call endrun('**** ZM_CONVI : tht_tweaks must be T in order to use second_call or retrigger ****') + write(iulog,*) 'ZM tuning parameters:' + write(iulog,*) ' Maximum number of CINs in CAPE : num_cin', num_cin + !+tht check required here to ensure code integrity! + if (num_cin.gt.5) call endrun('**** ZM_CONVI : NUM_CIN must not exceeed 5 ****') + write(iulog,*) ' Conv. autoconversion rate on land: c0_lnd ',c0_lnd + write(iulog,*) ' Conv. autoconversion rate on ocn.: c0_ocn ',c0_ocn + if (zm_org) then + write(iulog,*) ' Evaporation efficiency over land : ke_lnd ',ke_lnd + write(iulog,*) ' Evaporation efficiency over ocn. : ke ',ke + else + write(iulog,*) ' Evaporation efficiency : ke ',ke + endif + write(iulog,*) 'ZM parameters "hard-wired" in the code:' + write(iulog,*) ' CAPE threshold parameter : capelmt ',capelmt + write(iulog,*) ' CAPE closure time-scale : cape_tau ',tau + write(iulog,*) ' Minimum pressure of LCL allowed : plclmin ',plclmin + write(iulog,*) ' Entrainment rate in initial test plume for CAPE: tentrm ',tentrm + if (zm_org .and. .not.tht_tweaks) & + write(iulog,*) ' Entrainment rate on land in CAPE test plume : tentr_lnd ',tentr_lnd + write(iulog,*) ' "Tiedke param."=launch buoyancy of plume ens. : tiedke_add ',tiedke_add + write(iulog,*) ' Maximum entrainment rate in convective ensemble: entrmn ',entrmn + write(iulog,*) ' Detrainment/entrainment ratio in convect. ens. : afladet ',alfadet + if (use_cin) & + write(iulog,*) ' (tht) Maximum allowed CIN as a fraction of CAPE : cin_threshd',cin_threshd + write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****' +!-tht + endif + +end subroutine zm_convi + + + +subroutine zm_convr(lchnk ,ncol , & + t ,qh ,prec ,jctop ,jcbot , & + pblh ,zm ,geos ,zi ,qtnd , & + heat ,pap ,paph ,dpp , & +! delt ,mcon ,cme ,cape , & + delt ,mcon ,cme ,cape ,eurt , & !+tht: eurt=entrainment rate + tpert ,dlf ,pflx ,zdu ,rprd , & + mu ,md ,du ,eu ,ed , & +! dp ,dsubcld ,jt ,maxg ,ideep , & + dp ,dsubcld ,jt ,maxg ,ideep , lengath , & + ql ,rliq ,landfrac, & + org ,orgt ,org2d , & + dif ,dnlf ,dnif ,conv , & + aero , rice) +!----------------------------------------------------------------------- +! +! Purpose: +! Main driver for zhang-mcfarlane convection scheme +! +! Method: +! performs deep convective adjustment based on mass-flux closure +! algorithm. +! +! Author:guang jun zhang, m.lazare, n.mcfarlane. CAM Contact: P. Rasch +! +! This is contributed code not fully standardized by the CAM core group. +! All variables have been typed, where most are identified in comments +! The current procedure will be reimplemented in a subsequent version +! of the CAM where it will include a more straightforward formulation +! and will make use of the standard CAM nomenclature +! +!----------------------------------------------------------------------- + use phys_control, only: cam_physpkg_is + +! +! ************************ index of variables ********************** +! +! wg * alpha array of vertical differencing used (=1. for upstream). +! w * cape convective available potential energy. +! wg * capeg gathered convective available potential energy. +! c * capelmt threshold value for cape for deep convection. +! ic * cpres specific heat at constant pressure in j/kg-degk. +! i * dpp +! ic * delt length of model time-step in seconds. +! wg * dp layer thickness in mbs (between upper/lower interface). +! wg * dqdt mixing ratio tendency at gathered points. +! wg * dsdt dry static energy ("temp") tendency at gathered points. +! wg * dudt u-wind tendency at gathered points. +! wg * dvdt v-wind tendency at gathered points. +! wg * dsubcld layer thickness in mbs between lcl and maxi. +! ic * grav acceleration due to gravity in m/sec2. +! wg * du detrainment in updraft. specified in mid-layer +! wg * ed entrainment in downdraft. +! wg * eu entrainment in updraft. +! wg * hmn moist static energy. +! wg * hsat saturated moist static energy. +! w * ideep holds position of gathered points vs longitude index. +! ic * pver number of model levels. +! wg * j0 detrainment initiation level index. +! wg * jd downdraft initiation level index. +! ic * jlatpr gaussian latitude index for printing grids (if needed). +! wg * jt top level index of deep cumulus convection. +! w * lcl base level index of deep cumulus convection. +! wg * lclg gathered values of lcl. +! w * lel index of highest theoretical convective plume. +! wg * lelg gathered values of lel. +! w * lon index of onset level for deep convection. +! w * maxi index of level with largest moist static energy. +! wg * maxg gathered values of maxi. +! wg * mb cloud base mass flux. +! wg * mc net upward (scaled by mb) cloud mass flux. +! wg * md downward cloud mass flux (positive up). +! wg * mu upward cloud mass flux (positive up). specified +! at interface +! ic * msg number of missing moisture levels at the top of model. +! w * p grid slice of ambient mid-layer pressure in mbs. +! i * pblt row of pbl top indices. +! w * pcpdh scaled surface pressure. +! w * pf grid slice of ambient interface pressure in mbs. +! wg * pg grid slice of gathered values of p. +! w * q grid slice of mixing ratio. +! wg * qd grid slice of mixing ratio in downdraft. +! wg * qg grid slice of gathered values of q. +! i/o * qh grid slice of specific humidity. +! w * qh0 grid slice of initial specific humidity. +! wg * qhat grid slice of upper interface mixing ratio. +! wg * ql grid slice of cloud liquid water. +! wg * qs grid slice of saturation mixing ratio. +! w * qstp grid slice of parcel temp. saturation mixing ratio. +! wg * qstpg grid slice of gathered values of qstp. +! wg * qu grid slice of mixing ratio in updraft. +! ic * rgas dry air gas constant. +! wg * rl latent heat of vaporization. +! w * s grid slice of scaled dry static energy (t+gz/cp). +! wg * sd grid slice of dry static energy in downdraft. +! wg * sg grid slice of gathered values of s. +! wg * shat grid slice of upper interface dry static energy. +! wg * su grid slice of dry static energy in updraft. +! i/o * t +! o * jctop row of top-of-deep-convection indices passed out. +! O * jcbot row of base of cloud indices passed out. +! wg * tg grid slice of gathered values of t. +! w * tl row of parcel temperature at lcl. +! wg * tlg grid slice of gathered values of tl. +! w * tp grid slice of parcel temperatures. +! wg * tpg grid slice of gathered values of tp. +! i/o * u grid slice of u-wind (real). +! wg * ug grid slice of gathered values of u. +! i/o * utg grid slice of u-wind tendency (real). +! i/o * v grid slice of v-wind (real). +! w * va work array re-used by called subroutines. +! wg * vg grid slice of gathered values of v. +! i/o * vtg grid slice of v-wind tendency (real). +! i * w grid slice of diagnosed large-scale vertical velocity. +! w * z grid slice of ambient mid-layer height in metres. +! w * zf grid slice of ambient interface height in metres. +! wg * zfg grid slice of gathered values of zf. +! wg * zg grid slice of gathered values of z. +! +!----------------------------------------------------------------------- +! +! multi-level i/o fields: +! i => input arrays. +! i/o => input/output arrays. +! w => work arrays. +! wg => work arrays operating only on gathered points. +! ic => input data constants. +! c => data constants pertaining to subroutine itself. +! +! input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: t(pcols,pver) ! grid slice of temperature at mid-layer. + real(r8), intent(in) :: qh(pcols,pver) ! grid slice of specific humidity. + real(r8), intent(in) :: pap(pcols,pver) + real(r8), intent(in) :: paph(pcols,pver+1) + real(r8), intent(in) :: dpp(pcols,pver) ! local sigma half-level thickness (i.e. dshj). + real(r8), intent(in) :: zm(pcols,pver) + real(r8), intent(in) :: geos(pcols) + real(r8), intent(in) :: zi(pcols,pver+1) + real(r8), intent(in) :: pblh(pcols) + real(r8), intent(in) :: tpert(pcols) + real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac + + type(zm_conv_t), intent(inout) :: conv + type(zm_aero_t), intent(inout) :: aero ! aerosol object. intent(inout) because the + ! gathered arrays are set here + ! before passing object + ! to microphysics +! output arguments +! + real(r8), intent(out) :: qtnd(pcols,pver) ! specific humidity tendency (kg/kg/s) + real(r8), intent(out) :: heat(pcols,pver) ! heating rate (dry static energy tendency, W/kg) + real(r8), intent(out) :: mcon(pcols,pverp) + real(r8), intent(out) :: dlf(pcols,pver) ! scattrd version of the detraining cld h2o tend + real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level + real(r8), intent(out) :: cme(pcols,pver) + real(r8), intent(out) :: cape(pcols) ! w convective available potential energy. + real(r8), intent(out) :: zdu(pcols,pver) + real(r8), intent(out) :: rprd(pcols,pver) ! rain production rate + real(r8), intent(out) :: dif(pcols,pver) ! detrained convective cloud ice mixing ratio. + real(r8), intent(out) :: dnlf(pcols,pver) ! detrained convective cloud water num concen. + real(r8), intent(out) :: dnif(pcols,pver) ! detrained convective cloud ice num concen. + +! move these vars from local storage to output so that convective +! transports can be done in outside of conv_cam. + real(r8), intent(out) :: mu(pcols,pver) + real(r8), intent(out) :: eu(pcols,pver) + real(r8), intent(out) :: eurt(pcols,pver) !+tht: entrainment rate (full z-dependence) + !real(r8), intent(out) :: eurt(pcols) !+tht: entrainment rate (avg or max) + real(r8), intent(out) :: du(pcols,pver) + real(r8), intent(out) :: md(pcols,pver) + real(r8), intent(out) :: ed(pcols,pver) + real(r8), intent(out) :: dp(pcols,pver) ! wg layer thickness in mbs (between upper/lower interface). + real(r8), intent(out) :: dsubcld(pcols) ! wg layer thickness in mbs between lcl and maxi. + real(r8), intent(out) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. + real(r8), intent(out) :: jcbot(pcols) ! o row of base of cloud indices passed out. + real(r8), intent(out) :: prec(pcols) + real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals + real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldce) for energy integrals + + integer, intent(out) :: ideep(pcols) ! column indices of gathered points + integer, intent(out) :: lengath + + real(r8) cin (pcols) !+tht CIN + + type(zm_conv_t) :: loc_conv + + real(r8), pointer :: org(:,:) ! Only used if zm_org is true + real(r8), pointer :: orgt(:,:) ! Only used if zm_org is true + real(r8), pointer :: org2d(:,:) ! Only used if zm_org is true + + real(r8) zs(pcols) + real(r8) dlg(pcols,pver) ! gathrd version of the detraining cld h2o tend + real(r8) pflxg(pcols,pverp) ! gather precip flux at each level + real(r8) cug(pcols,pver) ! gathered condensation rate + + real(r8) evpg(pcols,pver) ! gathered evap rate of rain in downdraft + real(r8) orgavg(pcols) + real(r8) dptot(pcols) + real(r8) mumax(pcols) + integer jt(pcols) ! wg top level index of deep cumulus convection. + integer maxg(pcols) ! wg gathered values of maxi. +! integer lengath +! diagnostic field used by chem/wetdep codes + real(r8) ql(pcols,pver) ! wg grid slice of cloud liquid water. +! + real(r8) pblt(pcols) ! i row of pbl top indices. + + + + +! +!----------------------------------------------------------------------- +! +! general work fields (local variables): +! + real(r8) q(pcols,pver) ! w grid slice of mixing ratio. + real(r8) p(pcols,pver) ! w grid slice of ambient mid-layer pressure in mbs. + real(r8) z(pcols,pver) ! w grid slice of ambient mid-layer height in metres. + real(r8) s(pcols,pver) ! w grid slice of scaled dry static energy (t+gz/cp). + real(r8) tp(pcols,pver) ! w grid slice of parcel temperatures. + real(r8) zf(pcols,pver+1) ! w grid slice of ambient interface height in metres. + real(r8) pf(pcols,pver+1) ! w grid slice of ambient interface pressure in mbs. + real(r8) qstp(pcols,pver) ! w grid slice of parcel temp. saturation mixing ratio. + + real(r8) tl(pcols) ! w row of parcel temperature at lcl. + + integer lcl(pcols) ! w base level index of deep cumulus convection. + integer lel(pcols) ! w index of highest theoretical convective plume. + integer lon(pcols) ! w index of onset level for deep convection. + integer maxi(pcols) ! w index of level with largest moist static energy. + + real(r8) precip +! +! gathered work fields: +! + real(r8) qg(pcols,pver) ! wg grid slice of gathered values of q. + real(r8) tg(pcols,pver) ! w grid slice of temperature at interface. + real(r8) pg(pcols,pver) ! wg grid slice of gathered values of p. + real(r8) zg(pcols,pver) ! wg grid slice of gathered values of z. + real(r8) sg(pcols,pver) ! wg grid slice of gathered values of s. + real(r8) tpg(pcols,pver) ! wg grid slice of gathered values of tp. + real(r8) zfg(pcols,pver+1) ! wg grid slice of gathered values of zf. + real(r8) qstpg(pcols,pver) ! wg grid slice of gathered values of qstp. + real(r8) ug(pcols,pver) ! wg grid slice of gathered values of u. + real(r8) vg(pcols,pver) ! wg grid slice of gathered values of v. + real(r8) cmeg(pcols,pver) + + real(r8) rprdg(pcols,pver) ! wg gathered rain production rate + real(r8) capeg(pcols) ! wg gathered convective available potential energy. + real(r8) tlg(pcols) ! wg grid slice of gathered values of tl. + real(r8) landfracg(pcols) ! wg grid slice of landfrac + + integer lclg(pcols) ! wg gathered values of lcl. + integer lelg(pcols) + + integer indxd(pcols) !+tht work array +! +! work fields arising from gathered calculations. +! + real(r8) dqdt(pcols,pver) ! wg mixing ratio tendency at gathered points. + real(r8) dsdt(pcols,pver) ! wg dry static energy ("temp") tendency at gathered points. +! real(r8) alpha(pcols,pver) ! array of vertical differencing used (=1. for upstream). + real(r8) sd(pcols,pver) ! wg grid slice of dry static energy in downdraft. + real(r8) qd(pcols,pver) ! wg grid slice of mixing ratio in downdraft. + real(r8) mc(pcols,pver) ! wg net upward (scaled by mb) cloud mass flux. + real(r8) qhat(pcols,pver) ! wg grid slice of upper interface mixing ratio. + real(r8) qu(pcols,pver) ! wg grid slice of mixing ratio in updraft. + real(r8) su(pcols,pver) ! wg grid slice of dry static energy in updraft. + real(r8) qs(pcols,pver) ! wg grid slice of saturation mixing ratio. + real(r8) shat(pcols,pver) ! wg grid slice of upper interface dry static energy. + real(r8) hmn(pcols,pver) ! wg moist static energy. + real(r8) hsat(pcols,pver) ! wg saturated moist static energy. + real(r8) qlg(pcols,pver) + real(r8) dudt(pcols,pver) ! wg u-wind tendency at gathered points. + real(r8) dvdt(pcols,pver) ! wg v-wind tendency at gathered points. +! real(r8) ud(pcols,pver) +! real(r8) vd(pcols,pver) + + !real(r8) dmpdz(pcols) !+tht Parcel fractional mass entrainment rate (/m) + real(r8) dmpdz(pcols,pver) !+tht Parcel fractional mass entrainment rate (/m) + + real(r8) qldeg(pcols,pver) ! cloud liquid water mixing ratio for detrainment (kg/kg) + real(r8) mb(pcols) ! wg cloud base mass flux. + + integer jlcl(pcols) + integer j0(pcols) ! wg detrainment initiation level index. + integer jd(pcols) ! wg downdraft initiation level index. + + real(r8) delt ! length of model time-step in seconds. + + integer i + integer ii + integer k, kk, l, m + + integer msg ! ic number of missing moisture levels at the top of model. + real(r8) qdifr + real(r8) sdifr + + real(r8) hk, dmmx(pcols), dmsm(pcols), orgc(pcols) !+tht for diagnostic entrainment + + real(r8), parameter :: dcon = 25.e-6_r8 + real(r8), parameter :: mucon = 5.3_r8 + real(r8) negadq + logical doliq + + +! +!--------------------------Data statements------------------------------ + + dmpdz=-tentrm !+tht initialise value for entrainment rate + +! +! Set internal variable "msg" (convection limit) to "limcnv-1" +! + msg = limcnv - 1 +! +! initialize necessary arrays. +! zero out variables not used in cam +! + + if (zm_org) then + orgt(:,:) = 0._r8 + end if + + qtnd(:,:) = 0._r8 + heat(:,:) = 0._r8 + mcon(:,:) = 0._r8 + rliq(:ncol) = 0._r8 + rice(:ncol) = 0._r8 + + if (zmconv_microp) then + allocate( & + loc_conv%frz(pcols,pver), & + loc_conv%sprd(pcols,pver), & + loc_conv%wu(pcols,pver), & + loc_conv%qi(pcols,pver), & + loc_conv%qliq(pcols,pver), & + loc_conv%qice(pcols,pver), & + loc_conv%qrain(pcols,pver), & + loc_conv%qsnow(pcols,pver), & + loc_conv%di(pcols,pver), & + loc_conv%dnl(pcols,pver), & + loc_conv%dni(pcols,pver), & + loc_conv%qnl(pcols,pver), & + loc_conv%qni(pcols,pver), & + loc_conv%qnr(pcols,pver), & + loc_conv%qns(pcols,pver), & + loc_conv%qide(pcols,pver), & + loc_conv%qncde(pcols,pver), & + loc_conv%qnide(pcols,pver), & + loc_conv%autolm(pcols,pver), & + loc_conv%accrlm(pcols,pver), & + loc_conv%bergnm(pcols,pver), & + loc_conv%fhtimm(pcols,pver), & + loc_conv%fhtctm(pcols,pver), & + loc_conv%fhmlm(pcols,pver), & + loc_conv%hmpim(pcols,pver), & + loc_conv%accslm(pcols,pver), & + loc_conv%dlfm(pcols,pver), & + loc_conv%cmel(pcols,pver), & + loc_conv%autoln(pcols,pver), & + loc_conv%accrln(pcols,pver), & + loc_conv%bergnn(pcols,pver), & + loc_conv%fhtimn(pcols,pver), & + loc_conv%fhtctn(pcols,pver), & + loc_conv%fhmln(pcols,pver), & + loc_conv%accsln(pcols,pver), & + loc_conv%activn(pcols,pver), & + loc_conv%dlfn(pcols,pver), & + loc_conv%autoim(pcols,pver), & + loc_conv%accsim(pcols,pver), & + loc_conv%difm(pcols,pver), & + loc_conv%cmei(pcols,pver), & + loc_conv%nuclin(pcols,pver), & + loc_conv%autoin(pcols,pver), & + loc_conv%accsin(pcols,pver), & + loc_conv%hmpin(pcols,pver), & + loc_conv%difn(pcols,pver), & + loc_conv%trspcm(pcols,pver), & + loc_conv%trspcn(pcols,pver), & + loc_conv%trspim(pcols,pver), & + loc_conv%trspin(pcols,pver), & + loc_conv%lambdadpcu(pcols,pver), & + loc_conv%mudpcu(pcols,pver), & + loc_conv%dcape(pcols) ) + end if + +! +! initialize convective tendencies +! + prec(:ncol) = 0._r8 + !eurt(:ncol) = 0._r8 !+tht (avg or max) + do k = 1,pver + do i = 1,ncol + dqdt(i,k) = 0._r8 + dsdt(i,k) = 0._r8 + dudt(i,k) = 0._r8 + dvdt(i,k) = 0._r8 + pflx(i,k) = 0._r8 + pflxg(i,k) = 0._r8 + cme(i,k) = 0._r8 + rprd(i,k) = 0._r8 + zdu(i,k) = 0._r8 + ql(i,k) = 0._r8 + qlg(i,k) = 0._r8 + dlf(i,k) = 0._r8 + dlg(i,k) = 0._r8 + qldeg(i,k) = 0._r8 + eurt(i,k) = 0._r8 !+tht entr.rate (full) + + dif(i,k) = 0._r8 + dnlf(i,k) = 0._r8 + dnif(i,k) = 0._r8 + + end do + end do + + if (zmconv_microp) then + do k = 1,pver + do i = 1,ncol + loc_conv%qliq(i,k) = 0._r8 + loc_conv%qice(i,k) = 0._r8 + loc_conv%di(i,k) = 0._r8 + loc_conv%qrain(i,k)= 0._r8 + loc_conv%qsnow(i,k)= 0._r8 + loc_conv%dnl(i,k) = 0._r8 + loc_conv%dni(i,k) = 0._r8 + loc_conv%wu(i,k) = 0._r8 + loc_conv%qnl(i,k) = 0._r8 + loc_conv%qni(i,k) = 0._r8 + loc_conv%qnr(i,k) = 0._r8 + loc_conv%qns(i,k) = 0._r8 + loc_conv%frz(i,k) = 0._r8 + loc_conv%sprd(i,k) = 0._r8 + loc_conv%qide(i,k) = 0._r8 + loc_conv%qncde(i,k) = 0._r8 + loc_conv%qnide(i,k) = 0._r8 + + loc_conv%autolm(i,k) = 0._r8 + loc_conv%accrlm(i,k) = 0._r8 + loc_conv%bergnm(i,k) = 0._r8 + loc_conv%fhtimm(i,k) = 0._r8 + loc_conv%fhtctm(i,k) = 0._r8 + loc_conv%fhmlm (i,k) = 0._r8 + loc_conv%hmpim (i,k) = 0._r8 + loc_conv%accslm(i,k) = 0._r8 + loc_conv%dlfm (i,k) = 0._r8 + + loc_conv%autoln(i,k) = 0._r8 + loc_conv%accrln(i,k) = 0._r8 + loc_conv%bergnn(i,k) = 0._r8 + loc_conv%fhtimn(i,k) = 0._r8 + loc_conv%fhtctn(i,k) = 0._r8 + loc_conv%fhmln (i,k) = 0._r8 + loc_conv%accsln(i,k) = 0._r8 + loc_conv%activn(i,k) = 0._r8 + loc_conv%dlfn (i,k) = 0._r8 + loc_conv%cmel (i,k) = 0._r8 + + loc_conv%autoim(i,k) = 0._r8 + loc_conv%accsim(i,k) = 0._r8 + loc_conv%difm (i,k) = 0._r8 + loc_conv%cmei (i,k) = 0._r8 + + loc_conv%nuclin(i,k) = 0._r8 + loc_conv%autoin(i,k) = 0._r8 + loc_conv%accsin(i,k) = 0._r8 + loc_conv%hmpin (i,k) = 0._r8 + loc_conv%difn (i,k) = 0._r8 + + loc_conv%trspcm(i,k) = 0._r8 + loc_conv%trspcn(i,k) = 0._r8 + loc_conv%trspim(i,k) = 0._r8 + loc_conv%trspin(i,k) = 0._r8 + + conv%qi(i,k) = 0._r8 + conv%frz(i,k) = 0._r8 + conv%sprd(i,k) = 0._r8 + conv%qi(i,k) = 0._r8 + conv%qliq(i,k) = 0._r8 + conv%qice(i,k) = 0._r8 + conv%qnl(i,k) = 0._r8 + conv%qni(i,k) = 0._r8 + conv%qnr(i,k) = 0._r8 + conv%qns(i,k) = 0._r8 + conv%qrain(i,k) = 0._r8 + conv%qsnow(i,k) = 0._r8 + conv%wu(i,k) = 0._r8 + + conv%autolm(i,k) = 0._r8 + conv%accrlm(i,k) = 0._r8 + conv%bergnm(i,k) = 0._r8 + conv%fhtimm(i,k) = 0._r8 + conv%fhtctm(i,k) = 0._r8 + conv%fhmlm (i,k) = 0._r8 + conv%hmpim (i,k) = 0._r8 + conv%accslm(i,k) = 0._r8 + conv%dlfm (i,k) = 0._r8 + + conv%autoln(i,k) = 0._r8 + conv%accrln(i,k) = 0._r8 + conv%bergnn(i,k) = 0._r8 + conv%fhtimn(i,k) = 0._r8 + conv%fhtctn(i,k) = 0._r8 + conv%fhmln (i,k) = 0._r8 + conv%accsln(i,k) = 0._r8 + conv%activn(i,k) = 0._r8 + conv%dlfn (i,k) = 0._r8 + conv%cmel (i,k) = 0._r8 + + conv%autoim(i,k) = 0._r8 + conv%accsim(i,k) = 0._r8 + conv%difm (i,k) = 0._r8 + conv%cmei (i,k) = 0._r8 + + conv%nuclin(i,k) = 0._r8 + conv%autoin(i,k) = 0._r8 + conv%accsin(i,k) = 0._r8 + conv%hmpin (i,k) = 0._r8 + conv%difn (i,k) = 0._r8 + + conv%trspcm(i,k) = 0._r8 + conv%trspcn(i,k) = 0._r8 + conv%trspim(i,k) = 0._r8 + conv%trspin(i,k) = 0._r8 + + end do + end do + + conv%lambdadpcu = (mucon + 1._r8)/dcon + conv%mudpcu = mucon + loc_conv%lambdadpcu = conv%lambdadpcu + loc_conv%mudpcu = conv%mudpcu + + end if + + do i = 1,ncol + pflx(i,pverp) = 0 + pflxg(i,pverp) = 0 + end do +! + do i = 1,ncol + pblt(i) = pver + dsubcld(i) = 0._r8 + + + jctop(i) = pver + jcbot(i) = 1 + + end do + + if (zmconv_microp) then + do i = 1,ncol + conv%dcape(i) = 0._r8 + loc_conv%dcape(i) = 0._r8 + end do + end if + + if (zm_org) then +! compute vertical average here + orgavg(:) = 0._r8 + dptot(:) = 0._r8 + + do k = 1, pver + do i = 1,ncol + if (org(i,k) .gt. 0) then + orgavg(i) = orgavg(i)+dpp(i,k)*org(i,k) + dptot(i) = dptot(i)+dpp(i,k) + endif + enddo + enddo + + do i = 1,ncol + if (dptot(i) .gt. 0) then + orgavg(i) = orgavg(i)/dptot(i) + endif + enddo + + do k = 1, pver + do i = 1, ncol + org2d(i,k) = orgavg(i) + enddo + enddo + + endif + +! +! calculate local pressure (mbs) and height (m) for both interface +! and mid-layer locations. +! + do i = 1,ncol + zs(i) = geos(i)*rgrav + pf(i,pver+1) = paph(i,pver+1)*0.01_r8 + zf(i,pver+1) = zi(i,pver+1) + zs(i) + end do + do k = 1,pver + do i = 1,ncol + p(i,k) = pap(i,k)*0.01_r8 + pf(i,k) = paph(i,k)*0.01_r8 + z(i,k) = zm(i,k) + zs(i) + zf(i,k) = zi(i,k) + zs(i) + end do + end do +! + do k = pver - 1,msg + 1,-1 + do i = 1,ncol + if (abs(z(i,k)-zs(i)-pblh(i)) < (zf(i,k)-zf(i,k+1))*0.5_r8) pblt(i) = k + end do + end do +! +! store incoming specific humidity field for subsequent calculation +! of precipitation (through change in storage). +! define dry static energy (normalized by cp). +! + do k = 1,pver + do i = 1,ncol + q(i,k) = qh(i,k) +!+tht moist thermo + !s(i,k) = t(i,k) + (grav/cpres)*z(i,k) + s(i,k) = t(i,k) + (grav/((1._r8+zvir*q(i,k))*cpres))*z(i,k) +!-tht + tp(i,k)=0.0_r8 + shat(i,k) = s(i,k) + qhat(i,k) = q(i,k) + end do + end do + + do i = 1,ncol + capeg(i) = 0._r8 + lclg(i) = 1 + lelg(i) = pver + maxg(i) = 1 + tlg(i) = 400._r8 + dsubcld(i) = 0._r8 + end do + + if( cam_physpkg_is('cam3')) then + + ! For cam3 physics package, call non-dilute + + call buoyan(lchnk ,ncol , & + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,rl ,cape , & + pblt ,lcl ,lel ,lon ,maxi , & + rgas ,grav ,cpres ,msg , & + tpert ) + else + + ! Evaluate Tparcel, qs(Tparcel), buoyancy and CAPE, + ! lcl, lel, parcel launch level at index maxi()=hmax + + call buoyan_dilute(lchnk ,ncol , & + q ,t ,p ,z ,pf , & +! tp ,qstp ,tl ,rl ,cape , & + tp ,qstp ,tl ,rl ,cape , cin , & !+tht CIN + pblt ,lcl ,lel ,lon ,maxi , & + rgas ,grav ,cpres ,msg , & +! tpert , org2d , landfrac) + !tpert , org2d , landfrac , dmpdz) !+tht DMPDZ + tpert , org , landfrac , dmpdz) !+tht DMPDZ 3D + end if + +! +! determine whether grid points will undergo some deep convection +! (ideep=1) or not (ideep=0), based on values of cape,lcl,lel +! (require cape.gt. 0 and lel capelmt) then + if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: don't convect if CIN comparable to CAPE + lengath = lengath + 1 + ideep(lengath) = i + indxd(lengath) = i !+tht sub-index + endif + end if + end do + + if (lengath.eq.0) return + +! do ii=1,lengath +! i=indxd(ii) +! ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN +! end do +! +! obtain gathered arrays necessary for ensuing calculations. +! + do k = 1,pver + do i = 1,lengath + dp(i,k) = 0.01_r8*dpp(ideep(i),k) + qg(i,k) = q(ideep(i),k) + tg(i,k) = t(ideep(i),k) + pg(i,k) = p(ideep(i),k) + zg(i,k) = z(ideep(i),k) + sg(i,k) = s(ideep(i),k) + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + ug(i,k) = 0._r8 + vg(i,k) = 0._r8 + end do + end do + + if (zmconv_microp) then + + if (aero%scheme == 'modal') then + + do m = 1, aero%nmodes + + do k = 1,pver + do i = 1,lengath + aero%numg_a(i,k,m) = aero%num_a(m)%val(ideep(i),k) + aero%dgnumg(i,k,m) = aero%dgnum(m)%val(ideep(i),k) + end do + end do + + do l = 1, aero%nspec(m) + do k = 1,pver + do i = 1,lengath + aero%mmrg_a(i,k,l,m) = aero%mmr_a(l,m)%val(ideep(i),k) + end do + end do + end do + + end do + + else if (aero%scheme == 'bulk') then + + do m = 1, aero%nbulk + do k = 1,pver + do i = 1,lengath + aero%mmrg_bulk(i,k,m) = aero%mmr_bulk(m)%val(ideep(i),k) + end do + end do + end do + + end if + + end if + +! + do i = 1,lengath + zfg(i,pver+1) = zf(ideep(i),pver+1) + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + landfracg(i) = landfrac(ideep(i)) + end do +! +! calculate sub-cloud layer pressure "thickness" for use in +! closure and tendency routines. +! + do k = msg + 1,pver + do i = 1,lengath + if (k >= maxg(i)) then + dsubcld(i) = dsubcld(i) + dp(i,k) + end if + end do + end do +! +! define array of factors (alpha) which defines interfacial +! values, as well as interfacial values for (q,s) used in +! subsequent routines. +! + do k = msg + 2,pver + do i = 1,lengath +! alpha(i,k) = 0.5 + sdifr = 0._r8 + qdifr = 0._r8 + if (sg(i,k) > 0._r8 .or. sg(i,k-1) > 0._r8) & + sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) + if (qg(i,k) > 0._r8 .or. qg(i,k-1) > 0._r8) & + qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) + if (sdifr > 1.E-6_r8) then + shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) + else + shat(i,k) = 0.5_r8* (sg(i,k)+sg(i,k-1)) + end if + if (qdifr > 1.E-6_r8) then + qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) + else + qhat(i,k) = 0.5_r8* (qg(i,k)+qg(i,k-1)) + end if + end do + end do +! +! obtain cloud properties. +! + + call cldprp(lchnk , & + qg ,tg ,ug ,vg ,pg , & + zg ,sg ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zfg ,qs ,hmn , & + hsat ,shat ,qlg , & + cmeg ,maxg ,lelg ,jt ,jlcl , & + maxg ,j0 ,jd ,rl ,lengath , & + rgas ,grav ,cpres ,msg , & + pflxg ,evpg ,cug ,rprdg ,limcnv ,landfracg , & + qldeg ,aero ,loc_conv,qhat ) + +!=================================================================================== +!!++tht second call to buoyan_dilute for new CAPE using entrainment rate from CLDPRP + if (second_call) then + do i = 1,lengath + hk=0._r8 + + !dmpdz(ideep(i)) = 1._r8 ! large value 2D + dmpdz(ideep(i),:) = 1._r8 ! large value 3D + +!+tht 17.04.16 use org as parameter to mix max and avg EU(k) + dmmx(i)=0._r8 + dmsm(i)=0._r8 ! 2D + !orgc(i)=min(max(org2d(ideep(i),1),0._r8),1._r8) ! use vertical-avg org + orgc(i)=1._r8 ! don't use ORG 10/5/2016 + do k = pver,msg+1,-1 + !orgc(i)=min(max(org(ideep (i),k),0._r8),1._r8) ! use full 3D org + if (eu(i,k).gt.0_r8) then + dmmx(i) = -max(-dmmx(i),eu(i,k)) + !dmsm(i) = dmsm(i)-eu(i,k)*tg(i,k)*dp(i,k)/pg(i,k) ! 2D + !hk=hk+tg(i,k)*dp(i,k)/pg(i,k) ! 2D + dmsm(i) = dmsm(i)-eu(i,k) ! 2D + hk=hk+1._r8 ! 2D + !dmpdz(ideep(i),k) = -eu(i,k) *orgc(i) + dmmx(i) *(1._r8-orgc(i)) ! 3D + endif + enddo + if (hk.gt.0) then + dmsm(i) = dmsm(i)/hk ! 2D + dmpdz(ideep(i),:) = dmsm(i) *orgc(i) + dmmx(i) *(1._r8-orgc(i)) ! 2D + !dmpdz(ideep(i) ) = dmsm(i) *orgc(i) + dmmx(i) *(1._r8-orgc(i)) ! 2D + endif +!-tht 17.04.16 + enddo + + call buoyan_dilute(lchnk ,ncol , & + q ,t ,p ,z ,pf , & +! tp ,qstp ,tl ,rl ,cape , & + tp ,qstp ,tl ,rl ,cape , cin , & + pblt ,lcl ,lel ,lon ,maxi , & + rgas ,grav ,cpres ,msg , & +! tpert , org2d , landfrac ) !+tht + !tpert , org2d , landfrac , dmpdz) !+tht DMPDZ, ORG 2D + tpert , org , landfrac , dmpdz) !+tht DMPDZ, ORG 3D + + !------------------------------------------------------------------------------- + !+tht: retrigger? + if (retrigger) then + lengath = 0 + ideep(:)= 0 + indxd(:)= 0 + do i=1,ncol + if (cape(i) > capelmt) then + if (.not.use_cin .or. cin(i).lt.cape(i)*cin_threshd) then !+tht: don't convect if CIN comparable to CAPE + lengath = lengath + 1 + indxd(lengath) = i !+tht sub-index + endif + end if + end do + if (lengath.eq.0) return + do ii=1,lengath + i=indxd(ii) + ideep(ii)=i !+tht keeping ideep and indxd distinguished for possible different use of CIN + end do + !---- + ! shorten all gathered arrays to new triggered subset + do k = 1,pver + do i = 1,lengath + dp(i,k) = 0.01_r8*dpp(ideep(i),k) + qg(i,k) = q(ideep(i),k) + tg(i,k) = t(ideep(i),k) + pg(i,k) = p(ideep(i),k) + zg(i,k) = z(ideep(i),k) + sg(i,k) = s(ideep(i),k) + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + ug(i,k) = 0._r8 + vg(i,k) = 0._r8 + end do + end do + if (zmconv_microp) then + if (aero%scheme == 'modal') then + do m = 1, aero%nmodes + do k = 1,pver + do i = 1,lengath + aero%numg_a(i,k,m) = aero%num_a(m)%val(ideep(i),k) + aero%dgnumg(i,k,m) = aero%dgnum(m)%val(ideep(i),k) + end do + end do + do l = 1, aero%nspec(m) + do k = 1,pver + do i = 1,lengath + aero%mmrg_a(i,k,l,m) = aero%mmr_a(l,m)%val(ideep(i),k) + end do + end do + end do + end do + else if (aero%scheme == 'bulk') then + do m = 1, aero%nbulk + do k = 1,pver + do i = 1,lengath + aero%mmrg_bulk(i,k,m) = aero%mmr_bulk(m)%val(ideep(i),k) + end do + end do + end do + end if + end if + do i = 1,lengath + zfg(i,pver+1) = zf(ideep(i),pver+1) + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + landfracg(i) = landfrac(ideep(i)) + dsubcld(i) = 0._r8 + end do + do k = msg + 1,pver + do i = 1,lengath + if (k >= maxg(i)) then + dsubcld(i) = dsubcld(i) + dp(i,k) + end if + end do + end do + do k = msg + 2,pver + do i = 1,lengath +! alpha(i,k) = 0.5 + sdifr = 0._r8 + qdifr = 0._r8 + if (sg(i,k) > 0._r8 .or. sg(i,k-1) > 0._r8) & + sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k))) + if (qg(i,k) > 0._r8 .or. qg(i,k-1) > 0._r8) & + qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k))) + if (sdifr > 1.E-6_r8) then + shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k)) + else + shat(i,k) = 0.5_r8* (sg(i,k)+sg(i,k-1)) + end if + if (qdifr > 1.E-6_r8) then + qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k)) + else + qhat(i,k) = 0.5_r8* (qg(i,k)+qg(i,k-1)) + end if + end do + end do + ! tesbus dereggirt wen ot syarra derethag lla netrosh + !---- + else ! end retrigger=T + do k = 1,pver + do i = 1,lengath + tpg(i,k) = tp(ideep(i),k) + zfg(i,k) = zf(ideep(i),k) + qstpg(i,k) = qstp(ideep(i),k) + end do + end do + do i = 1,lengath + capeg(i) = cape(ideep(i)) + lclg(i) = lcl(ideep(i)) + lelg(i) = lel(ideep(i)) + maxg(i) = maxi(ideep(i)) + tlg(i) = tl(ideep(i)) + end do + endif ! end retrigger=F + !------------------------------------------------------------------------------- + + call cldprp(lchnk , & + qg ,tg ,ug ,vg ,pg , & + zg ,sg ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zfg ,qs ,hmn , & + hsat ,shat ,qlg , & + cmeg ,maxg ,lelg ,jt ,jlcl , & + maxg ,j0 ,jd ,rl ,lengath , & + rgas ,grav ,cpres ,msg , & + pflxg ,evpg ,cug ,rprdg ,limcnv ,landfracg , & + qldeg ,aero ,loc_conv,qhat ) + !else ! end second_call=T + endif ! end second_call=F + + !do i = 1,lengath + !eurt (ideep(i)) =-dmpdz(ideep(i)) !+tht entr.rate 2D + !enddo + do k = msg + 1,pver + do i = 1,lengath + eurt (ideep(i),k)=-dmpdz(ideep(i),k) !+tht entr.rate 3D + enddo + enddo + +!!--tht +!=================================================================================== + + if (zmconv_microp) then + do i = 1,lengath + capeg(i) = capeg(i)+ loc_conv%dcape(i) + end do + end if + +! +! convert detrainment from units of "1/m" to "1/mb". +! + + do k = msg + 1,pver + do i = 1,lengath + du (i,k) = du (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + eu (i,k) = eu (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + ed (i,k) = ed (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + cug (i,k) = cug (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + cmeg (i,k) = cmeg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + rprdg(i,k) = rprdg(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + evpg (i,k) = evpg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + end do + end do + + if (zmconv_microp) then + do k = msg + 1,pver + do i = 1,lengath + loc_conv%sprd(i,k) = loc_conv%sprd(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + loc_conv%frz (i,k) = loc_conv%frz (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k) + end do + end do + end if + + call closure(lchnk , & + qg ,tg ,pg ,zg ,sg , & + tpg ,qs ,qu ,su ,mc , & + du ,mu ,md ,qd ,sd , & + qhat ,shat ,dp ,qstpg ,zfg , & + qlg ,dsubcld ,mb ,capeg ,tlg , & + lclg ,lelg ,jt ,maxg ,1 , & + lengath ,rgas ,grav ,cpres ,rl , & + msg ,capelmt ) +! +! limit cloud base mass flux to theoretical upper bound. +! + do i=1,lengath + mumax(i) = 0 + end do + do k=msg + 2,pver + do i=1,lengath + mumax(i) = max(mumax(i), mu(i,k)/dp(i,k)) + end do + end do + + do i=1,lengath + if (mumax(i) > 0._r8) then + mb(i) = min(mb(i),0.5_r8/(delt*mumax(i))) + else + mb(i) = 0._r8 + endif + end do + ! If no_deep_pbl = .true., don't allow convection entirely + ! within PBL (suggestion of Bjorn Stevens, 8-2000) + + if (no_deep_pbl) then + do i=1,lengath + if (zm(ideep(i),jt(i)) < pblh(ideep(i))) mb(i) = 0 + end do + end if + + if (zmconv_microp) then + do k=msg+1,pver + do i=1,lengath + loc_conv%sprd(i,k) = loc_conv%sprd(i,k)*mb(i) + loc_conv%frz (i,k) = loc_conv%frz (i,k)*mb(i) + end do + end do + end if + + do k=msg+1,pver + do i=1,lengath + mu (i,k) = mu (i,k)*mb(i) + md (i,k) = md (i,k)*mb(i) + mc (i,k) = mc (i,k)*mb(i) + du (i,k) = du (i,k)*mb(i) + eu (i,k) = eu (i,k)*mb(i) + ed (i,k) = ed (i,k)*mb(i) + cmeg (i,k) = cmeg (i,k)*mb(i) + rprdg(i,k) = rprdg(i,k)*mb(i) + cug (i,k) = cug (i,k)*mb(i) + evpg (i,k) = evpg (i,k)*mb(i) + pflxg(i,k+1)= pflxg(i,k+1)*mb(i)*100._r8/grav + + + if ( zmconv_microp .and. mb(i).eq.0._r8) then + qlg (i,k) = 0._r8 + loc_conv%qliq (i,k) = 0._r8 + loc_conv%qice (i,k) = 0._r8 + loc_conv%qrain(i,k) = 0._r8 + loc_conv%qsnow(i,k) = 0._r8 + loc_conv%wu(i,k) = 0._r8 + loc_conv%qnl (i,k) = 0._r8 + loc_conv%qni (i,k) = 0._r8 + loc_conv%qnr (i,k) = 0._r8 + loc_conv%qns (i,k) = 0._r8 + + loc_conv%autolm(i,k) = 0._r8 + loc_conv%accrlm(i,k) = 0._r8 + loc_conv%bergnm(i,k) = 0._r8 + loc_conv%fhtimm(i,k) = 0._r8 + loc_conv%fhtctm(i,k) = 0._r8 + loc_conv%fhmlm (i,k) = 0._r8 + loc_conv%hmpim (i,k) = 0._r8 + loc_conv%accslm(i,k) = 0._r8 + loc_conv%dlfm (i,k) = 0._r8 + + loc_conv%autoln(i,k) = 0._r8 + loc_conv%accrln(i,k) = 0._r8 + loc_conv%bergnn(i,k) = 0._r8 + loc_conv%fhtimn(i,k) = 0._r8 + loc_conv%fhtctn(i,k) = 0._r8 + loc_conv%fhmln (i,k) = 0._r8 + loc_conv%accsln(i,k) = 0._r8 + loc_conv%activn(i,k) = 0._r8 + loc_conv%dlfn (i,k) = 0._r8 + loc_conv%cmel (i,k) = 0._r8 + + loc_conv%autoim(i,k) = 0._r8 + loc_conv%accsim(i,k) = 0._r8 + loc_conv%difm (i,k) = 0._r8 + loc_conv%cmei (i,k) = 0._r8 + + loc_conv%nuclin(i,k) = 0._r8 + loc_conv%autoin(i,k) = 0._r8 + loc_conv%accsin(i,k) = 0._r8 + loc_conv%hmpin (i,k) = 0._r8 + loc_conv%difn (i,k) = 0._r8 + + loc_conv%trspcm(i,k) = 0._r8 + loc_conv%trspcn(i,k) = 0._r8 + loc_conv%trspim(i,k) = 0._r8 + loc_conv%trspin(i,k) = 0._r8 + end if + end do + end do +! +! compute temperature and moisture changes due to convection. +! + call q1q2_pjr(lchnk , & + dqdt ,dsdt ,qg ,qs ,qu , & + su ,du ,qhat ,shat ,dp , & + mu ,md ,sd ,qd ,qldeg , & + dsubcld ,jt ,maxg ,1 ,lengath , & + cpres ,rl ,msg , & + dlg ,evpg ,cug , & + loc_conv ) +! +! gather back temperature and mixing ratio. +! + + if (zmconv_microp) then + do k = msg + 1,pver + do i = 1,lengath + if (dqdt(i,k)*2._r8*delt+qg(i,k)<0._r8) then + negadq = (dqdt(i,k)+0.5_r8*qg(i,k)/delt)/0.9999_r8 + dqdt(i,k) = dqdt(i,k)-negadq + + do kk=k,jt(i),-1 + if (negadq<0._r8) then + if (rprdg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then + dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres + if (rprdg(i,kk)>loc_conv%sprd(i,kk)) then + if(rprdg(i,kk)-loc_conv%sprd(i,kk)<-negadq*dp(i,k)/dp(i,kk)) then + dsdt(i,k) = dsdt(i,k) + (negadq+ (rprdg(i,kk)-loc_conv%sprd(i,kk))*dp(i,kk)/dp(i,k))*latice/cpres + loc_conv%sprd(i,kk) = negadq*dp(i,k)/dp(i,kk)+rprdg(i,kk) + end if + else + loc_conv%sprd(i,kk) = loc_conv%sprd(i,kk)+negadq*dp(i,k)/dp(i,kk) + dsdt(i,k) = dsdt(i,k) + negadq*latice/cpres + end if + rprdg(i,kk) = rprdg(i,kk)+negadq*dp(i,k)/dp(i,kk) + negadq = 0._r8 + else + negadq = rprdg(i,kk)*dp(i,kk)/dp(i,k)+negadq + dsdt(i,k) = dsdt(i,k) - rprdg(i,kk)*rl/cpres*dp(i,kk)/dp(i,k) + if (rprdg(i,kk)>loc_conv%sprd(i,kk)) then + dsdt(i,k) = dsdt(i,k) - loc_conv%sprd(i,kk)*latice/cpres*dp(i,kk)/dp(i,k) + loc_conv%sprd(i,kk) = 0._r8 + else + dsdt(i,k) = dsdt(i,k) -rprdg(i,kk)*latice/cpres*dp(i,kk)/dp(i,k) + loc_conv%sprd(i,kk)= loc_conv%sprd(i,kk)- rprdg(i,kk) + end if + rprdg(i,kk) = 0._r8 + end if + + if (dlg(i,kk)>loc_conv%di(i,kk)) then + doliq= .true. + else + doliq= .false. + end if + + if (negadq<0._r8) then + if (doliq) then + if (dlg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then + dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres + loc_conv%dnl(i,kk) = loc_conv%dnl(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/dlg(i,kk)) + dlg(i,kk) = dlg(i,kk)+negadq*dp(i,k)/dp(i,kk) + negadq = 0._r8 + else + negadq = negadq + dlg(i,kk)*dp(i,kk)/dp(i,k) + dsdt(i,k) = dsdt(i,k) - dlg(i,kk)*dp(i,kk)/dp(i,k)*rl/cpres + dlg(i,kk) = 0._r8 + loc_conv%dnl(i,kk) = 0._r8 + end if + else + if (loc_conv%di(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then + dsdt(i,k) = dsdt(i,k) + negadq*(rl+latice)/cpres + loc_conv%dni(i,kk) = loc_conv%dni(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/loc_conv%di(i,kk)) + loc_conv%di(i,kk) = loc_conv%di(i,kk)+negadq*dp(i,k)/dp(i,kk) + negadq = 0._r8 + else + negadq = negadq + loc_conv%di(i,kk)*dp(i,kk)/dp(i,k) + dsdt(i,k) = dsdt(i,k) - loc_conv%di(i,kk)*dp(i,kk)/dp(i,k)*(rl+latice)/cpres + loc_conv%di(i,kk) = 0._r8 + loc_conv%dni(i,kk) = 0._r8 + end if + doliq= .false. + end if + end if + if (negadq<0._r8 .and. doliq ) then + if (dlg(i,kk)> -negadq*dp(i,k)/dp(i,kk)) then + dsdt(i,k) = dsdt(i,k) + negadq*rl/cpres + loc_conv%dnl(i,kk) = loc_conv%dnl(i,kk)*(1._r8+negadq*dp(i,k)/dp(i,kk)/dlg(i,kk)) + dlg(i,kk) = dlg(i,kk)+negadq*dp(i,k)/dp(i,kk) + negadq = 0._r8 + else + negadq = negadq + dlg(i,kk)*dp(i,kk)/dp(i,k) + dsdt(i,k) = dsdt(i,k) - dlg(i,kk)*dp(i,kk)/dp(i,k)*rl/cpres + dlg(i,kk) = 0._r8 + loc_conv%dnl(i,kk) = 0._r8 + end if + end if + + end if + end do + + if (negadq<0._r8) then + dqdt(i,k) = dqdt(i,k) + negadq + end if + + end if + end do + end do + end if + + do k = msg + 1,pver + do i = 1,lengath +! +! q is updated to compute net precip. +! + q(ideep(i),k) = qh(ideep(i),k) + 2._r8*delt*dqdt(i,k) + qtnd(ideep(i),k) = dqdt (i,k) + cme (ideep(i),k) = cmeg (i,k) + rprd(ideep(i),k) = rprdg(i,k) + zdu (ideep(i),k) = du (i,k) + mcon(ideep(i),k) = mc (i,k) + heat(ideep(i),k) = dsdt (i,k)*cpres + dlf (ideep(i),k) = dlg (i,k) + pflx(ideep(i),k) = pflxg(i,k) + ql (ideep(i),k) = qlg (i,k) + end do + end do + + if (zmconv_microp) then + do k = msg + 1,pver + do i = 1,lengath + dif (ideep(i),k) = loc_conv%di (i,k) + dnlf(ideep(i),k) = loc_conv%dnl (i,k) + dnif(ideep(i),k) = loc_conv%dni (i,k) + + conv%qi (ideep(i),k) = loc_conv%qice(i,k) + conv%frz(ideep(i),k) = loc_conv%frz(i,k)*latice/cpres + conv%sprd(ideep(i),k) = loc_conv%sprd(i,k) + conv%wu (ideep(i),k) = loc_conv%wu (i,k) + conv%qliq(ideep(i),k) = loc_conv%qliq (i,k) + conv%qice(ideep(i),k) = loc_conv%qice (i,k) + conv%qrain(ideep(i),k) = loc_conv%qrain (i,k) + conv%qsnow(ideep(i),k) = loc_conv%qsnow (i,k) + conv%qnl(ideep(i),k) = loc_conv%qnl(i,k) + conv%qni(ideep(i),k) = loc_conv%qni(i,k) + conv%qnr(ideep(i),k) = loc_conv%qnr(i,k) + conv%qns(ideep(i),k) = loc_conv%qns(i,k) + + conv%autolm(ideep(i),k) = loc_conv%autolm(i,k) + conv%accrlm(ideep(i),k) = loc_conv%accrlm(i,k) + conv%bergnm(ideep(i),k) = loc_conv%bergnm(i,k) + conv%fhtimm(ideep(i),k) = loc_conv%fhtimm(i,k) + conv%fhtctm(ideep(i),k) = loc_conv%fhtctm(i,k) + conv%fhmlm (ideep(i),k) = loc_conv%fhmlm (i,k) + conv%hmpim (ideep(i),k) = loc_conv%hmpim (i,k) + conv%accslm(ideep(i),k) = loc_conv%accslm(i,k) + conv%dlfm (ideep(i),k) = loc_conv%dlfm (i,k) + + conv%autoln(ideep(i),k) = loc_conv%autoln(i,k) + conv%accrln(ideep(i),k) = loc_conv%accrln(i,k) + conv%bergnn(ideep(i),k) = loc_conv%bergnn(i,k) + conv%fhtimn(ideep(i),k) = loc_conv%fhtimn(i,k) + conv%fhtctn(ideep(i),k) = loc_conv%fhtctn(i,k) + conv%fhmln (ideep(i),k) = loc_conv%fhmln (i,k) + conv%accsln(ideep(i),k) = loc_conv%accsln(i,k) + conv%activn(ideep(i),k) = loc_conv%activn(i,k) + conv%dlfn (ideep(i),k) = loc_conv%dlfn (i,k) + conv%cmel (ideep(i),k) = loc_conv%cmel (i,k) + + conv%autoim(ideep(i),k) = loc_conv%autoim(i,k) + conv%accsim(ideep(i),k) = loc_conv%accsim(i,k) + conv%difm (ideep(i),k) = loc_conv%difm (i,k) + conv%cmei (ideep(i),k) = loc_conv%cmei (i,k) + + conv%nuclin(ideep(i),k) = loc_conv%nuclin(i,k) + conv%autoin(ideep(i),k) = loc_conv%autoin(i,k) + conv%accsin(ideep(i),k) = loc_conv%accsin(i,k) + conv%hmpin (ideep(i),k) = loc_conv%hmpin (i,k) + conv%difn (ideep(i),k) = loc_conv%difn (i,k) + + conv%trspcm(ideep(i),k) = loc_conv%trspcm(i,k) + conv%trspcn(ideep(i),k) = loc_conv%trspcn(i,k) + conv%trspim(ideep(i),k) = loc_conv%trspim(i,k) + conv%trspin(ideep(i),k) = loc_conv%trspin(i,k) + conv%lambdadpcu(ideep(i),k) = loc_conv%lambdadpcu(i,k) + conv%mudpcu(ideep(i),k) = loc_conv%mudpcu(i,k) + + end do + end do + + do k = msg + 1,pver + do i = 1,ncol + + !convert it from units of "kg/kg" to "g/m3" + + if(k.lt.pver) then + conv%qice (i,k) = 0.5_r8*(conv%qice(i,k)+conv%qice(i,k+1)) + conv%qliq (i,k) = 0.5_r8*(conv%qliq(i,k)+conv%qliq(i,k+1)) + conv%qrain (i,k) = 0.5_r8*(conv%qrain(i,k)+conv%qrain(i,k+1)) + conv%qsnow (i,k) = 0.5_r8*(conv%qsnow(i,k)+conv%qsnow(i,k+1)) + conv%qni (i,k) = 0.5_r8*(conv%qni(i,k)+conv%qni(i,k+1)) + conv%qnl (i,k) = 0.5_r8*(conv%qnl(i,k)+conv%qnl(i,k+1)) + conv%qnr (i,k) = 0.5_r8*(conv%qnr(i,k)+conv%qnr(i,k+1)) + conv%qns (i,k) = 0.5_r8*(conv%qns(i,k)+conv%qns(i,k+1)) + conv%wu(i,k) = 0.5_r8*(conv%wu(i,k)+conv%wu(i,k+1)) + end if + + if (t(i,k).gt. 273.15_r8 .and. t(i,k-1).le.273.15_r8) then + conv%qice (i,k-1) = conv%qice (i,k-1) + conv%qice (i,k) + conv%qice (i,k) = 0._r8 + conv%qni (i,k-1) = conv%qni (i,k-1) + conv%qni (i,k) + conv%qni (i,k) = 0._r8 + conv%qsnow (i,k-1) = conv%qsnow (i,k-1) + conv%qsnow (i,k) + conv%qsnow (i,k) = 0._r8 + conv%qns (i,k-1) = conv%qns (i,k-1) + conv%qns (i,k) + conv%qns (i,k) = 0._r8 + end if + + conv%qice (i,k) = conv%qice(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 + conv%qliq (i,k) = conv%qliq(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 + conv%qrain (i,k) = conv%qrain(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 + conv%qsnow (i,k) = conv%qsnow(i,k) * pap(i,k)/t(i,k)/rgas *1000._r8 + conv%qni (i,k) = conv%qni(i,k) * pap(i,k)/t(i,k)/rgas + conv%qnl (i,k) = conv%qnl(i,k) * pap(i,k)/t(i,k)/rgas + conv%qnr (i,k) = conv%qnr(i,k) * pap(i,k)/t(i,k)/rgas + conv%qns (i,k) = conv%qns(i,k) * pap(i,k)/t(i,k)/rgas + end do + end do + end if + +! + do i = 1,lengath + jctop(ideep(i)) = jt(i) + jcbot(ideep(i)) = maxg(i) + pflx(ideep(i),pverp) = pflxg(i,pverp) + end do + + if (zmconv_microp) then + do i = 1,lengath + conv%dcape(ideep(i)) = loc_conv%dcape(i) + end do + end if + +! Compute precip by integrating change in water vapor minus detrained cloud water + do k = pver,msg + 1,-1 + do i = 1,ncol + prec(i) = prec(i) - dpp(i,k)* (q(i,k)-qh(i,k)) - dpp(i,k)*(dlf(i,k)+dif(i,k))*2._r8*delt + end do + end do + +! obtain final precipitation rate in m/s. + do i = 1,ncol + prec(i) = rgrav*max(prec(i),0._r8)/ (2._r8*delt)/1000._r8 + end do + +! Compute reserved liquid (not yet in cldliq) for energy integrals. +! Treat rliq as flux out bottom, to be added back later. + do k = 1, pver + do i = 1, ncol + rliq(i) = rliq(i) + (dlf(i,k)+dif(i,k))*dpp(i,k)/gravit + rice(i) = rice(i) + dif(i,k)*dpp(i,k)/gravit + end do + end do + rliq(:ncol) = rliq(:ncol) /1000._r8 + rice(:ncol) = rice(:ncol) /1000._r8 + + if (zmconv_microp) then + deallocate( & + loc_conv%frz, & + loc_conv%sprd, & + loc_conv%wu, & + loc_conv%qi, & + loc_conv%qliq, & + loc_conv%qice, & + loc_conv%qrain, & + loc_conv%qsnow, & + loc_conv%di, & + loc_conv%dnl, & + loc_conv%dni, & + loc_conv%qnl, & + loc_conv%qni, & + loc_conv%qnr, & + loc_conv%qns, & + loc_conv%qide, & + loc_conv%qncde, & + loc_conv%qnide, & + loc_conv%autolm, & + loc_conv%accrlm, & + loc_conv%bergnm, & + loc_conv%fhtimm, & + loc_conv%fhtctm, & + loc_conv%fhmlm, & + loc_conv%hmpim, & + loc_conv%accslm, & + loc_conv%dlfm, & + loc_conv%cmel, & + loc_conv%autoln, & + loc_conv%accrln, & + loc_conv%bergnn, & + loc_conv%fhtimn, & + loc_conv%fhtctn, & + loc_conv%fhmln, & + loc_conv%accsln, & + loc_conv%activn, & + loc_conv%dlfn, & + loc_conv%autoim, & + loc_conv%accsim, & + loc_conv%difm, & + loc_conv%cmei, & + loc_conv%nuclin, & + loc_conv%autoin, & + loc_conv%accsin, & + loc_conv%hmpin, & + loc_conv%difn, & + loc_conv%trspcm, & + loc_conv%trspcn, & + loc_conv%trspim, & + loc_conv%trspin, & + loc_conv%lambdadpcu, & + loc_conv%mudpcu, & + loc_conv%dcape ) + end if + + return +end subroutine zm_convr + +!=============================================================================== +subroutine zm_conv_evap(ncol,lchnk, & + t,pmid,pdel,q, & + landfrac, & + tend_s, tend_s_snwprd, tend_s_snwevmlt, tend_q, & + prdprec, cldfrc, deltat, & + prec, snow, ntprprd, ntsnprd, flxprec, flxsnow, prdsnow) + + +!----------------------------------------------------------------------- +! Compute tendencies due to evaporation of rain from ZM scheme +!-- +! Compute the total precipitation and snow fluxes at the surface. +! Add in the latent heat of fusion for snow formation and melt, since it not dealt with +! in the Zhang-MacFarlane parameterization. +! Evaporate some of the precip directly into the environment using a Sundqvist type algorithm +!----------------------------------------------------------------------- + + use wv_saturation, only: qsat + use phys_grid, only: get_rlat_all_p + +!------------------------------Arguments-------------------------------- + integer,intent(in) :: ncol, lchnk ! number of columns and chunk index + real(r8),intent(in), dimension(pcols,pver) :: t ! temperature (K) + real(r8),intent(in), dimension(pcols,pver) :: pmid ! midpoint pressure (Pa) + real(r8),intent(in), dimension(pcols,pver) :: pdel ! layer thickness (Pa) + real(r8),intent(in), dimension(pcols,pver) :: q ! water vapor (kg/kg) + real(r8),intent(in), dimension(pcols) :: landfrac + real(r8),intent(inout), dimension(pcols,pver) :: tend_s ! heating rate (J/kg/s) + real(r8),intent(inout), dimension(pcols,pver) :: tend_q ! water vapor tendency (kg/kg/s) + real(r8),intent(out ), dimension(pcols,pver) :: tend_s_snwprd ! Heating rate of snow production + real(r8),intent(out ), dimension(pcols,pver) :: tend_s_snwevmlt ! Heating rate of evap/melting of snow + + + + real(r8), intent(in ) :: prdprec(pcols,pver)! precipitation production (kg/ks/s) + real(r8), intent(in ) :: cldfrc(pcols,pver) ! cloud fraction + real(r8), intent(in ) :: deltat ! time step + + real(r8), intent(inout) :: prec(pcols) ! Convective-scale preciptn rate + real(r8), intent(out) :: snow(pcols) ! Convective-scale snowfall rate + + real(r8), optional, intent(in), allocatable :: prdsnow(:,:) ! snow production (kg/ks/s) + +! +!---------------------------Local storage------------------------------- + + real(r8) :: es (pcols,pver) ! Saturation vapor pressure + real(r8) :: fice (pcols,pver) ! ice fraction in precip production + real(r8) :: fsnow_conv(pcols,pver) ! snow fraction in precip production + real(r8) :: qs (pcols,pver) ! saturation specific humidity + real(r8),intent(out) :: flxprec(pcols,pverp) ! Convective-scale flux of precip at interfaces (kg/m2/s) + real(r8),intent(out) :: flxsnow(pcols,pverp) ! Convective-scale flux of snow at interfaces (kg/m2/s) + real(r8),intent(out) :: ntprprd(pcols,pver) ! net precip production in layer + real(r8),intent(out) :: ntsnprd(pcols,pver) ! net snow production in layer + real(r8) :: work1 ! temp variable (pjr) + real(r8) :: work2 ! temp variable (pjr) + + real(r8) :: evpvint(pcols) ! vertical integral of evaporation + real(r8) :: evpprec(pcols) ! evaporation of precipitation (kg/kg/s) + real(r8) :: evpsnow(pcols) ! evaporation of snowfall (kg/kg/s) + real(r8) :: snowmlt(pcols) ! snow melt tendency in layer + real(r8) :: flxsntm(pcols) ! flux of snow into layer, after melting + + real(r8) :: kemask + real(r8) :: evplimit ! temp variable for evaporation limits + real(r8) :: rlat(pcols) + real(r8) :: dum + real(r8) :: omsm + + integer :: i,k ! longitude,level indices + logical :: old_snow + + +!----------------------------------------------------------------------- + + ! If prdsnow is passed in and allocated, then use it in the calculation, otherwise + ! use the old snow calculation + old_snow=.true. + if (present(prdsnow)) then + if (allocated(prdsnow)) then + old_snow=.false. + end if + end if + +! convert input precip to kg/m2/s + prec(:ncol) = prec(:ncol)*1000._r8 + +! determine saturation vapor pressure + call qsat(t(1:ncol, 1:pver), pmid(1:ncol, 1:pver), & + es(1:ncol, 1:pver), qs(1:ncol, 1:pver)) + +! determine ice fraction in rain production (use cloud water parameterization fraction at present) + call cldfrc_fice(ncol, t, fice, fsnow_conv) + +! zero the flux integrals on the top boundary + flxprec(:ncol,1) = 0._r8 + flxsnow(:ncol,1) = 0._r8 + evpvint(:ncol) = 0._r8 + omsm=0.9999_r8 + + do k = 1, pver + do i = 1, ncol + +! Melt snow falling into layer, if necessary. + if( old_snow ) then + if (t(i,k) > tmelt) then + flxsntm(i) = 0._r8 + snowmlt(i) = flxsnow(i,k) * gravit/ pdel(i,k) + else + flxsntm(i) = flxsnow(i,k) + snowmlt(i) = 0._r8 + end if + else + ! make sure melting snow doesn't reduce temperature below threshold + if (t(i,k) > tmelt) then + dum = -latice/cpres*flxsnow(i,k)*gravit/pdel(i,k)*deltat + if (t(i,k) + dum .le. tmelt) then + dum = (t(i,k)-tmelt)*cpres/latice/deltat + dum = dum/(flxsnow(i,k)*gravit/pdel(i,k)) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + dum = dum*omsm + flxsntm(i) = flxsnow(i,k)*(1.0_r8-dum) + snowmlt(i) = dum*flxsnow(i,k)*gravit/ pdel(i,k) + else + flxsntm(i) = flxsnow(i,k) + snowmlt(i) = 0._r8 + end if + end if + +! relative humidity depression must be > 0 for evaporation +!+tht: Q is a mixing ration, QS a specific humidity. Change one of the two before taking ratio. + if (tht_tweaks) then + !+tht assume parametrisation for EVPPREC is correct with spec. hum. + evplimit = max(1._r8 - q(i,k)/(1._r8+q(i,k))/qs(i,k), 0._r8) !+tht + else + evplimit = max(1._r8 - q(i,k)/qs(i,k), 0._r8) ! orig + endif +!-tht + + if (zm_org) then + kemask = ke * (1._r8 - landfrac(i)) + ke_lnd * landfrac(i) + else + kemask = ke + endif + +! total evaporation depends on flux in the top of the layer +! flux prec is the net production above layer minus evaporation into environmet + evpprec(i) = kemask * (1._r8 - cldfrc(i,k)) * evplimit * sqrt(flxprec(i,k)) +!********************************************************** +!! evpprec(i) = 0. ! turn off evaporation for now +!********************************************************** + +! Don't let evaporation supersaturate layer (approx). Layer may already be saturated. +! Currently does not include heating/cooling change to qs + if (tht_tweaks) then + !+tht assume parametrisation for EVPPREC is correct with spec. hum. + !evplimit = max(0._r8, (qs(i,k)-q(i,k)/(1._r8+q(i,k))) / deltat) !+tht + else + evplimit = max(0._r8, (qs(i,k)-q(i,k)) / deltat) ! orig + endif +! Don't evaporate more than is falling into the layer - do not evaporate rain formed +! in this layer but if precip production is negative, remove from the available precip +! Negative precip production occurs because of evaporation in downdrafts. +!!$ evplimit = flxprec(i,k) * gravit / pdel(i,k) + min(prdprec(i,k), 0.) + evplimit = min(evplimit, flxprec(i,k) * gravit / pdel(i,k)) + +! Total evaporation cannot exceed input precipitation + evplimit = min(evplimit, (prec(i) - evpvint(i)) * gravit / pdel(i,k)) + + evpprec(i) = min(evplimit, evpprec(i)) + if( .not.old_snow ) then + evpprec(i) = max(0._r8, evpprec(i)) + evpprec(i) = evpprec(i)*omsm + end if + + +! evaporation of snow depends on snow fraction of total precipitation in the top after melting + if (flxprec(i,k) > 0._r8) then +! evpsnow(i) = evpprec(i) * flxsntm(i) / flxprec(i,k) +! prevent roundoff problems + work1 = min(max(0._r8,flxsntm(i)/flxprec(i,k)),1._r8) + evpsnow(i) = evpprec(i) * work1 + else + evpsnow(i) = 0._r8 + end if + +! vertically integrated evaporation + evpvint(i) = evpvint(i) + evpprec(i) * pdel(i,k)/gravit + +! net precip production is production - evaporation + ntprprd(i,k) = prdprec(i,k) - evpprec(i) +! net snow production is precip production * ice fraction - evaporation - melting +!pjrworks ntsnprd(i,k) = prdprec(i,k)*fice(i,k) - evpsnow(i) - snowmlt(i) +!pjrwrks2 ntsnprd(i,k) = prdprec(i,k)*fsnow_conv(i,k) - evpsnow(i) - snowmlt(i) +! the small amount added to flxprec in the work1 expression has been increased from +! 1e-36 to 8.64e-11 (1e-5 mm/day). This causes the temperature based partitioning +! scheme to be used for small flxprec amounts. This is to address error growth problems. + + if( old_snow ) then +#ifdef PERGRO + work1 = min(max(0._r8,flxsnow(i,k)/(flxprec(i,k)+8.64e-11_r8)),1._r8) +#else + if (flxprec(i,k).gt.0._r8) then + work1 = min(max(0._r8,flxsnow(i,k)/flxprec(i,k)),1._r8) + else + work1 = 0._r8 + endif +#endif + work2 = max(fsnow_conv(i,k), work1) + if (snowmlt(i).gt.0._r8) work2 = 0._r8 +! work2 = fsnow_conv(i,k) + ntsnprd(i,k) = prdprec(i,k)*work2 - evpsnow(i) - snowmlt(i) + tend_s_snwprd (i,k) = prdprec(i,k)*work2*latice + tend_s_snwevmlt(i,k) = - ( evpsnow(i) + snowmlt(i) )*latice + else + ntsnprd(i,k) = prdsnow(i,k) - min(flxsnow(i,k)*gravit/pdel(i,k), evpsnow(i)+snowmlt(i)) + tend_s_snwprd (i,k) = prdsnow(i,k)*latice + tend_s_snwevmlt(i,k) = -min(flxsnow(i,k)*gravit/pdel(i,k), evpsnow(i)+snowmlt(i) )*latice + end if + +! precipitation fluxes + flxprec(i,k+1) = flxprec(i,k) + ntprprd(i,k) * pdel(i,k)/gravit + flxsnow(i,k+1) = flxsnow(i,k) + ntsnprd(i,k) * pdel(i,k)/gravit + +! protect against rounding error + flxprec(i,k+1) = max(flxprec(i,k+1), 0._r8) + flxsnow(i,k+1) = max(flxsnow(i,k+1), 0._r8) +! more protection (pjr) +! flxsnow(i,k+1) = min(flxsnow(i,k+1), flxprec(i,k+1)) + +! heating (cooling) and moistening due to evaporation +! - latent heat of vaporization for precip production has already been accounted for +! - snow is contained in prec + if( old_snow ) then + tend_s(i,k) =-evpprec(i)*latvap + ntsnprd(i,k)*latice + else + tend_s(i,k) =-evpprec(i)*latvap + tend_s_snwevmlt(i,k) + end if + tend_q(i,k) = evpprec(i) + end do + end do + +! set output precipitation rates (m/s) + prec(:ncol) = flxprec(:ncol,pver+1) / 1000._r8 + snow(:ncol) = flxsnow(:ncol,pver+1) / 1000._r8 + +!********************************************************** +!!$ tend_s(:ncol,:) = 0. ! turn heating off +!********************************************************** + +end subroutine zm_conv_evap + + + +subroutine convtran(lchnk , & + doconvtran,q ,ncnst ,mu ,md , & + du ,eu ,ed ,dp ,dsubcld , & + jt ,mx ,ideep ,il1g ,il2g , & + nstep ,fracis ,dqdt ,dpdry ,dt) +!----------------------------------------------------------------------- +! +! Purpose: +! Convective transport of trace species +! +! Mixing ratios may be with respect to either dry or moist air +! +! Method: +! +! +! +! Author: P. Rasch +! +!----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: cnst_get_type_byind + use ppgrid + + implicit none +!----------------------------------------------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncnst ! number of tracers to transport + logical, intent(in) :: doconvtran(ncnst) ! flag for doing convective transport + real(r8), intent(in) :: q(pcols,pver,ncnst) ! Tracer array including moisture + real(r8), intent(in) :: mu(pcols,pver) ! Mass flux up + real(r8), intent(in) :: md(pcols,pver) ! Mass flux down + real(r8), intent(in) :: du(pcols,pver) ! Mass detraining from updraft + real(r8), intent(in) :: eu(pcols,pver) ! Mass entraining from updraft + real(r8), intent(in) :: ed(pcols,pver) ! Mass entraining from downdraft + real(r8), intent(in) :: dp(pcols,pver) ! Delta pressure between interfaces + real(r8), intent(in) :: dsubcld(pcols) ! Delta pressure from cloud base to sfc + real(r8), intent(in) :: fracis(pcols,pver,ncnst) ! fraction of tracer that is insoluble + + integer, intent(in) :: jt(pcols) ! Index of cloud top for each column + integer, intent(in) :: mx(pcols) ! Index of cloud top for each column + integer, intent(in) :: ideep(pcols) ! Gathering array + integer, intent(in) :: il1g ! Gathered min lon indices over which to operate + integer, intent(in) :: il2g ! Gathered max lon indices over which to operate + integer, intent(in) :: nstep ! Time step index + + real(r8), intent(in) :: dpdry(pcols,pver) ! Delta pressure between interfaces + + real(r8), intent(in) :: dt ! 2 delta t (model time increment) + +! input/output + + real(r8), intent(out) :: dqdt(pcols,pver,ncnst) ! Tracer tendency array + +!--------------------------Local Variables------------------------------ + + integer i ! Work index + integer k ! Work index + integer kbm ! Highest altitude index of cloud base + integer kk ! Work index + integer kkp1 ! Work index + integer km1 ! Work index + integer kp1 ! Work index + integer ktm ! Highest altitude index of cloud top + integer m ! Work index + + real(r8) cabv ! Mix ratio of constituent above + real(r8) cbel ! Mix ratio of constituent below + real(r8) cdifr ! Normalized diff between cabv and cbel + real(r8) chat(pcols,pver) ! Mix ratio in env at interfaces + real(r8) cond(pcols,pver) ! Mix ratio in downdraft at interfaces + real(r8) const(pcols,pver) ! Gathered tracer array + real(r8) fisg(pcols,pver) ! gathered insoluble fraction of tracer + real(r8) conu(pcols,pver) ! Mix ratio in updraft at interfaces + real(r8) dcondt(pcols,pver) ! Gathered tend array + real(r8) small ! A small number + real(r8) mbsth ! Threshold for mass fluxes + real(r8) mupdudp ! A work variable + real(r8) minc ! A work variable + real(r8) maxc ! A work variable + real(r8) fluxin ! A work variable + real(r8) fluxout ! A work variable + real(r8) netflux ! A work variable + + real(r8) dutmp(pcols,pver) ! Mass detraining from updraft + real(r8) eutmp(pcols,pver) ! Mass entraining from updraft + real(r8) edtmp(pcols,pver) ! Mass entraining from downdraft + real(r8) dptmp(pcols,pver) ! Delta pressure between interfaces + real(r8) total(pcols) + real(r8) negadt,qtmp + +!----------------------------------------------------------------------- +! + small = 1.e-36_r8 +! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s) + mbsth = 1.e-15_r8 + +! Find the highest level top and bottom levels of convection + ktm = pver + kbm = pver + do i = il1g, il2g + ktm = min(ktm,jt(i)) + kbm = min(kbm,mx(i)) + end do + +! Loop ever each constituent + do m = 2, ncnst + if (doconvtran(m)) then + + if (cnst_get_type_byind(m).eq.'dry') then + do k = 1,pver + do i =il1g,il2g + dptmp(i,k) = dpdry(i,k) + dutmp(i,k) = du(i,k)*dp(i,k)/dpdry(i,k) + eutmp(i,k) = eu(i,k)*dp(i,k)/dpdry(i,k) + edtmp(i,k) = ed(i,k)*dp(i,k)/dpdry(i,k) + end do + end do + else + do k = 1,pver + do i =il1g,il2g + dptmp(i,k) = dp(i,k) + dutmp(i,k) = du(i,k) + eutmp(i,k) = eu(i,k) + edtmp(i,k) = ed(i,k) + end do + end do + endif +! dptmp = dp + +! Gather up the constituent and set tend to zero + do k = 1,pver + do i =il1g,il2g + const(i,k) = q(ideep(i),k,m) + fisg(i,k) = fracis(ideep(i),k,m) + end do + end do + +! From now on work only with gathered data + +! Interpolate environment tracer values to interfaces + do k = 1,pver + km1 = max(1,k-1) + do i = il1g, il2g + minc = min(const(i,km1),const(i,k)) + maxc = max(const(i,km1),const(i,k)) + if (minc < 0) then + cdifr = 0._r8 + else + cdifr = abs(const(i,k)-const(i,km1))/max(maxc,small) + endif + +! If the two layers differ significantly use a geometric averaging +! procedure + if (cdifr > 1.E-6_r8) then + cabv = max(const(i,km1),maxc*1.e-12_r8) + cbel = max(const(i,k),maxc*1.e-12_r8) + chat(i,k) = log(cabv/cbel)/(cabv-cbel)*cabv*cbel + + else ! Small diff, so just arithmetic mean + chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1)) + end if + +! Provisional up and down draft values + conu(i,k) = chat(i,k) + cond(i,k) = chat(i,k) + +! provisional tends + dcondt(i,k) = 0._r8 + + end do + end do + +! Do levels adjacent to top and bottom + k = 2 + km1 = 1 + kk = pver + do i = il1g,il2g + mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk) + if (mupdudp > mbsth) then + conu(i,kk) = (+eutmp(i,kk)*fisg(i,kk)*const(i,kk)*dptmp(i,kk))/mupdudp + endif + if (md(i,k) < -mbsth) then + cond(i,k) = (-edtmp(i,km1)*fisg(i,km1)*const(i,km1)*dptmp(i,km1))/md(i,k) + endif + end do + +! Updraft from bottom to top + do kk = pver-1,1,-1 + kkp1 = min(pver,kk+1) + do i = il1g,il2g + mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk) + if (mupdudp > mbsth) then + conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eutmp(i,kk)*fisg(i,kk)* & + const(i,kk)*dptmp(i,kk) )/mupdudp + endif + end do + end do + +! Downdraft from top to bottom + do k = 3,pver + km1 = max(1,k-1) + do i = il1g,il2g + if (md(i,k) < -mbsth) then + cond(i,k) = ( md(i,km1)*cond(i,km1)-edtmp(i,km1)*fisg(i,km1)*const(i,km1) & + *dptmp(i,km1) )/md(i,k) + endif + end do + end do + + + do k = ktm,pver + km1 = max(1,k-1) + kp1 = min(pver,k+1) + do i = il1g,il2g + +! version 1 hard to check for roundoff errors +! dcondt(i,k) = +! $ +(+mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) +! $ -mu(i,k)* (conu(i,k)-chat(i,k)) +! $ +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) +! $ -md(i,k)* (cond(i,k)-chat(i,k)) +! $ )/dp(i,k) + +! version 2 hard to limit fluxes +! fluxin = mu(i,kp1)*conu(i,kp1) + mu(i,k)*chat(i,k) +! $ -(md(i,k) *cond(i,k) + md(i,kp1)*chat(i,kp1)) +! fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*chat(i,kp1) +! $ -(md(i,kp1)*cond(i,kp1) + md(i,k)*chat(i,k)) + +! version 3 limit fluxes outside convection to mass in appropriate layer +! these limiters are probably only safe for positive definite quantitities +! it assumes that mu and md already satify a courant number limit of 1 + fluxin = mu(i,kp1)*conu(i,kp1)+ mu(i,k)*min(chat(i,k),const(i,km1)) & + -(md(i,k) *cond(i,k) + md(i,kp1)*min(chat(i,kp1),const(i,kp1))) + fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*min(chat(i,kp1),const(i,k)) & + -(md(i,kp1)*cond(i,kp1) + md(i,k)*min(chat(i,k),const(i,k))) + + netflux = fluxin - fluxout + if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then + netflux = 0._r8 + endif + dcondt(i,k) = netflux/dptmp(i,k) + end do + end do +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! + do k = kbm,pver + km1 = max(1,k-1) + do i = il1g,il2g + if (k == mx(i)) then + +! version 1 +! dcondt(i,k) = (1./dsubcld(i))* +! $ (-mu(i,k)*(conu(i,k)-chat(i,k)) +! $ -md(i,k)*(cond(i,k)-chat(i,k)) +! $ ) + +! version 2 +! fluxin = mu(i,k)*chat(i,k) - md(i,k)*cond(i,k) +! fluxout = mu(i,k)*conu(i,k) - md(i,k)*chat(i,k) +! version 3 + fluxin = mu(i,k)*min(chat(i,k),const(i,km1)) - md(i,k)*cond(i,k) + fluxout = mu(i,k)*conu(i,k) - md(i,k)*min(chat(i,k),const(i,k)) + + netflux = fluxin - fluxout + if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then + netflux = 0._r8 + endif +! dcondt(i,k) = netflux/dsubcld(i) + dcondt(i,k) = netflux/dptmp(i,k) + else if (k > mx(i)) then +! dcondt(i,k) = dcondt(i,k-1) + dcondt(i,k) = 0._r8 + end if + end do + end do + + if (zmconv_microp) then + do i = il1g,il2g + do k = jt(i),mx(i) + if (dcondt(i,k)*dt+const(i,k)<0._r8) then + negadt = dcondt(i,k)+const(i,k)/dt + dcondt(i,k) = -const(i,k)/dt + do kk= k+1, mx(i) + if (negadt<0._r8 .and. dcondt(i,kk)*dt+const(i,kk)>0._r8 ) then + qtmp = dcondt(i,kk)+negadt*dptmp(i,k)/dptmp(i,kk) + if (qtmp*dt+const(i,kk)>0._r8) then + dcondt(i,kk)= qtmp + negadt=0._r8 + else + negadt= negadt+(const(i,kk)/dt+dcondt(i,kk))*dptmp(i,kk)/dptmp(i,k) + dcondt(i,kk)= -const(i,kk)/dt + end if + + end if + end do + do kk= k-1, jt(i), -1 + if (negadt<0._r8 .and. dcondt(i,kk)*dt+const(i,kk)>0._r8 ) then + qtmp = dcondt(i,kk)+negadt*dptmp(i,k)/dptmp(i,kk) + if (qtmp*dt+const(i,kk)>0._r8) then + dcondt(i,kk)= qtmp + negadt=0._r8 + else + negadt= negadt+(const(i,kk)/dt+dcondt(i,kk))*dptmp(i,kk)/dptmp(i,k) + dcondt(i,kk)= -const(i,kk)/dt + end if + end if + end do + + if (negadt<0._r8) then + dcondt(i,k) = dcondt(i,k) + negadt + end if + end if + end do + end do + end if + + +! Initialize to zero everywhere, then scatter tendency back to full array + dqdt(:,:,m) = 0._r8 + do k = 1,pver + kp1 = min(pver,k+1) + do i = il1g,il2g + dqdt(ideep(i),k,m) = dcondt(i,k) + end do + end do + + end if ! for doconvtran + + end do + + return +end subroutine convtran + +!========================================================================================= + +subroutine momtran(lchnk, ncol, & + domomtran,q ,ncnst ,mu ,md , & + du ,eu ,ed ,dp ,dsubcld , & + jt ,mx ,ideep ,il1g ,il2g , & + nstep ,dqdt ,pguall ,pgdall, icwu, icwd, dt, seten ) +!----------------------------------------------------------------------- +! +! Purpose: +! Convective transport of momentum +! +! Mixing ratios may be with respect to either dry or moist air +! +! Method: +! Based on the convtran subroutine by P. Rasch +! +! +! Author: J. Richter and P. Rasch +! +!----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: cnst_get_type_byind + use ppgrid + + implicit none +!----------------------------------------------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: ncnst ! number of tracers to transport + logical, intent(in) :: domomtran(ncnst) ! flag for doing convective transport + real(r8), intent(in) :: q(pcols,pver,ncnst) ! Wind array + real(r8), intent(in) :: mu(pcols,pver) ! Mass flux up + real(r8), intent(in) :: md(pcols,pver) ! Mass flux down + real(r8), intent(in) :: du(pcols,pver) ! Mass detraining from updraft + real(r8), intent(in) :: eu(pcols,pver) ! Mass entraining from updraft + real(r8), intent(in) :: ed(pcols,pver) ! Mass entraining from downdraft + real(r8), intent(in) :: dp(pcols,pver) ! Delta pressure between interfaces + real(r8), intent(in) :: dsubcld(pcols) ! Delta pressure from cloud base to sfc + real(r8), intent(in) :: dt ! time step in seconds : 2*delta_t + + integer, intent(in) :: jt(pcols) ! Index of cloud top for each column + integer, intent(in) :: mx(pcols) ! Index of cloud top for each column + integer, intent(in) :: ideep(pcols) ! Gathering array + integer, intent(in) :: il1g ! Gathered min lon indices over which to operate + integer, intent(in) :: il2g ! Gathered max lon indices over which to operate + integer, intent(in) :: nstep ! Time step index + + + +! input/output + + real(r8), intent(out) :: dqdt(pcols,pver,ncnst) ! Tracer tendency array + +!--------------------------Local Variables------------------------------ + + integer i ! Work index + integer k ! Work index + integer kbm ! Highest altitude index of cloud base + integer kk ! Work index + integer kkp1 ! Work index + integer kkm1 ! Work index + integer km1 ! Work index + integer kp1 ! Work index + integer ktm ! Highest altitude index of cloud top + integer m ! Work index + integer ii ! Work index + + real(r8) cabv ! Mix ratio of constituent above + real(r8) cbel ! Mix ratio of constituent below + real(r8) cdifr ! Normalized diff between cabv and cbel + real(r8) chat(pcols,pver) ! Mix ratio in env at interfaces + real(r8) cond(pcols,pver) ! Mix ratio in downdraft at interfaces + real(r8) const(pcols,pver) ! Gathered wind array + real(r8) conu(pcols,pver) ! Mix ratio in updraft at interfaces + real(r8) dcondt(pcols,pver) ! Gathered tend array + real(r8) mbsth ! Threshold for mass fluxes + real(r8) mupdudp ! A work variable + real(r8) minc ! A work variable + real(r8) maxc ! A work variable + real(r8) fluxin ! A work variable + real(r8) fluxout ! A work variable + real(r8) netflux ! A work variable + + real(r8) sum ! sum + real(r8) sum2 ! sum2 + + real(r8) mududp(pcols,pver) ! working variable + real(r8) mddudp(pcols,pver) ! working variable + + real(r8) pgu(pcols,pver) ! Pressure gradient term for updraft + real(r8) pgd(pcols,pver) ! Pressure gradient term for downdraft + + real(r8),intent(out) :: pguall(pcols,pver,ncnst) ! Apparent force from updraft PG + real(r8),intent(out) :: pgdall(pcols,pver,ncnst) ! Apparent force from downdraft PG + + real(r8),intent(out) :: icwu(pcols,pver,ncnst) ! In-cloud winds in updraft + real(r8),intent(out) :: icwd(pcols,pver,ncnst) ! In-cloud winds in downdraft + + real(r8),intent(out) :: seten(pcols,pver) ! Dry static energy tendency + real(r8) gseten(pcols,pver) ! Gathered dry static energy tendency + + real(r8) mflux(pcols,pverp,ncnst) ! Gathered momentum flux + + real(r8) wind0(pcols,pver,ncnst) ! gathered wind before time step + real(r8) windf(pcols,pver,ncnst) ! gathered wind after time step + real(r8) fkeb, fket, ketend_cons, ketend, utop, ubot, vtop, vbot, gset2 + + +!----------------------------------------------------------------------- +! + +! Initialize outgoing fields + pguall(:,:,:) = 0.0_r8 + pgdall(:,:,:) = 0.0_r8 +! Initialize in-cloud winds to environmental wind + icwu(:ncol,:,:) = q(:ncol,:,:) + icwd(:ncol,:,:) = q(:ncol,:,:) + +! Initialize momentum flux and final winds + mflux(:,:,:) = 0.0_r8 + wind0(:,:,:) = 0.0_r8 + windf(:,:,:) = 0.0_r8 + +! Initialize dry static energy + + seten(:,:) = 0.0_r8 + gseten(:,:) = 0.0_r8 + +! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s) + mbsth = 1.e-15_r8 + +! Find the highest level top and bottom levels of convection + ktm = pver + kbm = pver + do i = il1g, il2g + ktm = min(ktm,jt(i)) + kbm = min(kbm,mx(i)) + end do + +! Loop ever each wind component + do m = 1, ncnst !start at m = 1 to transport momentum + if (domomtran(m)) then + +! Gather up the winds and set tend to zero + do k = 1,pver + do i =il1g,il2g + const(i,k) = q(ideep(i),k,m) + wind0(i,k,m) = const(i,k) + end do + end do + + +! From now on work only with gathered data + +! Interpolate winds to interfaces + + do k = 1,pver + km1 = max(1,k-1) + do i = il1g, il2g + + ! use arithmetic mean + chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1)) + +! Provisional up and down draft values + conu(i,k) = chat(i,k) + cond(i,k) = chat(i,k) + +! provisional tends + dcondt(i,k) = 0._r8 + + end do + end do + + +! +! Pressure Perturbation Term +! + + !Top boundary: assume mu is zero + + k=1 + pgu(:il2g,k) = 0.0_r8 + pgd(:il2g,k) = 0.0_r8 + + do k=2,pver-1 + km1 = max(1,k-1) + kp1 = min(pver,k+1) + do i = il1g,il2g + + !interior points + + mududp(i,k) = ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) & + + mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k)) + + pgu(i,k) = - momcu * 0.5_r8 * mududp(i,k) + + + mddudp(i,k) = ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) & + + md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k)) + + pgd(i,k) = - momcd * 0.5_r8 * mddudp(i,k) + + + end do + end do + + ! bottom boundary + k = pver + km1 = max(1,k-1) + do i=il1g,il2g + + mududp(i,k) = mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) + pgu(i,k) = - momcu * mududp(i,k) + + mddudp(i,k) = md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) + + pgd(i,k) = - momcd * mddudp(i,k) + + end do + + +! +! In-cloud velocity calculations +! + +! Do levels adjacent to top and bottom + k = 2 + km1 = 1 + kk = pver + kkm1 = max(1,kk-1) + do i = il1g,il2g + mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk) + if (mupdudp > mbsth) then + + conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp + endif + if (md(i,k) < -mbsth) then + cond(i,k) = (-ed(i,km1)*const(i,km1)*dp(i,km1))-pgd(i,km1)*dp(i,km1)/md(i,k) + endif + + + end do + + + +! Updraft from bottom to top + do kk = pver-1,1,-1 + kkm1 = max(1,kk-1) + kkp1 = min(pver,kk+1) + do i = il1g,il2g + mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk) + if (mupdudp > mbsth) then + + conu(i,kk) = ( mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* & + const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp + endif + end do + + end do + + +! Downdraft from top to bottom + do k = 3,pver + km1 = max(1,k-1) + do i = il1g,il2g + if (md(i,k) < -mbsth) then + + cond(i,k) = ( md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) & + *dp(i,km1)-pgd(i,km1)*dp(i,km1) )/md(i,k) + + endif + end do + end do + + + sum = 0._r8 + sum2 = 0._r8 + + + do k = ktm,pver + km1 = max(1,k-1) + kp1 = min(pver,k+1) + do i = il1g,il2g + ii = ideep(i) + +! version 1 hard to check for roundoff errors + dcondt(i,k) = & + +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) & + -mu(i,k)* (conu(i,k)-chat(i,k)) & + +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) & + -md(i,k)* (cond(i,k)-chat(i,k)) & + )/dp(i,k) + + end do + end do + + ! dcont for bottom layer + ! + do k = kbm,pver + km1 = max(1,k-1) + do i = il1g,il2g + if (k == mx(i)) then + + ! version 1 + dcondt(i,k) = (1._r8/dp(i,k))* & + (-mu(i,k)*(conu(i,k)-chat(i,k)) & + -md(i,k)*(cond(i,k)-chat(i,k)) & + ) + end if + end do + end do + +! Initialize to zero everywhere, then scatter tendency back to full array + dqdt(:,:,m) = 0._r8 + + do k = 1,pver + do i = il1g,il2g + ii = ideep(i) + dqdt(ii,k,m) = dcondt(i,k) + ! Output apparent force on the mean flow from pressure gradient + pguall(ii,k,m) = -pgu(i,k) + pgdall(ii,k,m) = -pgd(i,k) + icwu(ii,k,m) = conu(i,k) + icwd(ii,k,m) = cond(i,k) + end do + end do + + ! Calculate momentum flux in units of mb*m/s2 + + do k = ktm,pver + do i = il1g,il2g + ii = ideep(i) + mflux(i,k,m) = & + -mu(i,k)* (conu(i,k)-chat(i,k)) & + -md(i,k)* (cond(i,k)-chat(i,k)) + end do + end do + + + ! Calculate winds at the end of the time step + + do k = ktm,pver + do i = il1g,il2g + ii = ideep(i) + km1 = max(1,k-1) + kp1 = k+1 + windf(i,k,m) = const(i,k) - (mflux(i,kp1,m) - mflux(i,k,m)) * dt /dp(i,k) + + end do + end do + + end if ! for domomtran + end do + + ! Need to add an energy fix to account for the dissipation of kinetic energy + ! Formulation follows from Boville and Bretherton (2003) + ! formulation by PJR + + do k = ktm,pver + km1 = max(1,k-1) + kp1 = min(pver,k+1) + do i = il1g,il2g + + ii = ideep(i) + + ! calculate the KE fluxes at top and bot of layer + ! based on a discrete approximation to b&b eq(35) F_KE = u*F_u + v*F_v at interface + utop = (wind0(i,k,1)+wind0(i,km1,1))/2._r8 + vtop = (wind0(i,k,2)+wind0(i,km1,2))/2._r8 + ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2._r8 + vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2._r8 + fket = utop*mflux(i,k,1) + vtop*mflux(i,k,2) ! top of layer + fkeb = ubot*mflux(i,k+1,1) + vbot*mflux(i,k+1,2) ! bot of layer + + ! divergence of these fluxes should give a conservative redistribution of KE + ketend_cons = (fket-fkeb)/dp(i,k) + + ! tendency in kinetic energy resulting from the momentum transport + ketend = ((windf(i,k,1)**2 + windf(i,k,2)**2) - (wind0(i,k,1)**2 + wind0(i,k,2)**2))*0.5_r8/dt + + ! the difference should be the dissipation + gset2 = ketend_cons - ketend + gseten(i,k) = gset2 + + end do + + end do + + ! Scatter dry static energy to full array + do k = 1,pver + do i = il1g,il2g + ii = ideep(i) + seten(ii,k) = gseten(i,k) + + end do + end do + + return +end subroutine momtran + +!========================================================================================= + +subroutine buoyan(lchnk ,ncol , & + q ,t ,p ,z ,pf , & + tp ,qstp ,tl ,rl ,cape , & + pblt ,lcl ,lel ,lon ,mx , & + rd ,grav ,cp ,msg , & + tpert ) +!----------------------------------------------------------------------- +! +! Purpose: +! +! +! Method: +! +! +! +! Author: +! This is contributed code not fully standardized by the CCM core group. +! The documentation has been enhanced to the degree that we are able. +! Reviewed: P. Rasch, April 1996 +! +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: q(pcols,pver) ! spec. humidity + real(r8), intent(in) :: t(pcols,pver) ! temperature + real(r8), intent(in) :: p(pcols,pver) ! pressure + real(r8), intent(in) :: z(pcols,pver) ! height + real(r8), intent(in) :: pf(pcols,pver+1) ! pressure at interfaces + real(r8), intent(in) :: pblt(pcols) ! index of pbl depth + real(r8), intent(in) :: tpert(pcols) ! perturbation temperature by pbl processes + +! +! output arguments +! + real(r8), intent(out) :: tp(pcols,pver) ! parcel temperature + real(r8), intent(out) :: qstp(pcols,pver) ! saturation mixing ratio of parcel + real(r8), intent(out) :: tl(pcols) ! parcel temperature at lcl + real(r8), intent(out) :: cape(pcols) ! convective aval. pot. energy. + integer lcl(pcols) ! + integer lel(pcols) ! + integer lon(pcols) ! level of onset of deep convection + integer mx(pcols) ! level of max moist static energy +! +!--------------------------Local Variables------------------------------ +! + real(r8) capeten(pcols,num_cin) ! provisional value of cape + real(r8) tv(pcols,pver) ! + real(r8) tpv(pcols,pver) ! + real(r8) buoy(pcols,pver) + + real(r8) a1(pcols) + real(r8) a2(pcols) + real(r8) estp(pcols) + real(r8) pl(pcols) + real(r8) plexp(pcols) + real(r8) hmax(pcols) + real(r8) hmn(pcols) + real(r8) y(pcols) + + logical plge600(pcols) + integer knt(pcols) + integer lelten(pcols,num_cin) + + real(r8) cp + real(r8) e + real(r8) grav + + integer i + integer k + integer msg + integer n + + real(r8) rd + real(r8) rl +#ifdef PERGRO + real(r8) rhd +#endif +! +!----------------------------------------------------------------------- +! + do n = 1,num_cin + do i = 1,ncol + lelten(i,n) = pver + capeten(i,n) = 0._r8 + end do + end do +! + do i = 1,ncol + lon(i) = pver + knt(i) = 0 + lel(i) = pver + mx(i) = lon(i) + cape(i) = 0._r8 + hmax(i) = 0._r8 + end do + + tp(:ncol,:) = t(:ncol,:) + qstp(:ncol,:) = q(:ncol,:) + +!!! RBN - Initialize tv and buoy for output. +!!! tv=tv : tpv=tpv : qstp=q : buoy=0. + tv(:ncol,:) = t(:ncol,:) *(1._r8+1.608_r8*q(:ncol,:))/ (1._r8+q(:ncol,:)) + tpv(:ncol,:) = tv(:ncol,:) + buoy(:ncol,:) = 0._r8 + +! +! set "launching" level(mx) to be at maximum moist static energy. +! search for this level stops at planetary boundary layer top. +! +#ifdef PERGRO + do k = pver,msg + 1,-1 + do i = 1,ncol + hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) +! +! Reset max moist static energy level when relative difference exceeds 1.e-4 +! + rhd = (hmn(i) - hmax(i))/(hmn(i) + hmax(i)) + if (k >= nint(pblt(i)) .and. k <= lon(i) .and. rhd > -1.e-4_r8) then + hmax(i) = hmn(i) + mx(i) = k + end if + end do + end do +#else + do k = pver,msg + 1,-1 + do i = 1,ncol + hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) + if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then + hmax(i) = hmn(i) + mx(i) = k + end if + end do + end do +#endif +! + do i = 1,ncol + lcl(i) = mx(i) + e = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) + tl(i) = 2840._r8/ (3.5_r8*log(t(i,mx(i)))-log(e)-4.805_r8) + 55._r8 + if (tl(i) < t(i,mx(i))) then + plexp(i) = (1._r8/ (0.2854_r8* (1._r8-0.28_r8*q(i,mx(i))))) + pl(i) = p(i,mx(i))* (tl(i)/t(i,mx(i)))**plexp(i) + else + tl(i) = t(i,mx(i)) + pl(i) = p(i,mx(i)) + end if + end do + +! +! calculate lifting condensation level (lcl). +! + do k = pver,msg + 2,-1 + do i = 1,ncol + if (k <= mx(i) .and. (p(i,k) > pl(i) .and. p(i,k-1) <= pl(i))) then + lcl(i) = k - 1 + end if + end do + end do +! +! if lcl is above the nominal level of non-divergence (600 mbs), +! no deep convection is permitted (ensuing calculations +! skipped and cape retains initialized value of zero). +! + do i = 1,ncol + plge600(i) = pl(i).ge.plclmin + end do +! +! initialize parcel properties in sub-cloud layer below lcl. +! + do k = pver,msg + 1,-1 + do i=1,ncol + if (k > lcl(i) .and. k <= mx(i) .and. plge600(i)) then + tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) + qstp(i,k) = q(i,mx(i)) + tp(i,k) = t(i,mx(i))* (p(i,k)/p(i,mx(i)))**(0.2854_r8* (1._r8-0.28_r8*q(i,mx(i)))) +! +! buoyancy is increased by 0.5 k as in tiedtke +! +!-jjh tpv (i,k)=tp(i,k)*(1.+1.608*q(i,mx(i)))/ +!-jjh 1 (1.+q(i,mx(i))) + tpv(i,k) = (tp(i,k)+tpert(i))*(1._r8+1.608_r8*q(i,mx(i)))/ (1._r8+q(i,mx(i))) + buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add + end if + end do + end do + +! +! define parcel properties at lcl (i.e. level immediately above pl). +! + do k = pver,msg + 1,-1 + do i=1,ncol + if (k == lcl(i) .and. plge600(i)) then + tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) + qstp(i,k) = q(i,mx(i)) + tp(i,k) = tl(i)* (p(i,k)/pl(i))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k))) +! estp(i) =exp(21.656_r8 - 5418._r8/tp(i,k)) +! use of different formulas for es has about 1 g/kg difference +! in qs at t= 300k, and 0.02 g/kg at t=263k, with the formula +! above giving larger qs. + call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) + a1(i) = cp / rl + qstp(i,k) * (1._r8+ qstp(i,k) / eps1) * rl * eps1 / & + (rd * tp(i,k) ** 2) + a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* & + (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ & + (rd**2*tp(i,k)**4)-qstp(i,k)* & + (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ & + (rd*tp(i,k)**3)) + a1(i) = 1._r8/a1(i) + a2(i) = -a2(i)*a1(i)**3 + y(i) = q(i,mx(i)) - qstp(i,k) + tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2 + call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) +! +! buoyancy is increased by 0.5 k in cape calculation. +! dec. 9, 1994 +!-jjh tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/(1.+q(i,mx(i))) +! + tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+q(i,mx(i))) + buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add + end if + end do + end do +! +! main buoyancy calculation. +! + do k = pver - 1,msg + 1,-1 + do i=1,ncol + if (k < lcl(i) .and. plge600(i)) then + tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) + qstp(i,k) = qstp(i,k+1) + tp(i,k) = tp(i,k+1)* (p(i,k)/p(i,k+1))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k))) + call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) + a1(i) = cp/rl + qstp(i,k)* (1._r8+qstp(i,k)/eps1)*rl*eps1/ (rd*tp(i,k)**2) + a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* & + (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ & + (rd**2*tp(i,k)**4)-qstp(i,k)* & + (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ & + (rd*tp(i,k)**3)) + a1(i) = 1._r8/a1(i) + a2(i) = -a2(i)*a1(i)**3 + y(i) = qstp(i,k+1) - qstp(i,k) + tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2 + call qsat_hPa(tp(i,k), p(i,k), estp(i), qstp(i,k)) +!-jjh tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/ +!jt (1.+q(i,mx(i))) + tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k))/(1._r8+q(i,mx(i))) + buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add + end if + end do + end do + +! + do k = msg + 2,pver + do i = 1,ncol + if (k < lcl(i) .and. plge600(i)) then + if (buoy(i,k+1) > 0._r8 .and. buoy(i,k) <= 0._r8) then + knt(i) = min(5,knt(i) + 1) + lelten(i,knt(i)) = k + end if + end if + end do + end do +! +! calculate convective available potential energy (cape). +! + do n = 1,5 + do k = msg + 1,pver + do i = 1,ncol + if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then + capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) + end if + end do + end do + end do +! +! find maximum cape from all possible tentative capes from +! one sounding, +! and use it as the final cape, april 26, 1995 +! + do n = 1,5 + do i = 1,ncol + if (capeten(i,n) > cape(i)) then + cape(i) = capeten(i,n) + lel(i) = lelten(i,n) + end if + end do + end do +! +! put lower bound on cape for diagnostic purposes. +! + do i = 1,ncol + cape(i) = max(cape(i), 0._r8) + end do +! + return +end subroutine buoyan + +subroutine cldprp(lchnk , & + q ,t ,u ,v ,p , & + z ,s ,mu ,eu ,du , & + md ,ed ,sd ,qd ,mc , & + qu ,su ,zf ,qst ,hmn , & + hsat ,shat ,ql , & + cmeg ,jb ,lel ,jt ,jlcl , & + mx ,j0 ,jd ,rl ,il2g , & + rd ,grav ,cp ,msg , & + pflx ,evp ,cu ,rprd ,limcnv ,landfrac, & + qcde ,aero ,loc_conv,qhat ) + +!----------------------------------------------------------------------- +! +! Purpose: +! +! +! Method: +! may 09/91 - guang jun zhang, m.lazare, n.mcfarlane. +! original version cldprop. +! +! Author: See above, modified by P. Rasch +! This is contributed code not fully standardized by the CCM core group. +! +! this code is very much rougher than virtually anything else in the CCM +! there are debug statements left strewn about and code segments disabled +! these are to facilitate future development. We expect to release a +! cleaner code in a future release +! +! the documentation has been enhanced to the degree that we are able +! +!----------------------------------------------------------------------- + + implicit none + +!------------------------------------------------------------------------------ +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + + real(r8), intent(in) :: q(pcols,pver) ! spec. humidity of env + real(r8), intent(in) :: t(pcols,pver) ! temp of env + real(r8), intent(in) :: p(pcols,pver) ! pressure of env + real(r8), intent(in) :: z(pcols,pver) ! height of env + real(r8), intent(in) :: s(pcols,pver) ! normalized dry static energy of env + real(r8), intent(in) :: zf(pcols,pverp) ! height of interfaces + real(r8), intent(in) :: u(pcols,pver) ! zonal velocity of env + real(r8), intent(in) :: v(pcols,pver) ! merid. velocity of env + + real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac + + integer, intent(in) :: jb(pcols) ! updraft base level + integer, intent(in) :: lel(pcols) ! updraft launch level + integer, intent(out) :: jt(pcols) ! updraft plume top + integer, intent(out) :: jlcl(pcols) ! updraft lifting cond level + integer, intent(in) :: mx(pcols) ! updraft base level (same is jb) + integer, intent(out) :: j0(pcols) ! level where updraft begins detraining + integer, intent(out) :: jd(pcols) ! level of downdraft + integer, intent(in) :: limcnv ! convection limiting level + integer, intent(in) :: il2g !CORE GROUP REMOVE + integer, intent(in) :: msg ! missing moisture vals (always 0) + real(r8), intent(in) :: rl ! latent heat of vap + real(r8), intent(in) :: shat(pcols,pver) ! interface values of dry stat energy + real(r8), intent(in) :: qhat(pcols,pver) ! wg grid slice of upper interface mixing ratio. + type(zm_aero_t), intent(in) :: aero ! aerosol object + +! +! output +! + real(r8), intent(out) :: rprd(pcols,pver) ! rate of production of precip at that layer + real(r8), intent(out) :: du(pcols,pver) ! detrainement rate of updraft + real(r8), intent(out) :: ed(pcols,pver) ! entrainment rate of downdraft + real(r8), intent(out) :: eu(pcols,pver) ! entrainment rate of updraft + real(r8), intent(out) :: hmn(pcols,pver) ! moist stat energy of env + real(r8), intent(out) :: hsat(pcols,pver) ! sat moist stat energy of env + real(r8), intent(out) :: mc(pcols,pver) ! net mass flux + real(r8), intent(out) :: md(pcols,pver) ! downdraft mass flux + real(r8), intent(out) :: mu(pcols,pver) ! updraft mass flux + real(r8), intent(out) :: pflx(pcols,pverp) ! precipitation flux thru layer + real(r8), intent(out) :: qd(pcols,pver) ! spec humidity of downdraft + real(r8), intent(out) :: ql(pcols,pver) ! liq water of updraft + real(r8), intent(out) :: qst(pcols,pver) ! saturation mixing ratio of env. + real(r8), intent(out) :: qu(pcols,pver) ! spec hum of updraft + real(r8), intent(out) :: sd(pcols,pver) ! normalized dry stat energy of downdraft + real(r8), intent(out) :: su(pcols,pver) ! normalized dry stat energy of updraft + real(r8), intent(out) :: qcde(pcols,pver) ! cloud water mixing ratio for detrainment (kg/kg) + + type(zm_conv_t) :: loc_conv + + real(r8) rd ! gas constant for dry air + real(r8) grav ! gravity + real(r8) cp ! heat capacity of dry air + +! +! Local workspace +! + real(r8) gamma(pcols,pver) + real(r8) dz(pcols,pver) + real(r8) iprm(pcols,pver) + real(r8) hu(pcols,pver) + real(r8) hd(pcols,pver) + real(r8) eps(pcols,pver) + real(r8) f(pcols,pver) + real(r8) k1(pcols,pver) + real(r8) i2(pcols,pver) + real(r8) ihat(pcols,pver) + real(r8) i3(pcols,pver) + real(r8) idag(pcols,pver) + real(r8) i4(pcols,pver) + real(r8) qsthat(pcols,pver) + real(r8) hsthat(pcols,pver) + real(r8) gamhat(pcols,pver) + real(r8) cu(pcols,pver) + real(r8) evp(pcols,pver) + real(r8) cmeg(pcols,pver) + real(r8) qds(pcols,pver) +! RBN For c0mask + real(r8) c0mask(pcols) +!tht For tiedke_msk + real(r8) tiedke_msk(pcols) + +!tht moist thermo vars + real(r8), dimension(pcols,pver) :: mcp,mrd,mrl,tu,td +!-tht + + real(r8) hmin(pcols) + real(r8) expdif(pcols) + real(r8) expnum(pcols) + real(r8) ftemp(pcols) + real(r8) eps0(pcols) + real(r8) rmue(pcols) + real(r8) zuef(pcols) + real(r8) zdef(pcols) + real(r8) epsm(pcols) + real(r8) ratmjb(pcols) + real(r8) est(pcols) + real(r8) totpcp(pcols) + real(r8) totevp(pcols) + real(r8) alfa(pcols) + real(r8) ql1 + !real(r8) tu + real(r8) estu + real(r8) qstu + + real(r8) small + real(r8) mdt + + real(r8) fice(pcols,pver) ! ice fraction in precip production + real(r8) tug(pcols,pver) + + real(r8) tvuo(pcols,pver) ! updraft virtual T w/o freezing heating + real(r8) tvu(pcols,pver) ! updraft virtual T with freezing heating + real(r8) totfrz(pcols) + real(r8) frz (pcols,pver) ! rate of freezing + integer jto(pcols) ! updraft plume old top + integer tmplel(pcols) + + integer iter, itnum + integer m + + integer khighest + integer klowest + integer kount + integer i,k + + logical doit(pcols) + logical done(pcols) +! +!------------------------------------------------------------------------------ +! + if (zmconv_microp) then + loc_conv%autolm(:il2g,:) = 0._r8 + loc_conv%accrlm(:il2g,:) = 0._r8 + loc_conv%bergnm(:il2g,:) = 0._r8 + loc_conv%fhtimm(:il2g,:) = 0._r8 + loc_conv%fhtctm(:il2g,:) = 0._r8 + loc_conv%fhmlm (:il2g,:) = 0._r8 + loc_conv%hmpim (:il2g,:) = 0._r8 + loc_conv%accslm(:il2g,:) = 0._r8 + loc_conv%dlfm (:il2g,:) = 0._r8 + + loc_conv%autoln(:il2g,:) = 0._r8 + loc_conv%accrln(:il2g,:) = 0._r8 + loc_conv%bergnn(:il2g,:) = 0._r8 + loc_conv%fhtimn(:il2g,:) = 0._r8 + loc_conv%fhtctn(:il2g,:) = 0._r8 + loc_conv%fhmln (:il2g,:) = 0._r8 + loc_conv%accsln(:il2g,:) = 0._r8 + loc_conv%activn(:il2g,:) = 0._r8 + loc_conv%dlfn (:il2g,:) = 0._r8 + + loc_conv%autoim(:il2g,:) = 0._r8 + loc_conv%accsim(:il2g,:) = 0._r8 + loc_conv%difm (:il2g,:) = 0._r8 + + loc_conv%nuclin(:il2g,:) = 0._r8 + loc_conv%autoin(:il2g,:) = 0._r8 + loc_conv%accsin(:il2g,:) = 0._r8 + loc_conv%hmpin (:il2g,:) = 0._r8 + loc_conv%difn (:il2g,:) = 0._r8 + + loc_conv%trspcm(:il2g,:) = 0._r8 + loc_conv%trspcn(:il2g,:) = 0._r8 + loc_conv%trspim(:il2g,:) = 0._r8 + loc_conv%trspin(:il2g,:) = 0._r8 + + loc_conv%dcape (:il2g) = 0._r8 + + end if + + do i = 1,il2g + ftemp(i) = 0._r8 + expnum(i) = 0._r8 + expdif(i) = 0._r8 + c0mask(i) = c0_ocn * (1._r8-landfrac(i)) + c0_lnd * landfrac(i) + tiedke_msk(i)=tiedke_add* (1._r8-landfrac(i)) + tiedke_lnd* landfrac(i) + end do +! +!jr Change from msg+1 to 1 to prevent blowup +! + do k = 1,pver + do i = 1,il2g + dz(i,k) = zf(i,k) - zf(i,k+1) + end do + end do + +! +! initialize many output and work variables to zero +! + pflx(:il2g,1) = 0 + + do k = 1,pver + do i = 1,il2g + k1(i,k) = 0._r8 + i2(i,k) = 0._r8 + i3(i,k) = 0._r8 + i4(i,k) = 0._r8 + mu(i,k) = 0._r8 + f(i,k) = 0._r8 + eps(i,k) = 0._r8 + eu(i,k) = 0._r8 + du(i,k) = 0._r8 + ql(i,k) = 0._r8 + cu(i,k) = 0._r8 + evp(i,k) = 0._r8 + cmeg(i,k) = 0._r8 + qds(i,k) = q(i,k) + md(i,k) = 0._r8 + ed(i,k) = 0._r8 + sd(i,k) = s(i,k) + qd(i,k) = q(i,k) + mc(i,k) = 0._r8 + qu(i,k) = q(i,k) + su(i,k) = s(i,k) + call qsat_hPa(t(i,k), p(i,k), est(i), qst(i,k)) + + if ( p(i,k)-est(i) <= 0._r8 ) then + qst(i,k) = 1.0_r8 + end if +!tht moist thermo + mrd(i,k) = (1._r8+zvir*q(i,k))*rd + mcp(i,k) = (1._r8+cpvir*q(i,k))*cp + mrl(i,k) = (1._r8-dcol*(t(i,k)-tmelt))*rl +! gamma(i,k) = qst(i,k)*(1._r8 + qst(i,k)/eps1)*eps1*rl/(rd*t(i,k)**2)*rl/cp +!!tht: mixing ratios; note that q dependence of Cp and T dependence of L are ignored +! hmn(i,k) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) +! hsat(i,k) = cp*t(i,k) + grav*z(i,k) + rl*qst(i,k) + gamma(i,k) = qst(i,k)*(1._r8 + qst(i,k)/eps1)*eps1*mrl(i,k)/(mrd(i,k)*t(i,k)**2)*mrl(i,k)/mcp(i,k) + hmn(i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*q(i,k) + hsat(i,k) = mcp(i,k)*t(i,k) + grav*z(i,k) + mrl(i,k)*qst(i,k) +!-tht + hu(i,k) = hmn(i,k) + hd(i,k) = hmn(i,k) + rprd(i,k) = 0._r8 + + fice(i,k) = 0._r8 + tug(i,k) = 0._r8 + qcde(i,k) = 0._r8 +!+tht moist thermo + !tvuo(i,k) = (shat(i,k) - grav/cp*zf(i,k))*(1._r8 + 0.608_r8*qhat(i,k)) + tvuo(i,k) = (shat(i,k) - grav/mcp(i,k)*zf(i,k))*(1._r8+zvir*qhat(i,k)) +!-tht + tvu(i,k) = tvuo(i,k) + frz(i,k) = 0._r8 + + end do + end do + if (zmconv_microp) then + do k = 1,pver + do i = 1,il2g + loc_conv%sprd(i,k) = 0._r8 + loc_conv%wu(i,k) = 0._r8 + loc_conv%cmel(i,k) = 0._r8 + loc_conv%cmei(i,k) = 0._r8 + loc_conv%qliq(i,k) = 0._r8 + loc_conv%qice(i,k) = 0._r8 + loc_conv%qnl(i,k) = 0._r8 + loc_conv%qni(i,k) = 0._r8 + loc_conv%qide(i,k) = 0._r8 + loc_conv%qncde(i,k) = 0._r8 + loc_conv%qnide(i,k) = 0._r8 + loc_conv%qnr(i,k) = 0._r8 + loc_conv%qns(i,k) = 0._r8 + loc_conv%qrain(i,k)= 0._r8 + loc_conv%qsnow(i,k)= 0._r8 + loc_conv%frz(i,k) = 0._r8 + end do + end do + end if +! +!jr Set to zero things which make this routine blow up +! + do k=1,msg + do i=1,il2g + rprd(i,k) = 0._r8 + end do + end do +! +! interpolate the layer values of qst, hsat and gamma to +! layer interfaces +! + do k = 1, msg+1 + do i = 1,il2g + hsthat(i,k) = hsat(i,k) + qsthat(i,k) = qst(i,k) + gamhat(i,k) = gamma(i,k) + end do + end do + do i = 1,il2g + totpcp(i) = 0._r8 + totevp(i) = 0._r8 + end do + do k = msg + 2,pver + do i = 1,il2g + if (abs(qst(i,k-1)-qst(i,k)) > 1.E-6_r8) then + qsthat(i,k) = log(qst(i,k-1)/qst(i,k))*qst(i,k-1)*qst(i,k)/ (qst(i,k-1)-qst(i,k)) + else + qsthat(i,k) = qst(i,k) + end if +!+tht moist thermo + !hsthat(i,k) = cp*shat(i,k) + rl*qsthat(i,k) + hsthat(i,k) =mcp(i,k)*shat(i,k) +mrl(i,k)*qsthat(i,k) +!-tht + if (abs(gamma(i,k-1)-gamma(i,k)) > 1.E-6_r8) then + gamhat(i,k) = log(gamma(i,k-1)/gamma(i,k))*gamma(i,k-1)*gamma(i,k)/ & + (gamma(i,k-1)-gamma(i,k)) + else + gamhat(i,k) = gamma(i,k) + end if + end do + end do +! +! initialize cloud top to highest plume top. +!jr changed hard-wired 4 to limcnv+1 (not to exceed pver) +! + jt(:) = pver + do i = 1,il2g + jt(i) = max(lel(i),limcnv+1) + jt(i) = min(jt(i),pver) + jd(i) = pver + jlcl(i) = lel(i) + hmin(i) = 1.E6_r8 + end do +! +! find the level of minimum hsat, where detrainment starts +! + + do k = msg + 1,pver + do i = 1,il2g + if (hsat(i,k) <= hmin(i) .and. k >= jt(i) .and. k <= jb(i)) then + hmin(i) = hsat(i,k) + j0(i) = k + end if + end do + end do + do i = 1,il2g + j0(i) = min(j0(i),jb(i)-2) + j0(i) = max(j0(i),jt(i)+2) +! +! Fix from Guang Zhang to address out of bounds array reference +! + j0(i) = min(j0(i),pver) + end do +! +! Initialize certain arrays inside cloud +! + do k = msg + 1,pver + do i = 1,il2g + if (k >= jt(i) .and. k <= jb(i)) then +!+tht moist thermo - uniform perturbation either in h or in s + hu(i,k) = hmn(i,mx(i)) + cp*tiedke_msk(i) + !su(i,k) = s(i,mx(i)) + tiedke_msk(i) + su(i,k) = s(i,mx(i)) + tiedke_msk(i)/(1._r8+cpvir*qu(i,k)) +!-tht + end if + end do + end do +! +! ********************************************************* +! compute taylor series for approximate eps(z) below +! ********************************************************* +! + do k = pver - 1,msg + 1,-1 + do i = 1,il2g + if (k < jb(i) .and. k >= jt(i)) then + k1(i,k) = k1(i,k+1) + (hmn(i,mx(i))-hmn(i,k))*dz(i,k) + ihat(i,k) = 0.5_r8* (k1(i,k+1)+k1(i,k)) + i2(i,k) = i2(i,k+1) + ihat(i,k)*dz(i,k) + idag(i,k) = 0.5_r8* (i2(i,k+1)+i2(i,k)) + i3(i,k) = i3(i,k+1) + idag(i,k)*dz(i,k) + iprm(i,k) = 0.5_r8* (i3(i,k+1)+i3(i,k)) + i4(i,k) = i4(i,k+1) + iprm(i,k)*dz(i,k) + end if + end do + end do +! +! re-initialize hmin array for ensuing calculation. +! + do i = 1,il2g + hmin(i) = 1.E6_r8 + end do + do k = msg + 1,pver + do i = 1,il2g + if (k >= j0(i) .and. k <= jb(i) .and. hmn(i,k) <= hmin(i)) then + hmin(i) = hmn(i,k) + expdif(i) = hmn(i,mx(i)) - hmin(i) + end if + end do + end do +! +! ********************************************************* +! compute approximate eps(z) using above taylor series +! ********************************************************* +! + do k = msg + 2,pver + do i = 1,il2g + expnum(i) = 0._r8 + ftemp(i) = 0._r8 + if (k < jt(i) .or. k >= jb(i)) then + k1(i,k) = 0._r8 + expnum(i) = 0._r8 + else + expnum(i) = hmn(i,mx(i)) - (hsat(i,k-1)*(zf(i,k)-z(i,k)) + & + hsat(i,k)* (z(i,k-1)-zf(i,k)))/(z(i,k-1)-z(i,k)) + end if + if ((expdif(i) > 100._r8 .and. expnum(i) > 0._r8) .and. & + k1(i,k) > expnum(i)*dz(i,k)) then + ftemp(i) = expnum(i)/k1(i,k) + f(i,k) = ftemp(i) + i2(i,k)/k1(i,k)*ftemp(i)**2 + & + (2._r8*i2(i,k)**2-k1(i,k)*i3(i,k))/k1(i,k)**2* & + ftemp(i)**3 + (-5._r8*k1(i,k)*i2(i,k)*i3(i,k)+ & + 5._r8*i2(i,k)**3+k1(i,k)**2*i4(i,k))/ & + k1(i,k)**3*ftemp(i)**4 + f(i,k) = max(f(i,k),0._r8) +!-->> maximum entr. rate (lambda_0 in paper) here set = 2e-4 !! (tht) <<-- + !f(i,k) = min(f(i,k),0.0002_r8) + f(i,k) = min(f(i,k),entrmn) + end if + end do + end do + do i = 1,il2g + if (j0(i) < jb(i)) then + if (f(i,j0(i)) < 1.E-6_r8 .and. f(i,j0(i)+1) > f(i,j0(i))) j0(i) = j0(i) + 1 + end if + end do + do k = msg + 2,pver + do i = 1,il2g + if (k >= jt(i) .and. k <= j0(i)) then + f(i,k) = max(f(i,k),f(i,k-1)) + end if + end do + end do + do i = 1,il2g + eps0(i) = f(i,j0(i)) + eps(i,jb(i)) = eps0(i) + end do +! +! This is set to match the Rasch and Kristjansson paper +! + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k >= j0(i) .and. k <= jb(i)) then + eps(i,k) = f(i,j0(i)) + end if + end do + end do + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k < j0(i) .and. k >= jt(i)) eps(i,k) = f(i,k) + end do + end do + + if (zmconv_microp) then + itnum = 2 + else + itnum = 1 + end if + + do iter=1, itnum + + if (zmconv_microp) then + do k = pver,msg + 1,-1 + do i = 1,il2g + cu(i,k) = 0._r8 + loc_conv%qliq(i,k) = 0._r8 + loc_conv%qice(i,k) = 0._r8 + ql(i,k) = 0._r8 + loc_conv%frz(i,k) = 0._r8 + end do + end do + do i = 1,il2g + totpcp(i) = 0._r8 + hu(i,jb(i)) = hmn(i,jb(i)) + cp*tiedke_msk(i) + end do + + end if + +! +! specify the updraft mass flux mu, entrainment eu, detrainment du +! and moist static energy hu. +! here and below mu, eu,du, md and ed are all normalized by mb +! + do i = 1,il2g + if (eps0(i) > 0._r8) then + mu(i,jb(i)) = 1._r8 + eu(i,jb(i)) = mu(i,jb(i))/dz(i,jb(i)) + end if + if (zmconv_microp) then + tmplel(i) = lel(i) + else + tmplel(i) = jt(i) + end if + end do + do k = pver,msg + 1,-1 + do i = 1,il2g + if (eps0(i) > 0._r8 .and. (k >= tmplel(i) .and. k < jb(i))) then + zuef(i) = zf(i,k) - zf(i,jb(i)) + rmue(i) = (1._r8/eps0(i))* (exp(eps(i,k+1)*zuef(i))-1._r8)/zuef(i) + mu(i,k) = (1._r8/eps0(i))* (exp(eps(i,k )*zuef(i))-1._r8)/zuef(i) + eu(i,k) = (rmue(i)-mu(i,k+1))/dz(i,k) + du(i,k) = (rmue(i)-mu(i,k))/dz(i,k) + end if + end do + end do + + khighest = pverp + klowest = 1 + do i=1,il2g + khighest = min(khighest,lel(i)) + klowest = max(klowest,jb(i)) + end do + do k = klowest-1,khighest,-1 + do i = 1,il2g + if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._r8) then + if (mu(i,k) < 0.02_r8) then + hu(i,k) = hmn(i,k) + mu(i,k) = 0._r8 + eu(i,k) = 0._r8 + du(i,k) = mu(i,k+1)/dz(i,k) + else + if (zmconv_microp) then + hu(i,k) = (mu(i,k+1)*hu(i,k+1) + dz(i,k)*(eu(i,k)*hmn(i,k) + & + latice*frz(i,k)))/(mu(i,k)+ dz(i,k)*du(i,k)) + else + hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + & + dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k)) + end if + end if + end if + end do + end do +! +! reset cloud top index beginning from two layers above the +! cloud base (i.e. if cloud is only one layer thick, top is not reset +! + do i=1,il2g + doit(i) = .true. + totfrz(i)= 0._r8 + do k = pver,msg + 1,-1 + totfrz(i)= totfrz(i)+ frz(i,k)*dz(i,k) + end do + end do + do k=klowest-2,khighest-1,-1 + do i=1,il2g + if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then + if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) & + .and. mu(i,k) >= 0.02_r8) then + if (hu(i,k)-hsthat(i,k) < -2000._r8) then + jt(i) = k + 1 + doit(i) = .false. + else + jt(i) = k + doit(i) = .false. + end if + else if ( (hu(i,k) > hu(i,jb(i)) .and. totfrz(i)<=0._r8) .or. mu(i,k) < 0.02_r8) then + jt(i) = k + 1 + doit(i) = .false. + end if + end if + end do + end do + + if (iter == 1) jto(:) = jt(:) + + do k = pver,msg + 1,-1 + do i = 1,il2g + if (k >= lel(i) .and. k <= jt(i) .and. eps0(i) > 0._r8) then + mu(i,k) = 0._r8 + eu(i,k) = 0._r8 + du(i,k) = 0._r8 + hu(i,k) = hmn(i,k) + end if + if (k == jt(i) .and. eps0(i) > 0._r8) then + du(i,k) = mu(i,k+1)/dz(i,k) + eu(i,k) = 0._r8 + mu(i,k) = 0._r8 + end if + end do + end do + +! initialise tu (moist thermo) + do k = pver,msg + 2,-1 + do i = 1,il2g + tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._r8+dcol*tmelt)*rl*qu(i,k)) & + /(cp*( 1._r8 + (cpvir-dcol*(rl/cp))*qu(i,k) )) + end do + end do + + do i = 1,il2g + done(i) = .false. + end do + kount = 0 + do k = pver,msg + 2,-1 + do i = 1,il2g + if (k == jb(i) .and. eps0(i) > 0._r8) then + qu(i,k) = q(i,mx(i)) +!+tht moist thermo + !su(i,k) = (hu(i,k)-rl*qu(i,k))/cp + tu(i,k) = (hu(i,k)-grav*zf(i,k)-(1._r8+dcol*tmelt)*rl*qu(i,k)) & + /(cp*( 1._r8 + (cpvir-dcol*(rl/cp))*qu(i,k) )) + su(i,k) = (hu(i,k)-(1._r8-dcol*(tu(i,k)-tmelt))*rl*qu(i,k)) & + /((1._r8+cpvir*qu(i,k))*cp) +!-tht + end if + if (( .not. done(i) .and. k > jt(i) .and. k < jb(i)) .and. eps0(i) > 0._r8) then + su(i,k) = mu(i,k+1)/mu(i,k)*su(i,k+1) + & + dz(i,k)/mu(i,k)* (eu(i,k)-du(i,k))*s(i,k) + qu(i,k) = mu(i,k+1)/mu(i,k)*qu(i,k+1) + dz(i,k)/mu(i,k)* (eu(i,k)*q(i,k)- & + du(i,k)*qst(i,k)) +!+tht moist thermo + !tu = su(i,k) - grav/cp*zf(i,k) + !call qsat_hPa(tu, (p(i,k)+p(i,k-1))/2._r8, estu, qstu) + tu(i,k) = su(i,k) - grav/((1._r8+0.85*qu(i,k))*cp)*zf(i,k) + call qsat_hPa(tu(i,k), (p(i,k)+p(i,k-1))/2._r8, estu, qstu) +!-tht + if (qu(i,k) >= qstu) then + jlcl(i) = k + kount = kount + 1 + done(i) = .true. + end if + end if + end do + if (kount >= il2g) goto 690 + end do +690 continue + do k = msg + 2,pver + do i = 1,il2g + if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._r8) then +!+tht moist thermo + !su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/(cp* (1._r8+gamhat(i,k))) + !qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ & + ! (rl* (1._r8+gamhat(i,k))) + qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ & + ((1._r8-dcol*(tu(i,k)-tmelt))*rl* (1._r8+gamhat(i,k))) + su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/((1._r8+cpvir*qu(i,k))*cp* (1._r8+gamhat(i,k))) + tu(i,k) = su(i,k) - grav/((1._r8+cpvir*qu(i,k))*cp)*zf(i,k) +!-tht + end if + end do + end do + +! compute condensation in updraft + if (zmconv_microp) then + tmplel(:il2g) = jlcl(:il2g)+1 + else + tmplel(:il2g) = jb(:il2g) + end if + + do k = pver,msg + 2,-1 + do i = 1,il2g + if (k >= jt(i) .and. k < tmplel(i) .and. eps0(i) > 0._r8) then + if (zmconv_microp) then + cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & + dz(i,k)- eu(i,k)*s(i,k)+du(i,k)*su(i,k))/(rl/cp) & +!+tht moist thermo + *((1._r8+cpvir*qu(i,k))/(1._r8-dcol*(tu(i,k)-tmelt))) & +!-tht + - latice*frz(i,k)/rl + else + + cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ & +!+tht moist thermo + !dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp) + dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp) & + *((1._r8+cpvir*qu(i,k))/(1._r8-dcol*(tu(i,k)-tmelt))) +!-tht + end if + if (k == jt(i)) cu(i,k) = 0._r8 + cu(i,k) = max(0._r8,cu(i,k)) + end if + end do + end do + + + if (zmconv_microp) then + + tug(:il2g,:) = t(:il2g,:) + fice(:,:) = 0._r8 + + do k = pver, msg+2, -1 + do i = 1, il2g +!+tht moist thermo + !tug(i,k) = su(i,k) - grav/cp*zf(i,k) + tug(i,k) = su(i,k) - grav/cp*zf(i,k)/(1._r8+cpvir*qu(i,k)) +!-tht + end do + end do + + do k = 1, pver-1 + do i = 1, il2g + + if (tug(i,k+1) > 273.15_r8) then + ! If warmer than tmax then water phase + fice(i,k) = 0._r8 + + else if (tug(i,k+1) < 233.15_r8) then + ! If colder than tmin then ice phase + fice(i,k) = 1._r8 + + else + ! Otherwise mixed phase, with ice fraction decreasing linearly + ! from tmin to tmax + fice(i,k) =(273.15_r8 - tug(i,k+1)) / 40._r8 + end if + end do + end do + + do k = 1, pver + do i = 1,il2g + loc_conv%cmei(i,k) = cu(i,k)* fice(i,k) + loc_conv%cmel(i,k) = cu(i,k) * (1._r8-fice(i,k)) + end do + end do + + call zm_mphy(su, qu, mu, du, eu, loc_conv%cmel, loc_conv%cmei, zf, p, t, q, & + eps0, jb, jt, jlcl, msg, il2g, grav, cp, rd, aero, gamhat, & + loc_conv%qliq, loc_conv%qice, loc_conv%qnl, loc_conv%qni, qcde, loc_conv%qide, & + loc_conv%qncde, loc_conv%qnide, rprd, loc_conv%sprd, frz, & + loc_conv%wu, loc_conv%qrain, loc_conv%qsnow, loc_conv%qnr, loc_conv%qns, & + loc_conv%autolm, loc_conv%accrlm, loc_conv%bergnm, loc_conv%fhtimm, loc_conv%fhtctm, & + loc_conv%fhmlm, loc_conv%hmpim, loc_conv%accslm, loc_conv%dlfm, loc_conv%autoln, & + loc_conv%accrln, loc_conv%bergnn, loc_conv%fhtimn, loc_conv%fhtctn, & + loc_conv%fhmln, loc_conv%accsln, loc_conv%activn, loc_conv%dlfn, loc_conv%autoim, & + loc_conv%accsim, loc_conv%difm, loc_conv%nuclin, loc_conv%autoin, & + loc_conv%accsin, loc_conv%hmpin, loc_conv%difn, loc_conv%trspcm, loc_conv%trspcn, & + loc_conv%trspim, loc_conv%trspin, loc_conv%lambdadpcu, loc_conv%mudpcu ) + + + do k = pver,msg + 2,-1 + do i = 1,il2g + ql(i,k) = loc_conv%qliq(i,k)+ loc_conv%qice(i,k) + loc_conv%frz(i,k) = frz(i,k) + end do + end do + + do i = 1,il2g + if (iter == 2 .and. jt(i)> jto(i)) then + do k = jt(i), jto(i), -1 + loc_conv%frz(i,k) = 0.0_r8 + cu(i,k)=0.0_r8 + end do + end if + end do + + + do k = pver,msg + 2,-1 + do i = 1,il2g + if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8 .and. mu(i,k) >= 0.0_r8) then + totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*(qcde(i,k+1)+loc_conv%qide(i,k+1) )) + end if + end do + end do + + do k = msg + 2,pver + do i = 1,il2g + if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._r8) then + if (iter == 1) tvuo(i,k)= (su(i,k) - grav/cp*zf(i,k))*(1._r8+0.608_r8*qu(i,k)) + if (iter == 2 .and. k > max(jt(i),jto(i)) ) then +!+tht moist thermo + !tvu(i,k) = (su(i,k) - grav/cp*zf(i,k))*(1._r8 +0.608_r8*qu(i,k)) + tvu(i,k) = (su(i,k) - grav/(cp*(1._r8+cpvir*qu(i,k)))*zf(i,k))*(1._r8 +0.608_r8*qu(i,k)) +!-tht + loc_conv%dcape(i) = loc_conv%dcape(i)+ rd*(tvu(i,k)-tvuo(i,k))*log(p(i,k)/p(i,k-1)) + end if + end if + end do + end do + + else ! no convective microphysics + +! compute condensed liquid, rain production rate +! accumulate total precipitation (condensation - detrainment of liquid) +! Note ql1 = ql(k) + rprd(k)*dz(k)/mu(k) +! The differencing is somewhat strange (e.g. du(i,k)*ql(i,k+1)) but is +! consistently applied. +! mu, ql are interface quantities +! cu, du, eu, rprd are midpoint quantites + + do k = pver,msg + 2,-1 + do i = 1,il2g + rprd(i,k) = 0._r8 + if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8 .and. mu(i,k) >= 0.0_r8) then + if (mu(i,k) > 0._r8) then + ql1 = 1._r8/mu(i,k)* (mu(i,k+1)*ql(i,k+1)- & + dz(i,k)*du(i,k)*ql(i,k+1)+dz(i,k)*cu(i,k)) + ql(i,k) = ql1/ (1._r8+dz(i,k)*c0mask(i)) + else + ql(i,k) = 0._r8 + end if + totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*ql(i,k+1)) + rprd(i,k) = c0mask(i)*mu(i,k)*ql(i,k) + qcde(i,k) = ql(i,k) + + if (zmconv_microp) then + loc_conv%qide(i,k) = 0._r8 + loc_conv%qncde(i,k) = 0._r8 + loc_conv%qnide(i,k) = 0._r8 + loc_conv%sprd(i,k) = 0._r8 + end if + + end if + end do + end do +! + end if ! zmconv_microp + + end do !iter +! +! specify downdraft properties (no downdrafts if jd.ge.jb). +! scale down downward mass flux profile so that net flux +! (up-down) at cloud base in not negative. +! + do i = 1,il2g +! +! in normal downdraft strength run alfa=0.2. In test4 alfa=0.1 +!+tht: detrainment proportionality factor (alpha in paper) hard-wired to 0.1 here + !alfa(i) = 0.1_r8 + alfa(i) = alfadet +!-tht + jt(i) = min(jt(i),jb(i)-1) + jd(i) = max(j0(i),jt(i)+1) + jd(i) = min(jd(i),jb(i)) + hd(i,jd(i)) = hmn(i,jd(i)-1) + if (jd(i) < jb(i) .and. eps0(i) > 0._r8) then + epsm(i) = eps0(i) + md(i,jd(i)) = -alfa(i)*epsm(i)/eps0(i) + end if + end do + do k = msg + 1,pver + do i = 1,il2g + if ((k > jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8) then + zdef(i) = zf(i,jd(i)) - zf(i,k) +!tht: why the factor 2 here? + md(i,k) = -alfa(i)/ (2._r8*eps0(i))*(exp(2._r8*epsm(i)*zdef(i))-1._r8)/zdef(i) + end if + end do + end do + + do k = msg + 1,pver + do i = 1,il2g + if ((k >= jt(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then + ratmjb(i) = min(abs(mu(i,jb(i))/md(i,jb(i))),1._r8) + md(i,k) = md(i,k)*ratmjb(i) + end if + end do + end do + + small = 1.e-20_r8 + do k = msg + 1,pver + do i = 1,il2g + if ((k >= jt(i) .and. k <= pver) .and. eps0(i) > 0._r8) then + ed(i,k-1) = (md(i,k-1)-md(i,k))/dz(i,k-1) + mdt = min(md(i,k),-small) + hd(i,k) = (md(i,k-1)*hd(i,k-1) - dz(i,k-1)*ed(i,k-1)*hmn(i,k-1))/mdt + end if + end do + end do +! +! calculate updraft and downdraft properties. +! + do k = msg + 2,pver + do i = 1,il2g + if ((k >= jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then + qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & + (rl*(1._r8 + gamhat(i,k))) +!+tht moist thermo + td(i,k) = (hd(i,k)-grav*zf(i,k)-(1._r8+dcol*tmelt)*rl*qds(i,k)) & + /(cp*( 1._r8 + (cpvir-dcol*(rl/cp))*qds(i,k) )) + qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ & + ((1._r8-dcol*(td(i,k)-tmelt))*rl*(1._r8 + gamhat(i,k))) +!-tht + end if + end do + end do + + do i = 1,il2g + qd(i,jd(i)) = qds(i,jd(i)) +!+tht moist thermo + !sd(i,jd(i)) = (hd(i,jd(i)) - rl*qd(i,jd(i)))/cp + k=jd(i) ! BUG FIX 2019 05 24 + sd(i,jd(i)) = (hd(i,jd(i)) - (1._r8-dcol*(td(i,k)-tmelt))*rl*qd(i,jd(i)))/((1._r8+cpvir*qd(i,k))*cp) + td(i,k) = sd(i,k) - grav/((1._r8+cpvir*qd(i,k))*cp)*zf(i,k) +!-tht + end do +! + do k = msg + 2,pver + do i = 1,il2g + if (k >= jd(i) .and. k < jb(i) .and. eps0(i) > 0._r8) then + qd(i,k+1) = qds(i,k+1) + evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k)-md(i,k+1)*qd(i,k+1))/dz(i,k) + evp(i,k) = max(evp(i,k),0._r8) + mdt = min(md(i,k+1),-small) + if (zmconv_microp) then + evp(i,k) = min(evp(i,k),rprd(i,k)) + end if +!+tht moist thermo + !sd(i,k+1) = ((rl/cp*evp(i,k)-ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt + sd(i,k+1) = (((1._r8-dcol*(td(i,k)-tmelt))*rl/((1._r8+cpvir*qd(i,k))*cp)*evp(i,k) & + -ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt +!-tht + totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) + end if + end do + end do + do i = 1,il2g +!*guang totevp(i) = totevp(i) + md(i,jd(i))*q(i,jd(i)-1) - + totevp(i) = totevp(i) + md(i,jd(i))*qd(i,jd(i)) - md(i,jb(i))*qd(i,jb(i)) + end do +!!$ if (.true.) then + if (.false.) then + do i = 1,il2g + k = jb(i) + if (eps0(i) > 0._r8) then + evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k))/dz(i,k) + evp(i,k) = max(evp(i,k),0._r8) + totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k) + end if + end do + endif + + do i = 1,il2g + totpcp(i) = max(totpcp(i),0._r8) + totevp(i) = max(totevp(i),0._r8) + end do +! + do k = msg + 2,pver + do i = 1,il2g + if (totevp(i) > 0._r8 .and. totpcp(i) > 0._r8) then + md(i,k) = md (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) + ed(i,k) = ed (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) + evp(i,k) = evp(i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i))) + else + md(i,k) = 0._r8 + ed(i,k) = 0._r8 + evp(i,k) = 0._r8 + end if +! cmeg is the cloud water condensed - rain water evaporated +! rprd is the cloud water converted to rain - (rain evaporated) + cmeg(i,k) = cu(i,k) - evp(i,k) + rprd(i,k) = rprd(i,k)-evp(i,k) + end do + end do + +! compute the net precipitation flux across interfaces + pflx(:il2g,1) = 0._r8 + do k = 2,pverp + do i = 1,il2g + pflx(i,k) = pflx(i,k-1) + rprd(i,k-1)*dz(i,k-1) + end do + end do +! + do k = msg + 1,pver + do i = 1,il2g + mc(i,k) = mu(i,k) + md(i,k) + end do + end do +! + return +end subroutine cldprp + +subroutine closure(lchnk , & + q ,t ,p ,z ,s , & + tp ,qs ,qu ,su ,mc , & + du ,mu ,md ,qd ,sd , & + qhat ,shat ,dp ,qstp ,zf , & + ql ,dsubcld ,mb ,cape ,tl , & + lcl ,lel ,jt ,mx ,il1g , & + il2g ,rd ,grav ,cp ,rl , & + msg ,capelmt ) +!----------------------------------------------------------------------- +! +! Purpose: +! +! +! Method: +! +! +! +! Author: G. Zhang and collaborators. CCM contact:P. Rasch +! This is contributed code not fully standardized by the CCM core group. +! +! this code is very much rougher than virtually anything else in the CCM +! We expect to release cleaner code in a future release +! +! the documentation has been enhanced to the degree that we are able +! +!----------------------------------------------------------------------- + +! +!-----------------------------Arguments--------------------------------- +! + integer, intent(in) :: lchnk ! chunk identifier + + real(r8), intent(inout) :: q(pcols,pver) ! spec humidity + real(r8), intent(inout) :: t(pcols,pver) ! temperature + real(r8), intent(inout) :: p(pcols,pver) ! pressure (mb) + real(r8), intent(inout) :: mb(pcols) ! cloud base mass flux + real(r8), intent(in) :: z(pcols,pver) ! height (m) + real(r8), intent(in) :: s(pcols,pver) ! normalized dry static energy + real(r8), intent(in) :: tp(pcols,pver) ! parcel temp + real(r8), intent(in) :: qs(pcols,pver) ! sat spec humidity + real(r8), intent(in) :: qu(pcols,pver) ! updraft spec. humidity + real(r8), intent(in) :: su(pcols,pver) ! normalized dry stat energy of updraft + real(r8), intent(in) :: mc(pcols,pver) ! net convective mass flux + real(r8), intent(in) :: du(pcols,pver) ! detrainment from updraft + real(r8), intent(in) :: mu(pcols,pver) ! mass flux of updraft + real(r8), intent(in) :: md(pcols,pver) ! mass flux of downdraft + real(r8), intent(in) :: qd(pcols,pver) ! spec. humidity of downdraft + real(r8), intent(in) :: sd(pcols,pver) ! dry static energy of downdraft + real(r8), intent(in) :: qhat(pcols,pver) ! environment spec humidity at interfaces + real(r8), intent(in) :: shat(pcols,pver) ! env. normalized dry static energy at intrfcs + real(r8), intent(in) :: dp(pcols,pver) ! pressure thickness of layers + real(r8), intent(in) :: qstp(pcols,pver) ! spec humidity of parcel + real(r8), intent(in) :: zf(pcols,pver+1) ! height of interface levels + real(r8), intent(in) :: ql(pcols,pver) ! liquid water mixing ratio + + real(r8), intent(in) :: cape(pcols) ! available pot. energy of column + real(r8), intent(in) :: tl(pcols) + real(r8), intent(in) :: dsubcld(pcols) ! thickness of subcloud layer + + integer, intent(in) :: lcl(pcols) ! index of lcl + integer, intent(in) :: lel(pcols) ! index of launch leve + integer, intent(in) :: jt(pcols) ! top of updraft + integer, intent(in) :: mx(pcols) ! base of updraft +! +!--------------------------Local variables------------------------------ +! + real(r8) dtpdt(pcols,pver) + real(r8) dqsdtp(pcols,pver) + real(r8) dtmdt(pcols,pver) + real(r8) dqmdt(pcols,pver) + real(r8) dboydt(pcols,pver) + real(r8) thetavp(pcols,pver) + real(r8) thetavm(pcols,pver) + + real(r8) dtbdt(pcols),dqbdt(pcols),dtldt(pcols) + real(r8) beta + real(r8) capelmt + real(r8) cp + real(r8) dadt(pcols) + real(r8) debdt + real(r8) dltaa + real(r8) eb + real(r8) grav + + integer i + integer il1g + integer il2g + integer k, kmin, kmax + integer msg + + real(r8) rd + real(r8) rl +!+tht moist thermo + real(r8) rltp +!-tht moist thermo + +! change of subcloud layer properties due to convection is +! related to cumulus updrafts and downdrafts. +! mc(z)=f(z)*mb, mub=betau*mb, mdb=betad*mb are used +! to define betau, betad and f(z). +! note that this implies all time derivatives are in effect +! time derivatives per unit cloud-base mass flux, i.e. they +! have units of 1/mb instead of 1/sec. +! + do i = il1g,il2g + mb(i) = 0._r8 + eb = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i))) + dtbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(shat(i,mx(i))-su(i,mx(i)))+ & + md(i,mx(i))* (shat(i,mx(i))-sd(i,mx(i)))) + dqbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(qhat(i,mx(i))-qu(i,mx(i)))+ & + md(i,mx(i))* (qhat(i,mx(i))-qd(i,mx(i)))) + debdt = eps1*p(i,mx(i))/ (eps1+q(i,mx(i)))**2*dqbdt(i) + dtldt(i) = -2840._r8* (3.5_r8/t(i,mx(i))*dtbdt(i)-debdt/eb)/ & + (3.5_r8*log(t(i,mx(i)))-log(eb)-4.805_r8)**2 + end do +! +! dtmdt and dqmdt are cumulus heating and drying. +! + do k = msg + 1,pver + do i = il1g,il2g + dtmdt(i,k) = 0._r8 + dqmdt(i,k) = 0._r8 + end do + end do +! + do k = msg + 1,pver - 1 + do i = il1g,il2g + if (k == jt(i)) then +!+tht moist thermo -- changes in this most parts of routine do not seem essential + !dtmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (su(i,k+1)-shat(i,k+1)- & + ! rl/cp*ql(i,k+1))+md(i,k+1)* (sd(i,k+1)-shat(i,k+1))) + !dqmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (qu(i,k+1)- & + ! qhat(i,k+1)+ql(i,k+1))+md(i,k+1)*(qd(i,k+1)-qhat(i,k+1))) + dqmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)*(qu(i,k+1)-qhat(i,k+1) +ql(i,k+1)) & + +md(i,k+1)*(qd(i,k+1)-qhat(i,k+1) )) + dtmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)*(su(i,k+1)-shat(i,k+1)-rl/cp*ql(i,k+1)) & + +md(i,k+1)*(sd(i,k+1)-shat(i,k+1) )) +!-tht + end if + end do + end do +! + beta = 0._r8 + do k = msg + 1,pver - 1 + do i = il1g,il2g + if (k > jt(i) .and. k < mx(i)) then + dtmdt(i,k) = (mc(i,k)*(shat(i,k)-s(i,k)) - mc(i,k+1)*(shat(i,k+1)-s(i,k)))/dp(i,k) & + - rl/cp*du(i,k)*(beta*ql(i,k)+ (1-beta)*ql(i,k+1)) +! dqmdt(i,k)=(mc(i,k)*(qhat(i,k)-q(i,k)) +! 1 +mc(i,k+1)*(q(i,k)-qhat(i,k+1)))/dp(i,k) +! 2 +du(i,k)*(qs(i,k)-q(i,k)) +! 3 +du(i,k)*(beta*ql(i,k)+(1-beta)*ql(i,k+1)) + + dqmdt(i,k) = (mu(i,k+1)*(qu(i,k+1)-qhat(i,k+1)+cp/rl*(su(i,k+1)-s(i,k))) & + -mu(i,k )*(qu(i,k )-qhat(i,k )+cp/rl*(su(i,k )-s(i,k))) & + +md(i,k+1)*(qd(i,k+1)-qhat(i,k+1)+cp/rl*(sd(i,k+1)-s(i,k))) & + -md(i,k )*(qd(i,k )-qhat(i,k )+cp/rl*(sd(i,k )-s(i,k))))/dp(i,k) + & + du(i,k)* (beta*ql(i,k)+(1-beta)*ql(i,k+1)) + end if + end do + end do +! + do k = msg + 1,pver + do i = il1g,il2g + if (k >= lel(i) .and. k <= lcl(i)) then + thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))**(rd/cp) *(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i))) + thetavm(i,k) = t (i,k)* (1000._r8/p(i,k))**(rd/cp) *(1._r8+0.608_r8*q(i,k) ) +!!+tht moist thermo ...but probably important for parcel heating + dqsdtp(i,k) = qstp(i,k)* (1._r8+qstp(i,k)/eps1)*eps1*rl/(rd*tp(i,k)**2) + !rltp=rl*(1.-dcol*(tp(i,k)-tmelt)) + !dqsdtp(i,k) = qstp(i,k)* (1._r8+qstp(i,k)/eps1)*eps1*rltp/(rd*tp(i,k)**2) +! +! dtpdt is the parcel temperature change due to change of +! subcloud layer properties during convection. +! + dtpdt(i,k) = tp(i,k)/ (1._r8 + rl/cp*(dqsdtp(i,k)-qstp(i,k)/tp(i,k))) & + *(dtbdt(i)/t(i,mx(i)) + rl/cp*(dqbdt(i)/tl(i)-q(i,mx(i))/tl(i)**2*dtldt(i))) + !rltp=rltp/(cp*(1.+cpvir*qstp(i,k))) + !dtpdt(i,k) = tp(i,k)/ (1._r8 + rltp*(dqsdtp(i,k)-qstp(i,k)/tp(i,k))) & + ! *(dtbdt(i)/t(i,mx(i)) + rltp*(dqbdt(i)/tl(i)-q(i,mx(i))/tl(i)**2*dtldt(i))) +!!-tht +! +! dboydt is the integrand of cape change. +! + dboydt(i,k) = ((dtpdt(i,k)/tp(i,k) & + +1._r8 /(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i))) & + *(1.608_r8*dqsdtp(i,k)*dtpdt(i,k)-dqbdt(i))) & + -(dtmdt(i,k)/t (i,k) & + +0.608_r8/(1._r8+0.608_r8*q(i,k) ) & + *dqmdt(i,k)) & + )*grav*thetavp(i,k)/thetavm(i,k) + end if + end do + end do +! + do k = msg + 1,pver + do i = il1g,il2g + if (k > lcl(i) .and. k < mx(i)) then + thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))**(rd/cp) *(1._r8+0.608_r8*q(i,mx(i))) + thetavm(i,k) = t (i,k)* (1000._r8/p(i,k))**(rd/cp) *(1._r8+0.608_r8*q(i,k )) +! +! dboydt is the integrand of cape change. +! + dboydt(i,k) = (dtbdt(i )/t(i,mx(i)) & + +0.608_r8/(1._r8+0.608_r8*q(i,mx(i)))*dqbdt(i ) & + -dtmdt(i,k)/t(i,k ) & + -0.608_r8/(1._r8+0.608_r8*q(i,k ))*dqmdt(i,k) & + )*grav*thetavp(i,k)/thetavm(i,k) + end if + end do + end do + +! +! buoyant energy change is set to 2/3*excess cape per 3 hours +! + dadt(il1g:il2g) = 0._r8 + kmin = minval(lel(il1g:il2g)) + kmax = maxval(mx(il1g:il2g)) - 1 + do k = kmin, kmax + do i = il1g,il2g + if ( k >= lel(i) .and. k <= mx(i) - 1) then + dadt(i) = dadt(i) + dboydt(i,k)* (zf(i,k)-zf(i,k+1)) + endif + end do + end do + do i = il1g,il2g + dltaa = -1._r8* (cape(i)-capelmt) + if (dadt(i) /= 0._r8) mb(i) = max(dltaa/tau/dadt(i),0._r8) + end do +! + return +end subroutine closure + +subroutine q1q2_pjr(lchnk , & + dqdt ,dsdt ,q ,qs ,qu , & + su ,du ,qhat ,shat ,dp , & + mu ,md ,sd ,qd ,ql , & + dsubcld ,jt ,mx ,il1g ,il2g , & + cp ,rl ,msg , & + dl ,evp ,cu , & + loc_conv) + + + implicit none + +!----------------------------------------------------------------------- +! +! Purpose: +! +! +! Method: +! +! +! +! Author: phil rasch dec 19 1995 +! +!----------------------------------------------------------------------- + + + real(r8), intent(in) :: cp + + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: il1g + integer, intent(in) :: il2g + integer, intent(in) :: msg + + real(r8), intent(in) :: q(pcols,pver) + real(r8), intent(in) :: qs(pcols,pver) + real(r8), intent(in) :: qu(pcols,pver) + real(r8), intent(in) :: su(pcols,pver) + real(r8), intent(in) :: du(pcols,pver) + real(r8), intent(in) :: qhat(pcols,pver) + real(r8), intent(in) :: shat(pcols,pver) + real(r8), intent(in) :: dp(pcols,pver) + real(r8), intent(in) :: mu(pcols,pver) + real(r8), intent(in) :: md(pcols,pver) + real(r8), intent(in) :: sd(pcols,pver) + real(r8), intent(in) :: qd(pcols,pver) + real(r8), intent(in) :: ql(pcols,pver) + real(r8), intent(in) :: evp(pcols,pver) + real(r8), intent(in) :: cu(pcols,pver) + real(r8), intent(in) :: dsubcld(pcols) + + real(r8),intent(out) :: dqdt(pcols,pver),dsdt(pcols,pver) + real(r8),intent(out) :: dl(pcols,pver) + + type(zm_conv_t) :: loc_conv + + integer kbm + integer ktm + integer jt(pcols) + integer mx(pcols) +! +! work fields: +! + integer i + integer k + + real(r8) emc + real(r8) rl +!------------------------------------------------------------------- + do k = msg + 1,pver + do i = il1g,il2g + dsdt(i,k) = 0._r8 + dqdt(i,k) = 0._r8 + dl(i,k) = 0._r8 + end do + end do + + if (zmconv_microp) then + do k = msg + 1,pver + do i = il1g,il2g + loc_conv%di(i,k) = 0._r8 + loc_conv%dnl(i,k) = 0._r8 + loc_conv%dni(i,k) = 0._r8 + end do + end do + end if +! +! find the highest level top and bottom levels of convection +! + ktm = pver + kbm = pver + do i = il1g, il2g + ktm = min(ktm,jt(i)) + kbm = min(kbm,mx(i)) + end do + + !do k =ktm,pver-1 + ! do i=il1g,il2g + ! tu(i,k)=su(i,k)-grav*zf(i,k)/(cp*(1._r8+cpvir*qu(i,k))) + ! td(i,k)=sd(i,k)-grav*zf(i,k)/(cp*(1._r8+cpvir*qd(i,k))) + ! enddo + !enddo + + do k = ktm,pver-1 + do i = il1g,il2g + emc = -cu (i,k) & ! condensation in updraft + +evp(i,k) ! evaporating rain in downdraft + + !rlcu0=(1.-dcol*(tu(i,k )-tmelt))/(1._r8+cpvir*qu(i,k )) + !rlcu1=(1.-dcol*(tu(i,k+1)-tmelt))/(1._r8+cpvir*qu(i,k+1)) + !rlcd0=(1.-dcol*(td(i,k )-tmelt))/(1._r8+cpvir*qd(i,k )) + !rlcd1=(1.-dcol*(td(i,k+1)-tmelt))/(1._r8+cpvir*qd(i,k+1)) + + dsdt(i,k) = -rl/cp*emc & + + ( mu(i,k+1)* (su(i,k+1)-shat(i,k+1)) & + -mu(i,k )* (su(i,k )-shat(i,k )) & + +md(i,k+1)* (sd(i,k+1)-shat(i,k+1)) & + -md(i,k )* (sd(i,k )-shat(i,k )) & + )/dp(i,k) + + if (zmconv_microp) dsdt(i,k) = dsdt(i,k) + latice/cp*loc_conv%frz(i,k) + + dqdt(i,k) = emc + & + ( mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)) & + -mu(i,k )* (qu(i,k )-qhat(i,k )) & + +md(i,k+1)* (qd(i,k+1)-qhat(i,k+1)) & + -md(i,k )* (qd(i,k )-qhat(i,k )) & + )/dp(i,k) + + dl(i,k) = du(i,k)*ql(i,k+1) + + if (zmconv_microp) then + loc_conv%di(i,k) = du(i,k)*loc_conv%qide(i,k+1) + loc_conv%dnl(i,k) = du(i,k)*loc_conv%qncde(i,k+1) + loc_conv%dni(i,k) = du(i,k)*loc_conv%qnide(i,k+1) + end if + + end do + end do + +! + do k = kbm,pver + do i = il1g,il2g + if (k == mx(i)) then + dsdt(i,k) = (1._r8/dsubcld(i))* & + (-mu(i,k)* (su(i,k)-shat(i,k)) & + -md(i,k)* (sd(i,k)-shat(i,k)) & + ) + dqdt(i,k) = (1._r8/dsubcld(i))* & + (-mu(i,k)*(qu(i,k)-qhat(i,k)) & + -md(i,k)*(qd(i,k)-qhat(i,k)) & + ) + else if (k > mx(i)) then + dsdt(i,k) = dsdt(i,k-1) + dqdt(i,k) = dqdt(i,k-1) + end if + end do + end do +! + return +end subroutine q1q2_pjr + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +subroutine buoyan_dilute(lchnk ,ncol , & + q ,t ,p ,z ,pf , & +! tp ,qstp ,tl ,rl ,cape , & + tp ,qstp ,tl ,rl ,cape , cin , & !+tht cin + pblt ,lcl ,lel ,lon ,mx , & + rd ,grav ,cp ,msg , & +! tpert , org , landfrac) + tpert , org , landfrac , dmpdz) !+tht dmpdz +!----------------------------------------------------------------------- +! +! Purpose: +! Calculates CAPE the lifting condensation level and the convective top +! where buoyancy is first -ve. +! +! Method: Calculates the parcel temperature based on a simple constant +! entraining plume model. CAPE is integrated from buoyancy. +! 09/09/04 - Simplest approach using an assumed entrainment rate for +! testing (dmpdp). +! 08/04/05 - Swap to convert dmpdz to dmpdp +! +! SCAM Logical Switches - DILUTE:RBN - Now Disabled +! --------------------- +! switch(1) = .T. - Uses the dilute parcel calculation to obtain tendencies. +! switch(2) = .T. - Includes entropy/q changes due to condensate loss and freezing. +! switch(3) = .T. - Adds the PBL Tpert for the parcel temperature at all levels. +! +! References: +! Raymond and Blythe (1992) JAS +! +! Author: +! Richard Neale - September 2004 +! +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: q(pcols,pver) ! spec. humidity + real(r8), intent(in) :: t(pcols,pver) ! temperature + real(r8), intent(in) :: p(pcols,pver) ! pressure + real(r8), intent(in) :: z(pcols,pver) ! height + real(r8), intent(in) :: pf(pcols,pver+1) ! pressure at interfaces + real(r8), intent(in) :: pblt(pcols) ! index of pbl depth + real(r8), intent(in) :: tpert(pcols) ! perturbation temperature by pbl processes + +!+tht + !real(r8), intent(in), dimension(pcols) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 2D + real(r8), intent(in), dimension(pcols,pver) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 3D + !real(r8), dimension(pcols,pver) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 3D +!-tht + +! +! output arguments +! + real(r8), intent(out) :: tp(pcols,pver) ! parcel temperature + real(r8), intent(out) :: qstp(pcols,pver) ! saturation mixing ratio of parcel (only above lcl, just q below). + real(r8), intent(out) :: tl(pcols) ! parcel temperature at lcl + real(r8), intent(out) :: cape(pcols) ! convective aval. pot. energy. + + real(r8), intent(out) :: cin (pcols) !+tht: CIN + + integer lcl(pcols) ! + integer lel(pcols) ! + integer lon(pcols) ! level of onset of deep convection + integer mx(pcols) ! level of max moist static energy + + real(r8), pointer :: org(:,:) ! organization parameter + real(r8), intent(in) :: landfrac(pcols) +! +!--------------------------Local Variables------------------------------ +! + real(r8) capeten(pcols,5) ! provisional value of cape + real(r8) cinten (pcols,5) !+tht provisional value of CIN + real(r8) tv(pcols,pver) ! + real(r8) tpv(pcols,pver) ! + real(r8) buoy(pcols,pver) + + real(r8) a1(pcols) + real(r8) a2(pcols) + real(r8) estp(pcols) + real(r8) pl(pcols) + real(r8) plexp(pcols) + real(r8) hmax(pcols) + real(r8) hmn(pcols) + real(r8) y(pcols) + + logical plge600(pcols) + integer knt(pcols) + integer lelten(pcols,5) + + real(r8) cp + real(r8) e + real(r8) grav + + integer i + integer k + integer msg + integer n + + real(r8) rd + real(r8) rl +#ifdef PERGRO + real(r8) rhd +#endif +! +!----------------------------------------------------------------------- +! + do n = 1,5 + do i = 1,ncol + lelten(i,n) = pver + capeten(i,n) = 0._r8 + cinten (i,n) = 0._r8 + end do + end do +! + do i = 1,ncol +!+tht: variable LON initialised here (to PVER). +! This hard-wires lowest level where conv. initiation is permitted + !lon(i) = pver +! try something different, e.g. limit PBL ovverride: + lon(i) = min(pver,nint(pblt(i))+2) +!-tht + knt(i) = 0 + lel(i) = pver + mx(i) = lon(i) + cape(i) = 0._r8 + hmax(i) = 0._r8 + end do + + tp(:ncol,:) = t(:ncol,:) + qstp(:ncol,:) = q(:ncol,:) + +!!! RBN - Initialize tv and buoy for output. +!!! tv=tv : tpv=tpv : qstp=q : buoy=0. + if (tht_tweaks) then +!+tht use system constants + tv (:ncol,:) = t(:ncol,:) *(1._r8+q(:ncol,:)/eps1)/ (1._r8+q(:ncol,:)) !+tht + else + tv (:ncol,:) = t(:ncol,:) *(1._r8+1.608_r8*q(:ncol,:))/ (1._r8+q(:ncol,:)) + endif +!-tht + tpv (:ncol,:) = tv(:ncol,:) + buoy(:ncol,:) = 0._r8 + +! +! set "launching" level(mx) to be at maximum moist static energy. +! search for this level stops at planetary boundary layer top. +! +#ifdef PERGRO + do k = pver,msg + 1,-1 + do i = 1,ncol +!+tht: use correct total mse -- moist thermo + !hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) + hmn(i) =(cp+q(i,k)*cpliq)*t(i,k)/(1._r8+q(i,k)) + (1._r8+q(i,k)/eps1)/(1._r8+q(i,k))*grav*z(i,k) & + +(rl-(cpliq-cpwv)*(t(i,k)-tfreez))*q(i,k) +!-tht + +! +! Reset max moist static energy level when relative difference exceeds 1.e-4 +! + rhd = (hmn(i) - hmax(i))/(hmn(i) + hmax(i)) + if (k >= nint(pblt(i)) .and. k <= lon(i) .and. rhd > -1.e-4_r8) then + hmax(i) = hmn(i) + mx(i) = k + end if + end do + end do +#else + do k = pver,msg + 1,-1 + do i = 1,ncol +!+tht: use total mse -- moist thermo + !hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k) + hmn(i) =(cp+q(i,k)*cpliq)*t(i,k)/(1._r8+q(i,k)) + (1._r8+q(i,k)/eps1)/(1._r8+q(i,k))*grav*z(i,k) & + +(rl-(cpliq-cpwv)*(t(i,k)-tfreez))*q(i,k) +!-tht + if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then + hmax(i) = hmn(i) + mx(i) = k + end if + end do + end do +#endif + +! LCL dilute calculation - initialize to mx(i) +! Determine lcl in parcel_dilute and get pl,tl after parcel_dilute +! Original code actually sets LCL as level above wher condensate forms. +! Therefore in parcel_dilute lcl(i) will be at first level where qsmix < qtmix. + + do i = 1,ncol ! Initialise LCL variables. + lcl(i) = mx(i) + tl(i) = t(i,mx(i)) + pl(i) = p(i,mx(i)) + end do + +! +! main buoyancy calculation. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!! DILUTE PLUME CALCULATION USING ENTRAINING PLUME !!! +!!! RBN 9/9/04 !!! + +!+tht: add geop.height in argument to allow enthalpy mixing +! call parcel_dilute(lchnk, ncol, msg, mx, p, t, q, & + call parcel_dilute(lchnk, ncol, msg, mx, p, z, t, q, & + tpert, tp, tpv, qstp, pl, tl, lcl, & +! org, landfrac) + org, landfrac, dmpdz) +!-tht + + +! If lcl is above the nominal level of non-divergence (600 mbs), +! no deep convection is permitted (ensuing calculations +! skipped and cape retains initialized value of zero). +! + do i = 1,ncol + plge600(i) = pl(i).ge.plclmin ! Just change to always allow buoy calculation. + end do + +! +! Main buoyancy calculation. +! + do k = pver,msg + 1,-1 + do i=1,ncol + if (k <= mx(i) .and. plge600(i)) then ! Define buoy from launch level to cloud top. + if (tht_tweaks) then + tv(i,k) = t(i,k)* (1._r8+q(i,k)/eps1)/ (1._r8+q(i,k)) !+tht + else + tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k)) !orig + endif +! +0.5K or not? (arbitrary at this point - introduce in parcel_dilute instead? tht) + buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add ! +0.5K or not? + else + qstp(i,k) = q(i,k) + tp(i,k) = t(i,k) + tpv(i,k) = tv(i,k) + endif + end do + end do + + + +!------------------------------------------------------------------------------- +! beginning from one below top (first level p>40hPa, msg) check for at most +! num_cin levels of neutral buoyancy (LELten) and compute CAPEten between LCL +! and those (tht) + do k = msg + 2,pver + do i = 1,ncol + if (k < lcl(i) .and. plge600(i)) then + if (buoy(i,k+1) > 0._r8 .and. buoy(i,k) <= 0._r8) then + knt(i) = min(num_cin,knt(i) + 1) + lelten(i,knt(i)) = k + end if + end if + end do + end do + +! calculate convective available potential energy (cape). + do n = 1,num_cin + do k = msg + 1,pver + do i = 1,ncol + if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then + capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k)) +!+tht also compute total CIN + cinten (i,n) = cinten (i,n) - rd*min(buoy(i,k),0._r8)*log(pf(i,k+1)/pf(i,k)) +!-tht + end if + end do + end do + end do +! +! find maximum cape from all possible tentative capes from +! one sounding, +! and use it as the final cape, april 26, 1995 +! + do n = 1,num_cin + do i = 1,ncol + if (capeten(i,n) > cape(i)) then + cape(i) = capeten(i,n) + cin (i) = cinten (i,n) !+tht CIN + lel(i) = lelten(i,n) + end if + end do + end do +! +! put lower bound on cape for diagnostic purposes. +! + do i = 1,ncol + cape(i) = max(cape(i), 0._r8) + end do +! + return +end subroutine buoyan_dilute + + +!+tht +!subroutine parcel_dilute (lchnk, ncol, msg, klaunch, p, t, q, & + subroutine parcel_dilute (lchnk, ncol, msg, klaunch, p, z, t, q, & + tpert, tp, tpv, qstp, pl, tl, lcl, & +! org, landfrac) + org, landfrac, dmpdz) +!-tht + +! Routine to determine +! 1. Tp - Parcel temperature +! 2. qstp - Saturated mixing ratio at the parcel temperature. + +!-------------------- +implicit none +!-------------------- + +integer, intent(in) :: lchnk +integer, intent(in) :: ncol +integer, intent(in) :: msg + +integer, intent(in), dimension(pcols) :: klaunch(pcols) + +real(r8), intent(in), dimension(pcols,pver) :: p +!+tht +real(r8), intent(in), dimension(pcols,pver) :: z +!-tht +real(r8), intent(in), dimension(pcols,pver) :: t +real(r8), intent(in), dimension(pcols,pver) :: q +real(r8), intent(in), dimension(pcols) :: tpert ! PBL temperature perturbation. + +real(r8), intent(inout), dimension(pcols,pver) :: tp ! Parcel temp. +real(r8), intent(inout), dimension(pcols,pver) :: qstp ! Parcel water vapour (sat value above lcl). +real(r8), intent(inout), dimension(pcols) :: tl ! Actual temp of LCL. +real(r8), intent(inout), dimension(pcols) :: pl ! Actual pressure of LCL. + +integer, intent(inout), dimension(pcols) :: lcl ! Lifting condesation level (first model level with saturation). + +real(r8), intent(out), dimension(pcols,pver) :: tpv ! Define tpv within this routine. + +real(r8), pointer, dimension(:,:) :: org +real(r8), intent(in), dimension(pcols) :: landfrac + +!+tht +!real(r8), dimension(pcols) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 2D + real(r8), dimension(pcols,pver) :: dmpdz ! Parcel fractional mass entrainment rate (/m) 3D +!-tht + +!-------------------- + +! Have to be careful as s is also dry static energy. +!+tht +! in the mods below, s is used both as enthalpy (moist s.e.) and entropy +!-tht + +! If we are to retain the fact that CAM loops over grid-points in the internal +! loop then we need to dimension sp,atp,mp,xsh2o with ncol. + + +real(r8) tmix(pcols,pver) ! Tempertaure of the entraining parcel. +real(r8) qtmix(pcols,pver) ! Total water of the entraining parcel. +real(r8) qsmix(pcols,pver) ! Saturated mixing ratio at the tmix. +real(r8) smix(pcols,pver) ! Entropy of the entraining parcel. +real(r8) xsh2o(pcols,pver) ! Precipitate lost from parcel. +real(r8) ds_xsh2o(pcols,pver) ! Entropy change due to loss of condensate. +real(r8) ds_freeze(pcols,pver) ! Entropy change sue to freezing of precip. +real(r8) dmpdz2d(pcols,pver) ! variable detrainment rate + +!+tht +real(r8) zl(pcols) ! lcl +!-tht + +real(r8) mp(pcols) ! Parcel mass flux. +real(r8) qtp(pcols) ! Parcel total water. +real(r8) sp(pcols) ! Parcel entropy. + +real(r8) sp0(pcols) ! Parcel launch entropy. +real(r8) qtp0(pcols) ! Parcel launch total water. +real(r8) mp0(pcols) ! Parcel launch relative mass flux. + +real(r8) lwmax ! Maximum condesate that can be held in cloud before rainout. +real(r8) dmpdp ! Parcel fractional mass entrainment rate (/mb). +!real(r8) dmpdpc ! In cloud parcel mass entrainment rate (/mb). +!real(r8) dmpdz ! Parcel fractional mass entrainment rate (/m) +real(r8) dpdz,dzdp ! Hydrstatic relation and inverse of. +real(r8) senv ! Environmental entropy at each grid point. +real(r8) qtenv ! Environmental total water " " ". +real(r8) penv ! Environmental total pressure " " ". +!+tht +real(r8) zenv +!-tht +real(r8) tenv ! Environmental total temperature " " ". +real(r8) new_s ! Hold value for entropy after condensation/freezing adjustments. +real(r8) new_q ! Hold value for total water after condensation/freezing adjustments. +real(r8) dp ! Layer thickness (center to center) +real(r8) tfguess ! First guess for entropy inversion - crucial for efficiency! +real(r8) tscool ! Super cooled temperature offset (in degC) (eg -35). + +real(r8) qxsk, qxskp1 ! LCL excess water (k, k+1) +real(r8) dsdp, dqtdp, dqxsdp ! LCL s, qt, p gradients (k, k+1) +real(r8) slcl,qtlcl,qslcl ! LCL s, qt, qs values. +real(r8) org2rkm, org2Tpert +real(r8) dmpdz_lnd, dmpdz_mask + +integer rcall ! Number of ientropy call for errors recording +integer nit_lheat ! Number of iterations for condensation/freezing loop. +integer i,k,ii ! Loop counters. + +real(r8) est + +!====================================================================== +! SUMMARY +! +! 9/9/04 - Assumes parcel is initiated from level of maxh (klaunch) +! and entrains at each level with a specified entrainment rate. +! +! 15/9/04 - Calculates lcl(i) based on k where qsmix is first < qtmix. +! +!====================================================================== +! +! Set some values that may be changed frequently. +! + +if (zm_org) then + org2rkm = 10._r8 + org2Tpert = 0._r8 +endif + +nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing. + +!+tht should not be necessary but for bit-reproducibility it turns out it is + if (.not.tht_tweaks) then + dmpdz =-tentrm ! Entrainment rate. (-ve for /m) + dmpdz_lnd=-tentr_lnd ! idem, on land + endif +!-tht + +!dmpdpc = 3.e-2_r8 ! In cloud entrainment rate (/mb). + + lwmax = 1.e-3_r8 ! Need to put formula in for this. + tscool = 0.0_r8 ! Temp at which water loading freezes in the cloud. +!+tht +!lwmax = 1.e10_r8 ! tht: don't precipitate +!tscool =-10._r8 ! tht: allow even just mild supercooling?! +!-tht + +qtmix=0._r8 +smix=0._r8 + +qtenv = 0._r8 +senv = 0._r8 +tenv = 0._r8 +penv = 0._r8 +!+tht +zenv = 0._r8 +!-tht + +qtp0 = 0._r8 +sp0 = 0._r8 +mp0 = 0._r8 + +qtp = 0._r8 +sp = 0._r8 +mp = 0._r8 + +new_q = 0._r8 +new_s = 0._r8 + +zl(:)=0._r8 + +! **** Begin loops **** + +do k = pver, msg+1, -1 + do i=1,ncol + +! Initialize parcel values at launch level. + + if (k == klaunch(i)) then + qtp0(i) = q(i,k) ! Parcel launch total water (assuming subsaturated) - OK????. + +!+tht: formulate dilution on enthalpy not on entropy + if (tht_tweaks) then + sp0(i) = enthalpy(t(i,k),p(i,k),qtp0(i),z(i,k)) ! Parcel launch enthalpy. + else + sp0(i) = entropy (t(i,k),p(i,k),qtp0(i)) ! Parcel launch entropy. + endif +!-tht + mp0(i) = 1._r8 ! Parcel launch relative mass (=1 for dmpdp=0 i.e. undilute). + smix(i,k) = sp0(i) + qtmix(i,k) = qtp0(i) +!+tht: since the function to invert for T is *identical* with sp0(i)=entropy(t), unless there is +! a coding error (likely, given the mess) the result must be t(i,k) (verified 21/2/2014) + if (tht_tweaks) then + tmix(i,k) = t(i,k) + call qsat_hPa(tmix(i,k),p(i,k), est, qsmix(i,k)) + else + tfguess = t(i,k) + rcall = 1 + call ientropy (rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess) + endif +!-tht + end if + +! Entraining levels + + if (k < klaunch(i)) then + +! Set environmental values for this level. + + dp = (p(i,k)-p(i,k+1)) ! In -ve mb as p decreasing with height - difference between center of layers. + qtenv = 0.5_r8*(q(i,k)+q(i,k+1)) ! Total water of environment. + tenv = 0.5_r8*(t(i,k)+t(i,k+1)) + penv = 0.5_r8*(p(i,k)+p(i,k+1)) +!+tht + zenv = 0.5_r8*(z(i,k)+z(i,k+1)) +!-tht + +!+tht: base plume dilution on enthalpy not on entropy + if (tht_tweaks) then + senv = enthalpy(tenv,penv,qtenv,zenv) ! Enthalpy of environment. + else + senv = entropy (tenv,penv,qtenv) ! Entropy of environment. + endif +!-tht + +! Determine fractional entrainment rate /pa given value /m. + + dpdz = -(penv*grav)/(rgas*tenv) ! in mb/m since p in mb. + dzdp = 1._r8/dpdz ! in m/mb + if (zm_org) then +!+tht +! NB: land fudge makes no sense to me - make dmpdz_lnd=dmpdz (as per default code, hard-wired to 1e-3) + !dmpdz_mask=dmpdz + !dmpdz_mask=dmpdz(i) + dmpdz_mask=dmpdz(i,k) + if (tht_tweaks) dmpdz_lnd=dmpdz_mask + dmpdz_mask = landfrac(i) * dmpdz_lnd + (1._r8 - landfrac(i)) * dmpdz_mask + dmpdp = (dmpdz_mask/(1._r8+org(i,k)*org2rkm))*dzdp ! /mb Fractional entrainment + else + !dmpdp = dmpdz*dzdp + !dmpdp = dmpdz(i)*dzdp ! /mb Fractional entrainment 2D + dmpdp = dmpdz(i,k)*dzdp ! /mb Fractional entrainment 3D +!-tht + endif + +! Sum entrainment to current level +! entrains q,s out of intervening dp layers, in which linear variation is assumed +! so really it entrains the mean of the 2 stored values. + + sp(i) = sp(i) - dmpdp*dp*senv + qtp(i) = qtp(i) - dmpdp*dp*qtenv + mp(i) = mp(i) - dmpdp*dp + +! Entrain s and qt to next level. + + smix(i,k) = (sp0(i) + sp(i)) / (mp0(i) + mp(i)) + qtmix(i,k) = (qtp0(i) + qtp(i)) / (mp0(i) + mp(i)) + +! Invert entropy from s and q to determine T and saturation-capped q of mixture. +! t(i,k) used as a first guess so that it converges faster. + + tfguess = tmix(i,k+1) + rcall = 2 +!+tht + if (tht_tweaks) then + call ienthalpy(rcall,i,lchnk,smix(i,k),p(i,k),z(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess) + else + call ientropy (rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess) + endif +!-tht + +! +! Determine if this is lcl of this column if qsmix <= qtmix. +! FIRST LEVEL where this happens on ascending. + if (qsmix(i,k) <= qtmix(i,k) .and. qsmix(i,k+1) > qtmix(i,k+1)) then + lcl(i) = k + qxsk = qtmix(i,k) - qsmix(i,k) + qxskp1 = qtmix(i,k+1) - qsmix(i,k+1) + dqxsdp = (qxsk - qxskp1)/dp + pl(i) = p(i,k+1) - qxskp1/dqxsdp ! pressure level of actual lcl. +!+tht + zl(i) = z(i,k+1) - qxskp1/dqxsdp *dzdp +!-tht + dsdp = (smix(i,k) - smix(i,k+1))/dp + dqtdp = (qtmix(i,k) - qtmix(i,k+1))/dp + slcl = smix(i,k+1) + dsdp* (pl(i)-p(i,k+1)) + qtlcl = qtmix(i,k+1) + dqtdp*(pl(i)-p(i,k+1)) + + tfguess = tmix(i,k) + rcall = 3 +!+tht + if (tht_tweaks) then + call ienthalpy(rcall,i,lchnk,slcl,pl(i),zl(i),qtlcl,tl(i),qslcl,tfguess) + else + call ientropy (rcall,i,lchnk,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess) + endif +!-tht + +! write(iulog,*)' ' +! write(iulog,*)' p',p(i,k+1),pl(i),p(i,lcl(i)) +! write(iulog,*)' t',tmix(i,k+1),tl(i),tmix(i,lcl(i)) +! write(iulog,*)' s',smix(i,k+1),slcl,smix(i,lcl(i)) +! write(iulog,*)'qt',qtmix(i,k+1),qtlcl,qtmix(i,lcl(i)) +! write(iulog,*)'qs',qsmix(i,k+1),qslcl,qsmix(i,lcl(i)) + + endif +! + end if ! k < klaunch + + + end do ! Levels loop +end do ! Columns loop + +!!!!!!!!!!!!!!!!!!!!!!!!!!END ENTRAINMENT LOOP!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! Could stop now and test with this as it will provide some estimate of buoyancy +!! without the effects of freezing/condensation taken into account for tmix. + +!! So we now have a profile of entropy and total water of the entraining parcel +!! Varying with height from the launch level klaunch parcel=environment. To the +!! top allowed level for the existence of convection. + +!! Now we have to adjust these values such that the water held in vaopor is < or +!! = to qsmix. Therefore, we assume that the cloud holds a certain amount of +!! condensate (lwmax) and the rest is rained out (xsh2o). This, obviously +!! provides latent heating to the mixed parcel and so this has to be added back +!! to it. But does this also increase qsmix as well? Also freezing processes + + +xsh2o = 0._r8 +ds_xsh2o = 0._r8 +ds_freeze = 0._r8 + +!!!!!!!!!!!!!!!!!!!!!!!!!PRECIPITATION/FREEZING LOOP!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Iterate solution twice for accuracy + + + +do k = pver, msg+1, -1 + do i=1,ncol + +! Initialize variables at k=klaunch + + if (k == klaunch(i)) then + +! Set parcel values at launch level assume no liquid water. + + tp(i,k) = tmix(i,k) + qstp(i,k) = q(i,k) + if (zm_org) then + if (tht_tweaks) then + tpv(i,k) = (tp(i,k) + (org2Tpert*org(i,k)+tpert(i))) * (1._r8+qstp(i,k)/eps1) / (1._r8+qstp(i,k)) !+tht + else + tpv(i,k) = (tp(i,k) + (org2Tpert*org(i,k)+tpert(i))) * (1._r8+1.608_r8*qstp(i,k)) / (1._r8+qstp(i,k)) + endif + else + if (tht_tweaks) then + tpv(i,k) = (tp(i,k) + tpert(i)) * (1._r8+qstp(i,k)/eps1) / (1._r8+qstp(i,k)) !+tht OK with mx ratio + else + tpv(i,k) = (tp(i,k) + tpert(i)) * (1._r8+1.608_r8*qstp(i,k)) / (1._r8+qstp(i,k)) + endif + endif + + end if + + if (k < klaunch(i)) then + + if (tht_tweaks) then + smix(i,k)=entropy(tmix(i,k),p(i,k),qtmix(i,k)) !+tht make sure to use entropy here + endif + +!---- +! Initiate loop if switch(2) = .T. - RBN:DILUTE - TAKEN OUT BUT COULD BE RETURNED LATER. +! Iterate nit_lheat times for s,qt changes. + do ii=0,nit_lheat-1 + +! Rain (xsh2o) is excess condensate, bar LWMAX (Accumulated loss from qtmix). + xsh2o(i,k) = max (0._r8, qtmix(i,k) - qsmix(i,k) - lwmax) + +! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve) + ds_xsh2o(i,k) = ds_xsh2o(i,k+1) - cpliq * log (tmix(i,k)/tfreez) * max(0._r8,(xsh2o(i,k)-xsh2o(i,k+1))) +! +! Entropy of freezing: latice times amount of water involved divided by T. +! + if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) == 0._r8) then ! One off freezing of condensate. + ds_freeze(i,k) = (latice/tmix(i,k)) * max(0._r8,qtmix(i,k)-qsmix(i,k)-xsh2o(i,k)) ! Gain of LH + end if + + if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) /= 0._r8) then ! Continual freezing of additional condensate. + ds_freeze(i,k) = ds_freeze(i,k+1)+(latice/tmix(i,k)) * max(0._r8,(qsmix(i,k+1)-qsmix(i,k))) + end if + +! Adjust entropy and accordingly to sum of ds (be careful of signs). + new_s = smix(i,k) + ds_xsh2o(i,k) + ds_freeze(i,k) + +! Adjust liquid water and accordingly to xsh2o. + new_q = qtmix(i,k) - xsh2o(i,k) + +! Invert entropy to get updated Tmix and qsmix of parcel. + + tfguess = tmix(i,k) + rcall =4 + call ientropy (rcall,i,lchnk,new_s, p(i,k), new_q, tmix(i,k), qsmix(i,k), tfguess) + + end do ! Iteration loop for freezing processes. + +! tp - Parcel temp is temp of mixture. +! tpv - Parcel v. temp should be density temp with new_q total water. + + tp(i,k) = tmix(i,k) + +! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix) + if (new_q > qsmix(i,k)) then ! Super-saturated so condensate present - reduces buoyancy. + qstp(i,k) = qsmix(i,k) + else ! Just saturated/sub-saturated - no condensate virtual effects. + qstp(i,k) = new_q + end if + + if (zm_org) then + if (tht_tweaks) then + tpv(i,k) = (tp(i,k)+(org2Tpert*org(i,k)+tpert(i)))* (1._r8+qstp(i,k)/eps1) / (1._r8+ new_q) !+tht + else + tpv(i,k) = (tp(i,k)+(org2Tpert*org(i,k)+tpert(i)))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+ new_q) + endif + else + if (tht_tweaks) then + tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+qstp(i,k)/eps1) / (1._r8+ new_q) !+tht + else + tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+ new_q) + endif + endif + + end if ! k < klaunch + + end do ! Loop for columns + +end do ! Loop for vertical levels. + + +return +end subroutine parcel_dilute + +!----------------------------------------------------------------------------------------- +real(r8) function entropy(TK,p,qtot) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! from Raymond and Blyth 1992 +! + real(r8), intent(in) :: p,qtot,TK + real(r8) :: qv,qst,e,est,L + real(r8), parameter :: pref = 1000._r8 + +L = rl - (cpliq - cpwv)*(TK-tfreez) ! T IN CENTIGRADE + +call qsat_hPa(TK, p, est, qst) + +qv = min(qtot,qst) ! Partition qtot into vapor part only. +e = qv*p / (eps1 +qv) + +entropy = (cpres + qtot*cpliq)*log( TK/tfreez) - rgas*log( (p-e)/pref ) + & + L*qv/TK - qv*rh2o*log(qv/qst) + +end FUNCTION entropy + +! +!----------------------------------------------------------------------------------------- +SUBROUTINE ientropy (rcall,icol,lchnk,s,p,qt,T,qst,Tfg) +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts entropy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + use phys_grid, only: get_rlon_p, get_rlat_p + + integer, intent(in) :: icol, lchnk, rcall + real(r8), intent(in) :: s, p, Tfg, qt + real(r8), intent(out) :: qst, T + real(r8) :: est, this_lat,this_lon + real(r8) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(r8), parameter :: EPS = 3.e-8_r8 + + converged = .false. + + ! Invert the entropy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = entropy(a, p, qt) - s + fb = entropy(b, p, qt) - s + + c=b + fc=fb + tol=0.001_r8 + + converge: do i=0, LOOPMAX + if ((fb > 0.0_r8 .and. fc > 0.0_r8) .or. & + (fb < 0.0_r8 .and. fc < 0.0_r8)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_r8*EPS*abs(b)+0.5_r8*tol + xm=0.5_r8*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_r8) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_r8*xm*sbr + qbr=1.0_r8-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_r8*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_r8)) + qbr=(qbr-1.0_r8)*(rbr-1.0_r8)*(sbr-1.0_r8) + end if + if (pbr > 0.0_r8) qbr=-qbr + pbr=abs(pbr) + if (2.0_r8*pbr < min(3.0_r8*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = entropy(b, p, qt) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + this_lat = get_rlat_p(lchnk, icol)*57.296_r8 + this_lon = get_rlon_p(lchnk, icol)*57.296_r8 + write(iulog,*) '*** ZM_CONV: IENTROPY: Failed and about to exit, info follows ****' + write(iulog,100) 'ZM_CONV: IENTROPY. Details: call#,lchnk,icol= ',rcall,lchnk,icol, & + ' lat: ',this_lat,' lon: ',this_lon, & + ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._r8*qt, & + ' qst(g/kg) = ', 1000._r8*qst,', s(J/kg) = ',s + call endrun('**** ZM_CONV IENTROPY: Tmix did not converge ****') + end if + +100 format (A,I1,I4,I4,7(A,F6.2)) + +end SUBROUTINE ientropy + +! Wrapper for qsat_water that does translation between Pa and hPa +! qsat_water uses Pa internally, so get it right, need to pass in Pa. +! Afterward, set es back to hPa. +elemental subroutine qsat_hPa(t, p, es, qm) + use wv_saturation, only: qsat_water + + ! Inputs + real(r8), intent(in) :: t ! Temperature (K) + real(r8), intent(in) :: p ! Pressure (hPa) + ! Outputs + real(r8), intent(out) :: es ! Saturation vapor pressure (hPa) + real(r8), intent(out) :: qm ! Saturation mass mixing ratio + ! (vapor mass over dry mass, kg/kg) + + call qsat_water(t, p*100._r8, es, qm) + + es = es*0.01_r8 + +end subroutine qsat_hPa + +!----------------------------------------------------------------------------------------- +real(r8) function enthalpy(TK,p,qtot,z) +!----------------------------------------------------------------------------------------- +! +! TK(K),p(mb),qtot(kg/kg) +! + real(r8), intent(in) :: p,qtot,TK,z + real(r8) :: qv,qst,e,est,L + +L = rl - (cpliq - cpwv)*(TK-tfreez) + +call qsat_hPa(TK, p, est, qst) +qv = min(qtot,qst) ! Partition qtot into vapor part only. + +!enthalpy = (cpres + qtot*cpliq)*(TK-tfreez) + L*qv + (1._r8+qtot)*grav*z + enthalpy = (cpres + qtot*cpliq)* TK + L*qv + (1._r8+qtot)*grav*z + +return +end FUNCTION enthalpy + +!----------------------------------------------------------------------------------------- + SUBROUTINE ienthalpy (rcall,icol,lchnk,s,p,z,qt,T,qst,Tfg) !identical with iENTROPY, only function calls swapped +!----------------------------------------------------------------------------------------- +! +! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). +! Inverts entropy, pressure and total water qt +! for T and saturated vapor mixing ratio +! + + use phys_grid, only: get_rlon_p, get_rlat_p + + integer, intent(in) :: icol, lchnk, rcall + real(r8), intent(in) :: s, p, z, Tfg, qt + real(r8), intent(out) :: qst, T + real(r8) :: est, this_lat,this_lon + real(r8) :: a,b,c,d,ebr,fa,fb,fc,pbr,qbr,rbr,sbr,tol1,xm,tol + integer :: i + + logical :: converged + + ! Max number of iteration loops. + integer, parameter :: LOOPMAX = 100 + real(r8), parameter :: EPS = 3.e-8_r8 + + converged = .false. + + ! Invert the entropy equation -- use Brent's method + ! Brent, R. P. Ch. 3-4 in Algorithms for Minimization Without Derivatives. Englewood Cliffs, NJ: Prentice-Hall, 1973. + + T = Tfg ! Better first guess based on Tprofile from conv. + + a = Tfg-10 !low bracket + b = Tfg+10 !high bracket + + fa = enthalpy(a, p, qt,z) - s + fb = enthalpy(b, p, qt,z) - s + + c=b + fc=fb + tol=0.001_r8 + + converge: do i=0, LOOPMAX + if ((fb > 0.0_r8 .and. fc > 0.0_r8) .or. & + (fb < 0.0_r8 .and. fc < 0.0_r8)) then + c=a + fc=fa + d=b-a + ebr=d + end if + if (abs(fc) < abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + tol1=2.0_r8*EPS*abs(b)+0.5_r8*tol + xm=0.5_r8*(c-b) + converged = (abs(xm) <= tol1 .or. fb == 0.0_r8) + if (converged) exit converge + + if (abs(ebr) >= tol1 .and. abs(fa) > abs(fb)) then + sbr=fb/fa + if (a == c) then + pbr=2.0_r8*xm*sbr + qbr=1.0_r8-sbr + else + qbr=fa/fc + rbr=fb/fc + pbr=sbr*(2.0_r8*xm*qbr*(qbr-rbr)-(b-a)*(rbr-1.0_r8)) + qbr=(qbr-1.0_r8)*(rbr-1.0_r8)*(sbr-1.0_r8) + end if + if (pbr > 0.0_r8) qbr=-qbr + pbr=abs(pbr) + if (2.0_r8*pbr < min(3.0_r8*xm*qbr-abs(tol1*qbr),abs(ebr*qbr))) then + ebr=d + d=pbr/qbr + else + d=xm + ebr=d + end if + else + d=xm + ebr=d + end if + a=b + fa=fb + b=b+merge(d,sign(tol1,xm), abs(d) > tol1 ) + + fb = enthalpy(b, p, qt,z) - s + + end do converge + + T = b + call qsat_hPa(T, p, est, qst) + + if (.not. converged) then + this_lat = get_rlat_p(lchnk, icol)*57.296_r8 + this_lon = get_rlon_p(lchnk, icol)*57.296_r8 + write(iulog,*) '*** ZM_CONV: IENTHALPY: Failed and about to exit, info follows ****' + write(iulog,100) 'ZM_CONV: IENTHALPY. Details: call#,lchnk,icol= ',rcall,lchnk,icol, & + ' lat: ',this_lat,' lon: ',this_lon, & + ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._r8*qt, & + ' qst(g/kg) = ', 1000._r8*qst,', s(J/kg) = ',s + call endrun('**** ZM_CONV IENTHALPY: Tmix did not converge ****') + end if + +100 format (A,I1,I4,I4,7(A,F6.2)) + + end SUBROUTINE ienthalpy + +end module zm_conv diff --git a/src/NorESM/zm_conv_intr.F90 b/src/NorESM/zm_conv_intr.F90 new file mode 100644 index 0000000000..f070cf8a7b --- /dev/null +++ b/src/NorESM/zm_conv_intr.F90 @@ -0,0 +1,1395 @@ +module zm_conv_intr +!--------------------------------------------------------------------------------- +! Purpose: +! +! CAM interface to the Zhang-McFarlane deep convection scheme +! +! Author: D.B. Coleman +! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer +!--------------------------------------------------------------------------------- + use shr_kind_mod, only: r8=>shr_kind_r8 + use physconst, only: cpair + use ppgrid, only: pver, pcols, pverp, begchunk, endchunk + use zm_conv, only: zm_conv_evap, zm_convr, convtran, momtran + use zm_microphysics, only: zm_aero_t, zm_conv_t + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & + rad_cnst_get_aer_props, rad_cnst_get_mode_props !, & + use ndrop_bam, only: ndrop_bam_init + use cam_abortutils, only: endrun + use physconst, only: pi + use spmd_utils, only: masterproc + use perf_mod + use cam_logfile, only: iulog + use constituents, only: cnst_add + + implicit none + private + save + + ! Public methods + + public ::& + zm_conv_register, &! register fields in physics buffer + zm_conv_readnl, &! read namelist + zm_conv_init, &! initialize donner_deep module + zm_conv_tend, &! return tendencies + zm_conv_tend_2 ! return tendencies + + public :: zmconv_microp + + integer ::& ! indices for fields in the physics buffer + zm_mu_idx, & + zm_eu_idx, & + zm_du_idx, & + zm_md_idx, & + zm_ed_idx, & + zm_dp_idx, & + zm_dsubcld_idx, & + zm_jt_idx, & + zm_maxg_idx, & + zm_ideep_idx, & + dp_flxprc_idx, & + dp_flxsnw_idx, & + dp_cldliq_idx, & + ixorg, & + dp_cldice_idx, & + dlfzm_idx, & ! detrained convective cloud water mixing ratio. + difzm_idx, & ! detrained convective cloud ice mixing ratio. + dnlfzm_idx, & ! detrained convective cloud water num concen. + dnifzm_idx, & ! detrained convective cloud ice num concen. + prec_dp_idx, & + snow_dp_idx + + real(r8), parameter :: unset_r8 = huge(1.0_r8) + real(r8) :: zmconv_c0_lnd = unset_r8 + real(r8) :: zmconv_c0_ocn = unset_r8 + real(r8) :: zmconv_ke = unset_r8 + real(r8) :: zmconv_ke_lnd = unset_r8 + real(r8) :: zmconv_momcu = unset_r8 + real(r8) :: zmconv_momcd = unset_r8 + integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed + ! before the convection top and CAPE calculations are completed. + logical :: zmconv_org ! Parameterization for sub-grid scale convective organization for the ZM deep + ! convective scheme based on Mapes and Neale (2011) + logical :: zmconv_microp = .false. ! switch for microphysics + + +! indices for fields in the physics buffer + integer :: cld_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: rprddp_idx = 0 + integer :: fracis_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: dgnum_idx = 0 + + integer :: nmodes + integer :: nbulk + + type(zm_aero_t), allocatable :: aero(:) ! object contains information about the aerosols + +!========================================================================================= +contains +!========================================================================================= + +subroutine zm_conv_register + +!---------------------------------------- +! Purpose: register fields with the physics buffer +!---------------------------------------- + + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + + implicit none + + integer idx + + call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) + call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) + call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) + call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) + call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) + + ! wg layer thickness in mbs (between upper/lower interface). + call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) + + ! wg layer thickness in mbs between lcl and maxi. + call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) + + ! wg top level index of deep cumulus convection. + call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) + + ! wg gathered values of maxi. + call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) + + ! map gathered points to chunk index + call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) + +! Flux of precipitation from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) + +! Flux of snow from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) + +! deep gbm cloud liquid water (kg/kg) + call pbuf_add_field('DP_CLDLIQ','global',dtype_r8,(/pcols,pver/), dp_cldliq_idx) + +! deep gbm cloud liquid water (kg/kg) + call pbuf_add_field('DP_CLDICE','global',dtype_r8,(/pcols,pver/), dp_cldice_idx) + + call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) + call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) + call pbuf_add_field('NEVAPR_DPCU','physpkg',dtype_r8,(/pcols,pver/),nevapr_dpcu_idx) + call pbuf_add_field('PREC_DP', 'physpkg',dtype_r8,(/pcols/), prec_dp_idx) + call pbuf_add_field('SNOW_DP', 'physpkg',dtype_r8,(/pcols/), snow_dp_idx) + + ! detrained convective cloud water mixing ratio. + call pbuf_add_field('DLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dlfzm_idx) + ! detrained convective cloud ice mixing ratio. + call pbuf_add_field('DIFZM', 'physpkg', dtype_r8, (/pcols,pver/), difzm_idx) + + if (zmconv_microp) then + ! Only add the number conc fields if the microphysics is active. + + ! detrained convective cloud water num concen. + call pbuf_add_field('DNLFZM', 'physpkg', dtype_r8, (/pcols,pver/), dnlfzm_idx) + ! detrained convective cloud ice num concen. + call pbuf_add_field('DNIFZM', 'physpkg', dtype_r8, (/pcols,pver/), dnifzm_idx) + end if + + if (zmconv_org) then + call cnst_add('ZM_ORG',0._r8,0._r8,0._r8,ixorg,longname='organization parameter') + endif + +end subroutine zm_conv_register + +!========================================================================================= + +subroutine zm_conv_readnl(nlfile) + + use spmd_utils, only: mpicom, masterproc, masterprocid, mpi_real8, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'zm_conv_readnl' + + namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_num_cin, & + zmconv_ke, zmconv_ke_lnd, zmconv_org, & + zmconv_momcu, zmconv_momcd, zmconv_microp + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'zmconv_nl', status=ierr) + if (ierr == 0) then + read(unitn, zmconv_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + + end if + + ! Broadcast namelist variables + call mpi_bcast(zmconv_num_cin, 1, mpi_integer, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_num_cin") + call mpi_bcast(zmconv_c0_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_lnd") + call mpi_bcast(zmconv_c0_ocn, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_c0_ocn") + call mpi_bcast(zmconv_ke, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke") + call mpi_bcast(zmconv_ke_lnd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_ke_lnd") + call mpi_bcast(zmconv_momcu, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcu") + call mpi_bcast(zmconv_momcd, 1, mpi_real8, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_momcd") + call mpi_bcast(zmconv_org, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_org") + call mpi_bcast(zmconv_microp, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun("zm_conv_readnl: FATAL: mpi_bcast: zmconv_microp") + +end subroutine zm_conv_readnl + +!========================================================================================= + +subroutine zm_conv_init(pref_edge) + +!---------------------------------------- +! Purpose: declare output fields, initialize variables needed by convection +!---------------------------------------- + + use cam_history, only: addfld, add_default, horiz_only + use ppgrid, only: pcols, pver + use zm_conv, only: zm_convi + use pmgrid, only: plev,plevp + use spmd_utils, only: masterproc + use phys_control, only: phys_deepconv_pbl, phys_getopts, cam_physpkg_is + use physics_buffer, only: pbuf_get_index + + implicit none + + real(r8),intent(in) :: pref_edge(plevp) ! reference pressures at interfaces + + + logical :: no_deep_pbl ! if true, no deep convection in PBL + integer limcnv ! top interface level limit for convection + integer k, istat + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + +! Allocate the basic aero structure outside the zmconv_microp logical +! This allows the aero structure to be passed +! Note that all of the arrays inside this structure are conditionally allocated + + allocate(aero(begchunk:endchunk)) + +! +! Register fields with the output buffer +! + + if (zmconv_org) then + call addfld ('ZM_ORG ', (/ 'lev' /), 'A', '- ','Organization parameter') + call addfld ('ZM_ORG2D ', (/ 'lev' /), 'A', '- ','Organization parameter 2D') + endif + call addfld ('PRECZ', horiz_only, 'A', 'm/s','total precipitation from ZM convection') + call addfld ('ZMDT', (/ 'lev' /), 'A', 'K/s','T tendency - Zhang-McFarlane moist convection') + call addfld ('ZMDQ', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Zhang-McFarlane moist convection') + call addfld ('ZMDICE', (/ 'lev' /), 'A', 'kg/kg/s','Cloud ice tendency - Zhang-McFarlane convection') + call addfld ('ZMDLIQ', (/ 'lev' /), 'A', 'kg/kg/s','Cloud liq tendency - Zhang-McFarlane convection') + call addfld ('EVAPTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Evaporation/snow prod from Zhang convection') + call addfld ('FZSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Rain to snow conversion from Zhang convection') + call addfld ('EVSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Snow to rain prod from Zhang convection') + call addfld ('EVAPQZM', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Evaporation from Zhang-McFarlane moist convection') + + call addfld ('ZMFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of precipitation from ZM convection' ) + call addfld ('ZMFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of snow from ZM convection' ) + call addfld ('ZMNTPRPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net precipitation production from ZM convection') + call addfld ('ZMNTSNPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net snow production from ZM convection' ) + call addfld ('ZMEIHEAT', (/ 'lev' /) , 'A', 'W/kg' ,'Heating by ice and evaporation in ZM convection') + + call addfld ('CMFMCDZM', (/ 'ilev' /), 'A', 'kg/m2/s','Convection mass flux from ZM deep ') + call addfld ('PRECCDZM', horiz_only, 'A', 'm/s','Convective precipitation rate from ZM deep') + + call addfld ('PCONVB', horiz_only , 'A', 'Pa' ,'convection base pressure') + call addfld ('PCONVT', horiz_only , 'A', 'Pa' ,'convection top pressure') + + call addfld ('CAPE', horiz_only, 'A', 'J/kg', 'Convectively available potential energy') + call addfld ('FREQZM', horiz_only , 'A', 'fraction', 'Fractional occurance of ZM convection') + + call addfld ('ZMMTT', (/ 'lev' /), 'A', 'K/s', 'T tendency - ZM convective momentum transport') + call addfld ('ZMMTU', (/ 'lev' /), 'A', 'm/s2', 'U tendency - ZM convective momentum transport') + call addfld ('ZMMTV', (/ 'lev' /), 'A', 'm/s2', 'V tendency - ZM convective momentum transport') + + call addfld ('ZMMU', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection updraft mass flux') + call addfld ('ZMMD', (/ 'lev' /), 'A', 'kg/m2/s', 'ZM convection downdraft mass flux') + + call addfld ('ZMUPGU', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM updraft pressure gradient term') + call addfld ('ZMUPGD', (/ 'lev' /), 'A', 'm/s2', 'zonal force from ZM downdraft pressure gradient term') + call addfld ('ZMVPGU', (/ 'lev' /), 'A', 'm/s2', 'meridional force from ZM updraft pressure gradient term') + call addfld ('ZMVPGD', (/ 'lev' /), 'A', 'm/s2', 'merdional force from ZM downdraft pressure gradient term') + + call addfld ('ZMICUU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U updrafts') + call addfld ('ZMICUD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud U downdrafts') + call addfld ('ZMICVU', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V updrafts') + call addfld ('ZMICVD', (/ 'lev' /), 'A', 'm/s', 'ZM in-cloud V downdrafts') + + call addfld ('DIFZM' ,(/ 'lev' /), 'A','kg/kg/s ','Detrained ice water from ZM convection') + call addfld ('DLFZM' ,(/ 'lev' /), 'A','kg/kg/s ','Detrained liquid water from ZM convection') + +!+tht + !call addfld ('EURT', horiz_only, 'A', '1/m', 'ZM plume ensemble entrainment rate') ! 2D + call addfld ('EURT', (/ 'lev' /), 'A', '1/m', 'ZM plume ensemble entrainment rate') ! 3D +!-tht + + call phys_getopts( history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + if (zmconv_org) then + call add_default('ZM_ORG', 1, ' ') + call add_default('ZM_ORG2D', 1, ' ') + endif + if ( history_budget ) then + call add_default('EVAPTZM ', history_budget_histfile_num, ' ') + call add_default('EVAPQZM ', history_budget_histfile_num, ' ') + call add_default('ZMDT ', history_budget_histfile_num, ' ') + call add_default('ZMDQ ', history_budget_histfile_num, ' ') + call add_default('ZMDLIQ ', history_budget_histfile_num, ' ') + call add_default('ZMDICE ', history_budget_histfile_num, ' ') + call add_default('ZMMTT ', history_budget_histfile_num, ' ') + end if + + if (zmconv_microp) then + call add_default ('DIFZM', 1, ' ') + call add_default ('DLFZM', 1, ' ') + end if +! +! Limit deep convection to regions below 40 mb +! Note this calculation is repeated in the shallow convection interface +! + limcnv = 0 ! null value to check against below + if (pref_edge(1) >= 4.e3_r8) then + limcnv = 1 + else + do k=1,plev + if (pref_edge(k) < 4.e3_r8 .and. pref_edge(k+1) >= 4.e3_r8) then + limcnv = k + exit + end if + end do + if ( limcnv == 0 ) limcnv = plevp + end if + + if (masterproc) then + write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & + ' which is ',pref_edge(limcnv),' pascals' + end if + + no_deep_pbl = phys_deepconv_pbl() + call zm_convi(limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & + zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & + zmconv_microp, no_deep_pbl_in = no_deep_pbl) + + cld_idx = pbuf_get_index('CLD') + fracis_idx = pbuf_get_index('FRACIS') + + if (zmconv_microp) call zm_conv_micro_init() + +end subroutine zm_conv_init +!========================================================================================= +!subroutine zm_conv_tend(state, ptend, tdt) + +subroutine zm_conv_tend(pblh ,mcon ,cme , & + tpert ,pflx ,zdu , & + rliq ,rice ,ztodt , & + jctop ,jcbot , & + state ,ptend_all ,landfrac, pbuf) + + + use cam_history, only: outfld + use physics_types, only: physics_state, physics_ptend + use physics_types, only: physics_ptend_init, physics_update + use physics_types, only: physics_state_copy, physics_state_dealloc + use physics_types, only: physics_ptend_sum, physics_ptend_dealloc + + use phys_grid, only: get_lat_p, get_lon_p + use time_manager, only: get_nstep, is_first_step + use physics_buffer, only : pbuf_get_field, physics_buffer_desc, pbuf_old_tim_idx + use constituents, only: pcnst, cnst_get_ind, cnst_is_convtran1 + use check_energy, only: check_energy_chng + use physconst, only: gravit + use phys_control, only: cam_physpkg_is + + ! Arguments + + type(physics_state), intent(in),target :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend_all ! individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height + real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess + real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac + + real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c + real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level + real(r8), intent(out) :: cme(pcols,pver) ! cmf condensation - evaporation + real(r8), intent(out) :: zdu(pcols,pver) ! detraining mass flux + + real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals + real(r8), intent(out) :: rice(pcols) ! reserved ice (not yet in cldice) for energy integrals + + + ! Local variables + + type(zm_conv_t) :: conv + + integer :: i,k,l,m + integer :: ilon ! global longitude index of a column + integer :: ilat ! global latitude index of a column + integer :: nstep + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: itim_old ! for physics buffer fields + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + real(r8) :: ntprprd(pcols,pver) ! evap outfld: net precip production in layer + real(r8) :: ntsnprd(pcols,pver) ! evap outfld: net snow production in layer + real(r8) :: tend_s_snwprd (pcols,pver) ! Heating rate of snow production + real(r8) :: tend_s_snwevmlt(pcols,pver) ! Heating rate of evap/melting of snow + real(r8) :: fake_dpdry(pcols,pver) ! used in convtran call + + ! physics types + type(physics_state) :: state1 ! locally modify for evaporation to use, not returned + type(physics_ptend),target :: ptend_loc ! package tendencies + + ! physics buffer fields + real(r8), pointer, dimension(:) :: prec ! total precipitation + real(r8), pointer, dimension(:) :: snow ! snow from ZM convection + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. + real(r8), pointer, dimension(:,:) :: rprd ! rain production rate + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + real(r8), pointer, dimension(:,:) :: evapcdp ! Evaporation of deep convective precipitation + real(r8), pointer, dimension(:,:) :: flxprec ! Convective-scale flux of precip at interfaces (kg/m2/s) + real(r8), pointer, dimension(:,:) :: flxsnow ! Convective-scale flux of snow at interfaces (kg/m2/s) + real(r8), pointer, dimension(:,:) :: dp_cldliq + real(r8), pointer, dimension(:,:) :: dp_cldice + real(r8), pointer :: dlf(:,:) ! detrained convective cloud water mixing ratio. + real(r8), pointer :: dif(:,:) ! detrained convective cloud ice mixing ratio. + real(r8), pointer :: dnlf(:,:) ! detrained convective cloud water num concen. + real(r8), pointer :: dnif(:,:) ! detrained convective cloud ice num concen. + real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr + real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr + + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + integer :: lengath + + real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. + real(r8) :: jcbot(pcols) ! o row of base of cloud indices passed out. + + real(r8) :: pcont(pcols), pconb(pcols), freqzm(pcols) + +!+tht + !real(r8) :: eurt(pcols) !+tht: entr.rate 2D + real(r8) :: eurt(pcols,pver) !+tht: entr.rate 3D +!-tht + + ! history output fields + real(r8) :: cape(pcols) ! w convective available potential energy. + real(r8) :: mu_out(pcols,pver) + real(r8) :: md_out(pcols,pver) + + ! used in momentum transport calculation + real(r8) :: winds(pcols, pver, 2) + real(r8) :: wind_tends(pcols, pver, 2) + real(r8) :: pguall(pcols, pver, 2) + real(r8) :: pgdall(pcols, pver, 2) + real(r8) :: icwu(pcols,pver, 2) + real(r8) :: icwd(pcols,pver, 2) + real(r8) :: seten(pcols, pver) + logical :: l_windt(2) + real(r8) :: tfinal1, tfinal2 + integer :: ii + + real(r8),pointer :: zm_org2d(:,:) + real(r8),pointer :: orgt(:,:), org(:,:) + + logical :: lq(pcnst) + + !---------------------------------------------------------------------- + + ! initialize + lchnk = state%lchnk + ncol = state%ncol + nstep = get_nstep() + + if (zmconv_microp) then + allocate( & + conv%qi(pcols,pver), & + conv%qliq(pcols,pver), & + conv%qice(pcols,pver), & + conv%wu(pcols,pver), & + conv%sprd(pcols,pver), & + conv%qrain(pcols,pver), & + conv%qsnow(pcols,pver), & + conv%qnl(pcols,pver), & + conv%qni(pcols,pver), & + conv%qnr(pcols,pver), & + conv%qns(pcols,pver), & + conv%frz(pcols,pver), & + conv%autolm(pcols,pver), & + conv%accrlm(pcols,pver), & + conv%bergnm(pcols,pver), & + conv%fhtimm(pcols,pver), & + conv%fhtctm(pcols,pver), & + conv%fhmlm (pcols,pver), & + conv%hmpim (pcols,pver), & + conv%accslm(pcols,pver), & + conv%dlfm (pcols,pver), & + conv%autoln(pcols,pver), & + conv%accrln(pcols,pver), & + conv%bergnn(pcols,pver), & + conv%fhtimn(pcols,pver), & + conv%fhtctn(pcols,pver), & + conv%fhmln (pcols,pver), & + conv%accsln(pcols,pver), & + conv%activn(pcols,pver), & + conv%dlfn (pcols,pver), & + conv%autoim(pcols,pver), & + conv%accsim(pcols,pver), & + conv%difm (pcols,pver), & + conv%nuclin(pcols,pver), & + conv%autoin(pcols,pver), & + conv%accsin(pcols,pver), & + conv%hmpin (pcols,pver), & + conv%difn (pcols,pver), & + conv%cmel (pcols,pver), & + conv%cmei (pcols,pver), & + conv%trspcm(pcols,pver), & + conv%trspcn(pcols,pver), & + conv%trspim(pcols,pver), & + conv%trspin(pcols,pver), & + conv%lambdadpcu(pcols,pver), & + conv%mudpcu(pcols,pver), & + conv%dcape(pcols) ) + end if + + ftem = 0._r8 + mu_out(:,:) = 0._r8 + md_out(:,:) = 0._r8 + wind_tends(:ncol,:pver,:) = 0.0_r8 + + call physics_state_copy(state,state1) ! copy state to local state1. + + lq(:) = .FALSE. + lq(1) = .TRUE. + if (zmconv_org) then + lq(ixorg) = .TRUE. + endif + call physics_ptend_init(ptend_loc, state%psetcols, 'zm_convr', ls=.true., lq=lq)! initialize local ptend type + +! +! Associate pointers with physics buffer fields +! + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, icwmrdp_idx, ql ) + call pbuf_get_field(pbuf, rprddp_idx, rprd ) + call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + call pbuf_get_field(pbuf, prec_dp_idx, prec ) + call pbuf_get_field(pbuf, snow_dp_idx, snow ) + + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + call pbuf_get_field(pbuf, zm_jt_idx, jt) + call pbuf_get_field(pbuf, zm_maxg_idx, maxg) + call pbuf_get_field(pbuf, zm_ideep_idx, ideep) + + call pbuf_get_field(pbuf, dlfzm_idx, dlf) + call pbuf_get_field(pbuf, difzm_idx, dif) + + if (zmconv_microp) then + call pbuf_get_field(pbuf, dnlfzm_idx, dnlf) + call pbuf_get_field(pbuf, dnifzm_idx, dnif) + else + allocate(dnlf(pcols,pver), dnif(pcols,pver)) + end if + + if (zmconv_microp) then + + if (nmodes > 0) then + + ! Associate pointers with the modes and species that affect the climate + ! (list 0) + + do m = 1, nmodes + call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, aero(lchnk)%num_a(m)%val) + call pbuf_get_field(pbuf, dgnum_idx, aero(lchnk)%dgnum(m)%val, start=(/1,1,m/), kount=(/pcols,pver,1/)) + + do l = 1, aero(lchnk)%nspec(m) + call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, aero(lchnk)%mmr_a(l,m)%val) + end do + end do + + else if (nbulk > 0) then + + ! Associate pointers with the bulk aerosols that affect the climate + ! (list 0) + + do m = 1, nbulk + call rad_cnst_get_aer_mmr(0, m, state, pbuf, aero(lchnk)%mmr_bulk(m)%val) + end do + + end if + end if + +! +! Begin with Zhang-McFarlane (1996) convection parameterization +! + call t_startf ('zm_convr') + + if (zmconv_org) then + allocate(zm_org2d(pcols,pver)) + org => state%q(:,:,ixorg) + orgt => ptend_loc%q(:,:,ixorg) + endif + + call zm_convr( lchnk ,ncol , & + state%t ,state%q(:,:,1), prec ,jctop ,jcbot , & + pblh ,state%zm ,state%phis ,state%zi ,ptend_loc%q(:,:,1) , & + ptend_loc%s , state%pmid ,state%pint ,state%pdel , & +! .5_r8*ztodt ,mcon ,cme , cape, & + .5_r8*ztodt ,mcon ,cme , cape, eurt,& !+tht eurt + tpert ,dlf ,pflx ,zdu ,rprd , & + mu, md, du, eu, ed, & +! dp, dsubcld, jt, maxg, ideep, & + dp, dsubcld, jt, maxg, ideep, lengath, & + ql, rliq, landfrac, & + org, orgt, zm_org2d, & + dif, dnlf, dnif, conv, & + aero(lchnk), rice) + +! lengath = count(ideep > 0) + + call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output + + !call outfld('EURT', eurt, pcols, lchnk) !+tht: entr.rate 2D + call outfld('EURT', eurt(1,1), pcols, lchnk) !+tht: entr.rate 3D + +! +! Output fractional occurance of ZM convection +! + freqzm(:) = 0._r8 + do i = 1,lengath + freqzm(ideep(i)) = 1.0_r8 + end do + call outfld('FREQZM ',freqzm ,pcols ,lchnk ) +! +! Convert mass flux from reported mb/s to kg/m^2/s +! + mcon(:ncol,:pver) = mcon(:ncol,:pver) * 100._r8/gravit + + call outfld('CMFMCDZM', mcon, pcols, lchnk) + + ! Store upward and downward mass fluxes in un-gathered arrays + ! + convert from mb/s to kg/m^2/s + do i=1,lengath + do k=1,pver + ii = ideep(i) + mu_out(ii,k) = mu(i,k) * 100._r8/gravit + md_out(ii,k) = md(i,k) * 100._r8/gravit + end do + end do + + call outfld('ZMMU', mu_out, pcols, lchnk) + call outfld('ZMMD', md_out, pcols, lchnk) + + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('ZMDT ',ftem ,pcols ,lchnk ) + call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call t_stopf ('zm_convr') + + call outfld('DIFZM' ,dif ,pcols, lchnk) + call outfld('DLFZM' ,dlf ,pcols, lchnk) + + if (zmconv_microp) call zm_conv_micro_outfld(conv, dnif, dnlf, lchnk, ncol) + + pcont(:ncol) = state%ps(:ncol) + pconb(:ncol) = state%ps(:ncol) + do i = 1,lengath + if (maxg(i).gt.jt(i)) then + pcont(ideep(i)) = state%pmid(ideep(i),jt(i)) ! gathered array (or jctop ungathered) + pconb(ideep(i)) = state%pmid(ideep(i),maxg(i))! gathered array + endif + ! write(iulog,*) ' pcont, pconb ', pcont(i), pconb(i), cnt(i), cnb(i) + end do + call outfld('PCONVT ',pcont ,pcols ,lchnk ) + call outfld('PCONVB ',pconb ,pcols ,lchnk ) + + call physics_ptend_init(ptend_all, state%psetcols, 'zm_conv_tend') + + ! add tendency from this process to tendencies from other processes + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ! initialize ptend for next process + lq(:) = .FALSE. + lq(1) = .TRUE. + if (zmconv_org) then + lq(ixorg) = .TRUE. + endif + call physics_ptend_init(ptend_loc, state1%psetcols, 'zm_conv_evap', ls=.true., lq=lq) + + call t_startf ('zm_conv_evap') +! +! Determine the phase of the precipitation produced and add latent heat of fusion +! Evaporate some of the precip directly into the environment (Sundqvist) +! Allow this to use the updated state1 and the fresh ptend_loc type +! heating and specific humidity tendencies produced +! + + call pbuf_get_field(pbuf, dp_flxprc_idx, flxprec ) + call pbuf_get_field(pbuf, dp_flxsnw_idx, flxsnow ) + call pbuf_get_field(pbuf, dp_cldliq_idx, dp_cldliq ) + call pbuf_get_field(pbuf, dp_cldice_idx, dp_cldice ) + dp_cldliq(:ncol,:) = 0._r8 + dp_cldice(:ncol,:) = 0._r8 + + call zm_conv_evap(state1%ncol,state1%lchnk, & + state1%t,state1%pmid,state1%pdel,state1%q(:pcols,:pver,1), & + landfrac, & + ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, ptend_loc%q(:pcols,:pver,1), & + rprd, cld, ztodt, & + prec, snow, ntprprd, ntsnprd , flxprec, flxsnow, conv%sprd) + + evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) + + if (zmconv_org) then + ptend_loc%q(:ncol,:pver,ixorg) = min(1._r8,max(0._r8,(50._r8*1000._r8*1000._r8*abs(evapcdp(:ncol,:pver))) & + -(state%q(:ncol,:pver,ixorg)/10800._r8))) + ptend_loc%q(:ncol,:pver,ixorg) = (ptend_loc%q(:ncol,:pver,ixorg) - state%q(:ncol,:pver,ixorg))/ztodt + endif + +! +! Write out variables from zm_conv_evap +! + ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair + call outfld('EVAPTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwprd (:ncol,:pver)/cpair + call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) + ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair + call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) + call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call outfld('ZMFLXPRC', flxprec, pcols, lchnk) + call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) + call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) + call outfld('ZMNTSNPD', ntsnprd, pcols, lchnk) + call outfld('ZMEIHEAT', ptend_loc%s, pcols, lchnk) + call outfld('CMFMCDZM ',mcon , pcols ,lchnk ) + call outfld('PRECCDZM ',prec, pcols ,lchnk ) + + + call t_stopf ('zm_conv_evap') + + call outfld('PRECZ ', prec , pcols, lchnk) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + + ! Momentum Transport (non-cam3 physics) + + if ( .not. cam_physpkg_is('cam3')) then + + call physics_ptend_init(ptend_loc, state1%psetcols, 'momtran', ls=.true., lu=.true., lv=.true.) + + winds(:ncol,:pver,1) = state1%u(:ncol,:pver) + winds(:ncol,:pver,2) = state1%v(:ncol,:pver) + + l_windt(1) = .true. + l_windt(2) = .true. + + call t_startf ('momtran') + call momtran (lchnk, ncol, & + l_windt,winds, 2, mu, md, & + du, eu, ed, dp, dsubcld, & + jt, maxg, ideep, 1, lengath, & + nstep, wind_tends, pguall, pgdall, icwu, icwd, ztodt, seten ) + call t_stopf ('momtran') + + ptend_loc%u(:ncol,:pver) = wind_tends(:ncol,:pver,1) + ptend_loc%v(:ncol,:pver) = wind_tends(:ncol,:pver,2) + ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) + + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + ! update physics state type state1 with ptend_loc + call physics_update(state1, ptend_loc, ztodt) + + ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair + if (zmconv_org) then + call outfld('ZM_ORG', state%q(:,:,ixorg), pcols, lchnk) + call outfld('ZM_ORG2D', zm_org2d, pcols, lchnk) + endif + call outfld('ZMMTT', ftem , pcols, lchnk) + call outfld('ZMMTU', wind_tends(1,1,1), pcols, lchnk) + call outfld('ZMMTV', wind_tends(1,1,2), pcols, lchnk) + + ! Output apparent force from pressure gradient + call outfld('ZMUPGU', pguall(1,1,1), pcols, lchnk) + call outfld('ZMUPGD', pgdall(1,1,1), pcols, lchnk) + call outfld('ZMVPGU', pguall(1,1,2), pcols, lchnk) + call outfld('ZMVPGD', pgdall(1,1,2), pcols, lchnk) + + ! Output in-cloud winds + call outfld('ZMICUU', icwu(1,1,1), pcols, lchnk) + call outfld('ZMICUD', icwd(1,1,1), pcols, lchnk) + call outfld('ZMICVU', icwu(1,1,2), pcols, lchnk) + call outfld('ZMICVD', icwd(1,1,2), pcols, lchnk) + + end if + + ! Transport cloud water and ice only + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + lq(:) = .FALSE. + lq(2:) = cnst_is_convtran1(2:) + call physics_ptend_init(ptend_loc, state1%psetcols, 'convtran1', lq=lq) + + + ! dpdry is not used in this call to convtran since the cloud liquid and ice mixing + ! ratios are moist + fake_dpdry(:,:) = 0._r8 + + call t_startf ('convtran1') + call convtran (lchnk, & + ptend_loc%lq,state1%q, pcnst, mu, md, & + du, eu, ed, dp, dsubcld, & + jt,maxg, ideep, 1, lengath, & + nstep, fracis, ptend_loc%q, fake_dpdry, ztodt) + call t_stopf ('convtran1') + + call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) + call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) + + ! add tendency from this process to tend from other processes here + call physics_ptend_sum(ptend_loc,ptend_all, ncol) + + call physics_state_dealloc(state1) + call physics_ptend_dealloc(ptend_loc) + + if (zmconv_org) then + deallocate(zm_org2d) + end if + + if (zmconv_microp) then + deallocate( & + conv%qi, & + conv%qliq, & + conv%qice, & + conv%wu, & + conv%sprd, & + conv%qrain, & + conv%qsnow, & + conv%qnl, & + conv%qni, & + conv%qnr, & + conv%qns, & + conv%frz, & + conv%autolm, & + conv%accrlm, & + conv%bergnm, & + conv%fhtimm, & + conv%fhtctm, & + conv%fhmlm , & + conv%hmpim , & + conv%accslm, & + conv%dlfm , & + conv%autoln, & + conv%accrln, & + conv%bergnn, & + conv%fhtimn, & + conv%fhtctn, & + conv%fhmln , & + conv%accsln, & + conv%activn, & + conv%dlfn , & + conv%autoim, & + conv%accsim, & + conv%difm , & + conv%nuclin, & + conv%autoin, & + conv%accsin, & + conv%hmpin , & + conv%difn , & + conv%cmel , & + conv%cmei , & + conv%trspcm, & + conv%trspcn, & + conv%trspim, & + conv%trspin, & + conv%lambdadpcu, & + conv%mudpcu, & + conv%dcape ) + + else + + deallocate(dnlf, dnif) + + end if + +end subroutine zm_conv_tend +!========================================================================================= + + +subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) + + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use time_manager, only: get_nstep + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc + use constituents, only: pcnst, cnst_is_convtran2 + +! Arguments + type(physics_state), intent(in ) :: state ! Physics state variables + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + +! Local variables + integer :: i, lchnk, istat + integer :: lengath ! number of columns with deep convection + integer :: nstep + + real(r8), dimension(pcols,pver) :: dpdry + + ! physics buffer fields + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) + !----------------------------------------------------------------------------------- + + + call physics_ptend_init(ptend, state%psetcols, 'convtran2', lq=cnst_is_convtran2 ) + + call pbuf_get_field(pbuf, fracis_idx, fracis) + call pbuf_get_field(pbuf, zm_mu_idx, mu) + call pbuf_get_field(pbuf, zm_eu_idx, eu) + call pbuf_get_field(pbuf, zm_du_idx, du) + call pbuf_get_field(pbuf, zm_md_idx, md) + call pbuf_get_field(pbuf, zm_ed_idx, ed) + call pbuf_get_field(pbuf, zm_dp_idx, dp) + call pbuf_get_field(pbuf, zm_dsubcld_idx, dsubcld) + call pbuf_get_field(pbuf, zm_jt_idx, jt) + call pbuf_get_field(pbuf, zm_maxg_idx, maxg) + call pbuf_get_field(pbuf, zm_ideep_idx, ideep) + + lengath = count(ideep > 0) + + lchnk = state%lchnk + nstep = get_nstep() + + if (any(ptend%lq(:))) then + ! initialize dpdry for call to convtran + ! it is used for tracers of dry mixing ratio type + dpdry = 0._r8 + do i = 1, lengath + dpdry(i,:) = state%pdeldry(ideep(i),:)/100._r8 + end do + + call t_startf ('convtran2') + call convtran (lchnk, & + ptend%lq,state%q, pcnst, mu, md, & + du, eu, ed, dp, dsubcld, & + jt, maxg, ideep, 1, lengath, & + nstep, fracis, ptend%q, dpdry, ztodt) + call t_stopf ('convtran2') + end if + +end subroutine zm_conv_tend_2 + +!========================================================================================= + +subroutine zm_conv_micro_init() + + use cam_history, only: addfld, add_default, horiz_only + use ppgrid, only: pcols, pver + use pmgrid, only: plev,plevp + use phys_control, only: cam_physpkg_is + use physics_buffer, only: pbuf_get_index + use zm_microphysics, only: zm_mphyi + + implicit none + + integer :: i + + ! + ! Register fields with the output buffer + ! + call addfld ('ICIMRDP', (/ 'lev' /), 'A','kg/kg', 'Deep Convection in-cloud ice mixing ratio ') + call addfld ('CLDLIQZM',(/ 'lev' /), 'A','g/m3' ,'Cloud liquid water - ZM convection') + call addfld ('CLDICEZM',(/ 'lev' /), 'A','g/m3' ,'Cloud ice water - ZM convection') + call addfld ('CLIQSNUM',(/ 'lev' /), 'A','1' ,'Cloud liquid water sample number - ZM convection') + call addfld ('CICESNUM',(/ 'lev' /), 'A','1' ,'Cloud ice water sample number - ZM convection') + call addfld ('QRAINZM' ,(/ 'lev' /), 'A','g/m3' ,'rain water - ZM convection') + call addfld ('QSNOWZM' ,(/ 'lev' /), 'A','g/m3' ,'snow - ZM convection') + call addfld ('CRAINNUM',(/ 'lev' /), 'A','1' ,'Cloud rain water sample number - ZM convection') + call addfld ('CSNOWNUM',(/ 'lev' /), 'A','1' ,'Cloud snow sample number - ZM convection') + + call addfld ('DNIFZM' ,(/ 'lev' /), 'A','1/kg/s ' ,'Detrained ice water num concen from ZM convection') + call addfld ('DNLFZM' ,(/ 'lev' /), 'A','1/kg/s ' ,'Detrained liquid water num concen from ZM convection') + call addfld ('WUZM' ,(/ 'lev' /), 'A','m/s' ,'vertical velocity - ZM convection') + call addfld ('WUZMSNUM',(/ 'lev' /), 'A','1' ,'vertical velocity sample number - ZM convection') + + call addfld ('QNLZM',(/ 'lev' /), 'A','1/m3' ,'Cloud liquid water number concen - ZM convection') + call addfld ('QNIZM',(/ 'lev' /), 'A','1/m3' ,'Cloud ice number concen - ZM convection') + call addfld ('QNRZM',(/ 'lev' /), 'A','1/m3' ,'Cloud rain water number concen - ZM convection') + call addfld ('QNSZM',(/ 'lev' /), 'A','1/m3' ,'Cloud snow number concen - ZM convection') + + call addfld ('FRZZM',(/ 'lev' /), 'A','1/s' ,'mass tendency due to freezing - ZM convection') + + call addfld ('AUTOL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to autoconversion of droplets to rain') + call addfld ('ACCRL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of droplets by rain') + call addfld ('BERGN_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to Bergeron process') + call addfld ('FHTIM_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to immersion freezing') + call addfld ('FHTCT_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to contact freezing') + call addfld ('FHML_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to homogeneous freezing of droplet') + call addfld ('HMPI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to HM process') + call addfld ('ACCSL_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of droplet by snow') + call addfld ('DLF_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to detrainment of droplet') + call addfld ('COND_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to condensation') + + call addfld ('AUTOL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to autoconversion of droplets to rain') + call addfld ('ACCRL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of droplets by rain') + call addfld ('BERGN_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to Bergeron process') + call addfld ('FHTIM_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to immersion freezing') + call addfld ('FHTCT_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to contact freezing') + call addfld ('FHML_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to homogeneous freezing of droplet') + call addfld ('ACCSL_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of droplet by snow') + call addfld ('ACTIV_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to droplets activation') + call addfld ('DLF_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to detrainment of droplet') + + call addfld ('AUTOI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to autoconversion of ice to snow') + call addfld ('ACCSI_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to accretion of ice by snow') + call addfld ('DIF_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to detrainment of cloud ice') + call addfld ('DEPOS_M' ,(/ 'lev' /), 'A','kg/kg/m' ,'mass tendency due to deposition') + + call addfld ('NUCLI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to ice nucleation') + call addfld ('AUTOI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to autoconversion of ice to snow') + call addfld ('ACCSI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to accretion of ice by snow') + call addfld ('HMPI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to HM process') + call addfld ('DIF_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency due to detrainment of cloud ice') + + call addfld ('TRSPC_M' ,(/ 'lev' /), 'A','kg/kg/m','mass tendency of droplets due to convective transport') + call addfld ('TRSPC_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency of droplets due to convective transport') + call addfld ('TRSPI_M' ,(/ 'lev' /), 'A','kg/kg/m','mass tendency of ice crystal due to convective transport') + call addfld ('TRSPI_N' ,(/ 'lev' /), 'A','1/kg/m' ,'num tendency of ice crystal due to convective transport') + + + call add_default ('CLDLIQZM', 1, ' ') + call add_default ('CLDICEZM', 1, ' ') + call add_default ('CLIQSNUM', 1, ' ') + call add_default ('CICESNUM', 1, ' ') + call add_default ('DNIFZM', 1, ' ') + call add_default ('DNLFZM', 1, ' ') + call add_default ('WUZM', 1, ' ') + call add_default ('QRAINZM', 1, ' ') + call add_default ('QSNOWZM', 1, ' ') + call add_default ('CRAINNUM', 1, ' ') + call add_default ('CSNOWNUM', 1, ' ') + call add_default ('QNLZM', 1, ' ') + call add_default ('QNIZM', 1, ' ') + call add_default ('QNRZM', 1, ' ') + call add_default ('QNSZM', 1, ' ') + call add_default ('FRZZM', 1, ' ') + + ! Initialization for the microphysics + + call zm_mphyi() + + ! Initialize the aerosol object with data from the modes/species + ! affecting climate, + ! i.e., the list index is hardcoded to 0. + + call rad_cnst_get_info(0, nmodes=nmodes, naero=nbulk) + + + do i = begchunk, endchunk + call zm_aero_init(nmodes, nbulk, aero(i)) + end do + + if (nmodes > 0) then + + dgnum_idx = pbuf_get_index('DGNUM') + + else if (nbulk > 0 .and. cam_physpkg_is('cam4')) then + + ! This call is needed to allow running the ZM microphysics with the + ! cam4 physics package. + call ndrop_bam_init() + + end if + + end subroutine zm_conv_micro_init + + + subroutine zm_aero_init(nmodes, nbulk, aero) + + use pmgrid, only: plev,plevp + + ! Initialize the zm_aero_t object for modal aerosols + + integer, intent(in) :: nmodes + integer, intent(in) :: nbulk + type(zm_aero_t), intent(out) :: aero + + integer :: iaer, l, m + integer :: nspecmx ! max number of species in a mode + + character(len=20), allocatable :: aername(:) + character(len=32) :: str32 + character(len=*), parameter :: routine = 'zm_conv_init' + + real(r8) :: sigmag, dgnumlo, dgnumhi + real(r8) :: alnsg + !---------------------------------------------------------------------------------- + + aero%nmodes = nmodes + aero%nbulk = nbulk + + if (nmodes > 0) then + + ! Initialize the modal aerosol information + + aero%scheme = 'modal' + + ! Get number of species in each mode, and find max. + allocate(aero%nspec(aero%nmodes)) + nspecmx = 0 + do m = 1, aero%nmodes + + call rad_cnst_get_info(0, m, nspec=aero%nspec(m), mode_type=str32) + + nspecmx = max(nspecmx, aero%nspec(m)) + + ! save mode index for specified mode types + select case (trim(str32)) + case ('accum') + aero%mode_accum_idx = m + case ('aitken') + aero%mode_aitken_idx = m + case ('coarse') + aero%mode_coarse_idx = m + end select + + end do + + ! Check that required mode types were found + if (aero%mode_accum_idx == -1 .or. aero%mode_aitken_idx == -1 .or. aero%mode_coarse_idx == -1) then + write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & + aero%mode_accum_idx, aero%mode_aitken_idx, aero%mode_coarse_idx + call endrun(routine//': ERROR required mode type not found') + end if + + ! find indices for the dust and seasalt species in the coarse mode + do l = 1, aero%nspec(aero%mode_coarse_idx) + call rad_cnst_get_info(0, aero%mode_coarse_idx, l, spec_type=str32) + select case (trim(str32)) + case ('dust') + aero%coarse_dust_idx = l + case ('seasalt') + aero%coarse_nacl_idx = l + end select + end do + ! Check that required modal specie types were found + if (aero%coarse_dust_idx == -1 .or. aero%coarse_nacl_idx == -1) then + write(iulog,*) routine//': ERROR required mode-species type not found - indicies:', & + aero%coarse_dust_idx, aero%coarse_nacl_idx + call endrun(routine//': ERROR required mode-species type not found') + end if + + allocate( & + aero%num_a(nmodes), & + aero%mmr_a(nspecmx,nmodes), & + aero%numg_a(pcols,pver,nmodes), & + aero%mmrg_a(pcols,pver,nspecmx,nmodes), & + aero%voltonumblo(nmodes), & + aero%voltonumbhi(nmodes), & + aero%specdens(nspecmx,nmodes), & + aero%spechygro(nspecmx,nmodes), & + aero%dgnum(nmodes), & + aero%dgnumg(pcols,pver,nmodes) ) + + + do m = 1, nmodes + + ! Properties of modes + call rad_cnst_get_mode_props(0, m, & + sigmag=sigmag, dgnumlo=dgnumlo, dgnumhi=dgnumhi) + + alnsg = log(sigmag) + aero%voltonumblo(m) = 1._r8 / ( (pi/6._r8)*(dgnumlo**3._r8)*exp(4.5_r8*alnsg**2._r8) ) + aero%voltonumbhi(m) = 1._r8 / ( (pi/6._r8)*(dgnumhi**3._r8)*exp(4.5_r8*alnsg**2._r8) ) + + ! save sigmag of aitken mode + if (m == aero%mode_aitken_idx) aero%sigmag_aitken = sigmag + + ! Properties of modal species + do l = 1, aero%nspec(m) + call rad_cnst_get_aer_props(0, m, l, density_aer=aero%specdens(l,m), & + hygro_aer=aero%spechygro(l,m)) + end do + end do + + else if (nbulk > 0) then + + aero%scheme = 'bulk' + + ! Props needed for BAM number concentration calcs. + allocate( & + aername(nbulk), & + aero%num_to_mass_aer(nbulk), & + aero%mmr_bulk(nbulk), & + aero%mmrg_bulk(pcols,plev,nbulk) ) + + do iaer = 1, aero%nbulk + call rad_cnst_get_aer_props(0, iaer, & + aername = aername(iaer), & + num_to_mass_aer = aero%num_to_mass_aer(iaer) ) + + ! Look for sulfate aerosol in this list (Bulk aerosol only) + if (trim(aername(iaer)) == 'SULFATE') aero%idxsul = iaer + if (trim(aername(iaer)) == 'DUST1') aero%idxdst1 = iaer + if (trim(aername(iaer)) == 'DUST2') aero%idxdst2 = iaer + if (trim(aername(iaer)) == 'DUST3') aero%idxdst3 = iaer + if (trim(aername(iaer)) == 'DUST4') aero%idxdst4 = iaer + if (trim(aername(iaer)) == 'BCPHI') aero%idxbcphi = iaer + end do + + end if + + end subroutine zm_aero_init + + subroutine zm_conv_micro_outfld(conv, dnif, dnlf, lchnk, ncol) + + use cam_history, only: outfld + + type(zm_conv_t),intent(in) :: conv + real(r8), intent(in) :: dnlf(:,:) ! detrained convective cloud water num concen. + real(r8), intent(in) :: dnif(:,:) ! detrained convective cloud ice num concen. + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + + integer :: i,k + + real(r8) :: cice_snum(pcols,pver) ! convective cloud ice sample number. + real(r8) :: cliq_snum(pcols,pver) ! convective cloud liquid sample number. + real(r8) :: crain_snum(pcols,pver) ! convective rain water sample number. + real(r8) :: csnow_snum(pcols,pver) ! convective snow sample number. + real(r8) :: wu_snum(pcols,pver) ! vertical velocity sample number + + real(r8) :: qni_snum(pcols,pver) ! convective cloud ice number sample number. + real(r8) :: qnl_snum(pcols,pver) ! convective cloud liquid number sample number. + + do k = 1,pver + do i = 1,ncol + if (conv%qice(i,k) .gt. 0.0_r8) then + cice_snum(i,k) = 1.0_r8 + else + cice_snum(i,k) = 0.0_r8 + end if + if (conv%qliq(i,k) .gt. 0.0_r8) then + cliq_snum(i,k) = 1.0_r8 + else + cliq_snum(i,k) = 0.0_r8 + end if + if (conv%qsnow(i,k) .gt. 0.0_r8) then + csnow_snum(i,k) = 1.0_r8 + else + csnow_snum(i,k) = 0.0_r8 + end if + if (conv%qrain(i,k) .gt. 0.0_r8) then + crain_snum(i,k) = 1.0_r8 + else + crain_snum(i,k) = 0.0_r8 + end if + + if (conv%qnl(i,k) .gt. 0.0_r8) then + qnl_snum(i,k) = 1.0_r8 + else + qnl_snum(i,k) = 0.0_r8 + end if + if (conv%qni(i,k) .gt. 0.0_r8) then + qni_snum(i,k) = 1.0_r8 + else + qni_snum(i,k) = 0.0_r8 + end if + if (conv%wu(i,k) .gt. 0.0_r8) then + wu_snum(i,k) = 1.0_r8 + else + wu_snum(i,k) = 0.0_r8 + end if + + end do + end do + + call outfld('ICIMRDP ',conv%qi ,pcols, lchnk ) + call outfld('CLDLIQZM',conv%qliq ,pcols, lchnk) + call outfld('CLDICEZM',conv%qice ,pcols, lchnk) + call outfld('CLIQSNUM',cliq_snum ,pcols, lchnk) + call outfld('CICESNUM',cice_snum ,pcols, lchnk) + call outfld('QRAINZM' ,conv%qrain ,pcols, lchnk) + call outfld('QSNOWZM' ,conv%qsnow ,pcols, lchnk) + call outfld('CRAINNUM',crain_snum ,pcols, lchnk) + call outfld('CSNOWNUM',csnow_snum ,pcols, lchnk) + + call outfld('WUZM' ,conv%wu ,pcols, lchnk) + call outfld('WUZMSNUM',wu_snum ,pcols, lchnk) + call outfld('QNLZM' ,conv%qnl ,pcols, lchnk) + call outfld('QNIZM' ,conv%qni ,pcols, lchnk) + call outfld('QNRZM' ,conv%qnr ,pcols, lchnk) + call outfld('QNSZM' ,conv%qns ,pcols, lchnk) + call outfld('FRZZM' ,conv%frz ,pcols, lchnk) + + call outfld('AUTOL_M' ,conv%autolm ,pcols, lchnk) + call outfld('ACCRL_M' ,conv%accrlm ,pcols, lchnk) + call outfld('BERGN_M' ,conv%bergnm ,pcols, lchnk) + call outfld('FHTIM_M' ,conv%fhtimm ,pcols, lchnk) + call outfld('FHTCT_M' ,conv%fhtctm ,pcols, lchnk) + call outfld('FHML_M' ,conv%fhmlm ,pcols, lchnk) + call outfld('HMPI_M' ,conv%hmpim ,pcols, lchnk) + call outfld('ACCSL_M' ,conv%accslm ,pcols, lchnk) + call outfld('DLF_M' ,conv%dlfm ,pcols, lchnk) + + call outfld('AUTOL_N' ,conv%autoln ,pcols, lchnk) + call outfld('ACCRL_N' ,conv%accrln ,pcols, lchnk) + call outfld('BERGN_N' ,conv%bergnn ,pcols, lchnk) + call outfld('FHTIM_N' ,conv%fhtimn ,pcols, lchnk) + call outfld('FHTCT_N' ,conv%fhtctn ,pcols, lchnk) + call outfld('FHML_N' ,conv%fhmln ,pcols, lchnk) + call outfld('ACCSL_N' ,conv%accsln ,pcols, lchnk) + call outfld('ACTIV_N' ,conv%activn ,pcols, lchnk) + call outfld('DLF_N' ,conv%dlfn ,pcols, lchnk) + call outfld('AUTOI_M' ,conv%autoim ,pcols, lchnk) + call outfld('ACCSI_M' ,conv%accsim ,pcols, lchnk) + call outfld('DIF_M' ,conv%difm ,pcols, lchnk) + call outfld('NUCLI_N' ,conv%nuclin ,pcols, lchnk) + call outfld('AUTOI_N' ,conv%autoin ,pcols, lchnk) + call outfld('ACCSI_N' ,conv%accsin ,pcols, lchnk) + call outfld('HMPI_N' ,conv%hmpin ,pcols, lchnk) + call outfld('DIF_N' ,conv%difn ,pcols, lchnk) + call outfld('COND_M' ,conv%cmel ,pcols, lchnk) + call outfld('DEPOS_M' ,conv%cmei ,pcols, lchnk) + + call outfld('TRSPC_M' ,conv%trspcm ,pcols, lchnk) + call outfld('TRSPC_N' ,conv%trspcn ,pcols, lchnk) + call outfld('TRSPI_M' ,conv%trspim ,pcols, lchnk) + call outfld('TRSPI_N' ,conv%trspin ,pcols, lchnk) + call outfld('DNIFZM' ,dnif ,pcols, lchnk) + call outfld('DNLFZM' ,dnlf ,pcols, lchnk) + + end subroutine zm_conv_micro_outfld + +end module zm_conv_intr diff --git a/src/chemistry/mozart/chemistry.F90 b/src/chemistry/mozart/chemistry.F90 index dc7db5eadd..2abdb3b88a 100644 --- a/src/chemistry/mozart/chemistry.F90 +++ b/src/chemistry/mozart/chemistry.F90 @@ -863,7 +863,7 @@ subroutine chem_init(phys_state, pbuf2d) ! Add chemical tendency of water vapor to water budget output if ( history_budget ) then - call add_default ('CT_H2O' , history_budget_histfile_num, ' ') + call add_default ('CT_H2O_GHG' , history_budget_histfile_num, ' ') endif !----------------------------------------------------------------------- diff --git a/src/chemistry/mozart/mo_fstrat.F90 b/src/chemistry/mozart/mo_fstrat.F90 index 6e627c685f..75a0b5cbd3 100644 --- a/src/chemistry/mozart/mo_fstrat.F90 +++ b/src/chemistry/mozart/mo_fstrat.F90 @@ -456,7 +456,6 @@ subroutine set_fstrat_vals( vmr, pmid, pint, ltrop, calday, ncol,lchnk ) real(r8) :: pint_vals(2) real(r8), allocatable :: table_ox(:) logical :: found_trop - integer :: lat if (.not. any(has_fstrat(:))) return @@ -556,7 +555,7 @@ subroutine set_fstrat_vals( vmr, pmid, pint, ltrop, calday, ncol,lchnk ) + dels*(mr_ub(i,m,next,2:ub_nlevs-1,lchnk) & - mr_ub(i,m,last,2:ub_nlevs-1,lchnk)) #ifdef UB_DEBUG - write(iulog,*) 'set_fstrat_vals: table_ox @ lat = ',lat + write(iulog,*) 'set_fstrat_vals: table_ox @ i = ',i write(iulog,'(1p5g15.7)') table_ox(:) write(iulog,*) ' ' #endif @@ -572,7 +571,7 @@ subroutine set_fstrat_vals( vmr, pmid, pint, ltrop, calday, ncol,lchnk ) #endif call rebin( ub_nlevs-2, km, ub_plevse, pint(i,:km+1), table_ox, vmr(i,:km,map(m)) ) #ifdef UB_DEBUG - write(iulog,*) 'set_fstrat_vals: ub o3 @ lat = ',lat + write(iulog,*) 'set_fstrat_vals: ub o3 @ i = ',i write(iulog,'(1p5g15.7)') vmr(i,:km,map(m)) #endif end do @@ -631,7 +630,7 @@ subroutine set_fstrat_vals( vmr, pmid, pint, ltrop, calday, ncol,lchnk ) end do #ifdef DEBUG if( levrelax /= ltrop(i) ) then - write(iulog,*) 'warning -- raised ubc: ',lat,i, & + write(iulog,*) 'warning -- raised ubc: ',i, & ltrop(i)-1,nint(pmid(i,ltrop(i)-1)/100._r8),'mb -->', & levrelax,nint(pmid(i,levrelax)/100._r8),'mb' end if @@ -815,7 +814,6 @@ subroutine set_fstrat_h2o( h2o, pmid, ltrop, calday, ncol, lchnk ) real(r8) :: delp(ncol,zlower) real(r8) :: pint_vals(2) logical :: found_trop - integer :: lat h2o_overwrite : if( h2o_ndx > 0 .and. table_h2o_ndx > 0 ) then !-------------------------------------------------------- @@ -913,7 +911,7 @@ subroutine set_fstrat_h2o( h2o, pmid, ltrop, calday, ncol, lchnk ) end do #ifdef DEBUG if( levrelax /= ltrop(i) ) then - write(iulog,*) 'warning -- raised ubc: ',lat,i, & + write(iulog,*) 'warning -- raised ubc: ',i, & ltrop(i)-1,nint(pmid(i,ltrop(i)-1)/100._r8),'mb -->', & levrelax,nint(pmid(i,levrelax)/100._r8),'mb' end if diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index afcb13da0e..71a380f16b 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -506,7 +506,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & ! ... Calculate cosine of zenith angle ! then cast back to angle (radians) !----------------------------------------------------------------------- - call zenith( calday, rlats, rlons, zen_angle, ncol ) + call zenith( calday, rlats, rlons, zen_angle, ncol , delt) !+tht delt zen_angle(:) = acos( zen_angle(:) ) sza(:) = zen_angle(:) * rad2deg diff --git a/src/chemistry/mozart/mo_photo.F90 b/src/chemistry/mozart/mo_photo.F90 index a953c2db74..d02570d5b0 100644 --- a/src/chemistry/mozart/mo_photo.F90 +++ b/src/chemistry/mozart/mo_photo.F90 @@ -567,11 +567,17 @@ subroutine photo_inti( xs_coef_file, xs_short_file, xs_long_file, rsf_file, & end do end if #ifdef DEBUG - write(iulog,*) '-----------------------------------' - write(iulog,*) 'photo_inti: diagnostics' - write(iulog,*) 'ki, delp = ',ki,delp - write(iulog,*) 'pinterp,levs(ki-1:ki) = ',pinterp,levs(ki-1:ki) - write(iulog,*) '-----------------------------------' + if (masterproc) then + write(iulog,*) '-----------------------------------' + write(iulog,*) 'photo_inti: diagnostics' + write(iulog,*) 'ki, delp = ',ki,delp + if (ki>1) then + write(iulog,*) 'pinterp,levs(ki-1:ki) = ',pinterp,levs(ki-1:ki) + else + write(iulog,*) 'pinterp,levs(ki) = ',pinterp,levs(ki) + end if + write(iulog,*) '-----------------------------------' + endif #endif end if end if has_abs_columns @@ -1080,8 +1086,10 @@ subroutine xactive_photo( photos, vmr, temper, cwat, cldfr, & ncdate = yr*10000 + mon*100 + day ut = real(tod)/3600._r8 #ifdef DEBUG - write(iulog,*) 'photo: nj = ',nlng - write(iulog,*) 'photo: esfact = ',esfact + if (masterproc) then + write(iulog,*) 'photo: nj = ',nlng + write(iulog,*) 'photo: esfact = ',esfact + endif #endif col_loop : do i = 1,ncol daylight : & @@ -1700,10 +1708,12 @@ subroutine photo_timestep_init( calday ) dels = (calday - days(m)) / (days(m+1) - days(m)) end if #ifdef DEBUG - write(iulog,*) '-----------------------------------' - write(iulog,*) 'photo_timestep_init: diagnostics' - write(iulog,*) 'calday, last, next, dels = ',calday,last,next,dels - write(iulog,*) '-----------------------------------' + if (masterproc) then + write(iulog,*) '-----------------------------------' + write(iulog,*) 'photo_timestep_init: diagnostics' + write(iulog,*) 'calday, last, next, dels = ',calday,last,next,dels + write(iulog,*) '-----------------------------------' + endif #endif end if diff --git a/src/chemistry/mozart/mo_waccm_hrates.F90 b/src/chemistry/mozart/mo_waccm_hrates.F90 index 5e7b8a8405..50358e2c00 100644 --- a/src/chemistry/mozart/mo_waccm_hrates.F90 +++ b/src/chemistry/mozart/mo_waccm_hrates.F90 @@ -116,7 +116,7 @@ subroutine waccm_hrates(ncol, state, asdir, bot_mlt_lev, qrs_tot, pbuf ) use set_cp, only : calc_cp use cam_history, only : outfld use shr_orb_mod, only : shr_orb_decl - use time_manager, only : get_curr_calday + use time_manager, only : get_curr_calday, get_step_size !+tht step_size use cam_control_mod, only : lambm0, eccen, mvelpp, obliqr use mo_constants, only : r2d use short_lived_species,only: get_short_lived_species @@ -195,6 +195,9 @@ subroutine waccm_hrates(ncol, state, asdir, bot_mlt_lev, qrs_tot, pbuf ) real(r8) :: delta ! solar declination (radians) logical :: do_diag + integer :: dtime !+tht time step + real(r8) :: dtavg !+tht time step + real(r8), pointer :: ele_temp_fld(:,:) ! electron temperature pointer real(r8), pointer :: ion_temp_fld(:,:) ! ion temperature pointer @@ -239,7 +242,12 @@ subroutine waccm_hrates(ncol, state, asdir, bot_mlt_lev, qrs_tot, pbuf ) ! ... calculate cosine of zenith angle then cast back to angle !----------------------------------------------------------------------- calday = get_curr_calday() - call zenith( calday, rlats, rlons, zen_angle, ncol ) +!+tht + !call zenith( calday, rlats, rlons, zen_angle, ncol ) + dtime=get_step_size() + dtavg=dtime + call zenith( calday, rlats, rlons, zen_angle, ncol ,dtavg) +!-tht zen_angle(:) = acos( zen_angle(:) ) !----------------------------------------------------------------------- diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 new file mode 100644 index 0000000000..7bdcff9fcb --- /dev/null +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -0,0 +1,1123 @@ +!=============================================================================== +! Modal Aerosol Model +!=============================================================================== +module aero_model + +#include + + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts, cam_physpkg_is + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o + use spmd_utils, only: masterproc + use infnan, only: nan, assignment(=) + + use cam_history, only: outfld, fieldname_len + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + use aerosoldef, only: chemistryIndex, physicsIndex & + , getCloudTracerIndexDirect & + , getCloudTracerName + use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 & + , condtend_sub + use koagsub, only: coagtend, clcoag + use sox_cldaero_mod, only: sox_cldaero_init + !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode + !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max + + use ref_pres, only: top_lev => clim_modal_aero_top_lev + + !use modal_aero_wateruptake, only: modal_strat_sulfate + use mo_setsox, only: setsox + use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri + + implicit none + private + + public :: aero_model_readnl + public :: aero_model_register + public :: aero_model_init + public :: aero_model_gasaerexch ! create, grow, change, and shrink aerosols. + public :: aero_model_drydep ! aerosol dry deposition and sediment + public :: aero_model_wetdep ! aerosol wet removal + public :: aero_model_emissions ! aerosol emissions + public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry + public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry + + ! Misc private data + + ! number of modes + integer :: nmodes + integer :: pblh_idx = 0 + integer :: dgnum_idx = 0 + integer :: dgnumwet_idx = 0 + integer :: rate1_cw2pr_st_idx = 0 + + integer :: wetdens_ap_idx = 0 + integer :: qaerwat_idx = 0 + + integer :: fracis_idx = 0 + integer :: prain_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 + + integer :: sulfeq_idx = -1 + + ! variables for table lookup of aerosol impaction/interception scavenging rates + integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 + real(r8) :: dlndg_nimptblgrow + real(r8),allocatable :: scavimptblnum(:,:) + real(r8),allocatable :: scavimptblvol(:,:) + + ! for surf_area_dens + integer,allocatable :: num_idx(:) + integer,allocatable :: index_tot_mass(:,:) + integer,allocatable :: index_chm_mass(:,:) + + integer :: ndx_h2so4, ndx_soa_lv, ndx_soa_sv + + ! Namelist variables + character(len=16) :: wetdep_list(pcnst) = ' ' + character(len=16) :: drydep_list(pcnst) = ' ' + real(r8) :: sol_facti_cloud_borne = 1._r8 + real(r8) :: sol_factb_interstitial = 0.1_r8 + real(r8) :: sol_factic_interstitial = 0.4_r8 + real(r8) :: seasalt_emis_scale + + integer :: ndrydep = 0 + integer,allocatable :: drydep_indices(:) + integer :: nwetdep = 0 + integer,allocatable :: wetdep_indices(:) + logical :: drydep_lq(pcnst) + logical :: wetdep_lq(pcnst) + + + logical :: convproc_do_aer + +contains + + !============================================================================= + ! reads aerosol namelist options + !============================================================================= + subroutine aero_model_readnl(nlfile) + + 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 + character(len=*), parameter :: subname = 'aero_model_readnl' + + ! Namelist variables + character(len=16) :: aer_wetdep_list(pcnst) = ' ' + character(len=16) :: aer_drydep_list(pcnst) = ' ' + + namelist /aerosol_nl/ aer_wetdep_list, aer_drydep_list, sol_facti_cloud_borne, & + sol_factb_interstitial, sol_factic_interstitial + + !----------------------------------------------------------------------------- + + ! Read namelist + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'aerosol_nl', status=ierr) + if (ierr == 0) then + read(unitn, aerosol_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 + ! Broadcast namelist variables + call mpibcast(aer_wetdep_list, len(aer_wetdep_list(1))*pcnst, mpichar, 0, mpicom) + call mpibcast(aer_drydep_list, len(aer_drydep_list(1))*pcnst, mpichar, 0, mpicom) + call mpibcast(sol_facti_cloud_borne, 1, mpir8, 0, mpicom) + call mpibcast(sol_factb_interstitial, 1, mpir8, 0, mpicom) + call mpibcast(sol_factic_interstitial, 1, mpir8, 0, mpicom) + call mpibcast(seasalt_emis_scale, 1, mpir8, 0, mpicom) +#endif + + wetdep_list = aer_wetdep_list + drydep_list = aer_drydep_list + + end subroutine aero_model_readnl + + !============================================================================= + !============================================================================= + subroutine aero_model_register() + use aerosoldef, only: aero_register + use condtend, only: registerCondensation + + call aero_register() + call registerCondensation() + + end subroutine aero_model_register + + !============================================================================= + !============================================================================= + subroutine aero_model_init( pbuf2d ) + + !use mo_chem_utls, only: get_inv_ndx + use cam_history, only: addfld, add_default, horiz_only + use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx + !use modal_aero_data, only: cnst_name_cw + !use modal_aero_data, only: modal_aero_data_init + !use rad_constituents,only: rad_cnst_get_info + use dust_model, only: dust_init, dust_active + use seasalt_model, only: seasalt_init, seasalt_active + use drydep_mod, only: inidrydep + use wetdep, only: wetdep_init + + use condtend, only: initializeCondensation + use oslo_ocean_intr, only: oslo_ocean_init + use oslo_aerosols_intr, only: oslo_aero_initialize + + use opttab, only : initopt + use opttab_lw, only: initopt_lw + + use modal_aero_deposition , only: modal_aero_deposition_init + + !use modal_aero_calcsize, only: modal_aero_calcsize_init + !use modal_aero_coag, only: modal_aero_coag_init + !use modal_aero_deposition, only: modal_aero_deposition_init + !use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init + !use modal_aero_newnuc, only: modal_aero_newnuc_init + !use modal_aero_rename, only: modal_aero_rename_init + !use modal_aero_convproc, only: ma_convproc_init + + ! args + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local vars + character(len=*), parameter :: subrname = 'aero_model_init' + integer :: m, n, id + character(len=20) :: dummy + + logical :: history_aerosol ! Output MAM or SECT aerosol tendencies + + integer :: l + character(len=6) :: test_name + character(len=64) :: errmes + + character(len=2) :: unit_basename ! Units 'kg' or '1' + integer :: errcode + character(len=fieldname_len) :: field_name + + character(len=32) :: spec_name + character(len=32) :: spec_type + character(len=32) :: mode_type + integer :: nspec + + call phys_getopts(history_aerosol_out = history_aerosol, & + convproc_do_aer_out = convproc_do_aer) + +#ifdef OSLO_AERO + call constants + call initopt + call initlogn + call initopt_lw +#ifdef AEROCOM + call initaeropt + call initdryp +#endif ! aerocom +#endif + + call initializeCondensation() + call oslo_ocean_init() + + call oslo_aero_initialize(pbuf2d) + + call dust_init() + call seasalt_init() !seasalt_emis_scale) + call wetdep_init() + call modal_aero_deposition_init() + + + nwetdep = 0 + ndrydep = 0 + + + call inidrydep(rair, gravit) + dummy = 'RAM1' + call addfld (dummy,horiz_only, 'A','frac','RAM1') + if ( history_aerosol ) then + call add_default (dummy, 1, ' ') + endif + dummy = 'airFV' + call addfld (dummy,horiz_only, 'A','frac','FV') + if ( history_aerosol ) then + call add_default (dummy, 1, ' ') + endif + + !Get height of boundary layer for boundary layer nucleation + pblh_idx = pbuf_get_index('pblh') + + call cnst_get_ind ( "H2SO4", ndx_h2so4, abort=.true. ) + ndx_h2so4 = chemistryIndex(ndx_h2so4) + call cnst_get_ind ( "SOA_LV", ndx_soa_lv,abort=.true.) + ndx_soa_lv = chemistryIndex(ndx_soa_lv) + call cnst_get_ind ( "SOA_SV", ndx_soa_sv, abort=.true.) + ndx_soa_sv = chemistryIndex(ndx_soa_sv) + + do m = 1,gas_pcnst + + + unit_basename = 'kg' ! Units 'kg' or '1' + + call addfld( 'GS_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & + trim(solsym(m))//' gas chemistry/wet removal (for gas species)') + call addfld( 'AQ_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & + trim(solsym(m))//' aqueous chemistry (for gas species)') + if(physicsIndex(m).le.pcnst) then + if (getCloudTracerIndexDirect(physicsIndex(m)) .gt. 0)then + call addfld( 'AQ_'//getCloudTracerName(physicsIndex(m)),horiz_only, 'A', unit_basename//'/m2/s ', & + trim(solsym(m))//' aqueous chemistry (for cloud species)') + end if + end if + + if ( history_aerosol ) then + call add_default( 'GS_'//trim(solsym(m)), 1, ' ') + call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') + if(physicsIndex(m).le.pcnst) then + if(getCloudTracerIndexDirect(physicsIndex(m)).gt.0)then + call add_default( 'AQ_'//getCloudTracerName(physicsIndex(m)),1,' ') + end if + end if + endif + enddo + + call addfld ('NUCLRATE',(/'lev'/), 'A','#/cm3/s','Nucleation rate') + call addfld ('FORMRATE',(/'lev'/), 'A','#/cm3/s','Formation rate of 12nm particles') + call addfld ('COAGNUCL',(/'lev'/), 'A', '/s','Coagulation sink for nucleating particles') + call addfld ('GRH2SO4',(/'lev'/), 'A', 'nm/hour','Growth rate H2SO4') + call addfld ('GRSOA',(/'lev'/),'A','nm/hour','Growth rate SOA') + call addfld ('GR',(/'lev'/), 'A', 'nm/hour','Growth rate, H2SO4+SOA') + call addfld ('NUCLSOA',(/'lev'/),'A','kg/kg','SOA nucleate') + call addfld ('ORGNUCL',(/'lev'/),'A','kg/kg','Organic gas available for nucleation') + + if(history_aerosol)then + call add_default ('NUCLRATE', 1, ' ') + call add_default ('FORMRATE', 1, ' ') + call add_default ('COAGNUCL', 1, ' ') + call add_default ('GRH2SO4', 1, ' ') + call add_default ('GRSOA', 1, ' ') + call add_default ('GR', 1, ' ') + call add_default ('NUCLSOA', 1, ' ') + call add_default ('ORGNUCL', 1, ' ') + end if + + call addfld( 'XPH_LWC', (/ 'lev' /), 'A','kg/kg', 'pH value multiplied by lwc') + call addfld ('AQSO4_H2O2', horiz_only, 'A','kg/m2/s', 'SO4 aqueous phase chemistry due to H2O2') + call addfld ('AQSO4_O3', horiz_only, 'A','kg/m2/s', 'SO4 aqueous phase chemistry due to O3') + + if ( history_aerosol ) then + call add_default ('XPH_LWC', 1, ' ') + call add_default ('AQSO4_H2O2', 1, ' ') + call add_default ('AQSO4_O3', 1, ' ') + endif + + + +end subroutine aero_model_init + + !============================================================================= + !============================================================================= + subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) + + use calcaersize + use oslo_aerosols_intr, only: oslo_aero_dry_intr + use aerosoldef , only : numberOfProcessModeTracers + use commondefinitions, only: oslo_nmodes=>nmodes + + ! args + type(physics_state), intent(in) :: state ! Physics state variables + real(r8), intent(in) :: obklen(:) + real(r8), intent(in) :: ustar(:) ! sfc fric vel + type(cam_in_t), target, intent(in) :: cam_in ! import state + real(r8), intent(in) :: dt ! time step + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local vars + integer :: ncol + real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_dgnumwet + real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_wetdens + real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_dgnumwet_processmodes + real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_wetdens_processmodes + + ncol = state%ncol + + call calcaersize_sub( ncol, & + state%t, state%q(1,1,1), state%pmid, state%pdel & + ,oslo_dgnumwet , oslo_wetdens & + ,oslo_dgnumwet_processmodes, oslo_wetdens_processmodes & + ) + + call oslo_aero_dry_intr(state, pbuf, obklen, ustar, cam_in, dt, cam_out,ptend & + , oslo_dgnumwet, oslo_wetdens & + , oslo_dgnumwet_processmodes, oslo_wetdens_processmodes, & + cam_in%cflx ) !++alfgr + + return + endsubroutine aero_model_drydep + + !============================================================================= + !============================================================================= + subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) + + use oslo_aerosols_intr, only: oslo_aero_wet_intr + + type(physics_state), intent(in) :: state ! Physics state variables + real(r8), intent(in) :: dt ! time step + real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + call oslo_aero_wet_intr( state, dt, dlf, cam_out, ptend, pbuf) + + endsubroutine aero_model_wetdep + + !------------------------------------------------------------------------- + ! provides wet tropospheric aerosol surface area info for modal aerosols + ! called from mo_usrrxt + !------------------------------------------------------------------------- + subroutine aero_model_surfarea( & + mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & + dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) + + use commondefinitions, only: nmodes_oslo => nmodes + use const , only: numberToSurface + use aerosoldef , only: lifeCycleNumberMedianRadius + use oslo_utils , only: calculateNumberConcentration + + ! dummy args + real(r8), intent(in) :: pmid(:,:) + real(r8), intent(in) :: temp(:,:) + real(r8), intent(in) :: mmr(:,:,:) + real(r8), intent(in) :: radmean ! mean radii in cm + real(r8), intent(in) :: strato_sad(:,:) + integer, intent(in) :: ncol + integer, intent(in) :: ltrop(:) + real(r8), intent(in) :: dlat(:) ! degrees latitude + integer, intent(in) :: het1_ndx + real(r8), intent(in) :: relhum(:,:) + real(r8), intent(in) :: rho(:,:) ! total atm density (/cm^3) + real(r8), intent(in) :: sulfate(:,:) + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(inout) :: sfc(:,:,:) + real(r8), intent(inout) :: dm_aer(:,:,:) + real(r8), intent(inout) :: sad_trop(:,:) + real(r8), intent(out) :: reff_trop(:,:) + + ! local vars + !HAVE TO GET RID OF THIS MODE 0!! MESSES UP EVERYTHING!! + real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) + real(r8), target :: sad_mode(pcols,pver, nmodes_oslo) + real(r8) :: rho_air(pcols,pver) + integer :: l,m + integer :: i,k + + !Get air density + do k=1,pver + do i=1,ncol + rho_air(i,k) = pmid(i,k)/(temp(i,k)*287.04_r8) + end do + end do + ! + !Get number concentrations + call calculateNumberConcentration(ncol, mmr, rho_air, numberConcentration) + + !Convert to area using lifecycle-radius + sad_mode = 0._r8 + sad_trop = 0._r8 + do m=1,nmodes_oslo + do k=1,pver + sad_mode(:ncol,k,m) = numberConcentration(:ncol,k,m)*numberToSurface(m)*1.e-2_r8 !m2/m3 ==> cm2/cm3 + sad_trop(:ncol,k) = sad_trop(:ncol,k) + sad_mode(:ncol,k,m) + end do + end do + + do m=1,nmodes_oslo + do k=1,pver + sfc(:ncol,k,m) = sad_mode(:ncol,k,m) ! aitken_idx:aitken_idx) + dm_aer(:ncol,k,m) = 2.0_r8*lifeCycleNumberMedianRadius(m) + end do + end do + + !++ need to implement reff_trop here + reff_trop(:,:)=1.0e-6_r8 + !-- + + + end subroutine aero_model_surfarea + + !------------------------------------------------------------------------- + ! provides WET stratospheric aerosol surface area info for modal aerosols + ! if modal_strat_sulfate = TRUE -- called from mo_gas_phase_chemdr + !------------------------------------------------------------------------- + subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato_sad, reff_strat ) + + ! dummy args + integer, intent(in) :: ncol + real(r8), intent(in) :: mmr(:,:,:) + real(r8), intent(in) :: pmid(:,:) + real(r8), intent(in) :: temp(:,:) + integer, intent(in) :: ltrop(:) ! tropopause level indices + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: strato_sad(:,:) + real(r8), intent(out) :: reff_strat(:,:) + + ! local vars + real(r8), pointer, dimension(:,:,:) :: dgnumwet + integer :: beglev(ncol) + integer :: endlev(ncol) + + reff_strat = 0.1e-6_r8 + strato_sad = 0._r8 + !do nothing + return + + end subroutine aero_model_strat_surfarea + + !============================================================================= + !============================================================================= + subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_rates, & + tfld, pmid, pdel, mbar, relhum, & + zm, qh2o, cwat, cldfr, cldnum, & + airdens, invariants, del_h2so4_gasprod, & + vmr0, vmr, pbuf ) + + use time_manager, only : get_nstep + use condtend, only : condtend_sub + use aerosoldef, only: getCloudTracerName + !----------------------------------------------------------------------- + ! ... dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: loffset ! offset applied to modal aero "pointers" + integer, intent(in) :: ncol ! number columns in chunk + integer, intent(in) :: lchnk ! chunk index + integer, intent(in) :: troplev(pcols) + real(r8), intent(in) :: delt ! time step size (sec) + real(r8), intent(in) :: reaction_rates(:,:,:) ! reaction rates + real(r8), intent(in) :: tfld(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! pressure at model levels (Pa) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), intent(in) :: relhum(:,:) ! relative humidity + real(r8), intent(in) :: airdens(:,:) ! total atms density (molec/cm**3) + real(r8), intent(in) :: invariants(:,:,:) + real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ![molec/molec/sec] + real(r8), intent(in) :: zm(:,:) + real(r8), intent(in) :: qh2o(:,:) + real(r8), intent(in) :: cwat(:,:) ! cloud liquid water content (kg/kg) + real(r8), intent(in) :: cldfr(:,:) + real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) + real(r8), intent(in) :: vmr0(:,:,:) ! initial mixing ratios (before gas-phase chem changes) + real(r8), intent(inout) :: vmr(:,:,:) ! mixing ratios ( vmr ) + + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local vars + + integer :: n, m + integer :: i,k,l + integer :: nstep + + integer, parameter :: nmodes_aq_chem = 1 + + real(r8), dimension(ncol) :: wrk + character(len=32) :: name + real(r8) :: dvmrcwdt(ncol,pver,gas_pcnst) + real(r8) :: dvmrdt(ncol,pver,gas_pcnst) + real(r8) :: vmrcw(ncol,pver,gas_pcnst) ! cloud-borne aerosol (vmr) + + real(r8) :: del_h2so4_aeruptk(ncol,pver) + real(r8) :: del_h2so4_aqchem(ncol,pver) + real(r8) :: mmr_cond_vap_start_of_timestep(pcols,pver,N_COND_VAP) + real(r8) :: mmr_cond_vap_gasprod(pcols,pver,N_COND_VAP) + real(r8) :: del_soa_lv_gasprod(ncol,pver) + real(r8) :: del_soa_sv_gasprod(ncol,pver) + real(r8) :: dvmrdt_sv1(ncol,pver,gas_pcnst) + real(r8) :: dvmrcwdt_sv1(ncol,pver,gas_pcnst) + real(r8) :: mmr_tend_ncols(ncol, pver, gas_pcnst) + real(r8) :: mmr_tend_pcols(pcols, pver, gas_pcnst) + + integer :: cond_vap_idx + real(r8) :: aqso4(ncol,nmodes_aq_chem) ! aqueous phase chemistry + real(r8) :: aqh2so4(ncol,nmodes_aq_chem) ! aqueous phase chemistry + real(r8) :: aqso4_h2o2(ncol) ! SO4 aqueous phase chemistry due to H2O2 + real(r8) :: aqso4_o3(ncol) ! SO4 aqueous phase chemistry due to O3 + real(r8) :: xphlwc(ncol,pver) ! pH value multiplied by lwc + real(r8) :: delt_inverse ! 1 / timestep + + real(r8), pointer :: pblh(:) + + logical :: is_spcam_m2005 + + nstep = get_nstep() + + + is_spcam_m2005 = cam_physpkg_is('spcam_m2005') + + delt_inverse = 1.0_r8 / delt + + !Get height of boundary layer (needed for boundary layer nucleation) + call pbuf_get_field(pbuf, pblh_idx, pblh) + + ! calculate tendency due to gas phase chemistry and processes + dvmrdt(:ncol,:,:) = (vmr(:ncol,:,:) - vmr0(:ncol,:,:)) / delt + do m = 1, gas_pcnst + wrk(:) = 0._r8 + do k = 1,pver + wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + name = 'GS_'//trim(solsym(m)) + call outfld( name, wrk(:ncol), ncol, lchnk ) + enddo + +! Get mass mixing ratios at start of time step + call vmr2mmr( vmr0, mmr_tend_ncols, mbar, ncol ) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) = mmr_tend_ncols(1:ncol,:,ndx_h2so4) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) = mmr_tend_ncols(1:ncol,:,ndx_soa_lv) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) = mmr_tend_ncols(1:ncol,:,ndx_soa_sv) +! +! Aerosol processes ... +! + call qqcw2vmr( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) + + ! save h2so4 change by gas phase chem (for later new particle nucleation) + if (ndx_h2so4 > 0) then + del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - vmr0(1:ncol,:,ndx_h2so4) + endif + + del_soa_lv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_lv) - vmr0(1:ncol,:,ndx_soa_lv) + del_soa_sv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_sv) - vmr0(1:ncol,:,ndx_soa_sv) + + if (.not. is_spcam_m2005) then ! regular CAM + dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) + dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) + + !Save intermediate concentrations + dvmrdt_sv1 = vmr + dvmrcwdt_sv1 = vmrcw + + ! aqueous chemistry ... + + call setsox( & + ncol, & + lchnk, & + loffset, & + delt, & + pmid, & + pdel, & + tfld, & + mbar, & + cwat, & + cldfr, & + cldnum, & + airdens, & + invariants, & + vmrcw, & + vmr, & + xphlwc, & + aqso4, & + aqh2so4, & + aqso4_h2o2, & + aqso4_o3 & + ) + + call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) + call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) + call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) + + + ! vmr tendency from aqchem and soa routines + dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt + dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt + + if(ndx_h2so4 .gt. 0)then + del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 + else + del_h2so4_aqchem(:ncol,:) = 0.0_r8 + end if + + do m = 1,gas_pcnst + wrk(:ncol) = 0._r8 + do k = 1,pver + wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + name = 'AQ_'//trim(solsym(m)) + call outfld( name, wrk(:ncol), ncol, lchnk ) + + !In oslo aero also write out the tendencies for the + !cloud borne aerosols... + n = physicsIndex(m) + if (n.le.pcnst) then + if(getCloudTracerIndexDirect(n) .gt. 0)then + name = 'AQ_'//trim(getCloudTracerName(n)) + wrk(:ncol)=0.0_r8 + do k=1,pver + wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + call outfld( name, wrk(:ncol), ncol, lchnk ) + end if + end if + enddo + + else if (is_spcam_m2005) then ! SPCAM ECPP +! when ECPP is used, aqueous chemistry is done in ECPP, +! and not updated here. +! Minghuai Wang, 2010-02 (Minghuai.Wang@pnl.gov) +! + dvmrdt = 0.0_r8 + dvmrcwdt = 0.0_r8 + endif + + !condensation + call vmr2mmr( vmr, mmr_tend_ncols, mbar, ncol ) + do k = 1,pver + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_H2SO4) = adv_mass(ndx_h2so4) * (del_h2so4_gasprod(:ncol,k)+del_h2so4_aqchem(:ncol,k)) / mbar(:ncol,k)/delt + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_LV) = adv_mass(ndx_soa_lv) * del_soa_lv_gasprod(:ncol,k) / mbar(:ncol,k)/delt !cka + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_SV) = adv_mass(ndx_soa_sv) * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt !cka + end do + + !This should not happen since there are only + !production terms for these gases!! + do cond_vap_idx=1,N_COND_VAP + where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) + mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx) = 0.0_r8 + end where + end do + mmr_tend_ncols(:ncol,:,ndx_h2so4) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) + mmr_tend_ncols(:ncol,:,ndx_soa_lv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) + mmr_tend_ncols(:ncol,:,ndx_soa_sv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) + + !Rest of microphysics have pcols dimension + mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) + !Note use of "zm" here. In CAM5.3-implementation "zi" was used.. + !zm is passed through the generic interface, and it should not change much + !to check if "zm" is below boundary layer height instead of zi + call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & + pdel, delt, ncol, pblh, zm, qh2o) !cka + + + !coagulation + ! OS 280415 Concentratiions in cloud water is in vmr space and as a + ! temporary variable (vmrcw) Coagulation between aerosol and cloud + ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) + + call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) + + !Convert cloud water to mmr again ==> values in buffer + call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) + + !Call cloud coagulation routines (all in mass mixing ratios) + call clcoag( mmr_tend_pcols, pmid, pdel, tfld, cldnum ,cldfr, delt_inverse, ncol, lchnk,loffset,pbuf) + + !Make sure mmr==> vmr is done correctly + mmr_tend_ncols(:ncol,:,:) = mmr_tend_pcols(:ncol,:,:) + + !Go back to volume mixing ratio for chemistry + call mmr2vmr( mmr_tend_ncols, vmr, mbar, ncol ) + + return + + end subroutine aero_model_gasaerexch + + !============================================================================= + !============================================================================= + subroutine aero_model_emissions( state, cam_in ) + use seasalt_model, only: oslo_salt_emis_intr, seasalt_active, OMOceanSource + use dust_model, only: oslo_dust_emis_intr, dust_active + use oslo_ocean_intr, only: oslo_dms_emis_intr + use aerosoldef, only: l_om_ni + use physics_types, only: physics_state + + ! Arguments: + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(inout) :: cam_in ! import state + + ! local vars + + integer :: lchnk, ncol + real(r8) :: sflx(pcols) ! accumulate over all bins for output + real (r8), parameter :: z0=0.0001_r8 ! m roughness length over oceans--from ocean model + + lchnk = state%lchnk + ncol = state%ncol + + if (dust_active) then + + call oslo_dust_emis_intr( state, cam_in) + + ! some dust emis diagnostics ... + endif + + if (seasalt_active) then + + call oslo_salt_emis_intr(state, cam_in) + + endif + + !Add whatever OM ocean source was calculated in the seasalt module + cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) + + !Pick up correct DMS emissions (replace values from file if requested) + call oslo_dms_emis_intr(state, cam_in) + + end subroutine aero_model_emissions + + !=============================================================================== + ! private methods + + + !============================================================================= + !============================================================================= + subroutine surf_area_dens( ncol, mmr, pmid, temp, diam, beglev, endlev, sad, sfc ) + use mo_constants, only : pi + + ! dummy args + integer, intent(in) :: ncol + real(r8), intent(in) :: mmr(:,:,:) + real(r8), intent(in) :: pmid(:,:) + real(r8), intent(in) :: temp(:,:) + real(r8), intent(in) :: diam(:,:,:) + integer, intent(in) :: beglev(:) + integer, intent(in) :: endlev(:) + real(r8), intent(out) :: sad(:,:) + real(r8),optional, intent(out) :: sfc(:,:,:) + + ! local vars + + ! + ! Compute surface aero for each mode. + ! Total over all modes as the surface area for chemical reactions. + ! + + !oslo: do nothing for now + return + + end subroutine surf_area_dens + + !=============================================================================== + !=============================================================================== + subroutine modal_aero_bcscavcoef_init + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Computes lookup table for aerosol impaction/interception scavenging rates + ! + ! Authors: R. Easter + ! + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use modal_aero_data + use cam_abortutils, only: endrun + + implicit none + + ! oslo : do nothing for now + return + end subroutine modal_aero_bcscavcoef_init + + !=============================================================================== + !=============================================================================== + subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & + radius_part, density_part, sig_part, moment, lchnk ) + +! calculates surface deposition velocity of particles +! L. Zhang, S. Gong, J. Padro, and L. Barrie +! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module +! Atmospheric Environment, 35, 549-560, 2001. +! +! Authors: X. Liu + + ! + ! !USES + ! + use physconst, only: pi,boltz, gravit, rair + use mo_drydep, only: n_land_type, fraction_landuse + + ! !ARGUMENTS: + ! + implicit none + ! + real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) + real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) + real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) + real(r8), intent(in) :: ram1(pcols) !aerodynamical resistance (s/m) + real(r8), intent(in) :: radius_part(pcols,pver) ! mean (volume/number) particle radius (m) + real(r8), intent(in) :: density_part(pcols,pver) ! density of particle material (kg/m3) + real(r8), intent(in) :: sig_part(pcols,pver) ! geometric standard deviation of particles + integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) + integer, intent(in) :: ncol + integer, intent(in) :: lchnk + + real(r8), intent(out) :: vlc_trb(pcols) !Turbulent deposn velocity (m/s) + real(r8), intent(out) :: vlc_grv(pcols,pver) !grav deposn velocity (m/s) + real(r8), intent(out) :: vlc_dry(pcols,pver) !dry deposn velocity (m/s) + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! Local Variables + integer :: m,i,k,ix !indices + real(r8) :: rho !atm density (kg/m**3) + real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air + real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere + real(r8) :: shm_nbr ![frc] Schmidt number + real(r8) :: stk_nbr ![frc] Stokes number + real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air + real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle + real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor + real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition + real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance + real(r8) :: brownian ! collection efficiency for Browning diffusion + real(r8) :: impaction ! collection efficiency for impaction + real(r8) :: interception ! collection efficiency for interception + real(r8) :: stickfrac ! fraction of particles sticking to surface + real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment + real(r8) :: lnsig ! ln(sig_part) + real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) + + integer :: lt + real(r8) :: lnd_frc + real(r8) :: wrk1, wrk2, wrk3 + + ! constants + real(r8) gamma(11) ! exponent of schmidt number +! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & +! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & +! 0.50d+00/ + data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & + 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & + 0.54e+00_r8/ + save gamma + + real(r8) alpha(11) ! parameter for impaction +! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & +! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & +! 100.00d+00/ + data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & + 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & + 50.00e+00_r8/ + save alpha + + real(r8) radius_collector(11) ! radius (m) of surface collectors +! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & +! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & +! -1.00d+00/ + data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & + 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & + -1.00e+00_r8/ + save radius_collector + + integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 +! data iwet/1, -1, -1, -1, -1, & +! -1, -1, -1, 1, -1, & +! 1/ + data iwet/-1, -1, -1, -1, -1, & + -1, 1, -1, 1, -1, & + -1/ + save iwet + + + !------------------------------------------------------------------------ + do k=1,pver + do i=1,ncol + + lnsig = log(sig_part(i,k)) +! use a maximum radius of 50 microns when calculating deposition velocity + radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & + exp((float(moment)-1.5_r8)*lnsig*lnsig) + dispersion = exp(2._r8*lnsig*lnsig) + + rho=pmid(i,k)/rair/t(i,k) + + ! Quasi-laminar layer resistance: call rss_lmn_get + ! Size-independent thermokinetic properties + vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & + (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 + mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 + (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) + vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air + + slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & + (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & + radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 + vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & + gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 + vlc_grv(i,k) = vlc_grv(i,k) * dispersion + + vlc_dry(i,k)=vlc_grv(i,k) + enddo + enddo + k=pver ! only look at bottom level for next part + do i=1,ncol + dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] + (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 + shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 + + wrk2 = 0._r8 + wrk3 = 0._r8 + do lt = 1,n_land_type + lnd_frc = fraction_landuse(i,lt,lchnk) + if ( lnd_frc /= 0._r8 ) then + brownian = shm_nbr**(-gamma(lt)) + if (radius_collector(lt) > 0.0_r8) then +! vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) + interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 + else +! non-vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 + interception = 0.0_r8 + endif + impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 + + if (iwet(lt) > 0) then + stickfrac = 1.0_r8 + else + stickfrac = exp(-sqrt(stk_nbr)) + if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 + endif + rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) + rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) + + wrk1 = 1.0_r8 / rss_trb + wrk2 = wrk2 + lnd_frc*( wrk1 ) + wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) + endif + enddo ! n_land_type + vlc_trb(i) = wrk2 + vlc_dry(i,k) = wrk3 + enddo !ncol + + return + end subroutine modal_aero_depvel_part + + !=============================================================================== + subroutine modal_aero_bcscavcoef_get( m, ncol, isprx, dgn_awet, scavcoefnum, scavcoefvol ) + + use modal_aero_data + !----------------------------------------------------------------------- + implicit none + + integer,intent(in) :: m, ncol + logical,intent(in):: isprx(pcols,pver) + real(r8), intent(in) :: dgn_awet(pcols,pver,ntot_amode) + real(r8), intent(out) :: scavcoefnum(pcols,pver), scavcoefvol(pcols,pver) + + integer i, k, jgrow + + return + end subroutine modal_aero_bcscavcoef_get + + !============================================================================= + !============================================================================= + subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) + use modal_aero_data, only : qqcw_get_field + use physics_buffer, only : physics_buffer_desc + !----------------------------------------------------------------- + ! ... Xfrom from mass to volume mixing ratio + !----------------------------------------------------------------- + + use chem_mods, only : adv_mass, gas_pcnst + + implicit none + + !----------------------------------------------------------------- + ! ... Dummy args + !----------------------------------------------------------------- + integer, intent(in) :: lchnk, ncol, im + real(r8), intent(in) :: mbar(ncol,pver) + real(r8), intent(inout) :: vmr(ncol,pver,gas_pcnst) + type(physics_buffer_desc), pointer :: pbuf(:) + + !----------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------- + integer :: k, m + real(r8), pointer :: fldcw(:,:) + + do m=1,gas_pcnst + if( adv_mass(m) /= 0._r8 ) then + fldcw => qqcw_get_field(pbuf, m+im,lchnk,errorhandle=.true.) + if(associated(fldcw)) then + do k=1,pver + vmr(:ncol,k,m) = mbar(:ncol,k) * fldcw(:ncol,k) / adv_mass(m) + end do + else + vmr(:,:,m) = 0.0_r8 + end if + end if + end do + end subroutine qqcw2vmr + + + !============================================================================= + !============================================================================= + subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) + !----------------------------------------------------------------- + ! ... Xfrom from volume to mass mixing ratio + !----------------------------------------------------------------- + + use m_spc_id + use chem_mods, only : adv_mass, gas_pcnst + use modal_aero_data, only : qqcw_get_field + use physics_buffer, only : physics_buffer_desc + + implicit none + + !----------------------------------------------------------------- + ! ... Dummy args + !----------------------------------------------------------------- + integer, intent(in) :: lchnk, ncol, im + real(r8), intent(in) :: mbar(ncol,pver) + real(r8), intent(in) :: vmr(ncol,pver,gas_pcnst) + type(physics_buffer_desc), pointer :: pbuf(:) + + !----------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------- + integer :: k, m + real(r8), pointer :: fldcw(:,:) + !----------------------------------------------------------------- + ! ... The non-group species + !----------------------------------------------------------------- + do m = 1,gas_pcnst + fldcw => qqcw_get_field(pbuf, m+im,lchnk,errorhandle=.true.) + if( adv_mass(m) /= 0._r8 .and. associated(fldcw)) then + do k = 1,pver + fldcw(:ncol,k) = adv_mass(m) * vmr(:ncol,k,m) / mbar(:ncol,k) + end do + end if + end do + + end subroutine vmr2qqcw + +end module aero_model diff --git a/src/chemistry/oslo_aero/aeronucl.F90 b/src/chemistry/oslo_aero/aeronucl.F90 new file mode 100644 index 0000000000..74e0156957 --- /dev/null +++ b/src/chemistry/oslo_aero/aeronucl.F90 @@ -0,0 +1,374 @@ +subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) + +! Subroutine to calculate nucleation (formation) rates of new particles +! At the moment, the final nucleation rate consists of +! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) +! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract +! (2) Boundary-layer nucleation +! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html +! (3) First version published ACP (Risto Makkonen) +! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html +! Modified Spring 2015, cka + + use shr_kind_mod, only: r8 => shr_kind_r8 + use wv_saturation, only: qsat_water + use physconst, only: avogad, rair + use ppgrid, only: pcols, pver, pverp + use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na + use commondefinitions, only: originalNumberMedianRadius + use cam_history, only: outfld + use phys_control, only: phys_getopts + use chem_mods, only: adv_mass + use m_spc_id, only : id_H2SO4, id_soa_lv + use const, only : volumeToNumber + + implicit none + + !-- Arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric column + real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity + real(r8), intent(in) :: t(pcols,pver) ! Temperature (K) + real(r8), intent(in) :: h2so4pc(pcols,pver) ! Sulphuric acid concentration (kg kg-1) + real(r8), intent(in) :: oxidorg(pcols,pver) ! Organic vapour concentration (kg kg-1) + real(r8), intent(in) :: coagnuc(pcols,pver) ! Coagulation sink for nucleating particles [1/s] + real(r8), intent(out) :: nuclorg(pcols,pver) ! Nucleated mass (ORG) + real(r8), intent(out) :: nuclso4(pcols,pver) ! Nucleated mass (H2SO4) + real(r8), intent(in) :: zm(pcols,pver) ! Height at layer midpoints (m) + real(r8), intent(in) :: pblht(pcols) ! Planetary boundary layer height (m) + + !-- Local variables + + real(r8), parameter :: pi=3.141592654_r8 + !cka+ + real(r8), parameter :: gasconst_R=8.314472_r8 ! universal gas constant [J mol-1 K-1] + real(r8), parameter :: h2so4_dens=1841._r8 ! h2so4 density [kg m-3] + real(r8), parameter :: org_dens=2000._r8 ! density of organics [kg m-3], based on RM assumptions + !cka - + + integer :: i,k + real(r8) :: qs(pcols,pver) ! Saturation specific humidity + real(r8) :: relhum(pcols,pver) ! Relative humidity + real(r8) :: h2so4(pcols,pver) ! Sulphuric acid concentration [#/cm3] + real(r8) :: nuclvolume(pcols,pver) ! [m3/m3/s] Nucleated mass (SO4+ORG) + real(r8) :: rhoair(pcols,pver) ! density of air [kg/m3] !cka + real(r8) :: pblht_lim(pcols) ! Planetary boundary layer height (m) (500mzm(i,k) .AND. pbl_nucleation>0) then + + if(pbl_nucleation .EQ. 1) then + + !-- Paasonen et al. (2010), eqn 10, Table 4 + nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) + + else if(pbl_nucleation .EQ. 2) then + + !-- Paasonen et al. (2010) + !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 + nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) + + end if + + nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) + + else !Not using PBL-nucleation + nuclrate_pbl(i,k)=0._r8 + end if + !Size [nm] of particles in PBL + nuclsize_pbl(i,k)=2._r8 + + end do !horizontal points + end do !levels + + !-- Calculate total nucleated mass + do k=1,pver + do i=1,ncol + + ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 + vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) + grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) + grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) + + ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 + vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) + grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) + grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) + + ! Combined growth rate (cka) + gr(i,k)=grh2so4(i,k)+grorg(i,k) + + !-- Lehtinen 2007 parameterization for apparent formation rate + ! diameters in nm, growth rate in nm h-1, coagulation in s-1 + + call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) + call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) + + formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) + formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) + + ! Number of mol nucleated per g air per second. + nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] + *1.0e6_r8 & !==> [particles / m3 /] + /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] + / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec + + !Estimate how much is organic based on growth-rate + if(gr(i,k)>1.E-10_r8) then + frach2so4=grh2so4(i,k)/gr(i,k) + else + frach2so4=1._r8 + end if + + ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] + ! used density of particle phase, not of condensing gas + nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 + nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) + + end do + end do + + !-- Diagnostic output + call outfld('NUCLRATE', nuclrate_bin+nuclrate_pbl, pcols ,lchnk) + call outfld('FORMRATE', formrate_bin+formrate_pbl, pcols ,lchnk) + call outfld('COAGNUCL', coagnuc, pcols ,lchnk) + call outfld('GRH2SO4', grh2so4, pcols ,lchnk) + call outfld('GRSOA', grorg, pcols ,lchnk) + call outfld('GR', gr, pcols ,lchnk) + + return +end + diff --git a/src/chemistry/oslo_aero/aerosoldef.F90 b/src/chemistry/oslo_aero/aerosoldef.F90 new file mode 100644 index 0000000000..46e855ad7e --- /dev/null +++ b/src/chemistry/oslo_aero/aerosoldef.F90 @@ -0,0 +1,709 @@ +module aerosoldef + +!--------------------------------------------------------------------------------- +! Module to set up register aerosols indexes, number of gas and particle +! species and their scavenging rates. Tables for humidity growth +!--------------------------------------------------------------------------------- +! Modified Spring 2015 by cka to include a version of RM's treatment of soa. (Makkonen et al. 2012) +! Modified Summer 2015 by ak to include a new treatment of sea-salt (Salter et al. 2015) + + use commondefinitions + use modal_aero_data, only: qqcw_set_ptr + use mo_tracname, only : solsym + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name,cnst_get_ind + use cam_abortutils, only: endrun + + implicit none + save + private ! Make default type private to the module + + integer, public, parameter :: max_tracers_per_mode = 7 + real(r8), public,dimension (pcnst) ::rhopart + real(r8), public,dimension (pcnst) ::sgpart + real(r8), public,dimension (pcnst) ::osmoticCoefficient + real(r8), public,dimension (pcnst) ::numberOfIons + real(r8), public,dimension (pcnst) ::solubleMassFraction + integer, public,dimension (pcnst) ::aerosolType + real(r8), public, dimension(nbmodes) :: numberFractionAvailableAqChem + real(r8), public,dimension (pcnst) :: invrhopart + + + real(r8), public, parameter :: smallConcentration = 1.e-100_r8 !duplicate, sync with smallNumber in Const +! +! Public interfaces +! + public aero_register ! register consituents + public is_process_mode ! Check is an aerosol specie is a process mode + public isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) + public getTracerIndex + public getNumberOfTracersInMode + public getNumberOfBackgroundTracersInMode + public getCloudTracerIndex + public getCloudTracerIndexDirect + public getCloudTracerName + public chemistryIndex + public physicsIndex + public getDryDensity + public getConstituentFraction + public isTracerInMode + public fillAerosolTracerList + public getNumberOfAerosolTracers + public fillInverseAerosolTracerList + +!cka: Add SOA particles to mode 1 and 11 + integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode + integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 +!cka integer, parameter, public :: MODE_IDX_SO4_AIT = 1 !Pure SO4 in aitken mode, Created from 11 by growth (condensation) of SO4 + integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 + integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas + integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode +!cka integer, parameter, public :: MODE_IDX_SO4_NUC = 11 !SO4 nucleation mode + integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode + integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes + + integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) + integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) + + integer, parameter, public :: numberOfProcessModeTracers = 6 + integer, public, dimension(numberOfProcessModeTracers) :: tracerInProcessMode + integer, public, dimension(pcnst) :: processModeMap + + !These tables describe how the tracers behave chemically + integer, dimension(numberOfExternallyMixedModes), public :: externallyMixedMode = (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_NUC, MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) + integer, dimension(numberOfInternallyMixedMOdes), public :: internallyMixedMode = (/MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & + ,MODE_IDX_SO4_AC, MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1 & + ,MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) + +!cka: add l_soa_n, l_soa_na (particles) l_soa_a1 (condensate) and l_soa_lv, l_soa_sv (SOA precursors) +! following are species indices for individual camuio species + integer,public :: & + l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac, & + l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac, & + l_om_ni, l_om_ai ,l_om_ac, & + l_so4_pr, & + l_dst_a2, l_dst_a3, & + l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4, & + l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv + +! some code here has been moved to commondefinitions... + + integer :: n_aerosol_tracers !number of aerosol tracers + + integer :: imozart + + !Number of transported tracers in each mode + integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) !cka: added organic condensate to mode 1,2,4-10 + integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) !cka: added soa to mode 1 and 11 + + integer, dimension(0:nmodes, max_tracers_per_mode) :: tracer_in_mode + + + !Radius used for the modes in the lifeCycle MAY ASSUME SOME GROWTH ALREADY HAPPENED + real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleNumberMedianRadius = & +!BCsizes 1.e-6_r8*(/ 0.1_r8, 0.02_r8, 0.0118_r8, 0.04_r8, 0.04_r8, 0.075_r8, & + 1.e-6_r8*(/ 0.0626_r8, 0.025_r8, 0.025_r8, 0.04_r8, 0.06_r8, 0.075_r8, & + 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & ! Salter et al. (2015) +!BCsizes 0.0118_r8, 0.0118_r8, 0.04_r8, 0.04_r8 /) + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) + + !Sigma based on original lifecycle code (taken from "sigmak" used previously in lifecycle code) + real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleSigma = (/1.6_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !0-4 + ,1.59_r8, 1.59_r8, 2.0_r8 & !5,6,7 (SO4+dust) + ,2.1_r8, 1.72_r8, 1.6_r8 & !8-10 (SS) ! Salter et al. (2015) + ,1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !11-14 + /) + + !Below cloud scavenging coefficients for modes which have an actual size + real(r8), parameter, public, dimension(0:nmodes) :: belowCloudScavengingCoefficient= & + (/ 0.01_r8 , 0.02_r8 , 0.02_r8 , 0.0_r8 , 0.02_r8, 0.01_r8, & !(0-5) + 0.02_r8 , 0.2_r8 , 0.02_r8 , 0.02_r8, 0.5_r8, & !6-10 (DUST+SS) + 0.04_r8 , 0.08_r8 , 0.0_r8 , 0.02_r8 /) ! SO4_n, bc_n, N/A og bc/oc + + !Treatment of process-modes! + !The tracers indices can not be set here since they are not known on compile time + !tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) + + !The process modes need an "efficient size" (Why does A1 have a different size than the others??) + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeNumberMedianRadius = & + (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) + + !The process modes need an "efficient sigma" + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & + (/ 1.8_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.8_r8 /) + + + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: belowCloudScavengingCoefficientProcessModes = & + (/0.02_r8, 0.01_r8, 0.02_r8, 0.02_r8, 0.02_r8, 0.02_r8 /) + + !Growth of aerosols, duplicated in opttab!! AK: NB oppdaterte tall i opttab, rh der er ikke helt lik rhtab... + real(r8), public,dimension (10) :: rhtab + real(r8), public,dimension (10,pcnst):: rdivr0(10,pcnst) + + data rhtab/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.80_r8, 0.85_r8, 0.90_r8, 0.95_r8, 0.98_r8 / + + integer, dimension(pcnst) :: cloudTracerIndex + character(len=20) :: cloudTracerName(pcnst) +contains + + + !For a tracer in an aerosol mode, check if this is + !actually a real tracer or a process mode + function is_process_mode(l_index_in, isChemistry) result(answer) + implicit none + integer, intent(in) :: l_index_in + logical, intent(in) :: isChemistry !true if called from chemistry + integer :: l_index_phys + logical :: answer + + l_index_phys = l_index_in + if(isChemistry .eqv. .true.)then + l_index_phys = l_index_phys + iMozart - 1 + endif + + !answer becomes true if tracer is a "process mode" + answer = .FALSE. + if(l_index_phys .eq. l_so4_a1 & + .OR. l_index_phys .eq. l_so4_a2 & + .OR. l_index_phys .eq. l_so4_ac & + .OR. l_index_phys .eq. l_bc_ac & + .OR. l_index_phys .eq. l_om_ac & + .OR. l_index_phys .eq. l_soa_a1 ) then + answer = .TRUE. + endif + + return + end function is_process_mode + +!=============================================================================== + subroutine aero_register +!----------------------------------------------------------------------- +! +! Register aerosol modes and indices, should be changed to read in values +! instead of hard-coding it. +! +!----------------------------------------------------------------------- + + use mpishorthand + use physics_buffer, only: pbuf_add_field, dtype_r8 + use ppgrid, only: pcols, pver, pverp + + + implicit none + integer :: idx_dum, l,m,mm + logical isAlreadyCounted(pcnst) + +! register the species + + call cnst_get_ind('SO4_NA',l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) + call cnst_get_ind('SO4_A1',l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) + call cnst_get_ind('SO4_A2',l_so4_a2, abort=.true.) !sulfate produced in aq. chemistry + call cnst_get_ind('SO4_AC',l_so4_ac, abort=.true.) !sulfate from coagulation processes + call cnst_get_ind('SO4_PR',l_so4_pr, abort=.true.) !sulfate emitted as primary + + call cnst_get_ind('BC_N',l_bc_n, abort=.true.) !emissions (mainly industry) lost through coagulation + call cnst_get_ind('BC_AX',l_bc_ax, abort=.true.) !externally mixed (fluffy and impossible to activate) + call cnst_get_ind('BC_NI',l_bc_ni, abort=.true.) !mixed with oc (mainly biomass), externally mixed otherwise (before condensation etc) + call cnst_get_ind('BC_A',l_bc_a, abort=.true.) !formed when bc_n grows by condensation + call cnst_get_ind('BC_AI',l_bc_ai, abort=.true.) !formed when bc_ni grows by condensation + call cnst_get_ind('BC_AC',l_bc_ac, abort=.true.) !bc from coagulation processes + + call cnst_get_ind('OM_NI',l_om_ni, abort=.true.) !om (mainly from biomass), emitted + call cnst_get_ind('OM_AI',l_om_ai, abort=.true.) !om formed when condensation growth of om_ni + call cnst_get_ind('OM_AC',l_om_ac, abort=.true.) !om from coagulation processes + + call cnst_get_ind('DST_A2',l_dst_a2, abort=.true.) !Dust accumulation mode + call cnst_get_ind('DST_A3',l_dst_a3, abort=.true.) !Dust coarse mode + + call cnst_get_ind('SS_A1',l_ss_a1, abort=.true.) !Sea salt fine mode + call cnst_get_ind('SS_A2',l_ss_a2, abort=.true.) !Sea salt accumulation mode + call cnst_get_ind('SS_A3',l_ss_a3, abort=.true.) !Sea salt coarse mode + +!cka: register SOA species + call cnst_get_ind('SOA_NA',l_soa_na, abort=.true.) !Aitken mode SOA with SO4 and SOA condensate + call cnst_get_ind('SOA_A1',l_soa_a1, abort=.true.) !SOA condensate + call cnst_get_ind('SOA_LV',l_soa_lv, abort=.true.) !Gas phase low volatile SOA + call cnst_get_ind('SOA_SV',l_soa_sv, abort=.true.) !Gas phase semi volatile SOA + + !gas phase h2so4 + call cnst_get_ind('H2SO4', l_h2so4, abort=.true.) + + !Register the tracers in modes + call registerTracersInMode() + + !Set the aerosol types + aerosolType(:)=-99 + aerosolType(l_so4_na)=AEROSOL_TYPE_SULFATE + aerosolType(l_so4_a1)=AEROSOL_TYPE_SULFATE + aerosolType(l_so4_a2)=AEROSOL_TYPE_SULFATE + aerosolType(l_so4_ac)=AEROSOL_TYPE_SULFATE + aerosolType(l_so4_pr)=AEROSOL_TYPE_SULFATE + aerosolType(l_bc_n)=AEROSOL_TYPE_BC + aerosolType(l_bc_ax)=AEROSOL_TYPE_BC + aerosolType(l_bc_ni)=AEROSOL_TYPE_BC + aerosolType(l_bc_a) =AEROSOL_TYPE_BC + aerosolType(l_bc_ai)=AEROSOL_TYPE_BC + aerosolType(l_bc_ac)=AEROSOL_TYPE_BC + aerosolType(l_om_ni)=AEROSOL_TYPE_OM + aerosolType(l_om_ai)=AEROSOL_TYPE_OM + aerosolType(l_om_ac)=AEROSOL_TYPE_OM + aerosolType(l_dst_a2)=AEROSOL_TYPE_DUST + aerosolType(l_dst_a3)=AEROSOL_TYPE_DUST + aerosolType(l_ss_a1)=AEROSOL_TYPE_SALT + aerosolType(l_ss_a2)=AEROSOL_TYPE_SALT + aerosolType(l_ss_a3)=AEROSOL_TYPE_SALT + aerosolType(l_soa_na)=AEROSOL_TYPE_OM + aerosolType(l_soa_a1)=AEROSOL_TYPE_OM + + rhopart(:)= 1000.0_r8 + !assign values based on aerosol type + do m=0,nmodes + do l=1,n_tracers_in_mode(m) + mm= getTracerIndex(m,l,.false.) + osmoticCoefficient(mm) = aerosol_type_osmotic_coefficient(aerosolType(mm)) + rhopart(mm) = aerosol_type_density(aerosolType(mm)) + solubleMassFraction(mm) = aerosol_type_soluble_mass_fraction(aerosolType(mm)) + numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) + end do + end do + !SPECIAL CASES OF AEROSOL PROPERTIES: + !Density of bc_ax is rewritten later (calculated from fractal dimension) + !so4_a2 is different since it is ammonium sulfate and not sulf. acid. + rhopart(l_so4_a2) = 1769.0_r8 + + !These are not really particles, but set densities for the condenseable vapours + !used by condtend + rhopart(l_h2so4)= 1841.0_r8 + rhopart(l_soa_lv) = aerosol_type_density(AEROSOL_TYPE_OM) + rhopart(l_soa_sv) = aerosol_type_density(AEROSOL_TYPE_OM) +! Inverse calculated to avoid unneeded divisions in loop + invrhopart(:)=1._r8/rhopart(:) + !Set process mode sizes + tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) + processModeMap(:)=-99 !Force error if using unset values + do l =1,pcnst + do m=1,numberOfProcessModeTracers + if(tracerInProcessMode(m) .eq. l)then + processModeMap(l)=m + end if + end do + end do + + !Find out first mozart tracers (fxm: short lived species might mess up this!) + call cnst_get_ind(trim(solsym(1)), imozart, abort=.true.) + + !Add the cloud-tracers + isAlreadyCounted(:) = .false. + cloudTracerIndex(:) = -1 + do m=1,nmodes + do l=1,n_tracers_in_mode(m) + mm= getTracerIndex(m,l,.false.) + if(.not. isAlreadyCounted(mm))then + cloudTracerName(mm) = trim(cnst_name(mm))//"_OCW" + !print*, "CTN ", trim(cloudTracerName(mm)) + call pbuf_add_field(trim(cloudTracerName(mm)), 'global', dtype_r8, (/pcols,pver/), idx_dum) + call qqcw_set_ptr(mm,idx_dum) + cloudTracerIndex(mm) = idx_dum + isAlreadyCounted(mm) = .true. + endif + end do + end do + + + !Find out how many aerosol-tracers we carry + isAlreadyCounted(:) = .FALSE. + n_aerosol_tracers=0 + do m=1,nmodes + do l=1,n_tracers_in_mode(m) + mm=getTracerIndex(m,l,.false.) + if(.not. isAlreadyCounted(mm))then + n_aerosol_tracers = n_aerosol_tracers + 1 + isAlreadyCounted(mm)=.true. + endif + end do + end do + + !Tabulated rh-growth for all species + call inittabrh + + + return + end subroutine aero_register + + function getNumberOfAerosolTracers()RESULT(numberOfTracers) + implicit none + integer :: numberOfTracers + numberOfTracers = n_aerosol_tracers + end function getNumberOfAerosolTracers + + function chemistryIndex(phys_index) RESULT (chemistryIndexOut) + implicit none + integer, intent(in) :: phys_index + integer :: chemistryIndexOut + + chemistryIndexOut = phys_index - imozart + 1 + end function chemistryIndex + + function physicsIndex(chem_index) RESULT(physIndexOut) + implicit none + integer, intent(in) :: chem_index + integer :: physIndexOut + + physIndexOut = chem_index + imozart - 1 + end function physicsIndex + + function isAerosol(phys_index) RESULT(answer) + integer, intent(in) :: phys_index + logical answer + answer=.FALSE. + if(aerosolType(phys_index) .gt. 0)then + answer = .TRUE. + endif + return + end function isAerosol +!============================================================================= + + function getNumberOfTracersInMode(modeIndex) RESULT(numberOfSpecies) + implicit none + integer, intent(in) :: modeIndex + integer numberOfSpecies + numberOfSpecies = n_tracers_in_mode(modeIndex) + end function getNumberOfTracersInMode + + function getNumberOfBackgroundTracersInMode(modeIndex) RESULT (numberOfBackgroundSpecies) + implicit none + integer, intent(in) :: modeIndex + integer numberOfBackgroundSpecies + numberOfBackgroundSpecies = n_background_tracers_in_mode(modeIndex) + end function getNumberOfBackgroundTracersInMode + + !purpose: Ask for an index in mode + !The index is the index in the q-array + !Some tracers may exist in several modes (is that a problem??) + function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerIndex) + implicit none + integer, intent(in) :: modeIndex + integer, intent(in) :: componentIndex + logical, intent(in) :: isChemistry + integer tracerIndex + + if(isChemistry)then + !This is tracer index in physics array + tracerIndex = tracer_in_mode(modeIndex,componentIndex)-imozart+1 + else + tracerIndex = tracer_in_mode(modeIndex,componentIndex) + endif + + end function getTracerIndex + + !Obtain an index in the physics-buffer for a component in the lifecycle scheme + function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_index) + implicit none + integer, intent(in) :: modeIndex + integer, intent(in) :: componentIndex + integer :: tracerIndex + integer cloud_tracer_index + + if(componentIndex == 0)then + !Special key for number concentration of a mode + print*,"error no such species" + stop + else if (componentIndex > 0)then + !Lifecycle specie in a mode + tracerIndex = getTracerIndex(modeIndex,componentIndex,.false.) + cloud_tracer_index = cloudTracerIndex(tracerIndex) !ak: Index in phys-buffer + else + !error, negative component index + call endrun("negative componentindex in getCloudTracerIndex") + endif + end function getCloudTracerIndex + + !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" + !returns "-1" if the tracer does not have any corresponding cloud tracer + function getCloudTracerIndexDirect(tracerIndex) RESULT(cloudTracerIndexOut) + implicit none + integer, intent(in) :: tracerIndex + integer :: cloudTracerIndexOut + + cloudTracerIndexOut = cloudTracerIndex(tracerIndex) + + end function getCloudTracerIndexDirect + + function getDryDensity(m,l) RESULT(density) + implicit none + integer, intent(in) :: m !mode index + integer, intent(in) :: l !tracer index + real(r8) :: density + density = rhopart(tracer_in_mode(m,l)) + end function + + + function getCloudTracerName(tracerIndex) RESULT(cloudTracerNameOut) + implicit none + integer, intent(in) :: tracerIndex + character(len=20) :: cloudTracerNameOut + cloudTracerNameOut = trim(cloudTracerName(tracerIndex)) + return + end function getCloudTracerName + + subroutine fillAerosolTracerList(aerosolTracerList) + implicit none + integer, dimension (:), intent(out) :: aerosolTracerList + logical, dimension(pcnst) :: alreadyFound + + integer :: m,l,mm,nTracer + + alreadyFound(:) = .FALSE. + + nTracer = 0 + do m=1,nmodes + do l=1,n_tracers_in_mode(m) + mm=getTracerIndex(m,l,.FALSE.) + if(.NOT.alreadyFound(mm))then + nTracer = nTracer + 1 + alreadyFound(mm) = .TRUE. + aerosolTracerList(nTracer) = mm + end if + end do + end do + end subroutine fillAerosolTracerList + + subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) + implicit none + integer, dimension(:), intent(in) :: aerosolTracerList + integer, intent(in) :: n_aerosol_tracers + integer, dimension(pcnst), intent(out) :: inverseAerosolTracerList + integer :: i + + inverseAerosolTracerList(:) = -99 + do i=1,n_aerosol_tracers + inverseAerosolTracerList(aerosolTracerList(i)) = i + end do + + end subroutine + + !Register tracer index in modes + subroutine registerTracersInMode() + + implicit none + + tracer_in_mode(:,:) = -1 !undefined + !externally mixed bc + tracer_in_mode(MODE_IDX_BC_EXT_AC, 1:n_tracers_in_mode(MODE_IDX_BC_EXT_AC)) = (/l_bc_ax/) +!cka !sulphate + sulfate condensate +!cka tracer_in_mode(MODE_IDX_SO4_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4_AIT) ) = (/l_so4_na, l_so4_a1/) + !sulphate + soa, sulfate condensate. + tracer_in_mode(MODE_IDX_SO4SOA_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_AIT) ) = (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) + !bc + sulfate condensate + tracer_in_mode(MODE_IDX_BC_AIT,1:n_tracers_in_mode(MODE_IDX_BC_AIT)) = (/l_bc_a, l_so4_a1, l_soa_a1/) + !index not used + !tracer_in_mode(MODE_IDX_NOT_USED, 1:n_tracers_in_mode(MODE_IDX_NOT_USED)) = (/-1/) + !om / bc internally mixed with sulfate condensate and aquous phase sulfate + tracer_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT))= (/l_bc_ai, l_om_ai, l_so4_a1, l_so4_a2, l_soa_a1 /) + !accumulation mode sulfate with coagulate, condensate and aquous phase sulfate + tracer_in_mode(MODE_IDX_SO4_AC, 1:n_tracers_in_mode(MODE_IDX_SO4_AC)) = (/l_so4_pr, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !ac-mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_DST_A2, 1:n_tracers_in_mode(MODE_IDX_DST_A2)) = (/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !coarse mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_DST_A3, 1:n_tracers_in_mode(MODE_IDX_DST_A3)) = (/l_dst_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !at-mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A1, 1:n_tracers_in_mode(MODE_IDX_SS_A1)) = (/l_ss_a1, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !ac mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A2, 1:n_tracers_in_mode(MODE_IDX_SS_A2)) = (/l_ss_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !coarse mode ss sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A3, 1:n_tracers_in_mode(MODE_IDX_SS_A3)) = (/l_ss_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + !sulfate + soa nucleation mode (mode no longer used) + !tracer_in_mode(MODE_IDX_SO4SOA_NUC, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_NUC)) = (/ -1 /) + !bc in nucleation mode + tracer_in_mode(MODE_IDX_BC_NUC, 1:n_tracers_in_mode(MODE_IDX_BC_NUC)) = (/l_bc_n/) + !lumped organics + !tracer_in_mode(MODE_IDX_LUMPED_ORGANICS, 1:n_tracers_in_mode(MODE_IDX_LUMPED_ORGANICS)) = (/-1/) + !intermal mixture bc/oc coated + tracer_in_mode(MODE_IDX_OMBC_INTMIX_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_AIT)) = (/l_bc_ni, l_om_ni/) + + end subroutine registerTracersInMode + ! + + function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) + implicit none + integer, intent(in) :: modeIndex + integer, intent(in) :: constituentIndex + integer :: i + logical :: answer + answer = .FALSE. + do i=1,n_tracers_in_mode(modeIndex) + if(tracer_in_mode(modeIndex,i) == constituentIndex)then + answer = .TRUE. + endif + enddo + return + end function isTracerInMode + ! + + function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa & + ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction + implicit none + real(r8), intent(in) :: CProcessModes + real(r8), intent(in) :: f_c + real(r8), intent(in) :: f_bc + real(r8), intent(in) :: f_aq + real(r8), intent(in) :: f_so4_cond + real(r8), intent(in) :: f_soa + real(r8), intent(in) :: cam + real(r8), intent(in) :: f_aqm + real(r8), intent(in) :: f_bcm + real(r8), intent(in) :: f_acm + real(r8), intent(in) :: f_so4_condm + real(r8), intent(in) :: f_soam + integer, intent(in) :: constituentIndex + logical, optional, intent(in) :: debugPrint + logical :: doPrint = .false. + real(r8) :: fraction + + if(present(debugPrint))then + if(debugPrint .eqv. .true.)then + doPrint=.true. + endif + endif + + + fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below + + !This fraction is the mass of a certain tracer in a specific size-mode divided by the total + !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what + !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the + !aerosol size-distribution, which is assumed to be log-normal prior to growth. + if((l_so4_a1 .eq. constituentIndex))then !so4 condensation + fraction= (cam & + *(1.0_r8-f_acm) & !sulfate fraction + *(1.0_r8-f_aqm) & !fraction not from aq phase + *(f_so4_condm) & !fraction being condensate + ) & + / & + (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate + + if(doPrint .eqv. .true.)then + print*, " " + print*, "conc ==>", CProcessmodes, cam + print*, "modefrc ==>", f_acm, f_aqm, f_so4_condm + print*, "totfrc ==>", f_c, f_aq, f_so4_cond + print*, "fraction ==>", cam/(CProcessModes+smallConcentration)*100.0, fraction*100 , "%" + endif + + else if(l_so4_ac .eq. constituentIndex)then !so4 coagulation + fraction = (cam & + * (1.0_r8 - f_acm) & !sulfate fraction + * (1.0_r8 - f_aqm) & !fraction not from aq phase + * (1.0_r8 - f_so4_condm) & !fraction not being condensate + ) & + / & + (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*(1.0_r8-f_so4_cond) & !total non-aq sulf + +smallConcentration) + + else if(l_so4_a2 .eq. constituentIndex) then !so4 wet phase + fraction = (cam & + *(1.0_r8-f_acm) & !sulfate fraction + *f_aqm) & !aq phase fraction of sulfate + / & + (CProcessModes*(1.0_r8-f_c)*(f_aq)+smallConcentration) + + else if(l_bc_ac .eq. constituentIndex)then !bc coagulated + fraction = (cam & + *f_acm & ! carbonaceous fraction + *f_bcm) & ! bc fraction of carbonaceous + / & + (CProcessModes*f_c*f_bc+smallConcentration) + + else if(l_om_ac .eq. constituentIndex ) then !oc coagulated + fraction = (cam & + *f_acm & ! carbonaceous fraction + *(1.0_r8-f_bcm) & ! oc fraction of carbonaceous + *(1.0_r8-f_soam))& ! oc fraction which is soa + / & + (CProcessModes*f_c*(1.0_r8-f_bc)*(1.0_r8-f_soa)+smallConcentration) + + else if (l_soa_a1 .eq. constituentIndex) then !SOA condensate + fraction = cam & + *f_acm & !carbonaceous fraction + *(1.0_r8 -f_bcm) & !om fraction + *(f_soam) & !fraction of OM is SOA + / & + (CProcessModes * f_c* (1.0_r8 -f_bc)*f_soa + smallConcentration) + end if + + !if(fraction .gt. 1.2_r8)then + ! if(cam .gt. 1.e-8 *CprocessModes)then + ! print*, "warning, fraction > 1.2 in getConstituentFraction", constituentIndex, fraction + ! print*, " ==> ", CprocessModes, cam ,f_c, f_bc, f_aq,f_so4_cond + ! print*, " ==> ", f_acm, f_bcm, f_aq, f_so4_condm + ! print*, " ==> ", cam/CprocessModes + ! !stop + ! endif + ! fraction = 1.0_r8 + if (fraction .gt. 1.0_r8)then + fraction = 1.0_r8 + endif + + return + end function getConstituentFraction + +!********************************************** + + + subroutine inittabrh + + ! Tables for hygroscopic growth + + integer :: i + + + real(r8) :: rr0ss(10),rr0so4(10),rr0bcoc(10) + + data rr0ss / 1.00_r8, 1.00_r8, 1.02_r8, 1.57_r8, 1.88_r8, 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 3.62_r8 / + data rr0so4 / 1.00_r8, 1.34_r8, 1.39_r8, 1.52_r8, 1.62_r8, 1.69_r8, 1.78_r8, 1.92_r8, 2.22_r8, 2.79_r8 / + data rr0bcoc / 1.00_r8, 1.02_r8, 1.03_r8, 1.12_r8, 1.17_r8, 1.20_r8, 1.25_r8, 1.31_r8, 1.46_r8, 1.71_r8 / + + rdivr0(:,:)=1._r8 + + do i=1,10 + rdivr0(i,l_so4_na)=rr0so4(i) + rdivr0(i,l_so4_a1)=rr0so4(i) + rdivr0(i,l_so4_a2)=rr0so4(i) + rdivr0(i,l_so4_ac)=rr0so4(i) + rdivr0(i,l_so4_pr)=rr0so4(i) + + rdivr0(i,l_bc_a)=rr0bcoc(i) + +! rdivr0(i,l_bc_n)=rr0bcoc(i) + rdivr0(i,l_bc_ni)=rr0bcoc(i) + rdivr0(i,l_bc_ai)=rr0bcoc(i) + rdivr0(i,l_bc_ac)=rr0bcoc(i) + +! rdivr0(i,l_om_n)=rr0bcoc(i) + rdivr0(i,l_om_ni)=rr0bcoc(i) + rdivr0(i,l_om_ai)=rr0bcoc(i) + rdivr0(i,l_om_ac)=rr0bcoc(i) + + rdivr0(i,l_ss_a1)=rr0ss(i) + rdivr0(i,l_ss_a2)=rr0ss(i) + rdivr0(i,l_ss_a3)=rr0ss(i) + +!cka: Add hygroscopic properties for soa. Assume identical to bcoc properties. + rdivr0(i,l_soa_na)=rr0bcoc(i) +! rdivr0(i,l_soa_a1)=rr0bcoc(i) + + end do + return + end subroutine inittabrh + +end module aerosoldef + + diff --git a/src/chemistry/oslo_aero/appformrate.F90 b/src/chemistry/oslo_aero/appformrate.F90 new file mode 100644 index 0000000000..53ef08c64d --- /dev/null +++ b/src/chemistry/oslo_aero/appformrate.F90 @@ -0,0 +1,58 @@ +subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) + !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) + !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 + !-- Parameterization takes into account the loss of particles due to coagulation + !-- Growth by self-coagulation is not accounted for + !-- Typically, 1% of 1 nm nuclei make it to 12 nm + !-- Written by Risto Makkonen + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + !-- Arguments + + real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) + real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) + real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) + real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) + real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) + real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) + + !-- Local variables + + real(r8) :: m + real(r8) :: gamma + real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx + + ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm + + !-- (Eq. 6) Exponent m, depends on background distribution + ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) + ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 + m=-1.6_r8 + CoagS_d1=CoagS_dx*(d1/dx)**m + CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) + + gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) + gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) + + !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) + + !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 + !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) + jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) + + return + +end + + ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm + + ! Koagtendista: + ! Siis lasketaan siella koagulaatio SO4_N -moodille. + ! Condtend lasketaan ennen coagtendia, eli naita ei ole saatavilla!! Voisiko vaihtaa jarjestysta + ! Nama on constants.F90:ssa + ! rhob(0) = rhopart(l_bc_ax) ! mostly not in use (rhorbc in stead) + ! rk(1) = effsize(l_so4_n)*1.e6_r8 + ! Pitaisko siis koagsubissa laskea oma Kp12s4 nukleaatiokoon hiukkasille, vai olettaako samaksi kuin 10nm, vai onko joku kaava diff --git a/src/chemistry/oslo_aero/calcaersize.F90 b/src/chemistry/oslo_aero/calcaersize.F90 new file mode 100644 index 0000000000..cbc65878c6 --- /dev/null +++ b/src/chemistry/oslo_aero/calcaersize.F90 @@ -0,0 +1,179 @@ +module calcaersize + +contains + +! � Seland Calculates mean volume size and hygroscopic growth for use in +! dry deposition + subroutine calcaersize_sub( ncol, & + t, h2ommr, pmid, pdel,wetnumberMedianDiameter,wetrho & + , wetNumberMedianDiameter_processmode, wetrho_processmode) + + + use constituents, only : pcnst + use shr_kind_mod,only: r8 => shr_kind_r8 + use ppgrid + use wv_saturation, only: qsat_water + use commondefinitions, only: nmodes + use aerosoldef + use physconst, only: rhoh2o + + implicit none + + integer, intent(in) :: ncol ! number of columns + real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) + real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity + real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! layer pressure thickness (Pa) + + real(r8), intent(out):: wetNumberMedianDiameter(pcols,pver,0:nmodes) + real(r8), intent(out):: wetrho(pcols,pver,0:nmodes) ! wet aerosol density + real(r8), intent(out) :: wetNumberMedianDiameter_processmode(pcols,pver,numberOfProcessModeTracers) + real(r8), intent(out) :: wetrho_processmode(pcols,pver,numberOfProcessModeTracers) + +! local variables + real(r8) :: relhum(pcols,pver) ! Relative humidity + integer :: i,k,m,irelh,mm, tracerCounter + integer ::l ! species index + real(r8) :: xrh(pcols,pver) + real(r8) :: qs(pcols,pver) ! saturation specific humidity + real(r8) :: rmeanvol ! Mean radius with respect to volume + integer :: irh1(pcols,pver),irh2(pcols,pver) + integer :: t_irh1,t_irh2 + real(r8) :: t_rh1,t_rh2,t_xrh,rr1,rr2 + real(r8) :: volumeFractionAerosol !with respect to total (aerosol + water) + real(r8) :: tmp1, tmp2 + real(r8) :: wetrad_tmp(max_tracers_per_mode) + real(r8) :: dry_rhopart_tmp(max_tracers_per_mode) + real(r8) :: mixed_dry_rho + + + !Get the tabulated rh in all grid cells + do k=1,pver + do i=1,ncol + call qsat_water(t(i,k),pmid(i,k), tmp1, qs(i,k), tmp2) + xrh(i,k) = h2ommr(i,k)/qs(i,k) +!cak +! if(xrh(i,k).lt.0.0_r8.or.xrh(i,k).gt.1.0_r8) then +! write(*,*) 'i,k,rh calcaer=',i,k,xrh(i,k) +! endif +!cak + xrh(i,k) = max(xrh(i,k),0.0_r8) + xrh(i,k) = min(xrh(i,k),1.0_r8) + relhum(i,k)=xrh(i,k) + xrh(i,k)=min(xrh(i,k),rhtab(10)) + end do + end do + + !Find the relh-index in all grid-points + do irelh=1,SIZE(rhtab) - 1 + do k=1,pver + do i=1,ncol + if(xrh(i,k).ge.rhtab(irelh).and. & + xrh(i,k).le.rhtab(irelh+1)) then + irh1(i,k)=irelh !lower index + irh2(i,k)=irelh+1 !higher index + end if + end do + end do + end do + + do k=1,pver + do i=1,ncol + + !Get the indexes out as floating point single numbers + t_irh1 = irh1(i,k) + t_irh2 = irh2(i,k) + t_rh1 = rhtab(t_irh1) + t_rh2 = rhtab(t_irh2) + t_xrh = xrh(i,k) + + do m = 0, nmodes + !Do some weighting to mass mean property + !weighting by 1.5 is number median ==> volumetric mean + !http://dust.ess.uci.edu/facts/psd/psd.pdf + rmeanvol = lifeCycleNumberMedianRadius(m)*DEXP(1.5_r8*(log(lifeCycleSigma(m)))**2) + wetNumberMedianDiameter(i,k,m ) = 0.1e-6_r8 !Initialize to something.. + mixed_dry_rho = 1.e3_r8 + + tracerCounter = 0 + do l = 1,getNumberOfBackgroundTracersInMode(m) + + tracerCounter = tracerCounter + 1 + + !which tracer is this? + mm = getTracerIndex(m,l,.false.) + + !radius of lower rh-bin for this tracer + rr1=rdivr0(t_irh1,mm) + + !radius of upper rh-bin for this tracer + rr2=rdivr0(t_irh2,mm) + + !linear interpolate dry ==> wet radius for this tracer + wetrad_tmp(tracerCounter) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & + (t_rh2-t_rh1))*rmeanvol + + !mixed density of dry particle + dry_rhopart_tmp(tracerCounter) = getDryDensity(m,l) + + end do + + !Find the average growth of this mode + !(still not taking into account how much we have!!) + if(TracerCounter .gt. 0)then + + !Convert to diameter and take average (note: This is MASS median diameter) + wetNumberMedianDiameter(i,k,m) = 2.0_r8 * SUM(wetrad_tmp(1:tracerCounter))/dble(tracerCounter) + + !Take average density + mixed_dry_rho = SUM(dry_rhopart_tmp(1:tracerCounter))/dble(tracerCounter) + + !At this point the radius is in "mass mean" space + volumeFractionAerosol = MIN(1.0_r8, ( 2.0_r8*rmeanVol / wetNumberMedianDiameter(i,k,m) )**3) + + !wet density + wetrho(i,k,m) = mixed_dry_rho * volumeFractionAerosol & + + (1._r8-volumeFractionAerosol)*rhoh2o + + !convert back to number median diameter (wet) + wetNumberMedianDiameter(i,k,m) = wetNumberMedianDiameter(i,k,m)*DEXP(-1.5_r8*(log(lifeCycleSigma(m)))**2) + endif + + + end do !modes + + !Same thing for the process modes + do l=1,numberOfProcessModeTracers + + mm = tracerInProcessMode(l) !process mode tracer (physics space) + + !weighting by 1.5 is number median ==> volumetric mean + !http://dust.ess.uci.edu/facts/psd/psd.pdf + rmeanvol = processModeNumberMedianRadius(l)*DEXP(1.5_r8*(log(processModeSigma(l)))**2) + + !radius of lower rh-bin for this tracer + rr1=rdivr0(t_irh1,mm) + + !radius of upper rh-bin for this tracer + rr2=rdivr0(t_irh2,mm) + + !Note this is MASS median diameter + wetNumberMedianDiameter_processmode(i,k,l) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & + (t_rh2-t_rh1))*rmeanvol*2.0_r8 + + volumeFractionAerosol = MIN(1.0, (2.0_r8*rmeanVol/wetnumberMedianDiameter_processmode(i,k,l))**3) + + wetrho_processmode(i,k,l) = volumeFractionAerosol*rhopart(mm) & + + (1.0_r8 - volumeFractionAerosol)*rhoh2o + + !convert back to number median diameter (wet) + wetNumberMedianDiameter_processMode(i,k,l) = wetNumberMedianDiameter_processMode(i,k,l)*DEXP(-1.5_r8*(log(processModeSigma(l)))**2) + end do !process modes + end do !horizontal points + end do !layers + + return + end subroutine calcaersize_sub +end module + + diff --git a/src/chemistry/oslo_aero/commondefinitions.F90 b/src/chemistry/oslo_aero/commondefinitions.F90 new file mode 100644 index 0000000000..aaccd85641 --- /dev/null +++ b/src/chemistry/oslo_aero/commondefinitions.F90 @@ -0,0 +1,79 @@ + +module commondefinitions + +!--------------------------------------------------------------------------------- +! Module for aerosol hygroscopicities and dry size parameters which are common +! in AeroTab and CAM5-Oslo. Note: This file is not yet linked with AeroTab, so +! make sure that the look-up tables made with AeroTab (optics and the dry size +! parameters for modified size distributions) are based on the same version of +! commondefinitions.F90. +!--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + + + !Define some aerosol types and their properties.. + integer, parameter, public :: N_AEROSOL_TYPES = 5 + integer, parameter, public :: AEROSOL_TYPE_SULFATE = 1 + integer, parameter, public :: AEROSOL_TYPE_BC = 2 + integer, parameter, public :: AEROSOL_TYPE_OM = 3 + integer, parameter, public :: AEROSOL_TYPE_DUST = 4 + integer, parameter, public :: AEROSOL_TYPE_SALT = 5 + + !NUMBERS BELOW ARE ESSENTIAL TO CALCULATE HYGROSCOPICITY AND THEREFORE INDIRECT EFFECT! + !These numbers define the "hygroscopicity parameter" Numbers are selected so that they give reasonable hygroscipity + !note that changing numbers individually changes the hygroscopicity! + !Hygroscopicity is defined in Abdul-Razzak and S. Ghan: (B in their eqn 4) + !A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 + !http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract + ! + !Further note that changing any of these numbers without changing aerotab will lead to + !inconsistencies in the simulation since Aerotab tabulates hygroscopical growth! + ! + !Main reference for numbers chosen: Ghan et al MIRAGE paper (JRG, vol 106, D6, pp 5295), 2001 + !References: + !SULFATE : Using same numbers as MIRAGE paper (ammonium sulfate) + !BC : Does not really matter as long as soluble mass fraction is small + ! However, numbers below reproduces values from MIRAGE paper + ! New mass density (October 2016) is based on Bond and Bergstrom (2007): Light Absorption + ! by Carbonaceous Particles: An Investigative Review, Aerosol Science and Technology, 40:27œôòó67. + !OM : Soluble mass fraction tuned to give B of MIRAGE Paper + !DUST : The numbers give B of ~ 0.07 (high end of Kohler, Kreidenweis et al, GRL, vol 36, 2009. + ! (10% as soluble mass fraction seems reasonable) + ! (see also Osada et al, Atmospheric Research, vol 124, 2013, pp 101 + !SEA SALT: Soluble mass fraction tuned to give consistent values for (r/r0) at 99% when using the parametrization in + ! Koepke, Hess, Schult and Shettle: Max-Plack-Institut fur Meteorolgie, report No. 243 "GLOBAL AEROSOL DATA SET" + ! These values give "B" of 1.20 instead of 1.16 in MIRAGE paper. + + character(len=8),public, dimension(N_AEROSOL_TYPES) :: aerosol_type_name = & + (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_density = & + (/1769.0_r8, 1800.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_molecular_weight = & + (/132.0_r8, 12.0_r8, 168.2_r8, 135.0_r8, 58.44_r8 /) !kg/kmol + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_osmotic_coefficient = & + (/0.7_r8, 1.111_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_soluble_mass_fraction = & + (/1.0_r8, 1.67e-7_r8, 0.8725_r8, 0.1_r8, 0.885_r8 /) ![-] + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_number_of_ions = & + (/3.0_r8, 1.0_r8, 1.0_r8, 2.0_r8, 2.0_r8 /) ![-] + +! Define lognormal size parameters for each size mode (dry, at point of emission/production) + integer, public, parameter :: nmodes = 14 + integer, public, parameter :: nbmodes = 10 + !Number median radius of background emissions THESE DO NOT ASSUME IMPLICIT GROWTH!! + real(r8), parameter, public, dimension(0:nmodes) :: originalNumberMedianRadius = & + 1.e-6_r8* (/ 0.0626_r8, & !0 + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 + 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & !6-10 ! SS: Salter et al. (2015) + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) !11-14 + + !sigma of background aerosols ) + real(r8), parameter, public, dimension(0:nmodes) :: originalSigma = & + (/1.6_r8, & !0 + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.59_r8, & !1-5 + 1.59_r8, 2.0_r8, 2.1_r8, 1.72_r8, 1.60_r8, & !6-10 ! SS: Salter et al. (2015) + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 /) !11-14 + +end module diff --git a/src/chemistry/oslo_aero/condtend.F90 b/src/chemistry/oslo_aero/condtend.F90 new file mode 100644 index 0000000000..1b8cc27ed1 --- /dev/null +++ b/src/chemistry/oslo_aero/condtend.F90 @@ -0,0 +1,640 @@ +module condtend + + use phys_control, only: phys_getopts + use chem_mods, only: gas_pcnst + use mo_tracname, only: solsym + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid + use const + use cam_history, only: outfld + use aerosoldef + use physconst, only: rair, gravit, pi + use commondefinitions + use chem_mods, only: adv_mass !molecular weights from mozart +!soa + + save + + integer, parameter :: N_COND_VAP = 3 + integer, parameter :: COND_VAP_H2SO4 = 1 + integer, parameter :: COND_VAP_ORG_LV = 2 + integer, parameter :: COND_VAP_ORG_SV = 3 + + real(r8), public, dimension(0:nmodes,N_COND_VAP) :: normalizedCondensationSink ![m3/#/s] condensation sink per particle in mode i + + integer, private, dimension(gas_pcnst) :: lifeCycleReceiver ! [-] array of transformation of life cycle tracers + real(r8), private, dimension(0:nmodes,N_COND_VAP) :: stickingCoefficient ! [-] stickingCoefficient for H2SO4 on a mode + integer, private, dimension(N_COND_VAP) :: cond_vap_map + +! Assumed number of monolayers + real(r8), parameter, private :: n_so4_monolayers_age = 3.0_r8 + + real(r8), parameter, public :: & + dr_so4_monolayers_age = n_so4_monolayers_age * 4.76e-10_r8 +! thickness of the so4 monolayers (m) +! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3 as in MAM + + +contains + + subroutine registerCondensation() + + implicit none + + + integer :: iDonor + integer :: l_donor + integer :: tracerIndex + integer :: mode_index_donor + + !These are the lifecycle-species which receive mass when + !the externally mixed modes receive condensate, + !e.g. the receiver of l_so4_n mass is the tracer l_so4_na + lifeCycleReceiver(:) = -99 + lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_a) !create bc int mix from bc in mode 12 + lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ai) !create bc int mix from bc in mode 14 + lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ai) + !!create om int mix from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ai) + !!create bc int mix from bc in mode 0. Note Mass is conserved but not number + + !Sticking coeffcients for H2SO4 condensation + !See table 1 in Kirkevag et al (2013) + !http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html + !Note: In NorESM1, sticking coefficients of the externally mixed modes were + !used for the internally mixed modes in modallapp. In condtend the internally + !mixed modes had sticking coefficient = 1.0 + !This might be correct, but is too confusing, so here just + !assign based on background aerosol and table 1 in Kirkevag et al + stickingCoefficient(:,:) = 1.0_r8 + stickingCoefficient(MODE_IDX_BC_EXT_AC,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_BC_AIT,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_OMBC_INTMIX_COAT_AIT,:) = 0.5_r8 + stickingCoefficient(MODE_IDX_DST_A2,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_DST_A3,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_BC_NUC,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_OMBC_INTMIX_AIT,:) = 0.5_r8 + + + end subroutine registerCondensation + +!=============================================================================== + + subroutine initializeCondensation() + + !condensation coefficients: + !Theory: Poling et al, "The properties of gases and liquids" + !5th edition, eqn 11-4-4 + + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + implicit none + + real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit + real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] + real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature + real(r8), parameter :: p0 = 101325.0_r8 ! [Pa] Standard pressure + real(r8), parameter :: radair = 1.73e-10_r8 ![m] Typical air molecule collision radius + real(r8), parameter :: Mair = 28.97_r8 ![amu/molec] Molecular weight for dry air + !Diffusion volumes for simple molecules [Poling et al], table 11-1 + real(r8), dimension(N_COND_VAP), parameter :: vad = (/51.96_r8, 208.18_r8, 208.18_r8/) ![cm3/mol] + real(r8), parameter :: vadAir = 19.7_r8 ![cm3/mol] + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + real(r8), parameter :: cm2Tom2 = 1.e-4_r8 !convert from cm2 ==> m2 + + real(r8), dimension(0:100,0:nmodes,N_COND_VAP) :: DiffusionCoefficient ! [m2/s] Diffusion coefficient + character(len=fieldname_len+3) :: fieldname_donor + character(len=fieldname_len+3) :: fieldname_receiver + character(128) :: long_name + character(8) :: unit + + integer :: nsiz !counter for aerotab sizes + integer :: iChem !counter for chemical species + integer :: mode_index_donor !index for mode + integer :: iMode !Counter for mode + integer :: tracerIndex !counter for chem. spec + + logical :: history_aerosol + logical :: isAlreadyOnList(gas_pcnst) + integer :: cond_vap_idx + + real(r8), dimension(N_COND_VAP) :: mfv ![m] mean free path + real(r8), dimension(N_COND_VAP) :: diff ![m2/s] diffusion coefficient for cond. vap + real(r8) :: molecularWeight !amu/molec molecular weight + real(r8) :: Mdual ![molec/amu] 1/M_1 + 1/M_2 + real(r8) :: rho ![kg/m3] density of component in question + real(r8) :: radmol ![m] radius molecule + real(r8), dimension(N_COND_VAP) :: th !thermal velocity + + !Couple the condenseable vapours to chemical species for properties and indexes + cond_vap_map(COND_VAP_H2SO4) = chemistryIndex(l_h2so4) + cond_vap_map(COND_VAP_ORG_LV) = chemistryIndex(l_soa_lv) + cond_vap_map(COND_VAP_ORG_SV) = chemistryIndex(l_soa_sv) + + do cond_vap_idx = 1, N_COND_VAP + + rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from aerosoldef + + molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart + + !https://en.wikipedia.org/wiki/Thermal_velocity + th(cond_vap_idx) = sqrt(8.0_r8*boltz*t0/(pi*molecularweight*aunit)) ! thermal velocity for H2SO4 in air (m/s) + + !Radius of molecul (straight forward assuming spherical) + radmol=(3.0_r8*molecularWeight*aunit/(4.0_r8*pi*rho))**aThird ! molecule radius + + Mdual=2.0_r8/(1.0_r8/Mair+1.0_r8/molecularWeight) !factor of [1/m_1 + 1_m2] + + !calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): + mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) ! mean free path for molec in air (m) + + !Solve eqn 11-4.4 in Poling et al + !(A bit hard to follow units here, but result in the book is in cm2/s).. + !so scale by "cm2Tom2" to get m2/sec + diff(cond_vap_idx) = cm2Tom2 & + *0.00143_r8*t0**1.75_r8 & + /((p0/1.0e5_r8)*sqrt(Mdual) & + *(((Vad(cond_vap_idx))**aThird+(Vadair)**aThird)**2)) + + !Values used in noresm1: + !real(r8), parameter :: diff = 9.5e-6 !m2/s diffusion coefficient (H2SO4) + !real(r8), parameter :: th = 243.0_r8 !m/s thermal velocity (H2SO4) + !real(r8), parameter :: mfv = 1.65e-8 !m mean free path (H2SO4) + + !Check values obtained here (H2SO4 / SOA) + !write(*,*) 'mfv = ', mfv(cond_vap_idx) !2.800830854409093E-008 / 1.633546464678737E-008 + !write(*,*) ' diff = ', diff(cond_vap_idx) !-> 9.360361706957621E-006 / !-> 4.185923463242946E-006 + !write(*,*) ' th = ', th !-> 242.818542922924 / 185.421069430852 + end do + + do cond_vap_idx = 1, N_COND_VAP + do imode = 0, nmodes !all modes receive condensation + do nsiz = 1, nBinsTab !aerotab sizes + !Correct for non-continuum effects, formula is from + !Chuang and Penner, Tellus, 1995, sticking coeffient from + !Vignati et al, JGR, 2004 + !fxm: make "diff ==> diff (cond_vap_idx) + DiffusionCoefficient(nsiz,imode,cond_vap_idx) = diff(cond_vap_idx) & !original diffusion coefficient + /( & + rBinMidPoint(nsiz)/(rBinMidPoint(nsiz)+mfv(cond_vap_idx)) & !non-continuum correction factor + +4.0_r8*diff(cond_vap_idx)/(stickingCoefficient(imode,cond_vap_idx)*th(cond_vap_idx)*rBinMidPoint(nsiz)) & + ) + enddo + end do !receiver modes + end do + + normalizedCondensationSink(:,:) = 0.0_r8 + !Find sink per particle in mode "imode" + !Eqn 13 in Kulmala et al, Tellus 53B, 2001, pp 479 + !http://onlinelibrary.wiley.com/doi/10.1034/j.1600-0889.2001.530411.x/abstract + do cond_vap_idx =1, N_COND_VAP + do imode = 0, nmodes + do nsiz = 1, nBinsTab + normalizedCondensationSink(imode,cond_vap_idx) = & + normalizedCondensationSink(imode,cond_vap_idx) & + + 4.0_r8*pi & + * DiffusionCoefficient(nsiz,imode,cond_vap_idx) & ![m2/s] diffusion coefficient + * rBinMidPoint(nsiz) & ![m] look up table radius + * normnk(imode,nsiz) ![frc] + end do + end do + end do + + !Initialize output + call phys_getopts(history_aerosol_out = history_aerosol) + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + !Does this tracer have a receiver? If yes: It participate in condensation tendencies + if(lifeCycleReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"condTend" + fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"condTend" + if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) + isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, "A", unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + end do + !Need to add so4_a1, soa_na, so4_na, soa_a1 also (which are not parts of the donor-receiver stuff) + fieldname_receiver = trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency") + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" + call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_so4_na)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit , "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_na)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + + + + end subroutine initializeCondensation + + + + subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & + pmid, pdel, dt, ncol, pblh,zm,qh20) + +! Calculate the sulphate nucleation rate, and condensation rate of +! aerosols used for parameterising the transfer of externally mixed +! aitken mode particles into an internal mixture. +! Note the parameterisation for conversion of externally mixed particles +! used the h2so4 lifetime onto the particles, and not a given +! increase in particle radius. Will be improved in future versions of the model +! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) + + use cam_history, only: outfld,fieldname_len +!nuctst3+ use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers ! h2so4 and soa nucleation(cka) +! use koagsub, only: normCoagSinkMode1,normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers ! h2so4 and soa nucleation(cka) +!nuctst3- +!ak+ + use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers, & + numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd +!ak- + use constituents, only: pcnst ! h2so4 and soa nucleation (cka) + + implicit none + + ! arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of columns + real(r8), intent(in) :: temperature(pcols,pver) ! Temperature (K) + real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] pressure at mid point + real(r8), intent(in) :: pdel(pcols,pver) ! [Pa] difference in grid cell + real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) + real(r8), intent(in) :: dt ! Time step + ! Needed for soa nucleation treatment + real(r8), intent(in) :: pblh(pcols) ! pbl height (m) + real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) + real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) + + ! local + character(len=fieldname_len+3) :: fieldname + integer :: i,k,nsiz + integer :: mode_index_donor ![idx] index of mode donating mass + integer :: mode_index_receiver ![idx] index of mode receiving mass + integer :: tracerIndex + integer :: l_donor + integer :: l_receiver + integer :: iDonor ![idx] counter for externally mixed modes + real(r8) :: condensationSink(0:nmodes, N_COND_VAP)![1/s] loss rate per mode (mixture) + real(r8) :: condensationSinkFraction(pcols,pver,numberOfExternallyMixedModes,N_COND_VAP) ![frc] + real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink + real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration + real(r8) :: numberConcentrationExtMix(pcols,pver,numberOfExternallyMixedModes) + real(r8), dimension(pcols, gas_pcnst) :: coltend + real(r8), dimension(pcols) :: tracer_coltend + + real(r8) :: intermediateConcentration(pcols,pver,N_COND_VAP) + real(r8) :: rhoAir(pcols,pver) ![kg/m3] density of air +! Volume of added material from condensate; surface area of core particle; + real(r8) :: volume_shell, area_core,vol_monolayer + real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode + logical :: history_aerosol + character(128) :: long_name ![-] needed for diagnostics + +!cka:+ + ! needed for h2so4 and soa nucleation treatment + integer :: modeIndexReceiverCoag !Index of modes receiving coagulate + integer :: iCoagReceiver !counter for species receiving coagulate + real(r8) :: coagulationSink(pcols,pver) ![1/s] coaglation loss for SO4_n and soa_n +!nuctst3+ +! real(r8) :: normCSmode1(pcols,pver) !normalized coagulation from self coagulation (simplified) +!nuctst3- + real(r8), parameter :: lvocfrac=0.5 !Fraction of organic oxidation products with low enough + !volatility to enter nucleation mode particles (1-24 nm) + real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation + real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) + real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ! [frc] fraction of gas nucleated + real(r8) :: firstOrderLossRateNucl(pcols,pver,N_COND_VAP) ![1/s] first order loss rate due to nucleation + real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization + real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization + integer :: cond_vap_idx + + !Initialize h2so4 and soa nucl variables + coagulationSink(:,:)=0.0_r8 + condensationSinkFraction(:,:,:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour + numberConcentrationExtMix(:,:,:) = 0.0_r8 +!ak+ +! normCSmode1(:,:)=0.0_r8 +!ak- + + do k=1,pver + do i=1,ncol + + condensationSink(:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour + + !NB: The following is duplicated code, coordinate with koagsub!! + !Initialize number concentration for this receiver + + !Air density + rhoAir(i,k) = pmid(i,k)/rair/temperature(i,k) + + + numberConcentration(:) = 0.0_r8 + + !Go though all modes receiving condensation + do mode_index_receiver = 0, nmodes + + !Go through all core species in that mode + do tracerIndex = 1, getNumberOfBackgroundTracersInMode(mode_index_receiver) + + !Find the lifecycle-specie receiving the condensation + l_receiver = getTracerIndex(mode_index_receiver, tracerIndex, .true.) + + !Add up the number concentration of the receiving mode [#/m3] + numberConcentration(mode_index_receiver) = numberConcentration(mode_index_receiver) & !previous value + + q(i,k,l_receiver) & !kg/kg + / rhopart(physicsIndex(l_receiver)) & !m3/kg ==> m3_{aer}/kg_{air} + * volumeToNumber(mode_index_receiver) & !#/m3 ==> #/kg_{air} + * rhoAir(i,k) !kg/m3 ==> #/m3_{air} + end do !Lifecycle "core" species in this mode + enddo + + + !All modes are condensation receivers + do cond_vap_idx=1,N_COND_VAP + do mode_index_receiver = 0, nmodes + + !This is the loss rate a gas molecule will see due to aerosol surface area + condensationSink(mode_index_receiver,cond_vap_idx) = normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] + * numberConcentration(mode_index_receiver) ![#/m3] + !==> [1/s] + end do !Loop over receivers + end do + + !Find concentration after condensation of all + !condenseable vapours + do cond_vap_idx=1,N_COND_VAP + + !sum of cond. sink for this vapour [1/s] + sumCondensationSink(i,k,cond_vap_idx) = sum(condensationSink(:,cond_vap_idx)) + + + !Solve the intermediate (end of timestep) concentration using + !euler backward solution C_{old} + P *dt - L*C_{new}*dt = C_{new} ==> + !Cnew -Cold = prod - loss ==> + intermediateConcentration(i,k,cond_vap_idx) = & + ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & + / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt) + end do + + !Save the fraction of condensation sink for the externally mixed modes + !(Needed below to find volume shell) + do cond_vap_idx=1,N_COND_VAP + + do iDonor = 1,numberOfExternallyMixedModes + !Find the mode in question + mode_index_donor = externallyMixedMode(iDonor) + + !Remember fraction of cond sink for this mode + condensationSinkFraction(i,k,iDonor,cond_vap_idx) = & + condensationSink(mode_index_donor,cond_vap_idx) & + / sumCondensationSink(i,k,cond_vap_idx) + + !Remember number concentration in this mode + numberConcentrationExtMix(i,k,iDonor) = & + numberConcentration(mode_index_donor) + end do + end do + + !Assume only a fraction of ORG_LV left can contribute to nucleation + soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) !fraction of soa_lv left that is assumend to have low enough + !volatility to nucleate. + + modeIndexReceiverCoag = 0 + !Sum coagulation sink for nucleated so4 and soa particles over all receivers of coagulate. Needed for RM's nucleation code + !OBS - looks like RM's coagulation sink is multiplied by 10^-12?? + do iCoagReceiver = 1, numberOfCoagulationReceivers + + modeIndexReceiverCoag = receiverMode(iCoagReceiver) + + coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) + & ![1/] previous value + normalizedCoagulationSink(modeIndexReceiverCoag,MODE_IDX_SO4SOA_AIT) & ![m3/#/s] + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + end do !coagulation sink + +!nuctst3+ +! coagulationSink(i,k) = coagulationSink(i,k) + & +! normCoagSinkMode1*numberConcentration(1) +! if (i.eq.1.and.k.eq.30) write(*,*) 'cSink, dcSink = ', coagulationSink(i,k), normCoagSinkMode1*numberConcentration(1) +! if (i.eq.1.and.k.eq.30) write(*,*) 'nConc1 = ', numberConcentration(1) +!nuctst3- +!ak+ + !Sum coagulation sink for nucleated so4 and soa particles over all additional + !receivers od coagulate (not directly affecting the life-cycle). + do iCoagReceiver = 1, numberOfAddCoagReceivers + + modeIndexReceiverCoag = addReceiverMode(iCoagReceiver) + + coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) + & ![1/] previous value + normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + end do !coagulation sink +!ak- + + end do !index i + end do !index k + + !Calculate nucleated masses of so4 and soa (nuclso4, nuclsoa) + !following RM's parameterization (cka) + call aeronucl(lchnk,ncol,temperature, pmid, qh20, & + intermediateConcentration(:,:,COND_VAP_H2SO4), soa_lv_forNucleation, & + coagulationSink, nuclso4, nuclsoa, zm, pblh) + + + firstOrderLossRateNucl(:,:,:)=0.0_r8 + do k=1,pver + do i=1,ncol + + !First order loss rate (1/s) for nucleation + firstOrderLossRateNucl(i,k,COND_VAP_H2SO4) = nuclSo4(i,k)/intermediateConcentration(i,k,COND_VAP_H2SO4) + + !First order loss rate (1/s) for nucleation + firstOrderLossRateNucl(i,k,COND_VAP_ORG_LV) = nuclSOA(i,k)/intermediateConcentration(i,k,COND_VAP_ORG_LV) + + do cond_vap_idx = 1,N_COND_VAP + !Solve implicitly (again) + !C_new - C_old = PROD_{gas} - CS*C_new*dt - LR_{nucl}*C_new => + intermediateConcentration(i,k,cond_vap_idx) = & + ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & + / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt + firstOrderLossRateNucl(i,k,cond_vap_idx)*dt) + + !fraction nucleated + fracNucl(i,k,cond_vap_idx) = firstOrderLossRateNucl(i,k,cond_vap_idx) & + /(firstOrderLossRateNucl(i,k,cond_vap_idx) + sumCondensationSink(i,k,cond_vap_idx)) + !From budget, we get: lost = prod -cnew + cold + gasLost(i,k,cond_vap_idx) = cond_vap_gasprod(i,k,cond_vap_idx)*dt & !Produced + + q(i,k,cond_vap_map(cond_vap_idx)) & !cold + - intermediateConcentration(i,k,cond_vap_idx) !cnew + + end do !cond_vap_idx + + !Add nuceated mass to so4_na mode + q(i,k,chemistryIndex(l_so4_na)) = q(i,k,chemistryIndex(l_so4_na)) & + + gasLost(i,k,COND_VAP_H2SO4)*fracNucl(i,k,COND_VAP_H2SO4) + + !H2SO4 condensate + q(i,k,chemistryIndex(l_so4_a1)) = q(i,k,chemistryIndex(l_so4_a1)) & + + gasLost(i,k,COND_VAP_H2SO4)*(1.0_r8-fracNucl(i,k,COND_VAP_H2SO4)) + + !Add nucleated mass to soa_na mode + q(i,k,chemistryIndex(l_soa_na)) = q(i,k,chemistryIndex(l_soa_na)) & + + gasLost(i,k,COND_VAP_ORG_LV)*fracNucl(i,k,COND_VAP_ORG_LV) + + !Organic condensate (from both soa_lv and soa_sv) goes to the soaCondensateReceiver tracer (cka) + q(i,k,chemistryIndex(l_soa_a1)) = q(i,k,chemistryIndex(l_soa_a1)) & + + gasLost(i,k,COND_VAP_ORG_SV) & ! "semi volatile" can not nucleate + + gasLost(i,k,COND_VAP_ORG_LV)*(1.0_r8-fracNucl(i,k,COND_VAP_ORG_LV)) ! part of low volatile which does not nucleate + + !condenseable vapours + q(i,k,chemistryIndex(l_h2so4)) = intermediateConcentration(i,k,COND_VAP_H2SO4) + q(i,k,chemistryIndex(l_soa_lv)) = intermediateConcentration(i,k,COND_VAP_ORG_LV) + q(i,k,chemistryIndex(l_soa_sv)) = intermediateConcentration(i,k,COND_VAP_ORG_SV) + + + !Condensation transfers mass from externally mixed to internally mixed modes + do iDonor = 1,numberOfExternallyMixedModes + + !Find the mode in question + mode_index_donor = externallyMixedMode(iDonor) + + if(getNumberOfTracersInMode(mode_index_donor) .eq. 0)then + cycle + end if + + volume_shell = 0.0_r8 + do cond_vap_idx = 1, N_COND_VAP + + !Add up volume shell for this + !condenseable vapour + volume_shell = volume_shell & + + condensationSinkFraction(i,k,iDonor,cond_vap_idx) & ![frc] + * gasLost(i,k,cond_vap_idx)*(1.0_r8-fracNucl(i,k,cond_vap_idx)) & ![kg/kg] + * invRhoPart(physicsIndex(cond_vap_map(cond_vap_idx))) & !*[m3/kg] ==> [m3/kg_{air} + * rhoAir(i,k) !*[kg/m3] ==> m3/m3 + + end do + + area_core=numberConcentrationExtMix(i,k,iDonor)*numberToSurface(mode_index_donor) !#/m3 * m2/# ==> m2/m3 + vol_monolayer=area_core*dr_so4_monolayers_age + + ! Small fraction retained to avoid numerical irregularities + frac_transfer=min((volume_shell/vol_monolayer),0.999_r8) + + !How many tracers exist in donor mode? + !The "donor" is the externally mixed mode which will soon + !become internally mixed. The externally mixed is donating mass + !and the internally mixed is receiving... + do tracerIndex = 1, getNumberOfTracersInMode(mode_index_donor) + + !Indexes here are in "chemistry space" + l_donor = getTracerIndex(mode_index_donor, tracerIndex,.true.) + l_receiver = lifeCycleReceiver(l_donor) + + if( l_receiver .le. 0)then + stop !something wrong + endif + + !Transfer from donor to receiver takes into account + !fraction transferred + totalLoss(i,k,l_donor) = frac_transfer*q(i,k,l_donor) + q(i,k,l_donor) = q(i,k,l_donor) - totalLoss(i,k,l_donor) + q(i,k,l_receiver) = q(i,k,l_receiver) + totalLoss(i,k,l_donor) + end do !tracers in mode + end do !loop over receivers + end do !physical index k + end do !physical index i + + !Output for diagnostics + call phys_getopts(history_aerosol_out = history_aerosol) + + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + do i=1,gas_pcnst + !Check if species contributes to condensation + if(lifeCycleReceiver(i) .gt. 0)then + !Loss from the donor specie + tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit/dt + coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative (loss for donor) + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + endif + end do + + ! Remove so4_n ---> directly into so4_na + coltend(:ncol,chemistryIndex(l_so4_na)) = coltend(:ncol,chemistryIndex(l_so4_na)) + & + sum( & + gasLost(:ncol,:,COND_VAP_H2SO4) & + *fracNucl(:ncol,:,COND_VAP_H2SO4)*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account H2SO4 (gas) condensed in budget + coltend(:ncol,chemistryIndex(l_so4_a1)) = coltend(:ncol,chemistryIndex(l_so4_a1)) + & + sum( & + gasLost(:ncol,:,COND_VAP_H2SO4) & + *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_H2SO4))*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account soa_lv (gas) nucleated in budget + coltend(:ncol,chemistryIndex(l_soa_na)) = coltend(:ncol,chemistryIndex(l_soa_na)) + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_LV) & + *fracNucl(:ncol,:,COND_VAP_ORG_LV)*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account soa gas condensed in the budget (both LV and SV) + coltend(:ncol,chemistryIndex(l_soa_a1)) = coltend(:ncol,chemistryIndex(l_soa_a1)) + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_LV) & + *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_ORG_LV))*pdel(:ncol,:) , 2 & + )/gravit/dt & + + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_SV)*pdel(:ncol,:) , 2 & + )/gravit/dt + + do i=1,gas_pcnst + if(lifeCycleReceiver(i) .gt. 0 )then + long_name= trim(solsym(i))//"condTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(lifeCycleReceiver(i)))//"condTend" + call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) + end if + end do + long_name=trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_a1)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_a1)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_so4_na)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_na)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_soa_na)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_na)),pcols,lchnk) + + endif + + + return + end subroutine condtend_sub + + +end module condtend diff --git a/src/chemistry/oslo_aero/const.F90 b/src/chemistry/oslo_aero/const.F90 new file mode 100644 index 0000000000..4a6ed3ec8f --- /dev/null +++ b/src/chemistry/oslo_aero/const.F90 @@ -0,0 +1,83 @@ +module const + +!----------------------------------------------------------------------------- +!Module containing subroutines constants, koagsub and parmix and declaration +!of the variables required by them. Updated with one internally mixed and one +!externally mixed OC mode November 2004. +!Updated with extra variables for SOA by Alf Kirkevåg May 2013, and +!with explicit equations for diffusion variables for SOA and H2SO4 in July 2015 +!(moved to condtend.F90). +!----------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 +! use aerosoldef, only: nmodes + use commondefinitions, only: nmodes + use physconst, only: pi +! +implicit none +! +public +save + + real(r8), parameter:: smallNumber = 1.e-100_r8 + + !Essential size distribution parameters + real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size + real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size + integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins + + +!cak: diff, th and mfv for H2SO4 and SOA are now calculated in condtend.F90 + + + !Smallest particle which can receive aquous chemistry mass + real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 + real(r8) nk(0:nmodes,nbinsTab) !dN/dlogr for modes + real(r8) normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) + + real(r8) rBinEdge(nBinsTab+1) + real(r8) rBinMidpoint(nBinsTab) + +!soa +! real(r8) :: rrr1to3 (3,16) !TS: Modal radius array, mode 1 - 3 +! real(r8) :: sss1to3 (3,16) !TS: Standard deviation array, Mode 1 -3 +! real(r8) :: calog1to3(3,16) !TS: Array for reading catot from file +! real(r8) :: rk1to3 (3,16) !TS: Array for reading modal radius from file +! real(r8) :: stdv1to3 (3,16) !TS: Array for reading std. dev. from file +!soa + real(r8) :: rrr1to3 (3,16,6) !TS: Modal radius array, mode 1 - 3 + real(r8) :: sss1to3 (3,16,6) !TS: Standard deviation array, Mode 1 -3 + real(r8) :: calog1to3(3,96) !TS: Array for reading catot from file + real(r8) :: rk1to3 (3,96) !TS: Array for reading modal radius from file + real(r8) :: stdv1to3 (3,96) !TS: Array for reading std. dev. from file + real(r8) :: fraclog1to3 (3,96) !TS: Same as frac4, but for initlogn.F90 +!soa + + real(r8) :: rrr4 (16,6,6) !TS: Modal radius array, mode 4 + real(r8) :: sss4 (16,6,6) !TS: Modal radius array, mode 4 + real(r8) :: calog4(576) !TS: Same as catot4, but for initlogn.F90 + real(r8) :: fraclog4 (576) !TS: Same as frac4, but for initlogn.F90 + real(r8) :: fraqlog4 (576) !TS: Same as fraq4, but for initlogn.F90 + real(r8) :: rk4 (576) !TS: Array for reading modal radius from file + real(r8) :: stdv4 (576) !TS: Array for reading std. dev. from file + + real(r8) :: rrr (5:10,6,6,6,6) !TS: Modal radius array, mode 5 - 10 + real(r8) :: sss (5:10,6,6,6,6) !TS: Standard deviation array, mode 5 - 10 + real(r8) :: calog (5:10,1296) !TS: Same as catot, but for initlogn.F90 + real(r8) :: fraclog5to10 (5:10,1296) !TS: Same as frac5to10, but for initlogn.F90 + real(r8) :: fabclog5to10 (5:10,1296) !TS: Same as fabc5to10, but for initlogn.F90 + real(r8) :: fraqlog5to10 (5:10,1296) !TS: Same as fraq5to10, but for initlogn.F90 + real(r8) :: rk5to10 (5:10,1296) !TS: Array for reading modal radius from file + real(r8) :: stdv5to10 (5:10,1296) !TS: Array for reading std. dev. from file + + + real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) + real(r8), dimension(0:nmodes) :: volumeToNumber !m3 ==> # + real(r8), dimension(0:nmodes) :: numberToSurface !# ==> m2 + + +end module const + + + + diff --git a/src/chemistry/oslo_aero/constants.F90 b/src/chemistry/oslo_aero/constants.F90 new file mode 100644 index 0000000000..5e58b488d6 --- /dev/null +++ b/src/chemistry/oslo_aero/constants.F90 @@ -0,0 +1,123 @@ + +subroutine constants +! +! A number of constants used in the emission and size-calculation in CAM-Oslo +! �S Jan 2011. +! Updated by Alf Kirkev�g May 2013. +! Updated by Alf Grini February 2014. +! + use shr_kind_mod, only: r8 => shr_kind_r8 + use physconst, only: pi + use const + use aerosoldef + use koagsub, only : initializeCoagulationReceivers, initializeCoagulationCoefficients & + , initializeCoagulationOutput + + use oslo_utils + implicit none + + + integer kcomp,i + real(r8),dimension(0:nmodes) :: rhob !density of background aerosol in mode + + real(r8) :: rhorbc !This has to do with fractal dimensions of bc, come back to this!! + real(r8) :: sumnormnk + real(r8) :: totalLogDelta + real(r8) :: logDeltaBin + real(r8) :: logNextEdge + + rhob(:)=-1.0_r8 + volumeToNumber(:)=-1.0_r8 + numberToSurface(:)=-1.0_r8 + !Prepare modal properties + do i=0, nmodes + + if(getNumberOfTracersInMode(i) .gt. 0)then + + !Approximate density of mode + rhob(i) = rhopart(getTracerIndex(i,1,.false.)) !density of mode is density of first species in mode + + !REPLACE THE EFACT-VARIABLE WITH THIS!! + volumeToNumber(i) = 1.0_r8 & + / & + ( DEXP ( 4.5_r8 * ( log(originalSigma(i)) * log(originalSigma(i)) ) ) & + *(4.0_r8/3.0_r8)*pi*(originalNumberMedianRadius(i))**3 ) + + numberToSurface(i) = 4.0_r8*pi*lifeCycleNumberMedianRadius(i)*lifeCycleNumberMedianRadius(i)& + *DEXP(log(lifeCycleSigma(i))*log(lifeCycleSigma(i))) + end if + end do + + + !Find radius in edges and midpoints of bin + rBinEdge(1) = rTabMin + totalLogDelta = log(rTabMax/rTabMin) + logDeltaBin = totalLogDelta / nBinsTab + do i=2,nBinsTab+1 + logNextEdge = log(rBinEdge(i-1)) + logDeltaBin + rBinEdge(i) = DEXP(logNextEdge) + rBinMidPoint(i-1) = sqrt(rBinEdge(i)*rBinEdge(i-1)) + end do + + !Calculate the fraction of a mode which goes to aquous chemstry + numberFractionAvailableAqChem(:)=0.0_r8 + do i=1,nbmodes + if(isTracerInMode(i,l_so4_a2))then + numberFractionAvailableAqChem(i) = 1.0_r8 - calculateLognormalCDF(rMinAquousChemistry & + , originalNumberMedianRadius(i) & + , originalSigma(i) & + ) + end if + end do + + !Set the density of the fractal mode ==> we get lesser density + !than the emitted density, so for a given mass emitted, we get + !more number-concentration!! This is a way of simulating that the + !aerosols take up more space + rhorbc = calculateEquivalentDensityOfFractalMode( & + rhopart(l_bc_n) & !emitted density + ,originalNumberMedianRadius(MODE_IDX_BC_NUC) & !emitted size + ,2.5_r8 & !fractal dim + ,originalNumberMedianRadius(MODE_IDX_BC_EXT_AC) & !diameter of mode + ,originalSigma(MODE_IDX_BC_EXT_AC)) !sigma mode + + rhopart(l_bc_ax) = rhorbc + !fxm: not the right place for this change of value, + !but anyway.. this re-calculateion of tracer density + !influences density of mode used in coagulation + rhob(MODE_IDX_BC_EXT_AC)=rhorbc + + !Size distribution of the modes! + !Unclear if this should use the radii assuming growth or not! + !Mostly used in code where it is sensible to assume some growth has + !happened, so it is used here + do kcomp = 0,nmodes + do i=1,nBinsTab + !dN/dlogR (does not sum to one over size range) + nk(kcomp,i) = calculatedNdLogR(rBinMidPoint(i), lifeCycleNumberMedianRadius(kcomp), lifeCycleSigma(kcomp)) + !dN (sums to one) over the size range + normnk(kcomp,i) =logDeltaBin*nk(kcomp,i) + enddo + enddo ! kcomp + + !++test: Normalized size distribution must sum to one (accept 2% error) + do kcomp=0,nmodes + sumNormNk = sum(normnk(kcomp,:)) + if(abs(sum(normnk(kcomp,:)) - 1.0_r8) .gt. 2.0e-2_r8)then + print*, "sum normnk", sum(normnk(kcomp,:)) + stop + endif + enddo + !--test + + !Initialize coagulation + call initializeCoagulationReceivers() + + !Calculate the coagulation coefficients Note: Inaccurate density used! + call initializeCoagulationCoefficients(rhob, lifeCycleNumberMedianRadius) + + + call initializeCoagulationOutput() + + return + end subroutine constants diff --git a/src/chemistry/oslo_aero/dust_model.F90 b/src/chemistry/oslo_aero/dust_model.F90 new file mode 100644 index 0000000000..4d03c4c97e --- /dev/null +++ b/src/chemistry/oslo_aero/dust_model.F90 @@ -0,0 +1,228 @@ +module dust_model + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl + use spmd_utils, only: masterproc + use cam_abortutils, only: endrun + +use constituents, only: cnst_name +use aerosoldef, only: l_dst_a2, l_dst_a3 +use camsrfexch, only: cam_in_t +use ppgrid, only: pcols +use cam_logfile, only: iulog + +implicit none +private +save + + integer, parameter :: numberOfDustModes = 2 !define in aerosoldef? + + !This can be refined, but the fractions in coarse/fine mode are approx ok + real(r8), parameter, dimension(numberOfDustModes) :: emis_fraction_in_mode = (/0.13_r8, 0.87_r8 /) + integer, dimension(numberOfDustModes) :: tracerMap = (/-99, -99/) !index of dust tracers in the modes + character(len=6), public, dimension(10) :: dust_names + integer, parameter, public :: dust_nbin = numberOfDustModes + + !Related to soil erodibility + real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions + character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset + + logical, parameter, public :: dust_active = .TRUE. +public oslo_dust_emis_intr +public getNumberOfDustModes +public getDustTracerIndexInMode +public getEmissionFractionInDustMode +public isOsloDustTracer +public dust_init +public dust_readnl + + +!=============================================================================== +contains +!=============================================================================== + + subroutine dust_readnl(nlfile) + + 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 + character(len=*), parameter :: subname = 'dust_readnl' + + namelist /dust_nl/ dust_emis_fact, soil_erod_file + + !----------------------------------------------------------------------------- + + ! Read namelist + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'dust_nl', status=ierr) + if (ierr == 0) then + read(unitn, dust_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 + ! Broadcast namelist variables + call mpibcast(dust_emis_fact, 1, mpir8, 0, mpicom) + call mpibcast(soil_erod_file, len(soil_erod_file), mpichar, 0, mpicom) +#endif + + + + end subroutine dust_readnl + function getEmissionFractionInDustMode(modeIndex) RESULT(fraction) + integer, intent(in) :: modeIndex + real(r8) :: fraction + fraction = emis_fraction_in_mode(modeIndex) + end function getEmissionFractionInDustMode + + function getNumberOfDustModes() RESULT(answer) + integer answer + answer = numberOfDustModes + end function getNumberOfDustModes + + + subroutine dust_init() + + use soil_erod_mod, only: soil_erod_init + implicit none + integer :: i + + + call soil_erod_init( dust_emis_fact, soil_erod_file ) + + call set_oslo_indices() + + dust_names(:)=" " + do i=1,numberOfDustModes + dust_names(i) = cnst_name(tracerMap(i)) + end do + + end subroutine dust_init + + subroutine set_oslo_indices() + implicit none + tracerMap(1) = l_dst_a2 + tracerMap(2) = l_dst_a3 + end subroutine set_oslo_indices + + + !**************************************************** + !This is copied from the MAM aerosols. Should not really + !be necessary since the land model could calculate emissions + !based on soil erodibility. + + !However, the following code in dustMod.F90 (land model) makes it + !necessary to apply it here! + !715 Set basin factor to 1 for now + !716 + !717 call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) + !718 do c = begc, endc + !719 l = clm3%g%l%c%landunit(c) + !720 if (.not. clm3%g%l%lakpoi(l)) then + !721 mbl_bsn_fct(c) = 1.0_r8 + !722 end if + !723 end do + + !For a general discussion of these factors, see: + !Zender et al JGR (vol 108, D16, 2003) + !http://onlinelibrary.wiley.com/doi/10.1029/2002JD003039/abstract + + function getDustTracerIndexInMode(modeIndex)RESULT(answer) + integer, intent(in) :: modeIndex + integer answer + + answer = tracerMap(modeIndex) + + end function getDustTracerIndexInMode + + function isOsloDustTracer(physTracerIndex) RESULT(answer) + implicit none + integer, intent(in) :: physTracerIndex + integer :: n + logical :: answer + answer = .FALSE. + do n = 1, numberOfDustModes + if(tracerMap(n) .eq. physTracerIndex)then + answer = .TRUE. + end if + end do + end function isOsloDustTracer + + subroutine oslo_dust_emis_intr(state, cam_in) + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Interface to emission of all dusts. + ! Notice that the mobilization is calculated in the land model (need #define BGC) and + ! the soil erodibility factor is applied here. + ! + ! see comments above in subroutine read_soil_erodibility_data + !----------------------------------------------------------------------- + use cam_history, only: outfld + use physics_types, only: physics_state + use soil_erod_mod, only : soil_erod_fact + use soil_erod_mod, only : soil_erodibility + + implicit none + + ! Arguments: + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + ! Local variables + + integer :: lchnk + integer :: ncol + integer :: i,n + real(r8) :: soil_erod_tmp(pcols) + real(r8) :: totalEmissionFlux(pcols) + real(r8), pointer :: cflx(:,:) + + lchnk = state%lchnk + ncol = state%ncol + + !Filter away unreasonable values for soil erodibility + !(using low values e.g. gives emissions in greenland..) + where(soil_erodibility(:,lchnk) .lt. 0.1_r8) + soil_erod_tmp(:)=0.0_r8 + elsewhere + soil_erod_tmp(:)=soil_erodibility(:,lchnk) + end where + + totalEmissionFlux(:)=0.0_r8 + do i=1,ncol + totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) + end do + + cflx => cam_in%cflx + + !Note that following CESM use of "dust_emis_fact", the emissions are + !scaled by the INVERSE of the factor!! + !There is another random scale factor of 1.15 there. Adapting the exact + !same formulation as MAM now and tune later + !As of NE-380: Oslo dust emissions are 2/3 of CAM emissions + do n=1, numberOfDustModes + cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & + *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 ! gives better AOD close to dust sources + end do + + + !call outfld('MBL_BSN_FCT',soil_erod_tmp,pcols,lchnk) + !call outfld('OSLO_DUST_EMIS',totalEmissionFlux,pcols,lchnk) + + return + end subroutine oslo_dust_emis_intr + +end module dust_model diff --git a/src/chemistry/oslo_aero/dust_sediment_mod.F90 b/src/chemistry/oslo_aero/dust_sediment_mod.F90 new file mode 100644 index 0000000000..09bd7dcefa --- /dev/null +++ b/src/chemistry/oslo_aero/dust_sediment_mod.F90 @@ -0,0 +1,506 @@ +module dust_sediment_mod + +!--------------------------------------------------------------------------------- +! Purpose: +! +! Contains routines to compute tendencies from sedimentation of dust +! +! Author: Phil Rasch +! +!--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use ppgrid, only: pcols, pver, pverp + use physconst, only: gravit, rair + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + + private + public :: dust_sediment_vel, dust_sediment_tend + + + real (r8), parameter :: vland = 2.8_r8 ! dust fall velocity over land (cm/s) + real (r8), parameter :: vocean = 1.5_r8 ! dust fall velocity over ocean (cm/s) + real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor + +contains + +!=============================================================================== + subroutine dust_sediment_vel (ncol, & + icefrac , landfrac, ocnfrac , pmid , pdel , t , & + dustmr , pvdust ) + +!---------------------------------------------------------------------- + +! Compute gravitational sedimentation velocities for dust + + implicit none + +! Arguments + integer, intent(in) :: ncol ! number of colums to process + + real(r8), intent(in) :: icefrac (pcols) ! sea ice fraction (fraction) + real(r8), intent(in) :: landfrac(pcols) ! land fraction (fraction) + real(r8), intent(in) :: ocnfrac (pcols) ! ocean fraction (fraction) + real(r8), intent(in) :: pmid (pcols,pver) ! pressure of midpoint levels (Pa) + real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) + real(r8), intent(in) :: t (pcols,pver) ! temperature (K) + real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) + + real(r8), intent(out) :: pvdust (pcols,pverp) ! vertical velocity of dust (Pa/s) +! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) + +! Local variables + real (r8) :: rho(pcols,pver) ! air density in kg/m3 + real (r8) :: vfall(pcols) ! settling velocity of dust particles (m/s) + + integer i,k + + real (r8) :: lbound, ac, bc, cc + +!----------------------------------------------------------------------- +!--------------------- dust fall velocity ---------------------------- +!----------------------------------------------------------------------- + + do k = 1,pver + do i = 1,ncol + + ! merge the dust fall velocities for land and ocean (cm/s) + ! SHOULD ALSO ACCOUNT FOR ICEFRAC + vfall(i) = vland*landfrac(i) + vocean*(1._r8-landfrac(i)) + !! vfall(i) = vland*landfrac(i) + vocean*ocnfrac(i) + vseaice*icefrac(i) + + ! fall velocity (assume positive downward) + pvdust(i,k+1) = vfall(i) + end do + end do + + return + end subroutine dust_sediment_vel + + +!=============================================================================== + subroutine dust_sediment_tend ( & + ncol, dtime, pint, pmid, pdel, t, & + dustmr ,pvdust, dusttend, sfdust, dusttend_to_ll_out ) + +!---------------------------------------------------------------------- +! Apply Particle Gravitational Sedimentation +!---------------------------------------------------------------------- + + implicit none + +! Arguments + integer, intent(in) :: ncol ! number of colums to process + + real(r8), intent(in) :: dtime ! time step + real(r8), intent(in) :: pint (pcols,pverp) ! interfaces pressure (Pa) + real(r8), intent(in) :: pmid (pcols,pver) ! midpoint pressures (Pa) + real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) + real(r8), intent(in) :: t (pcols,pver) ! temperature (K) + real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) + real(r8), intent(in) :: pvdust (pcols,pverp) ! vertical velocity of dust drops (Pa/s) +! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) + + real(r8), intent(out) :: dusttend(pcols,pver) ! dust tend + real(r8), intent(out) :: sfdust (pcols) ! surface flux of dust (rain, kg/m/s) + + real(r8),intent(out),optional :: dusttend_to_ll_out(pcols) ! fluxes at the interfaces, dust (positive = down) +! Local variables + real(r8) :: fxdust(pcols,pverp) ! fluxes at the interfaces, dust (positive = down) + + integer :: i,k +!---------------------------------------------------------------------- + +! initialize variables + fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) + dusttend(:ncol,:) = 0._r8 ! tend (dust) + sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) + +! fluxes at interior points + call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust) + +! calculate fluxes at boundaries + do i = 1,ncol + fxdust(i,1) = 0 +! surface flux by upstream scheme + fxdust(i,pverp) = dustmr(i,pver) * pvdust(i,pverp) * dtime + end do + +! filter out any negative fluxes from the getflx routine + do k = 2,pver + fxdust(:ncol,k) = max(0._r8, fxdust(:ncol,k)) + end do + +! Limit the flux out of the bottom of each cell to the water content in each phase. +! Apply mxsedfac to prevent generating very small negative cloud water/ice +! NOTE, REMOVED CLOUD FACTOR FROM AVAILABLE WATER. ALL CLOUD WATER IS IN CLOUDS. +! ***Should we include the flux in the top, to allow for thin surface layers? +! ***Requires simple treatment of cloud overlap, already included below. + do k = 1,pver + do i = 1,ncol + fxdust(i,k+1) = min( fxdust(i,k+1), mxsedfac * dustmr(i,k) * pdel(i,k) ) +!!$ fxdust(i,k+1) = min( fxdust(i,k+1), dustmr(i,k) * pdel(i,k) + fxdust(i,k)) + end do + end do + +! Now calculate the tendencies + do k = 1,pver + do i = 1,ncol +! net flux into cloud changes cloud dust/ice (all flux is out of cloud) + dusttend(i,k) = (fxdust(i,k) - fxdust(i,k+1)) / (dtime * pdel(i,k)) + end do + end do + +! convert flux out the bottom to mass units Pa -> kg/m2/s + sfdust(:ncol) = fxdust(:ncol,pverp) / (dtime*gravit) + + if(present(dusttend_to_ll_out))then + dusttend_to_ll_out(1:ncol) = fxdust(:ncol,pver)/(dtime*pdel(:ncol,pver)) + endif + + return + end subroutine dust_sediment_tend + +!=============================================================================== + subroutine getflx(ncol, xw, phi, vel, deltat, flux) + +!.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 +!....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 +!....velw1.....velw2.....velw3.....velw4.....velw5.....velw6 +!.........phi1......phi2.......phi3.....phi4.......phi5....... + + + implicit none + + integer ncol ! number of colums to process + + integer i + integer k + + real (r8) vel(pcols,pverp) + real (r8) flux(pcols,pverp) + real (r8) xw(pcols,pverp) + real (r8) psi(pcols,pverp) + real (r8) phi(pcols,pverp-1) + real (r8) fdot(pcols,pverp) + real (r8) xx(pcols) + real (r8) fxdot(pcols) + real (r8) fxdd(pcols) + + real (r8) psistar(pcols) + real (r8) deltat + + real (r8) xxk(pcols,pver) + + do i = 1,ncol +! integral of phi + psi(i,1) = 0._r8 +! fluxes at boundaries + flux(i,1) = 0 + flux(i,pverp) = 0._r8 + end do + +! integral function + do k = 2,pverp + do i = 1,ncol + psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) + end do + end do + + +! calculate the derivatives for the interpolating polynomial + call cfdotmc_pro (ncol, xw, psi, fdot) + +! NEW WAY +! calculate fluxes at interior pts + do k = 2,pver + do i = 1,ncol + xxk(i,k) = xw(i,k)-vel(i,k)*deltat + end do + end do + do k = 2,pver + call cfint2(ncol, xw, psi, fdot, xxk(1,k), fxdot, fxdd, psistar) + do i = 1,ncol + flux(i,k) = (psi(i,k)-psistar(i)) + end do + end do + + + return + end subroutine getflx + + + +!############################################################################## + + subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) + + + implicit none + +! input + integer ncol ! number of colums to process + + real (r8) x(pcols, pverp) + real (r8) f(pcols, pverp) + real (r8) fdot(pcols, pverp) + real (r8) xin(pcols) + +! output + real (r8) fxdot(pcols) + real (r8) fxdd(pcols) + real (r8) psistar(pcols) + + integer i + integer k + integer intz(pcols) + real (r8) dx + real (r8) s + real (r8) c2 + real (r8) c3 + real (r8) xx + real (r8) xinf + real (r8) psi1, psi2, psi3, psim + real (r8) cfint + real (r8) cfnew + real (r8) xins(pcols) + +! the minmod function + real (r8) a, b, c + real (r8) minmod + real (r8) medan + minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) + medan(a,b,c) = a + minmod(b-a,c-a) + + do i = 1,ncol + xins(i) = medan(x(i,1), xin(i), x(i,pverp)) + intz(i) = 0 + end do + +! first find the interval + do k = 1,pverp-1 + do i = 1,ncol + if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then + intz(i) = k + endif + end do + end do + + do i = 1,ncol + if (intz(i).eq.0) then + write(iulog,*) ' interval was not found for col i ', i + call endrun('DUST_SEDIMENT_MOD:cfint2 -- interval was not found ') + endif + end do + +! now interpolate + do i = 1,ncol + k = intz(i) + dx = (x(i,k+1)-x(i,k)) + s = (f(i,k+1)-f(i,k))/dx + c2 = (3*s-2*fdot(i,k)-fdot(i,k+1))/dx + c3 = (fdot(i,k)+fdot(i,k+1)-2*s)/dx**2 + xx = (xins(i)-x(i,k)) + fxdot(i) = (3*c3*xx + 2*c2)*xx + fdot(i,k) + fxdd(i) = 6*c3*xx + 2*c2 + cfint = ((c3*xx + c2)*xx + fdot(i,k))*xx + f(i,k) + +! limit the interpolant + psi1 = f(i,k)+(f(i,k+1)-f(i,k))*xx/dx + if (k.eq.1) then + psi2 = f(i,1) + else + psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) + endif + if (k+1.eq.pverp) then + psi3 = f(i,pverp) + else + psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) + endif + psim = medan(psi1, psi2, psi3) + cfnew = medan(cfint, psi1, psim) + if (abs(cfnew-cfint)/(abs(cfnew)+abs(cfint)+1.e-36_r8) .gt..03_r8) then +! CHANGE THIS BACK LATER!!! +! $ .gt..1) then + + +! UNCOMMENT THIS LATER!!! +! write(iulog,*) ' cfint2 limiting important ', cfint, cfnew + + + endif + psistar(i) = cfnew + end do + + return + end subroutine cfint2 + + + +!############################################################################## + + subroutine cfdotmc_pro (ncol, x, f, fdot) + +! prototype version; eventually replace with final SPITFIRE scheme + +! calculate the derivative for the interpolating polynomial +! multi column version + + + implicit none + +! input + integer ncol ! number of colums to process + + real (r8) x(pcols, pverp) + real (r8) f(pcols, pverp) +! output + real (r8) fdot(pcols, pverp) ! derivative at nodes + +! assumed variable distribution +! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points +! f1.......f2.......f3.......f4.......f5.......f6 1,pverp points +! ...sh1.......sh2......sh3......sh4......sh5.... 1,pver points +! .........d2.......d3.......d4.......d5......... 2,pver points +! .........s2.......s3.......s4.......s5......... 2,pver points +! .............dh2......dh3......dh4............. 2,pver-1 points +! .............eh2......eh3......eh4............. 2,pver-1 points +! ..................e3.......e4.................. 3,pver-1 points +! .................ppl3......ppl4................ 3,pver-1 points +! .................ppr3......ppr4................ 3,pver-1 points +! .................t3........t4.................. 3,pver-1 points +! ................fdot3.....fdot4................ 3,pver-1 points + + +! work variables + + + integer i + integer k + + real (r8) a ! work var + real (r8) b ! work var + real (r8) c ! work var + real (r8) s(pcols,pverp) ! first divided differences at nodes + real (r8) sh(pcols,pverp) ! first divided differences between nodes + real (r8) d(pcols,pverp) ! second divided differences at nodes + real (r8) dh(pcols,pverp) ! second divided differences between nodes + real (r8) e(pcols,pverp) ! third divided differences at nodes + real (r8) eh(pcols,pverp) ! third divided differences between nodes + real (r8) pp ! p prime + real (r8) ppl(pcols,pverp) ! p prime on left + real (r8) ppr(pcols,pverp) ! p prime on right + real (r8) qpl + real (r8) qpr + real (r8) ttt + real (r8) t + real (r8) tmin + real (r8) tmax + real (r8) delxh(pcols,pverp) + + +! the minmod function + real (r8) minmod + real (r8) medan + minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) + medan(a,b,c) = a + minmod(b-a,c-a) + + do k = 1,pver + + +! first divided differences between nodes + do i = 1, ncol + delxh(i,k) = (x(i,k+1)-x(i,k)) + sh(i,k) = (f(i,k+1)-f(i,k))/delxh(i,k) + end do + +! first and second divided differences at nodes + if (k.ge.2) then + do i = 1,ncol + d(i,k) = (sh(i,k)-sh(i,k-1))/(x(i,k+1)-x(i,k-1)) + s(i,k) = minmod(sh(i,k),sh(i,k-1)) + end do + endif + end do + +! second and third divided diffs between nodes + do k = 2,pver-1 + do i = 1, ncol + eh(i,k) = (d(i,k+1)-d(i,k))/(x(i,k+2)-x(i,k-1)) + dh(i,k) = minmod(d(i,k),d(i,k+1)) + end do + end do + +! treat the boundaries + do i = 1,ncol + e(i,2) = eh(i,2) + e(i,pver) = eh(i,pver-1) +! outside level + fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) & + - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) + fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) + fdot(i,pverp) = sh(i,pver) + d(i,pver)*delxh(i,pver) & + + eh(i,pver-1)*delxh(i,pver)*(x(i,pverp)-x(i,pver-1)) + fdot(i,pverp) = minmod(fdot(i,pverp),3*sh(i,pver)) +! one in from boundary + fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) + fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) + fdot(i,pver) = sh(i,pver) - d(i,pver)*delxh(i,pver) & + - eh(i,pver-1)*delxh(i,pver)*delxh(i,pver-1) + fdot(i,pver) = minmod(fdot(i,pver),3*s(i,pver)) + end do + + + do k = 3,pver-1 + do i = 1,ncol + e(i,k) = minmod(eh(i,k),eh(i,k-1)) + end do + end do + + + + do k = 3,pver-1 + + do i = 1,ncol + +! p prime at k-0.5 + ppl(i,k)=sh(i,k-1) + dh(i,k-1)*delxh(i,k-1) +! p prime at k+0.5 + ppr(i,k)=sh(i,k) - dh(i,k) *delxh(i,k) + + t = minmod(ppl(i,k),ppr(i,k)) + +! derivate from parabola thru f(i,k-1), f(i,k), and f(i,k+1) + pp = sh(i,k-1) + d(i,k)*delxh(i,k-1) + +! quartic estimate of fdot + fdot(i,k) = pp & + - delxh(i,k-1)*delxh(i,k) & + *( eh(i,k-1)*(x(i,k+2)-x(i,k )) & + + eh(i,k )*(x(i,k )-x(i,k-2)) & + )/(x(i,k+2)-x(i,k-2)) + +! now limit it + qpl = sh(i,k-1) & + + delxh(i,k-1)*minmod(d(i,k-1)+e(i,k-1)*(x(i,k)-x(i,k-2)), & + d(i,k) -e(i,k)*delxh(i,k)) + qpr = sh(i,k) & + + delxh(i,k )*minmod(d(i,k) +e(i,k)*delxh(i,k-1), & + d(i,k+1)+e(i,k+1)*(x(i,k)-x(i,k+2))) + + fdot(i,k) = medan(fdot(i,k), qpl, qpr) + + ttt = minmod(qpl, qpr) + tmin = min(0._r8,3*s(i,k),1.5_r8*t,ttt) + tmax = max(0._r8,3*s(i,k),1.5_r8*t,ttt) + + fdot(i,k) = fdot(i,k) + minmod(tmin-fdot(i,k), tmax-fdot(i,k)) + + end do + + end do + + return + end subroutine cfdotmc_pro +end module dust_sediment_mod diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 new file mode 100644 index 0000000000..aadea38e2d --- /dev/null +++ b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 @@ -0,0 +1,945 @@ +module hetfrz_classnuc_oslo + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for hetfrz_classnuc module. +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, begchunk, endchunk +use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi +use constituents, only: cnst_get_ind, pcnst +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use phys_control, only: phys_getopts, use_hetfrz_classnuc + +use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & + pbuf_get_index, pbuf_get_field +use cam_history, only: addfld, add_default, outfld + +use ref_pres, only: top_lev => trop_cloud_top_lev +use wv_saturation, only: svp_water, svp_ice + +use cam_logfile, only: iulog +use error_messages, only: handle_errmsg, alloc_err +use cam_abortutils, only: endrun + +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 +implicit none +private +save + +public :: & + hetfrz_classnuc_oslo_readnl, & + hetfrz_classnuc_oslo_register, & + hetfrz_classnuc_oslo_init, & + hetfrz_classnuc_oslo_calc, & + hetfrz_classnuc_oslo_save_cbaero + +! Namelist variables +logical :: hist_hetfrz_classnuc = .false. + +! Vars set via init method. +real(r8) :: mincld ! minimum allowed cloud fraction + +! constituent indices +integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numliq_idx = -1, & + numice_idx = -1 + +! pbuf indices for fields provided by heterogeneous freezing +integer :: & + frzimm_idx, & + frzcnt_idx, & + frzdep_idx + +! pbuf indices for fields needed by heterogeneous freezing +integer :: & + ast_idx = -1 + +! specie properties +real(r8) :: specdens_dust +real(r8) :: specdens_so4 +real(r8) :: specdens_bc +real(r8) :: specdens_soa +real(r8) :: specdens_pom + +! List all species +integer :: ncnst = 0 ! Total number of constituents (mass and number) needed + ! by the parameterization (depends on aerosol model used) + +integer :: so4_accum ! sulfate in accumulation mode +integer :: bc_accum ! black-c in accumulation mode +integer :: pom_accum ! p-organic in accumulation mode +integer :: soa_accum ! s-organic in accumulation mode +integer :: dst_accum ! dust in accumulation mode +integer :: ncl_accum ! seasalt in accumulation mode +integer :: num_accum ! number in accumulation mode + +integer :: dst_coarse ! dust in coarse mode +integer :: ncl_coarse ! seasalt in coarse mode +integer :: so4_coarse ! sulfate in coarse mode +integer :: num_coarse ! number in coarse mode + +integer :: dst_finedust ! dust in finedust mode +integer :: so4_finedust ! sulfate in finedust mode +integer :: num_finedust ! number in finedust mode + +integer :: dst_coardust ! dust in coardust mode +integer :: so4_coardust ! sulfate in coardust mode +integer :: num_coardust ! number in coardust mode + +integer :: bc_pcarbon ! black-c in primary carbon mode +integer :: pom_pcarbon ! p-organic in primary carbon mode +integer :: num_pcarbon ! number in primary carbon mode + +! Index arrays for looping over all constituents +integer, allocatable :: mode_idx(:) +integer, allocatable :: spec_idx(:) + +! Copy of cloud borne aerosols before modification by droplet nucleation +! The basis is converted from mass to volume. +real(r8), allocatable :: aer_cb(:,:,:,:) + +! Copy of interstitial aerosols with basis converted from mass to volume. +real(r8), allocatable :: aer(:,:,:,:) + +!=============================================================================== +contains +!=============================================================================== + +subroutine hetfrz_classnuc_oslo_readnl(nlfile) + + 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 + character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' + + namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) + if (ierr == 0) then + read(unitn, hetfrz_classnuc_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 + ! Broadcast namelist variables + call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) +#endif + +end subroutine hetfrz_classnuc_oslo_readnl + +!================================================================================================ + +subroutine hetfrz_classnuc_oslo_register() + + if (.not. use_hetfrz_classnuc) return + + ! pbuf fields provided by hetfrz_classnuc + call pbuf_add_field('FRZIMM', 'physpkg', dtype_r8, (/pcols,pver/), frzimm_idx) + call pbuf_add_field('FRZCNT', 'physpkg', dtype_r8, (/pcols,pver/), frzcnt_idx) + call pbuf_add_field('FRZDEP', 'physpkg', dtype_r8, (/pcols,pver/), frzdep_idx) + +end subroutine hetfrz_classnuc_oslo_register + +!================================================================================================ + +subroutine hetfrz_classnuc_oslo_init(mincld_in) + + real(r8), intent(in) :: mincld_in + + ! local variables + logical :: prog_modal_aero + integer :: m, n, nspec + integer :: istat + + real(r8) :: sigma_logr_aer + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' + !-------------------------------------------------------------------------------------------- + + if (.not. use_hetfrz_classnuc) return + + ! This parameterization currently assumes that prognostic modal aerosols are on. Check... + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + + mincld = mincld_in + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMLIQ', numliq_idx) + call cnst_get_ind('NUMICE', numice_idx) + + ! pbuf fields used by hetfrz_classnuc + ast_idx = pbuf_get_index('AST') + + 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('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') + call addfld('bcuc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated bc number') + call addfld('dst1uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst1 number') + call addfld('dst3uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst3 number') + + call addfld('bc_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial bc number') + call addfld('dst_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst1 number') + call addfld('dst_a3_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst3 number') + 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') + + call addfld('na500', (/ 'lev' /), 'A', '#/cm3', 'interstitial aerosol number with D>500 nm') + call addfld('totna500', (/ 'lev' /), 'A', '#/cm3', 'total aerosol number with D>500 nm') + + call addfld('FREQIMM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of immersion freezing') + call addfld('FREQCNT', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of contact freezing') + call addfld('FREQDEP', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of deposition freezing') + call addfld('FREQMIX', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of mixed-phase clouds' ) + + call addfld('DSTFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'dust immersion freezing rate') + call addfld('DSTFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'dust contact freezing rate') + call addfld('DSTFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'dust deposition freezing rate') + + call addfld('BCFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'bc immersion freezing rate') + call addfld('BCFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'bc contact freezing rate') + call addfld('BCFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'bc deposition freezing rate') + + call addfld('NIMIX_IMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het immersion freezing in Mixed Clouds') + call addfld('NIMIX_CNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het contact freezing in Mixed Clouds') + call addfld('NIMIX_DEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het deposition freezing in Mixed Clouds') + + call addfld('DSTNIDEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst dep freezing in Mixed Clouds') + call addfld('DSTNICNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst cnt freezing in Mixed Clouds') + call addfld('DSTNIIMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst imm freezing in Mixed Clouds') + + call addfld('BCNIDEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc dep freezing in Mixed Clouds') + call addfld('BCNICNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc cnt freezing in Mixed Clouds') + call addfld('BCNIIMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc imm freezing in Mixed Clouds') + + call addfld('NUMICE10s', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to het freezing in Mixed Clouds during 10-s period') + call addfld('NUMIMM10sDST', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to imm freezing by dst in Mixed Clouds during 10-s period') + call addfld('NUMIMM10sBC', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to imm freezing by bc in Mixed Clouds during 10-s period') + + if (hist_hetfrz_classnuc) then + + call add_default('bc_num', 1, ' ') + call add_default('dst1_num', 1, ' ') + call add_default('dst3_num', 1, ' ') + call add_default('bcc_num', 1, ' ') + call add_default('dst1c_num', 1, ' ') + call add_default('dst3c_num', 1, ' ') + call add_default('bcuc_num', 1, ' ') + call add_default('dst1uc_num', 1, ' ') + call add_default('dst3uc_num', 1, ' ') + + call add_default('bc_a1_num', 1, ' ') + call add_default('dst_a1_num', 1, ' ') + call add_default('dst_a3_num', 1, ' ') + 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, ' ') + + call add_default('na500', 1, ' ') + call add_default('totna500', 1, ' ') + + call add_default('FREQIMM', 1, ' ') + call add_default('FREQCNT', 1, ' ') + call add_default('FREQDEP', 1, ' ') + call add_default('FREQMIX', 1, ' ') + + call add_default('DSTFREZIMM', 1, ' ') + call add_default('DSTFREZCNT', 1, ' ') + call add_default('DSTFREZDEP', 1, ' ') + + call add_default('BCFREZIMM', 1, ' ') + call add_default('BCFREZCNT', 1, ' ') + call add_default('BCFREZDEP', 1, ' ') + + call add_default('NIMIX_IMM', 1, ' ') + call add_default('NIMIX_CNT', 1, ' ') + call add_default('NIMIX_DEP', 1, ' ') + + call add_default('DSTNIDEP', 1, ' ') + call add_default('DSTNICNT', 1, ' ') + call add_default('DSTNIIMM', 1, ' ') + + call add_default('BCNIDEP', 1, ' ') + call add_default('BCNICNT', 1, ' ') + call add_default('BCNIIMM', 1, ' ') + + call add_default('NUMICE10s', 1, ' ') + call add_default('NUMIMM10sDST', 1, ' ') + call add_default('NUMIMM10sBC', 1, ' ') + + end if + + ! The following code sets indices of the mode specific species used + ! in the module. Having a list of the species needed allows us to + ! allocate temporary space for just those species rather than for all the + ! CAM species (pcnst) which may be considerably more than needed. + ! + ! The indices set below are for use with the CAM rad_constituents + ! interfaces. Using the rad_constituents interfaces isolates the physics + ! parameterization which requires constituent information from the chemistry + ! code which provides that information. + + ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. + allocate(aer_cb(pcols,pver,pcnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer_cb', pcols*pver*ncnst*(endchunk-begchunk+1)) + + ! Allocate space for copy of interstitial aerosols with modified basis + allocate(aer(pcols,pver,pcnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer', pcols*pver*ncnst*(endchunk-begchunk+1)) + call hetfrz_classnuc_init( & + rair, cpair, rh2o, rhoh2o, mwh2o, & + tmelt, pi, iulog) + +end subroutine hetfrz_classnuc_oslo_init + +!================================================================================================ + +subroutine hetfrz_classnuc_oslo_calc( & + state, deltatin, factnum, pbuf & + ,numberConcentration, volumeConcentration & + ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & + ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + + use commondefinitions, only: nmodes_oslo => nmodes + use modal_aero_data, only : qqcw_get_field + use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex + implicit none + + ! arguments + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) + + real(r8),intent(in) :: f_acm(pcols,pver, nmodes_oslo) + real(r8),intent(in) :: f_bcm(pcols,pver, nmodes_oslo) + real(r8),intent(in) :: f_aqm(pcols, pver, nmodes_oslo) + real(r8),intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8),intent(in) :: f_soam(pcols, pver, nmodes_oslo) + + real(r8),intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8),intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8),intent(in) :: cam(pcols,pver,nmodes_oslo) + 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 + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + integer :: itim_old + integer :: i, k + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8), pointer :: ast(:,:) + + real(r8) :: lcldm(pcols,pver) + + real(r8), pointer :: ptr2d(:,:) + + real(r8) :: fn(3) + real(r8) :: awcam(pcols,pver,3) + real(r8) :: awfacm(pcols,pver,3) + real(r8) :: hetraer(pcols,pver,3) + real(r8) :: dstcoat(pcols,pver,3) + real(r8) :: total_interstitial_aer_num(pcols,pver,3) + real(r8) :: total_cloudborne_aer_num(pcols,pver,3) + real(r8) :: total_aer_num(pcols,pver,3) + real(r8) :: coated_aer_num(pcols,pver,3) + real(r8) :: uncoated_aer_num(pcols,pver,3) + + real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) + + + real(r8) :: con1, r3lx, supersatice + + real(r8) :: qcic + real(r8) :: ncic + + real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) + real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) + real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) + + real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) + real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) + real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) + real(r8) :: niimm_bc(pcols,pver), nicnt_bc(pcols,pver), nidep_bc(pcols,pver) + real(r8) :: niimm_dst(pcols,pver), nicnt_dst(pcols,pver), nidep_dst(pcols,pver) + real(r8) :: numice10s(pcols,pver) + real(r8) :: numice10s_imm_dst(pcols,pver) + real(r8) :: numice10s_imm_bc(pcols,pver) + +!++oslo aerosol specific + real(r8) :: qaercwpt(pcols,pver,pcnst) + real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) + real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) +!--oslo aerosol specific + + real(r8) :: na500(pcols,pver) + real(r8) :: tot_na500(pcols,pver) + + character(128) :: errstring ! Error status + + integer :: n, m, kk + !------------------------------------------------------------------------------- + + associate( & + lchnk => state%lchnk, & + ncol => state%ncol, & + t => state%t, & + qc => state%q(:pcols,:pver,cldliq_idx), & + nc => state%q(:pcols,:pver,numliq_idx), & + pmid => state%pmid ) + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + rho(:,:) = 0._r8 + + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) + end do + end do + + ! Convert interstitial and cloud borne aerosols from a mass to a volume basis before + ! being used in get_aer_num + do i = 1, pcnst + aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) + + ! Check whether constituent is a mass or number mixing ratio + !if (spec_idx(i) == 0) then + ! call rad_cnst_get_mode_num(0, mode_idx(i), 'a', state, pbuf, ptr2d) + !else + ! call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'a', state, pbuf, ptr2d) + !end if + !aer(:ncol,:,i,lchnk) = ptr2d(:ncol,:) * rho(:ncol,:) + end do + + ! Init top levels of outputs of get_aer_num + total_aer_num = 0._r8 + coated_aer_num = 0._r8 + uncoated_aer_num = 0._r8 + total_interstitial_aer_num = 0._r8 + total_cloudborne_aer_num = 0._r8 + hetraer = 0._r8 + awcam = 0._r8 + awfacm = 0._r8 + dstcoat = 0._r8 + na500 = 0._r8 + tot_na500 = 0._r8 + + + !Get estimate of number of aerosols inside clouds + call calculateNumberConcentration(ncol, aer_cb, 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 + do k = top_lev, pver + 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,:), & + na500(i,k), tot_na500(i,k)) + + 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) + end do + end do + + call outfld('bc_num', total_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) + + 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) + + call outfld('bcuc_num', uncoated_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1uc_num', uncoated_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3uc_num', uncoated_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_a1_num', total_interstitial_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_a1_num', total_interstitial_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_a3_num', total_interstitial_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_c1_num', total_cloudborne_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_c1_num', total_cloudborne_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_c3_num', total_cloudborne_aer_num(:,:,3), pcols, lchnk) + + 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) + + ! frzimm, frzcnt, frzdep are the outputs of this parameterization used by the microphysics + 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 + + frzbcimm(:ncol,:) = 0._r8 + frzduimm(:ncol,:) = 0._r8 + frzbccnt(:ncol,:) = 0._r8 + frzducnt(:ncol,:) = 0._r8 + frzbcdep(:ncol,:) = 0._r8 + frzdudep(:ncol,:) = 0._r8 + + freqimm(:ncol,:) = 0._r8 + freqcnt(:ncol,:) = 0._r8 + freqdep(:ncol,:) = 0._r8 + freqmix(:ncol,:) = 0._r8 + + numice10s(:ncol,:) = 0._r8 + numice10s_imm_dst(:ncol,:) = 0._r8 + numice10s_imm_bc(:ncol,:) = 0._r8 + + nnuccc_bc(:,:) = 0._r8 + nnucct_bc(:,:) = 0._r8 + nnudep_bc(:,:) = 0._r8 + + nnuccc_dst(:,:) = 0._r8 + nnucct_dst(:,:) = 0._r8 + nnudep_dst(:,:) = 0._r8 + + niimm_bc(:,:) = 0._r8 + nicnt_bc(:,:) = 0._r8 + nidep_bc(:,:) = 0._r8 + + niimm_dst(:,:) = 0._r8 + nicnt_dst(:,:) = 0._r8 + 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 + qcic = min(qc(i,k)/lcldm(i,k), 5.e-3_r8) + ncic = max(nc(i,k)/lcldm(i,k), 0._r8) + + con1 = 1._r8/(1.333_r8*pi)**0.333_r8 + r3lx = con1*(rho(i,k)*qcic/(rhoh2o*max(ncic*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m + r3lx = max(4.e-6_r8, r3lx) + supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) + fn(1) = factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc accumulation mode + 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 + + 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) + + call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") + + frzimm(i,k) = frzbcimm(i,k) + frzduimm(i,k) + frzcnt(i,k) = frzbccnt(i,k) + frzducnt(i,k) + frzdep(i,k) = frzbcdep(i,k) + frzdudep(i,k) + + if (frzimm(i,k) > 0._r8) freqimm(i,k) = 1._r8 + if (frzcnt(i,k) > 0._r8) freqcnt(i,k) = 1._r8 + if (frzdep(i,k) > 0._r8) freqdep(i,k) = 1._r8 + if ((frzimm(i,k) + frzcnt(i,k) + frzdep(i,k)) > 0._r8) freqmix(i,k) = 1._r8 + else + frzimm(i,k) = 0._r8 + frzcnt(i,k) = 0._r8 + frzdep(i,k) = 0._r8 + end if + + nnuccc_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*ast(i,k) + nnucct_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*ast(i,k) + 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) + nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) + + niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin + nicnt_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*deltatin + nidep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*deltatin + + niimm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin + nicnt_dst(i,k) = frzducnt(i,k)*1.0e6_r8*deltatin + nidep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*deltatin + + numice10s(i,k) = (frzimm(i,k)+frzcnt(i,k)+frzdep(i,k))*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + end do + end do + + call outfld('FREQIMM', freqimm, pcols, lchnk) + call outfld('FREQCNT', freqcnt, pcols, lchnk) + call outfld('FREQDEP', freqdep, pcols, lchnk) + call outfld('FREQMIX', freqmix, pcols, lchnk) + + call outfld('DSTFREZIMM', nnuccc_dst, pcols, lchnk) + call outfld('DSTFREZCNT', nnucct_dst, pcols, lchnk) + call outfld('DSTFREZDEP', nnudep_dst, pcols, lchnk) + + call outfld('BCFREZIMM', nnuccc_bc, pcols, lchnk) + call outfld('BCFREZCNT', nnucct_bc, pcols, lchnk) + 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_DEP', nidep_bc+nidep_dst, pcols, lchnk) + + call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) + call outfld('DSTNIDEP', nidep_dst, pcols, lchnk) + call outfld('DSTNIIMM', niimm_dst, pcols, lchnk) + + call outfld('BCNICNT', nicnt_bc, pcols, lchnk) + call outfld('BCNIDEP', nidep_bc, pcols, lchnk) + call outfld('BCNIIMM', niimm_bc, pcols, lchnk) + + call outfld('NUMICE10s', numice10s, pcols, lchnk) + call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) + call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) + + end associate + +end subroutine hetfrz_classnuc_oslo_calc + +!==================================================================================================== + +subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) + + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode + use modal_aero_data, only: qqcw_get_field + + ! Save the required cloud borne aerosol constituents. + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local variables + integer :: i, lchnk, kk, ncol, m, n + real(r8), pointer :: ptr2d(:,:) + type qqcw_type + real(r8), pointer :: fldcw(:,:) + end type qqcw_type + type(qqcw_type) :: qqcw(pcnst) + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! loop over the cloud borne constituents required by this module and save + ! a local copy + + aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 + do m=1,nmodes_oslo + do n=1,getNumberOfTracersInMode(m) + kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array + qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk,lchnk,.TRUE.) + if(associated(qqcw(kk)%fldcw))then + aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw + end if + end do + end do + +end subroutine hetfrz_classnuc_oslo_save_cbaero + +!==================================================================================================== + +subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input + f_acm, f_condm, & + cam, volumeCore, volumeCoat, & + total_aer_num, & ! output + coated_aer_num, & + uncoated_aer_num, & + total_interstial_aer_num, & + total_cloudborne_aer_num, & + hetraer, awcam, awfacm, dstcoat, & +!++ wy4.0 + na500, tot_na500) +!-- wy4.0 + + use spmd_utils, only: iam + use shr_kind_mod, only: r8 => shr_kind_r8 +! use ppgrid, only : pcols, pver + use constituents, only: pcnst + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & + l_dst_a2, l_dst_a3, l_bc_ai, & + MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & + lifeCycleNumberMedianRadius, & + lifeCycleSigma + + + implicit none + + ! input + real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) + real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: f_acm(nmodes_oslo) + real(r8), intent(in) :: f_condm(nmodes_oslo) + real(r8), intent(in) :: cam(nmodes_oslo) + 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) :: 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] + real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(out) :: dstcoat(3) ! coated fraction + real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) + real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) + !local variables + !------------coated variables-------------------- + 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] + + 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 +!***************************************************************************** + + 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 +!***************************************************************************** + + 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 +!***************************************************************************** + +! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 + + sigmag_amode(1) = lifeCycleSigma(num_bc_idx) + sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) + sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) + + fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) + fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) + fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) + + tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(1) = tmp1/tmp2 + + 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 +!***************************************************************************** +! 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 + awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(2) = 0._r8 + end if + if (awcam(2) >0._r8) then + awfacm(2) = f_acm(num_dst1_idx) + else + awfacm(2) = 0._r8 + end if + + ! accumulation mode for dust_a3 + 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 + awfacm(3) = 0._r8 + end if + + + ! accumulation mode for bc + 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) + else + awfacm(1) = 0._r8 + end if + + +!***************************************************************************** +! prepare output +!***************************************************************************** + + 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(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) + uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) + end do + + + tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 +!#ifdef MODAL_AERO +!#if (defined MODAL_AERO_3MODE) + +total_aer_num(2)*0.488_r8 & ! scaled for D>0.5-1 um from 0.1-1 um +!#elif (defined MODAL_AERO_7MODE) +! +total_aer_num(2)*0.566_r8 & ! scaled for D>0.5-2 um from 0.1-2 um +!#endif + +total_aer_num(3) +!#endif + + na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 +!#ifdef MODAL_AERO +!#if (defined MODAL_AERO_3MODE) + +total_interstial_aer_num(2)*0.488_r8 & ! scaled for D>0.5-1 um from 0.1-1 um +!#elif (defined MODAL_AERO_7MODE) +! +total_interstial_aer_num(2)*0.566_r8 & ! scaled for D>0.5-2 um from 0.1-2 um +!#endif + +total_interstial_aer_num(3) +!#endif + +!-- wy4.0 + +end subroutine get_aer_num + +!==================================================================================================== + +end module hetfrz_classnuc_oslo diff --git a/src/chemistry/oslo_aero/initlogn.F90 b/src/chemistry/oslo_aero/initlogn.F90 new file mode 100644 index 0000000000..0fff53e2fd --- /dev/null +++ b/src/chemistry/oslo_aero/initlogn.F90 @@ -0,0 +1,289 @@ +subroutine initlogn + +! Created for CAM3 by Trude Storelvmo, Fall 2007. +! This subroutine reads the tabulated parameters for "best lognormal fits" +! of the aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. +! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013 +! Updated for reading inout files with extra header info - Alf Kirkevaag, May 2015, +! and for new tables including SOA September 2015. +! Modified for optimized added masses and mass fractions for concentrations from +! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use aerosoldef + use opttab, only: cat,fac,fbc,faq,cate + use const + use cam_logfile, only: iulog + use oslo_control, only: oslo_getopts,dir_string_length + + implicit none + + integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv + integer ic, ifil, lin + character(len=dir_string_length) :: aerotab_table_dir + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + + write(iulog,*)'b4 nlog open ok' + + !Where are the tables stored?? + call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) + + open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' & ! SO4&SOA(n/Ait) + ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' & ! BC(n/Ait) + ,form='formatted',status='old') + open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' & ! OC(n/Ait) + ,form='formatted',status='old') + open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' & ! BC&OC(n/Ait) + ,form='formatted',status='old') + open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' & ! SO4(Ait75) + ,form='formatted',status='old') + open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' & ! MINACC + ,form='formatted',status='old') + open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' & ! MINCOA + ,form='formatted',status='old') + open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' & ! SEASF + ,form='formatted',status='old') + open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' & ! SEASACC + ,form='formatted',status='old') + open(29,file=trim(aerotab_table_dir)//'/logntilp10.out' & ! SEASCOA + ,form='formatted',status='old') + + write(iulog,*)'nlog open ok' + +! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 20,29 + call checkTableHeader (ifil) + enddo + +! ************************************************************************ +! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) +! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) +! +! These two are treated the same way since there is no dependence on +! fombg (SOA fraction in the background) for mode 1. +! ************************************************************************ + +! do ifil = 1,3 + do ifil = 1,2 + do lin = 1,96 ! 16*6 entries + read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & + rk1to3(ifil,lin), stdv1to3(ifil,lin) + + do ic=1,16 +! if(calog1to3(ifil,lin).eq.cate(kcomp,ic)) then + if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic)) shr_kind_r8 + use ppgrid, only: pcols + use const, only: sss1to3, rrr1to3 + use opttab, only: cate, fac + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) camdiff + real(r8), dimension(pcols) :: xct + real(r8) xfac(ncol) + integer lon, long + + integer i, ictot, ict1, ict2 + real(r8) r1, r2, s1, s2 + integer ifac, ifac1, ifac2 + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 + real(r8) r11, r12, r21, r22, s11, s12, s21, s22 + real(r8) d2mx(2), dxm1(2), invd(2) + + real(r8) esssf10, ess + + real(r8), parameter :: eps= 1.0e-10_r8 + +! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + enddo + + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + ess = xct(lon) + do while (ictot.lt.15.and.(ess.lt.cate(kcomp,ictot).or. & + ess.gt.cate(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + ess = xfac(lon) + do while (ifac.lt.5.and.(ess.lt.fac(ifac).or. & + ess.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_cat1 = cate(kcomp,ict1) + t_cat2 = cate(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + +! partial lengths along each dimension (1-2) for interpolation + + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + +! interpolated (in 2 dimensions) modal median radius: + + r11=rrr1to3(kcomp,ict1,ifac1) + r12=rrr1to3(kcomp,ict1,ifac2) + r21=rrr1to3(kcomp,ict2,ifac1) + r22=rrr1to3(kcomp,ict2,ifac2) + + r1 =d2mx(2)*r11+dxm1(2)*r12 + r2 =d2mx(2)*r21+dxm1(2)*r22 + + xrk(lon) = (d2mx(1)*r1+dxm1(1)*r2)*invd(2)*invd(1)*1.e-6_r8 !Look-up table radii in um + +! interpolated (in 2 dimensions) modal standard deviation: + + s11=sss1to3(kcomp,ict1,ifac1) + s12=sss1to3(kcomp,ict1,ifac2) + s21=sss1to3(kcomp,ict2,ifac1) + s22=sss1to3(kcomp,ict2,ifac2) + + s1 =d2mx(2)*s11+dxm1(2)*s12 + s2 =d2mx(2)*s21+dxm1(2)*s22 + + xstdv(lon) = (d2mx(1)*s1+dxm1(1)*s2)*invd(2)*invd(1) + + + end do ! lon + + return + end subroutine intlog1to3_sub + +end module intlog1to3 + diff --git a/src/chemistry/oslo_aero/intlog4.F90 b/src/chemistry/oslo_aero/intlog4.F90 new file mode 100644 index 0000000000..0c8466e86d --- /dev/null +++ b/src/chemistry/oslo_aero/intlog4.F90 @@ -0,0 +1,171 @@ +module intlog4 + +contains + subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & + xfacin, xfaqin, cxs, xstdv, xrk) + +! Created by Trude Storelvmo, fall 2007. This subroutine gives as output +! the "new" modal radius and standard deviation for aerosol mode kcomp=4. +! These parameters are calculated for a best lognormal fit approximation of +! the aerosol size distribution. This because the aerosol activation routine +! (developed by Abdul-Razzak & Ghan, 2000) requires the size distribution +! to be described by lognormal modes. +! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September +! 2015, and also rewritten to a more generalized for for interpolations using +! common subroutines interpol*dim. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols + use const, only: sss4, rrr4 + use opttab, only: nbmp1, cate, fac, faq + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) camdiff + real(r8), dimension(pcols) :: xct, xfac, xfaq +!ces: integer arrays ict1, ict2, ifaq1 and ifaq2 +! substituted with scalar variables with the same name. + + integer lon, long + + integer i, ictot, ifac, ifaq, & + ict1, ict2, ifac1, ifac2, ifaq1, ifaq2 + + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & + t_faq1, t_faq2, t_xfaq + real(r8) r1, r2, s1, s2, tmp, e + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) sizepar3d(2,2,2) + +!ces: New local variables introduced by (or inspired by) Egil Stoeren: + + real(r8), parameter :: eps=1.0e-60_r8 + +! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + xfaq(lon) = 0.0_r8 + enddo + +!ces: All loops "do long=1,nlons" combined to one loop: + +! do lon=1,ncol + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) + + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + tmp = xct(lon) + do while (ictot.lt.15.and.(tmp.lt.cate(kcomp,ictot).or. & + tmp.gt.cate(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + tmp = xfac(lon) + do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & + tmp.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + + ifaq=1 + tmp = xfaq(lon) + do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & + .or.tmp.gt.faq(ifaq+1))) + ifaq=ifaq+1 + enddo + ifaq1=ifaq + ifaq2=ifaq+1 + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_cat1 = cate(kcomp,ict1) + t_cat2 = cate(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + t_faq1 = faq(ifaq1) + t_faq2 = faq(ifaq2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + t_xfaq = xfaq(lon) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_faq2-t_xfaq) + dxm1(3) = (t_xfaq-t_faq1) + invd(3) = 1.0_r8/(t_faq2-t_faq1) + +! Table points as basis for multidimentional linear interpolation, +! modal median radius: + + sizepar3d(1,1,1)=rrr4(ict1,ifac1,ifaq1) + sizepar3d(1,1,2)=rrr4(ict1,ifac1,ifaq2) + sizepar3d(1,2,1)=rrr4(ict1,ifac2,ifaq1) + sizepar3d(1,2,2)=rrr4(ict1,ifac2,ifaq2) + sizepar3d(2,1,1)=rrr4(ict2,ifac1,ifaq1) + sizepar3d(2,1,2)=rrr4(ict2,ifac1,ifaq2) + sizepar3d(2,2,1)=rrr4(ict2,ifac2,ifaq1) + sizepar3d(2,2,2)=rrr4(ict2,ifac2,ifaq2) + +! interpolation in the faq and fac dimension + call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, r1, r2) + +! finally, interpolation in the cate dimension + xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look up table radii in um + + +! Table points as basis for multidimentional linear interpolation, +! modal standard deviation: + sizepar3d(1,1,1)=sss4(ict1,ifac1,ifaq1) + sizepar3d(1,1,2)=sss4(ict1,ifac1,ifaq2) + sizepar3d(1,2,1)=sss4(ict1,ifac2,ifaq1) + sizepar3d(1,2,2)=sss4(ict1,ifac2,ifaq2) + sizepar3d(2,1,1)=sss4(ict2,ifac1,ifaq1) + sizepar3d(2,1,2)=sss4(ict2,ifac1,ifaq2) + sizepar3d(2,2,1)=sss4(ict2,ifac2,ifaq1) + sizepar3d(2,2,2)=sss4(ict2,ifac2,ifaq2) + +! interpolation in the faq and fac dimension + call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, s1, s2) + +! finally, interpolation in the cate dimension + xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) + + end do ! lon + + return +end subroutine intlog4_sub + +end module intlog4 + diff --git a/src/chemistry/oslo_aero/intlog5to10.F90 b/src/chemistry/oslo_aero/intlog5to10.F90 new file mode 100644 index 0000000000..4c32b525d1 --- /dev/null +++ b/src/chemistry/oslo_aero/intlog5to10.F90 @@ -0,0 +1,203 @@ +module intlog5to10 + +contains + + subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & + xfacin, xfbcin, xfaqin, cxs, xstdv, xrk) + +!Created by Trude Storelvmo, fall 2007, based on method of A. Kirkevag. +!This subroutine gives as output the "new" modal radius and standard deviation +!for a given aerosol mode, kcomp 1-5. These parameters are calculated for a +!best lognormal fit approximation of the aerosol size distribution. +!This because the aerosol activation routine (developed by Abdul-Razzak & Ghan, +!2000) requires the size distribution to be described by lognormal modes. +!Rewritten by Alf Kirkevaag September 2015 to a more generalized for for +!interpolations using common subroutines interpol*dim. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only : pcols + use commondefinitions, only: nmodes, nbmodes + use const, only : sss, rrr + use opttab, only: cat, fbc, fac, faq + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! = (Cbc+Coc)/(Cbc+Coc+Cso4) + real(r8), intent(in) :: xfbcin(pcols) ! = Cbc/(Cbc+Coc) + real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation of lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius of lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) xctsave, camdiff + real(r8), dimension(pcols) :: xct, xfac, xfbc, xfaq + + integer lon, long + + integer i, ictot, ifac, ifbc, ifaq, & + ict1, ict2, ifac1, ifac2, & + ifbc1, ifbc2, ifaq1, ifaq2 + + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & + t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc + real(r8) r1, r2, s1, s2, tmp, e + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) sizepar4d(2,2,2,2) + + real(r8), parameter :: eps=1.0e-10_r8 + +! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + xfbc(lon) = 0.0_r8 + xfaq(lon) = 0.0_r8 + enddo + +!ces: All loops "do long=1,nlons" combined to one loop: + +! do lon=1,ncol + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cat(kcomp,1)),cat(kcomp,6)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + xfbc(lon) = min(max(xfbcin(lon),fbc(1)),fbc(6)) + xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) + + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + tmp = xct(lon) + do while (ictot.lt.5.and.(tmp.lt.cat(kcomp,ictot).or. & + tmp.gt.cat(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + tmp = xfac(lon) + do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & + tmp.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + + ifbc=1 + tmp = xfbc(lon) + do while (ifbc.lt.5.and.(tmp.lt.fbc(ifbc).or. & + tmp.gt.fbc(ifbc+1))) + ifbc=ifbc+1 + enddo + ifbc1=ifbc + ifbc2=ifbc+1 + + ifaq=1 + tmp = xfaq(lon) + do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & + .or.tmp.gt.faq(ifaq+1))) + ifaq=ifaq+1 + enddo + ifaq1=ifaq + ifaq2=ifaq+1 + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_cat1 = cat(kcomp,ict1) + t_cat2 = cat(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + t_fbc1 = fbc(ifbc1) + t_fbc2 = fbc(ifbc2) + t_faq1 = faq(ifaq1) + t_faq2 = faq(ifaq2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + t_xfbc = xfbc(lon) + t_xfaq = xfaq(lon) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_fbc2-t_xfbc) + dxm1(3) = (t_xfbc-t_fbc1) + invd(3) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) + +! Table points as basis for multidimentional linear interpolation, +! modal median radius: + + sizepar4d(1,1,1,1)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq1) + sizepar4d(1,1,1,2)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq2) + sizepar4d(1,1,2,1)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq1) + sizepar4d(1,1,2,2)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq2) + sizepar4d(1,2,1,1)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq1) + sizepar4d(1,2,1,2)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq2) + sizepar4d(1,2,2,1)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq1) + sizepar4d(1,2,2,2)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq2) + sizepar4d(2,1,1,1)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq1) + sizepar4d(2,1,1,2)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq2) + sizepar4d(2,1,2,1)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq1) + sizepar4d(2,1,2,2)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq2) + sizepar4d(2,2,1,1)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq1) + sizepar4d(2,2,1,2)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq2) + sizepar4d(2,2,2,1)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq1) + sizepar4d(2,2,2,2)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq2) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, r1, r2) + +! finally, interpolation in the cat dimension + xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look-up table radii in um + +! Table points as basis for multidimentional linear interpolation, +! modal standard deviation: + + sizepar4d(1,1,1,1)=sss(kcomp,ict1,ifac1,ifbc1,ifaq1) + sizepar4d(1,1,1,2)=sss(kcomp,ict1,ifac1,ifbc1,ifaq2) + sizepar4d(1,1,2,1)=sss(kcomp,ict1,ifac1,ifbc2,ifaq1) + sizepar4d(1,1,2,2)=sss(kcomp,ict1,ifac1,ifbc2,ifaq2) + sizepar4d(1,2,1,1)=sss(kcomp,ict1,ifac2,ifbc1,ifaq1) + sizepar4d(1,2,1,2)=sss(kcomp,ict1,ifac2,ifbc1,ifaq2) + sizepar4d(1,2,2,1)=sss(kcomp,ict1,ifac2,ifbc2,ifaq1) + sizepar4d(1,2,2,2)=sss(kcomp,ict1,ifac2,ifbc2,ifaq2) + sizepar4d(2,1,1,1)=sss(kcomp,ict2,ifac1,ifbc1,ifaq1) + sizepar4d(2,1,1,2)=sss(kcomp,ict2,ifac1,ifbc1,ifaq2) + sizepar4d(2,1,2,1)=sss(kcomp,ict2,ifac1,ifbc2,ifaq1) + sizepar4d(2,1,2,2)=sss(kcomp,ict2,ifac1,ifbc2,ifaq2) + sizepar4d(2,2,1,1)=sss(kcomp,ict2,ifac2,ifbc1,ifaq1) + sizepar4d(2,2,1,2)=sss(kcomp,ict2,ifac2,ifbc1,ifaq2) + sizepar4d(2,2,2,1)=sss(kcomp,ict2,ifac2,ifbc2,ifaq1) + sizepar4d(2,2,2,2)=sss(kcomp,ict2,ifac2,ifbc2,ifaq2) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, s1, s2) + +! finally, interpolation in the cat dimension + xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) + + end do ! lon + return +end subroutine intlog5to10_sub + +end module intlog5to10 + diff --git a/src/chemistry/oslo_aero/koagsub.F90 b/src/chemistry/oslo_aero/koagsub.F90 new file mode 100644 index 0000000000..a183a4647e --- /dev/null +++ b/src/chemistry/oslo_aero/koagsub.F90 @@ -0,0 +1,821 @@ +module koagsub + + use phys_control, only: phys_getopts + use aerosoldef + use chem_mods, only: gas_pcnst + use mo_tracname, only: solsym + use const + use shr_kind_mod, only: r8 => shr_kind_r8 + use physconst, only: rair, gravit + use cam_logfile, only : iulog + save + + real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] + real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables + real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air + real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air + + real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water + + integer, parameter :: numberOfCoagulatingModes = 6 + integer, parameter :: numberOfCoagulationReceivers = 6 + + real(r8), dimension(0:nmodes,0:nmodes) :: normalizedCoagulationSink ![m3/#/s] + real(r8), dimension(0:nmodes) :: NCloudCoagulationSink ![m3/#/s] + +!nuctst3+ + real(r8) normCoagSinkMode1 ![m3/#/s] +!nuctst3- +!aktest+ + integer, parameter :: numberOfAddCoagReceivers = 6 + real(r8), dimension(numberOfAddCoagReceivers) :: normCoagSinkAdd ![m3/#/s] +!aktest- + + !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) + 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 + ! (belonging to mixtures no. 5, 6, 7, 8, 9, 10) + 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 + ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) + 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 /) +!aktest- + + !Coagulation moves aerosol mass to the "coagulate" species, so some + !lifecycle species will receive mass in this routine! + integer, dimension(gas_pcnst) :: lifeCycleReceiver + + ! 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 + ! more detailed addition onto larger particles. + + integer, dimension(gas_pcnst) :: CloudAerReceiver + +! Closest Table index for assumed size of droplets used in coagulation + integer :: tableindexcloud + real(r8),parameter :: rcoagdroplet = 10.e-6 ! m + + +contains + +subroutine initializeCoagulationOutput() + + use ppgrid, only: pver + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + implicit none + integer :: imode + integer :: iChem + integer :: modeIndexCoagulator + + character(len=fieldname_len+3) :: fieldname_receiver + character(len=fieldname_len+3) :: fieldname_donor + character(8) :: unit + logical :: history_aerosol + logical, dimension(gas_pcnst) :: isAlreadyOnList + + call phys_getopts(history_aerosol_out = history_aerosol) + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + !Does this tracer have a receiver? If yes: It contributes to coagulation + if(lifeCycleReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"coagTend" + fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"coagTend" + if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only ,"A", unit, "coagulation tendency") + isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, 'A', unit, "coagulation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + end do + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + if(CloudAerReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"clcoagTend" + fieldname_receiver = trim(solsym(CloudAerReceiver(iChem)))//"_OCWclcoagTend" + if(.not. isAlreadyOnList(CloudAerReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only, 'A', unit, "coagulation tendency" ) + isAlreadyOnList(CloudAerReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, "A", unit, "coagulation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + + end do + +end subroutine initializeCoagulationOutput + +subroutine initializeCoagulationReceivers() + implicit none + + !These are the lifecycle-species receiving coagulate + lifeCycleReceiver(:) = -99 + lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) + lifeCycleReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_ac) !create so4 coagulate from so4 in mode 1 + lifeCycleReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 + lifeCycleReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 + lifeCycleReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 + lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 + lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_ac) !Create so4 coagulate from so4 condensate + lifeCycleReceiver(chemistryINdex(l_soa_na)) = chemistryIndex(l_soa_a1) + + !These are the lifecycle-species receiving coagulate + CloudAerReceiver(:) = -99 + CloudAerReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) + CloudAerReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_a2) !create so4 coagulate from so4 in mode 1 + CloudAerReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 + CloudAerReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 + CloudAerReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 + CloudAerReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 + CloudAerReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 + CloudAerReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 + CloudAerReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_a2) !Create so4 coagulate from so4 condensate + cloudAerReceiver(chemistryIndex(l_soa_na)) = chemistryIndex(l_soa_a1) + + +end subroutine initializeCoagulationReceivers + +subroutine initializeCoagulationCoefficients(rhob,rk) + + use mo_constants, only: pi + use const, only: normnk + + implicit none + + 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+ +! real(r8), dimension(nBinsTab) :: CoagCoeffMode1 = 0.0_r8 !Coagulation coefficient mode 1 with 1 (m3/s) +!nuctst3- +!ak+ + real(r8), dimension(numberOfAddCoagReceivers,nBinsTab) :: CoagCoeffModeAdd = 0.0_r8 !Coagulation coefficient mode 1 (m3/s) +!ak- + + real(r8), dimension(numberOfCoagulatingModes,nBinsTab) :: K12Cl = 0.0_r8 !Coagulation coefficient (m3/s) + + real(r8), dimension(nBinsTab) :: coagulationCoefficient + integer :: aMode + integer :: modeIndex + integer :: modeIndexCoagulator !Index of coagulating mode + integer :: modeIndexReceiver !Index of receiving mode + integer :: iCoagulatingMode !Counter for coagulating mode + integer :: iReceiverMode !Counter for receiver modes + integer :: nsiz !counter for look up table sizes + + do iReceiverMode = 1, numberOfCoagulationReceivers + do iCoagulatingMode = 1,numberOfCoagulatingModes + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Index of receiver mode (0-14), see list above + modeIndexReceiver = receiverMode(iReceiverMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + 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 + + !Save values + K12(iReceiverMode,iCoagulatingMode,:) = CoagulationCoefficient(:) + + enddo + end do !receiver modes + +!nuctst3+ +! 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 +! CoagCoeffMode1(:) = CoagulationCoefficient(:) +!nuctst3- +!ak+ + do iReceiverMode = 1, numberOfAddCoagReceivers + iCoagulatingMode = 1 + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Index of receiver mode (0-14), see list above + modeIndexReceiver = addReceiverMode(iReceiverMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + 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 + + !Save values + CoagCoeffModeAdd(iReceiverMode,:) = CoagulationCoefficient(:) + + end do !receiver modes +!ak- + +! Onl one receivermode for cloud coagulation (water) + do iCoagulatingMode = 1,numberOfCoagulatingModes + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + 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 + + !Save values + K12Cl(iCoagulatingMode,:) = CoagulationCoefficient(:) + + enddo + + + + !We don't need to remember K12 for all lookuptable sizes!! + !We only need to rember for 1 [#/m3] of each receiver mode + !and then later scale by number concentration in receiver modes + normalizedCoagulationSink(:,:) = 0.0_r8 + + do iCoagulatingMode = 1, numberOfCoagulatingModes + + !Sum the loss for all possible receivers + do iReceiverMode = 1, numberOfCoagulationReceivers + + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode + + modeIndexReceiver = receiverMode(iReceiverMode) !Index of receiver mode + + 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 + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * K12(iReceiverMode, iCoagulatingMode, nsiz) !Koagulation coefficient (m3/#/s) + 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 +! normCoagSinkMode1 = normCoagSinkMode1 + normnk(1,nsiz) * CoagCoeffMode1(nsiz) +! end do !Look up table size +!nuctst3- +!ak+ + !Calculate additional coagulation sink for mode 1 in such a way that it + !affects coagulationSink but not the lifecycling (directly) otherwise + + !Sum the loss for all possible receivers + normCoagSinkAdd(:) = 0.0_r8 + iCoagulatingMode = 1 + do iReceiverMode = 1, numberOfAddCoagReceivers + + modeIndexReceiver = addReceiverMode(iReceiverMode) !Index of additional receiver mode + + 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 + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) + 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 + tableindexcloud=nsiz-1 + else + tableindexcloud=nsiz + end if + write(iulog,*) 'Assumed droplet size and table bin number for cloud & + coagulation ',rcoagdroplet, ' nbin ',tableindexcloud,'binmid',rBinMidPoint(tableindexcloud) + + do iCoagulatingMode = 1, numberOfCoagulatingModes + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode + + NCloudCoagulationSink(modeIndexCoagulator) = & ![m3/#/s] + K12Cl(iCoagulatingMode, tableindexcloud) !Koagulation coefficient (m3/#/s) + + end do + +end subroutine initializeCoagulationCoefficients + +!Calculates coagulation coefficient for a coagulator mode +!with a given radius with all look-up table modes +subroutine calculateCoagulationCoefficient(CoagulationCoefficient, modeRadius, modeDensity, receiverDensity) + + implicit none + + real(r8), intent(in) :: modeRadius ! [m] (?) + real(r8), intent(in) :: modeDensity ! [kg/m3] densityi + real(r8), intent(in) :: receiverDensity ! [kg/m3] density of receiver + real(r8), intent(out), dimension(:) :: coagulationCoefficient ![m3/s] + + integer :: i !Counter for look-up tables + + real(r8) :: diff1 ![m2/s] diffusivity + real(r8) :: diff2 ![m2/s] diffusivity + real(r8) :: g12 ![-] factor + 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) :: c2 ![m/s] particle thermal velocity + real(r8) :: mfv1 ![m] mean free path particle + real(r8) :: mfv2 ![m] mean free path particle + +! coagulation coefficient for SO4 (Brownian, Fuchs form) + !Loop through indexes in look-up table + do i=1,nBinsTab + c1=calculateThermalVelocity(rBinMidPoint(i), receiverDensity) !receiving size + c2=calculateThermalVelocity(modeRadius, modeDensity) !coagulating aerosol + c12=sqrt(c1**2+c2**2) + + diff1 = calculateParticleDiffusivity(rBinMidPoint(i)) !receiving particle + diff2 = calculateParticleDiffusivity(modeRadius) !coagulating particle + + mfv1=calculateMeanFreePath(diff1,c1) !receiving particle + mfv2=calculateMeanFreePath(diff2,c2) !coagulating particle + + g1 = calculateGFactor(rBinMidPoint(i), mfv1) + g2 = calculateGFactor(modeRadius, mfv2) + + g12=sqrt(g1**2+g2**2) + + !Coagulation coefficient of receiver size "i" with the coagulating + !mode "kcomp" + CoagulationCoefficient(i) = & + 4.0_r8*pi*(rBinMidPoint(i)+modeRadius)*(diff1+diff2) & + /((rBinMidPoint(i)+modeRadius)/(rBinMidPoint(i)+modeRadius+g12) & + +(4.0_r8/c12)*(diff1+diff2)/(modeRadius+rBinMidPoint(i))) + + enddo ! loop on imax + + return + +end subroutine calculateCoagulationCoefficient + + +!Time step routine for coagulation +!Called from chemistry + +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 +! 40 nm is assumed to have an efficient coagulation with other particles. + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only : pcols, pver +use cam_history, only: outfld +use aerosoldef +use const +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(in) :: delt_inverse ! [1/s] inverse time step + integer, intent(in) :: lchnk ! [] chnk id needed for output +! local + integer :: k ! level counter + integer :: i ! horizontal counter + integer :: m ! Species counter + integer :: iCoagulator !counter for species coagulating + integer :: iReceiver !counter for species receiving coagulate + integer :: iSpecie !counter for species in mode + integer :: nsiz !loop up table size + integer :: l_index_receiver + integer :: l_index_donor + 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), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration + real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + character(128) :: long_name ![-] needed for diagnostics + real(r8), pointer :: fldcw(:,:) + real(r8), dimension(pcols, gas_pcnst) :: coltend + real(r8), dimension(pcols) :: tracer_coltend + logical :: history_aerosol + + + totalLoss(:,:,:)=0.0_r8 + + + call phys_getopts(history_aerosol_out = history_aerosol) + + do k=1,pver + do i=1,ncol + + !Air density + rhoAir = pmid(i,k)/rair/temperature(i,k) + + !Initialize number concentration for all receivers + numberConcentration(:) = 0.0_r8 + + !Go though all modes receiving coagulation + do ireceiver = 1,numberOfCoagulationReceivers + + !Go through all core species in that mode + do iSpecie = 1,getNumberOfTracersInMode(receiverMode(ireceiver)) + + !Find the lifecycle-specie receiving the coagulation + l_index_receiver = getTracerIndex(receiverMode(ireceiver) , iSpecie , .true.) + + long_name = solsym(l_index_receiver) !For testing + + + if(.NOT. is_process_mode(l_index_receiver,.true.)) then + !Add up the number concentration of the receiving mode + 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 + * rhoAir !#/kg ==> #/m3 + end if + end do !Lifecycle "core" species in this mode + enddo + + + !Go through all coagulating modes + do iCoagulator = 1, numberOfCoagulatingModes + + !Initialize loss (for a coagulator) summed over all receivers + coagulationSink = 0.0_r8 + + modeIndexCoagulator = coagulatingMode(iCoagulator) + + !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] + * 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) + + !Each coagulating mode can contain several species + do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) + + !Get the lifecycle specie which is lost + l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) + + !Move lifecycle species to new lifecycle species due to coagulation + + !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 + + !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 + * q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s + / delt_inverse ! seconds ==> MMR + + !Can not loose more than we have + totalLoss(i,k,l_index_donor) = min(totalLoss(i,k,l_index_donor) , q(i,k,l_index_donor)) + + + end if !check on process modes + end do !species in mode + + end do !coagulator mode + end do ! i + end do ! k + + + !UPDATE THE TRACERS AND DO DIAGNOSTICS + do iCoagulator = 1, numberOfCoagulatingModes + do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) + + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) + + !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 + + 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) + + do k=1,pver + !Loose mass from tracer in donor mode + q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - totalLoss(:ncol,k,l_index_donor) + + !Give mass to tracer in receiver mode + q(:ncol,k,l_index_receiver) = q(:ncol,k,l_index_receiver) + totalLoss(:ncol,k,l_index_donor) + end do !k + endif + end do + end do + + !Output for diagnostics + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + 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) + endif + end do + do i=1,gas_pcnst + if(lifeCycleReceiver(i) .gt. 0)then + long_name= trim(solsym(i))//"coagTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(lifeCycleReceiver(i)))//"coagTend" + call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) + end if + end do + endif + +end subroutine coagtend + +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 +! 40 nm is assumed to have an efficient coagulation with other particles. + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only : pcols, pver +use cam_history, only: outfld +use aerosoldef +use const +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), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg + real(r8), dimension(ncol,pver),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 + integer, intent(in) :: im + + type(physics_buffer_desc), pointer :: pbuf(:) + + +! local + integer :: k ! level counter + integer :: i ! horizontal counter + integer :: m ! Species counter + integer :: iCoagulator !counter for species coagulating + integer :: iReceiver !counter for species receiving coagulate + integer :: iSpecie !counter for species in mode + integer :: nsiz !loop up table size + integer :: l_index_receiver + 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), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration + real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + character(128) :: long_name ![-] needed for diagnostics + real(r8) :: rhoAir ![kg/m3] air density + real(r8), pointer :: fldcw(:,:) + real(r8), dimension(pcols, gas_pcnst) :: coltend + real(r8), dimension(pcols) :: tracer_coltend + logical :: history_aerosol + + + call phys_getopts(history_aerosol_out = history_aerosol) + + cloudLoss(:,:,:)=0.0_r8 + + + do k=1,pver + 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 + do iCoagulator = 1, numberOfCoagulatingModes + + !Initialize loss (for a coagulator) summed over all receivers + coagulationSink = 0.0_r8 + + modeIndexCoagulator = coagulatingMode(iCoagulator) + + !Receiver for cloud coagulation is water droplets so do not need + !go through the coagulation receivers. + + !Sum up coagulation sink for this coagulating species (for all receiving modes) + coagulationSink = & ![1/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) + + !Get the lifecycle specie which is lost + l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) + + !Move lifecycle species to new lifecycle species due to coagulation + + !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 + + !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 + ! 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 do ! i + end do ! k + +!UPDATE THE TRACERS AND DO DIAGNOSTICS + do iCoagulator = 1, numberOfCoagulatingModes + do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) + + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) + + !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 + + 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) + fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im,lchnk,errorhandle=.true.) + do k=1,pver + !Loose mass from tracer in donor mode + q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - cloudLoss(:ncol,k,l_index_donor) + !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 do !k + endif + end do + end do + + + !Output for diagnostics + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + 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) + endif + end do + do i=1,gas_pcnst + if(CloudAerReceiver(i) .gt. 0)then + long_name= trim(solsym(i))//"clcoagTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(CloudAerReceiver(i)))//"_OCWclcoagTend" + call outfld(long_name, coltend(:ncol,CloudAerReceiver(i)),pcols,lchnk) + end if + end do + endif + + + + +end subroutine clcoag + +function calculateThermalVelocity(radius, density) result(thermalVelocity) + implicit none + real(r8), intent(in) :: radius ![m] + real(r8), intent(in) :: density ![kg/m3] + real(r8) :: thermalVelocity ![m/s] + + !Formula for "c1" in Seinfeld & Pandis, table 12.1 + thermalVelocity = sqrt(8.0_r8*kboltzmann*temperatureLookupTables/pi/pi/((4.0_r8/3.0_r8)*density*radius**3)) +end function calculateThermalVelocity + + + + +function calculateParticleDiffusivity(radius) result (diffusivity) + implicit none + real(r8), intent(in) :: radius ![m] particle radius + real(r8) :: knudsenNumber ![-] knudsen number + real(r8) :: diffusivity ![m2/s] diffusivity + + real(r8) :: factor + real(r8) :: numerator, nominator + + + !Solve eqn for diffusivity in Seinfeld/Pandis, table 12.1 + + knudsenNumber = mfpAir/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 + + diffusivity = factor*numerator/nominator +end function calculateParticleDiffusivity + + + + +function calculateMeanFreePath(diffusivity,thermalVelocity) result(MeanFreePath) + implicit none + real(r8) :: diffusivity ![m2/s] + real(r8) :: thermalVelocity ![m/s] + real(r8) :: meanFreePath ![m] + + meanFreePath = 8.0_r8*diffusivity/(pi*thermalVelocity) +end function calculateMeanFreePath + + +function calculateGFactor(radius, meanFreePath) result(g) + implicit none + real(r8) :: radius ![m] + real(r8) :: meanFreePath ![m] + real(r8) :: g + + g = ((2.0_r8*radius+meanFreePath)**3 & + -(4.0_r8*radius**2+meanFreePath**2)**1.5_r8) & + /(6.0_r8*radius*meanFreePath) & + -2.0_r8*radius + +end function calculateGFactor + +end module koagsub diff --git a/src/chemistry/oslo_aero/microp_aero.F90 b/src/chemistry/oslo_aero/microp_aero.F90 new file mode 100644 index 0000000000..a45ca985ad --- /dev/null +++ b/src/chemistry/oslo_aero/microp_aero.F90 @@ -0,0 +1,906 @@ +module microp_aero + +!--------------------------------------------------------------------------------- +! Purpose: +! CAM driver layer for aerosol activation processes. +! +! ***N.B.*** This module is currently hardcoded to recognize only the aerosols/modes that +! affect the climate calculation. This is implemented by using list +! index 0 in all the calls to rad_constituent interfaces. +! +! Author: Andrew Gettelman +! Based on code from: Hugh Morrison, Xiaohong Liu and Steve Ghan +! May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Andrew Gettelman (andrew@ucar.edu) +! Modifications: A. Gettelman Nov 2010 - changed to support separation of +! microphysics and macrophysics and concentrate aerosol information here +! B. Eaton, Sep 2014 - Refactored to move CAM interface code into the CAM +! interface modules and preserve just the driver layer functionality here. +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp +use ref_pres, only: top_lev => trop_cloud_top_lev +use physconst, only: rair +use constituents, only: cnst_get_ind +use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum, & + physics_state_copy, physics_update +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use phys_control, only: phys_getopts, use_hetfrz_classnuc +use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & + rad_cnst_get_mode_num +#ifndef OSLO_AERO +use nucleate_ice_cam, only: use_preexisting_ice, nucleate_ice_cam_readnl, nucleate_ice_cam_register, & + nucleate_ice_cam_init, nucleate_ice_cam_calc +#endif + +use ndrop, only: ndrop_init, dropmixnuc +use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + +#ifndef OSLO_AERO +use hetfrz_classnuc_cam, only: hetfrz_classnuc_cam_readnl, hetfrz_classnuc_cam_register, hetfrz_classnuc_cam_init, & + hetfrz_classnuc_cam_save_cbaero, hetfrz_classnuc_cam_calc + +#endif +use cam_history, only: addfld, add_default, outfld +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + + +#ifdef OSLO_AERO +use commondefinitions, only: nmodes_oslo => nmodes +use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC & + ,MODE_IDX_OMBC_INTMIX_COAT_AIT, lifeCycleNumberMedianRadius, & + l_dst_a2, l_dst_a3, l_bc_ai, getNumberOfTracersInMode, & + getTracerIndex, getCloudTracerIndex +use oslo_utils, only: CalculateNumberConcentration +use parmix_progncdnc +use hetfrz_classnuc_oslo +use nucleate_ice_oslo +#endif + +implicit none +private +save + +public :: microp_aero_init, microp_aero_run, microp_aero_readnl, microp_aero_register + +! Private module data + +character(len=16) :: eddy_scheme + +! contact freezing due to dust +! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 +real(r8), parameter :: rn_dst1 = 0.258e-6_r8 +real(r8), parameter :: rn_dst2 = 0.717e-6_r8 +real(r8), parameter :: rn_dst3 = 1.576e-6_r8 +real(r8), parameter :: rn_dst4 = 3.026e-6_r8 + +real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + +! smallest mixing ratio considered in microphysics +real(r8), parameter :: qsmall = 1.e-18_r8 + +! minimum allowed cloud fraction +real(r8), parameter :: mincld = 0.0001_r8 + +! indices in state%q and pbuf structures +integer :: cldliq_idx = -1 +integer :: cldice_idx = -1 +integer :: numliq_idx = -1 +integer :: numice_idx = -1 +integer :: kvh_idx = -1 +integer :: tke_idx = -1 +integer :: wp2_idx = -1 +integer :: ast_idx = -1 +integer :: cldo_idx = -1 +integer :: dgnumwet_idx = -1 + +! Bulk aerosols +character(len=20), allocatable :: aername(:) +real(r8), allocatable :: num_to_mass_aer(:) + +integer :: naer_all ! number of aerosols affecting climate +integer :: idxsul = -1 ! index in aerosol list for sulfate +integer :: idxdst2 = -1 ! index in aerosol list for dust2 +integer :: idxdst3 = -1 ! index in aerosol list for dust3 +integer :: idxdst4 = -1 ! index in aerosol list for dust4 + +! modal aerosols +logical :: clim_modal_aero + +integer :: mode_accum_idx = -1 ! index of accumulation mode +integer :: mode_aitken_idx = -1 ! index of aitken mode +integer :: mode_coarse_idx = -1 ! index of coarse mode +integer :: mode_coarse_dst_idx = -1 ! index of coarse dust mode +integer :: mode_coarse_slt_idx = -1 ! index of coarse sea salt mode +integer :: coarse_dust_idx = -1 ! index of dust in coarse mode +integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode +integer :: coarse_so4_idx = -1 ! index of sulfate in coarse mode + +integer :: npccn_idx, rndst_idx, nacon_idx + +logical :: separate_dust = .false. + +!========================================================================================= +contains +!========================================================================================= + +subroutine microp_aero_register + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Register pbuf fields for aerosols needed by microphysics + ! + ! Author: Cheryl Craig October 2012 + ! + !----------------------------------------------------------------------- + use ppgrid, only: pcols + use physics_buffer, only: pbuf_add_field, dtype_r8 + + call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/), npccn_idx) + + call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) + call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) + + call nucleate_ice_oslo_register() + call hetfrz_classnuc_oslo_register() + +end subroutine microp_aero_register + +!========================================================================================= + +subroutine microp_aero_init + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Initialize constants for aerosols needed by microphysics + ! + ! Author: Andrew Gettelman May 2010 + ! + !----------------------------------------------------------------------- + + ! local variables + integer :: iaer, ierr + integer :: m, n, nmodes, nspec + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'microp_aero_init' + logical :: history_amwg + !----------------------------------------------------------------------- + + ! Query the PBL eddy scheme + call phys_getopts(eddy_scheme_out = eddy_scheme, & + history_amwg_out = history_amwg ) + + ! Access the physical properties of the aerosols that are affecting the climate + ! by using routines from the rad_constituents module. + + ! get indices into state and pbuf structures + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMLIQ', numliq_idx) + call cnst_get_ind('NUMICE', numice_idx) + + select case(trim(eddy_scheme)) + case ('diag_TKE') + tke_idx = pbuf_get_index('tke') + case ('CLUBB_SGS') + wp2_idx = pbuf_get_index('WP2_nadv') + case default + kvh_idx = pbuf_get_index('kvh') + end select + + ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. + ! The modal aerosols can be either prognostic or prescribed. + call rad_cnst_get_info(0, nmodes=nmodes) + clim_modal_aero = (nmodes > 0) + + ast_idx = pbuf_get_index('AST') + +#if (defined OSLO_AERO) + cldo_idx = pbuf_get_index('CLDO') + clim_modal_aero = .true. !Needed to avoid ending up in BAM routines + + call ndrop_init() +#else + if (clim_modal_aero) then + + cldo_idx = pbuf_get_index('CLDO') + dgnumwet_idx = pbuf_get_index('DGNUMWET') + + call ndrop_init() + + ! Init indices for specific modes/species + + ! mode index for specified mode types + do m = 1, nmodes + call rad_cnst_get_info(0, m, mode_type=str32) + select case (trim(str32)) + case ('accum') + mode_accum_idx = m + case ('aitken') + mode_aitken_idx = m + case ('coarse') + mode_coarse_idx = m + case ('coarse_dust') + mode_coarse_dst_idx = m + case ('coarse_seasalt') + mode_coarse_slt_idx = m + end select + end do + + ! check if coarse dust is in separate mode + separate_dust = mode_coarse_dst_idx > 0 + + ! for 3-mode + if ( mode_coarse_dst_idx<0 ) mode_coarse_dst_idx = mode_coarse_idx + if ( mode_coarse_slt_idx<0 ) mode_coarse_slt_idx = mode_coarse_idx + + ! Check that required mode types were found + if (mode_accum_idx == -1 .or. mode_aitken_idx == -1 .or. & + mode_coarse_dst_idx == -1.or. mode_coarse_slt_idx == -1) then + write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & + mode_accum_idx, mode_aitken_idx, mode_coarse_dst_idx, mode_coarse_slt_idx + call endrun(routine//': ERROR required mode type not found') + end if + + ! species indices for specified types + ! find indices for the dust and seasalt species in the coarse mode + call rad_cnst_get_info(0, mode_coarse_dst_idx, nspec=nspec) + do n = 1, nspec + call rad_cnst_get_info(0, mode_coarse_dst_idx, n, spec_type=str32) + select case (trim(str32)) + case ('dust') + coarse_dust_idx = n + end select + end do + call rad_cnst_get_info(0, mode_coarse_slt_idx, nspec=nspec) + do n = 1, nspec + call rad_cnst_get_info(0, mode_coarse_slt_idx, n, spec_type=str32) + select case (trim(str32)) + case ('seasalt') + coarse_nacl_idx = n + end select + end do + if (mode_coarse_idx>0) then + call rad_cnst_get_info(0, mode_coarse_idx, nspec=nspec) + do n = 1, nspec + call rad_cnst_get_info(0, mode_coarse_idx, n, spec_type=str32) + select case (trim(str32)) + case ('sulfate') + coarse_so4_idx = n + end select + end do + endif + + ! Check that required mode specie types were found + if ( coarse_dust_idx == -1 .or. coarse_nacl_idx == -1 ) then + write(iulog,*) routine//': ERROR required mode-species type not found - indicies:', & + coarse_dust_idx, coarse_nacl_idx + call endrun(routine//': ERROR required mode-species type not found') + end if + + else + + ! Props needed for BAM number concentration calcs. + + call rad_cnst_get_info(0, naero=naer_all) + allocate( & + aername(naer_all), & + num_to_mass_aer(naer_all) ) + + do iaer = 1, naer_all + call rad_cnst_get_aer_props(0, iaer, & + aername = aername(iaer), & + num_to_mass_aer = num_to_mass_aer(iaer) ) + + ! Look for sulfate, dust, and soot in this list (Bulk aerosol only) + if (trim(aername(iaer)) == 'SULFATE') idxsul = iaer + if (trim(aername(iaer)) == 'DUST2') idxdst2 = iaer + if (trim(aername(iaer)) == 'DUST3') idxdst3 = iaer + if (trim(aername(iaer)) == 'DUST4') idxdst4 = iaer + end do + + call ndrop_bam_init() + + end if + +#endif + + call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') + + call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) + call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) + + if (history_amwg) then + call add_default ('WSUB ', 1, ' ') + end if + + call nucleate_ice_oslo_init(mincld, bulk_scale) + call hetfrz_classnuc_oslo_init(mincld) + +end subroutine microp_aero_init + +!========================================================================================= + +subroutine microp_aero_readnl(nlfile) + + 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 + + ! Namelist variables + real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'microp_aero_readnl' + + namelist /microp_aero_nl/ microp_aero_bulk_scale + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'microp_aero_nl', status=ierr) + if (ierr == 0) then + read(unitn, microp_aero_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 + ! Broadcast namelist variable + call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) +#endif + + ! set local variables + bulk_scale = microp_aero_bulk_scale + + call nucleate_ice_oslo_readnl(nlfile) + call hetfrz_classnuc_oslo_readnl(nlfile) + +end subroutine microp_aero_readnl + +!========================================================================================= + +subroutine microp_aero_run ( & + state, ptend_all, deltatin, pbuf) + + ! input arguments + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend_all + real(r8), intent(in) :: deltatin ! time step (s) + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local workspace + ! all units mks unless otherwise stated + + integer :: i, k, m + integer :: itim_old + integer :: nmodes + + type(physics_state) :: state1 ! Local copy of state variable + type(physics_ptend) :: ptend_loc + + real(r8), pointer :: ast(:,:) + + real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) + + real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing + real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing + + real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode + real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust + real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl + real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate + + real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) + real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) + real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance + + real(r8), pointer :: cldn(:,:) ! cloud fraction + real(r8), pointer :: cldo(:,:) ! old cloud fraction + + real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter + + real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8) :: lcldm(pcols,pver) ! liq cloud fraction + + real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud + real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud + real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid + real(r8) :: qcld ! total cloud water + real(r8) :: nctend_mixnuc(pcols,pver) + real(r8) :: dum, dum2 ! temporary dummy variable + real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. + integer :: dst_idx, num_idx + + ! bulk aerosol variables + real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) + real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) + + real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) + real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) + real(r8) :: nucboas + + real(r8) :: wght + + integer :: lchnk, ncol + + !++ MH_2015/04/10 + real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number + type qqcw_type + real(r8), pointer :: fldcw(:,:) + end type qqcw_type + type(qqcw_type) :: qqcw(pcnst) + real(r8) :: qaercwpt(pcols,pver,pcnst) + integer :: kk + + !++ MH_2015/04/10 +#ifdef OSLO_AERO + logical :: hasAerosol(pcols, pver, nmodes_oslo) + real(r8) :: f_acm(pcols,pver, nmodes_oslo) + real(r8) :: f_bcm(pcols,pver, nmodes_oslo) + real(r8) :: f_aqm(pcols, pver, nmodes_oslo) + real(r8) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8) :: f_soam(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) ![#/m3] number concentraiton + real(r8) :: volumeConcentration(pcols,pver,nmodes_oslo) ![m3/m3] volume concentration + real(r8) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8) :: CProcessModes(pcols,pver) + real(r8) :: cam(pcols,pver,nmodes_oslo) + real(r8) :: f_c(pcols, pver) + real(r8) :: f_aq(pcols,pver) + real(r8) :: f_bc(pcols,pver) + real(r8) :: f_so4_cond(pcols,pver) + real(r8) :: f_soa(pcols,pver) + real(r8) :: volumeCore(pcols,pver,nmodes_oslo) + real(r8) :: volumeCoat(pcols,pver,nmodes_oslo) + real(r8) :: sigmag_amode(3) + real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) + + real(r8) :: fn_bc(pcols,pver), fn_dst1(pcols,pver), fn_dst3(pcols,pver) + real(r8) :: hetraer_bc(pcols,pver), hetraer_dst1(pcols,pver), hetraer_dst3(pcols,pver) + real(r8) :: dstcoat_bc(pcols,pver), dstcoat_dst1(pcols,pver), dstcoat_dst3(pcols,pver) +#endif + !-- MH_2015/04/10 + + !------------------------------------------------------------------------------- + + call physics_state_copy(state,state1) + + lchnk = state1%lchnk + ncol = state1%ncol + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, npccn_idx, npccn) + + call pbuf_get_field(pbuf, nacon_idx, nacon) + call pbuf_get_field(pbuf, rndst_idx, rndst) + + call physics_ptend_init(ptend_all, state%psetcols, 'microp_aero') + + if (clim_modal_aero) then + + itim_old = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + +#ifndef OSLO_AERO + call rad_cnst_get_info(0, nmodes=nmodes) + call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) + + allocate(factnum(pcols,pver,nmodes)) +#endif + + end if + + ! initialize output + npccn(1:ncol,1:pver) = 0._r8 + + nacon(1:ncol,1:pver,:) = 0._r8 + + ! set default or fixed dust bins for contact freezing + rndst(1:ncol,1:pver,1) = rn_dst1 + rndst(1:ncol,1:pver,2) = rn_dst2 + rndst(1:ncol,1:pver,3) = rn_dst3 + rndst(1:ncol,1:pver,4) = rn_dst4 + + ! save copy of cloud borne aerosols for use in heterogeneous freezing + if (use_hetfrz_classnuc) then + call hetfrz_classnuc_oslo_save_cbaero(state, pbuf) + end if + + ! initialize time-varying parameters + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = state1%pmid(i,k)/(rair*state1%t(i,k)) + end do + end do + +!++ MH_2015/04/10 + factnum(1:ncol,1:pver,0:nmodes_oslo) = 0._r8 + + !hetraer(1:ncol,1:pver,1:3) = 0._r8 + !total_aer_num(1:ncol,1:pver,1:3) = 0._r8 + !coated_aer_num(1:ncol,1:pver,1:3) = 0._r8 + !uncoated_aer_num(1:ncol,1:pver,1:3) = 0._r8 + !total_interstitial_aer_num(1:ncol,1:pver,1:3) = 0._r8 + !total_cloudborne_aer_num(1:ncol,1:pver,1:3) = 0._r8 + !awcam(1:ncol,1:pver,1:3) = 0._r8 + !awfacm(1:ncol,1:pver,1:3) = 0._r8 + !dstcoat(1:ncol,1:pver,1:3) = 0._r8 + !++ wy4.0 + !na500(1:ncol,1:pver) = 0._r8 + !tot_na500(1:ncol,1:pver) = 0._r8 + !-- wy4.0 + +#ifdef OSLO_AERO + !qaercwpt(1:ncol,1:pver,:) = 0.0_r8 + ! do m=1,nmodes_oslo + ! do n=1,getNumberOfTracersInMode(m) + ! kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array + ! qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk,lchnk) + ! qaercwpt(:,:,kk) = qqcw(kk)%fldcw + ! end do + ! end do +#endif +!-- MH_2015/04/10 + + +#ifndef OSLO_AERO + if (clim_modal_aero) then + ! mode number mixing ratios + call rad_cnst_get_mode_num(0, mode_coarse_dst_idx, 'a', state1, pbuf, num_coarse) + + ! mode specie mass m.r. + call rad_cnst_get_aer_mmr(0, mode_coarse_dst_idx, coarse_dust_idx, 'a', state1, pbuf, coarse_dust) + call rad_cnst_get_aer_mmr(0, mode_coarse_slt_idx, coarse_nacl_idx, 'a', state1, pbuf, coarse_nacl) + if (mode_coarse_idx>0) then + call rad_cnst_get_aer_mmr(0, mode_coarse_idx, coarse_so4_idx, 'a', state1, pbuf, coarse_so4) + endif + + else + ! init number/mass arrays for bulk aerosols + allocate( & + naer2(pcols,pver,naer_all), & + maerosol(pcols,pver,naer_all)) + + do m = 1, naer_all + call rad_cnst_get_aer_mmr(0, m, state1, pbuf, aer_mmr) + maerosol(:ncol,:,m) = aer_mmr(:ncol,:)*rho(:ncol,:) + + if (m .eq. idxsul) then + naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m)*bulk_scale + else + naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m) + end if + end do + end if +#endif + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! More refined computation of sub-grid vertical velocity + ! Set to be zero at the surface by initialization. + + select case (trim(eddy_scheme)) + case ('diag_TKE') + call pbuf_get_field(pbuf, tke_idx, tke) + case ('CLUBB_SGS') + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/),kount=(/pcols,pverp,1/)) + allocate(tke(pcols,pverp)) + tke(:ncol,:) = (3._r8/2._r8)*wp2(:ncol,:) + + case default + call pbuf_get_field(pbuf, kvh_idx, kvh) + end select + + ! Set minimum values above top_lev. + wsub(:ncol,:top_lev-1) = 0.20_r8 + wsubi(:ncol,:top_lev-1) = 0.001_r8 + + do k = top_lev, pver + do i = 1, ncol + + select case (trim(eddy_scheme)) + case ('diag_TKE', 'CLUBB_SGS') + wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) + wsub(i,k) = min(wsub(i,k),10._r8) + case default + ! get sub-grid vertical velocity from diff coef. + ! following morrison et al. 2005, JAS + ! assume mixing length of 30 m + dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 + ! use maximum sub-grid vertical vel of 10 m/s + dum = min(dum, 10._r8) + ! set wsub to value at current vertical level + wsub(i,k) = dum + end select + + wsubi(i,k) = max(0.001_r8, wsub(i,k)) + if (.not. use_preexisting_ice) then + wsubi(i,k) = min(wsubi(i,k), 0.2_r8) + endif + + wsub(i,k) = max(0.20_r8, wsub(i,k)) + + end do + end do + + call outfld('WSUB', wsub, pcols, lchnk) + call outfld('WSUBI', wsubi, pcols, lchnk) + + if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) + +!++ MH_2015/04/10 +#ifdef OSLO_AERO + +!Get size distributed interstitial aerosol + call parmix_progncdnc_sub( & + ncol & !I [nbr] number of columns used + ,state%q & !I [kg/kg] mass mixing ratio of tracers + ,rho & !I [kg/m3] air density + ,CProcessModes & !O [kg/m3] added mass (total distributed all background modes) + ,f_c & !O + ,f_bc & !O + ,f_aq & !O + ,f_so4_cond & !O + ,f_soa & + ,cam & !O + ,f_acm & !O [frc] carbon fraction in mode + ,f_bcm & !O [frc] fraction of c being bc + ,f_aqm & !O [frc] fraction of sulfate being aquous + ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate + ,f_soam & + ,numberConcentration & !O [#/m3] number concentration + ,volumeConcentration & !O [m3/m3] volume concentration + ,hygroscopicity & !O [mol/mol] + ,lnsigma & !O [-] log sigma + ,hasAerosol & !I [t/f] do we have this type of aerosol here? + ,volumeCore & + ,volumeCoat & + ) +#endif +!-- MH_2015/04/10 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !ICE Nucleation + + call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) + + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + call physics_update(state1, ptend_loc, deltatin) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get liquid cloud fraction, check for minimum + + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) + end do + end do + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Droplet Activation + + if (clim_modal_aero) then + + ! for modal aerosol + + ! partition cloud fraction into liquid water part + lcldn = 0._r8 + lcldo = 0._r8 + cldliqf = 0._r8 + do k = top_lev, pver + do i = 1, ncol + qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) + if (qcld > qsmall) then + lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld + lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld + cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld + end if + end do + end do + + call outfld('LCLOUD', lcldn, pcols, lchnk) + + ! If not using preexsiting ice, then only use cloudbourne aerosol for the + ! liquid clouds. This is the same behavior as CAM5. + if (use_preexisting_ice) then + call dropmixnuc( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + !++ MH_2015/09/07 + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + !-- MH_2015/09/07 + nctend_mixnuc, & ! Output + !++ MH_2015/04/10 + factnum ) + !-- MH_2015/04/10 + else + ! Note difference in arguments lcldn, lcldo + cldliqf = 1._r8 + call dropmixnuc( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + lcldn, lcldo, cldliqf, & + !++ MH_2015/09/07 + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + !-- MH_2015/09/07 + nctend_mixnuc, & ! Output + !++ MH_2015/04/10 + factnum ) + !-- MH_2015/04/10 + end if + + npccn(:ncol,:) = nctend_mixnuc(:ncol,:) + + else + + ! for bulk aerosol + + ! no tendencies returned from ndrop_bam_run, so just init ptend here + call physics_ptend_init(ptend_loc, state1%psetcols, 'none') + + do k = top_lev, pver + do i = 1, ncol + + if (state1%q(i,k,cldliq_idx) >= qsmall) then + + ! get droplet activation rate + + call ndrop_bam_run( & + wsub(i,k), state1%t(i,k), rho(i,k), naer2(i,k,:), naer_all, & + naer_all, maerosol(i,k,:), & + dum2) + dum = dum2 + else + dum = 0._r8 + end if + + npccn(i,k) = (dum*lcldm(i,k) - state1%q(i,k,numliq_idx))/deltatin + end do + end do + + end if + + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + call physics_update(state1, ptend_loc, deltatin) + + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Contact freezing (-40 0.0_r8) then + nacon(i,k,3) = wght*num_coarse(i,k)*rho(i,k) + else + nacon(i,k,3) = 0._r8 + end if + + !also redefine parameters based on size... + + rndst(i,k,3) = 0.5_r8*dgnumwet(i,k,mode_coarse_dst_idx) + if (rndst(i,k,3) <= 0._r8) then + rndst(i,k,3) = rn_dst3 + end if + +#endif + else + + !For Bulk Aerosols: set equal to aerosol number for dust for bins 2-4 (bin 1=0) + + if (idxdst2 > 0) then + nacon(i,k,2) = naer2(i,k,idxdst2) + end if + if (idxdst3 > 0) then + nacon(i,k,3) = naer2(i,k,idxdst3) + end if + if (idxdst4 > 0) then + nacon(i,k,4) = naer2(i,k,idxdst4) + end if + end if + + end if + end do + end do + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !bulk aerosol ccn concentration (modal does it in ndrop, from dropmixnuc) + + if (.not. clim_modal_aero) then + + ! ccn concentration as diagnostic + call ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) + + deallocate( & + naer2, & + maerosol) + + end if + + ! heterogeneous freezing + if (use_hetfrz_classnuc) then + + call hetfrz_classnuc_oslo_calc(state1, deltatin, factnum, pbuf & + ,numberConcentration, volumeConcentration & + ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & + ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + + + end if +#ifndef OSLO_AERO + if (clim_modal_aero) then + deallocate(factnum) + end if +#endif + +end subroutine microp_aero_run + +!========================================================================================= + +end module microp_aero diff --git a/src/chemistry/oslo_aero/mo_chm_diags.F90 b/src/chemistry/oslo_aero/mo_chm_diags.F90 new file mode 100644 index 0000000000..ab0c663d1d --- /dev/null +++ b/src/chemistry/oslo_aero/mo_chm_diags.F90 @@ -0,0 +1,1076 @@ +module mo_chm_diags + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : gas_pcnst + use mo_tracname, only : solsym + use chem_mods, only : rxntot, nfs, gas_pcnst, indexm, adv_mass + use ppgrid, only : pver + use mo_constants, only : rgrav, rearth + use mo_chem_utls, only : get_rxt_ndx, get_spc_ndx + use cam_history, only : fieldname_len + use mo_jeuv, only : neuv + use gas_wetdep_opts,only : gas_wetdep_method + + implicit none + private + + public :: chm_diags_inti + public :: chm_diags + public :: het_diags + + integer :: id_n,id_no,id_no2,id_no3,id_n2o5,id_hno3,id_ho2no2,id_clono2,id_brono2 + integer :: id_cl,id_clo,id_hocl,id_cl2,id_cl2o2,id_oclo,id_hcl,id_brcl + integer :: id_ccl4,id_cfc11,id_cfc113,id_ch3ccl3,id_cfc12,id_ch3cl,id_hcfc22,id_cf3br,id_cf2clbr + integer :: id_cfc114,id_cfc115,id_hcfc141b,id_hcfc142b,id_h1202,id_h2402,id_ch2br2,id_chbr3 + integer :: id_hf,id_f,id_cof2,id_cofcl,id_ch3br + integer :: id_br,id_bro,id_hbr,id_hobr,id_ch4,id_h2o,id_h2 + integer :: id_o,id_o2,id_h, id_h2o2, id_n2o + integer :: id_co2,id_o3,id_oh,id_ho2,id_so4_a1,id_so4_a2,id_so4_a3 + integer :: id_num_a2,id_num_a3,id_dst_a3,id_ncl_a3 + integer :: id_ndep,id_nhdep + + integer, parameter :: NJEUV = neuv + integer :: rid_jeuv(NJEUV), rid_jno_i, rid_jno + + logical :: has_jeuvs, has_jno_i, has_jno + + integer :: nox_species(3), noy_species(26) + integer :: clox_species(6), cloy_species(9), tcly_species(21) + integer :: brox_species(4), broy_species(6), tbry_species(13) + integer :: foy_species(4), tfy_species(16) + integer :: hox_species(4) + integer :: toth_species(3) + integer :: sox_species(3) + integer :: nhx_species(2) + integer :: aer_species(gas_pcnst) + + character(len=fieldname_len) :: dtchem_name(gas_pcnst) + character(len=fieldname_len) :: depvel_name(gas_pcnst) + character(len=fieldname_len) :: depflx_name(gas_pcnst) + character(len=fieldname_len) :: wetdep_name(gas_pcnst) + character(len=fieldname_len) :: wtrate_name(gas_pcnst) +#ifdef OSLO_AERO + character(len=fieldname_len) :: wetdep_name_area(gas_pcnst) +#endif + + real(r8), parameter :: N_molwgt = 14.00674_r8 + real(r8), parameter :: S_molwgt = 32.066_r8 + +contains + + subroutine chm_diags_inti + !-------------------------------------------------------------------- + ! ... initialize utility routine + !-------------------------------------------------------------------- + + use cam_history, only : addfld, add_default, horiz_only + use constituents, only : cnst_get_ind, cnst_longname + use phys_control, only : phys_getopts + use mo_drydep, only : has_drydep + use species_sums_diags, only : species_sums_init +#if (defined OSLO_AERO) +! use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName & +! , N_AEROSOL_TYPES, aerosol_type_name, isAerosol + use commondefinitions + use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName & + , isAerosol +#endif + implicit none + + integer :: j, k, m, n + character(len=16) :: jname, spc_name, attr + character(len=2) :: jchar + character(len=2) :: unit_basename ! Units 'kg' or '1' + + integer :: id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3 + integer :: id_so2, id_so4, id_h2so4 + integer :: id_nh3, id_nh4 + integer :: id_honitr + integer :: id_alknit + integer :: id_isopnita + integer :: id_isopnitb + integer :: id_isopnooh + integer :: id_nc4ch2oh + integer :: id_nc4cho + integer :: id_noa + integer :: id_nterpooh + integer :: id_pbznit + integer :: id_terpnit + integer :: id_dst01, id_dst02, id_dst03, id_dst04, id_sslt01, id_sslt02, id_sslt03, id_sslt04 + integer :: id_soa, id_oc1, id_oc2, id_cb1, id_cb2 + integer :: id_soam,id_soai,id_soat,id_soab,id_soax + integer :: id_bry, id_cly + + logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: history_chemistry + logical :: history_cesm_forcing + logical :: history_scwaccm_forcing + logical :: history_chemspecies_srf ! output the chemistry constituents species in the surface layer + integer :: bulkaero_species(20) +#ifdef OSLO_AERO + integer :: cloudTracerIndex + character(len=20) :: cloudTracerName +#endif + + !----------------------------------------------------------------------- + + call phys_getopts( history_aerosol_out = history_aerosol, & + history_chemistry_out = history_chemistry, & + history_chemspecies_srf_out = history_chemspecies_srf, & + history_cesm_forcing_out = history_cesm_forcing, & + history_scwaccm_forcing_out = history_scwaccm_forcing ) + + id_bry = get_spc_ndx( 'BRY' ) + id_cly = get_spc_ndx( 'CLY' ) + + id_n = get_spc_ndx( 'N' ) + id_no = get_spc_ndx( 'NO' ) + id_no2 = get_spc_ndx( 'NO2' ) + id_no3 = get_spc_ndx( 'NO3' ) + id_n2o5 = get_spc_ndx( 'N2O5' ) + id_n2o = get_spc_ndx( 'N2O' ) + id_hno3 = get_spc_ndx( 'HNO3' ) + id_ho2no2 = get_spc_ndx( 'HO2NO2' ) + id_clono2 = get_spc_ndx( 'CLONO2' ) + id_brono2 = get_spc_ndx( 'BRONO2' ) + id_cl = get_spc_ndx( 'CL' ) + id_clo = get_spc_ndx( 'CLO' ) + id_hocl = get_spc_ndx( 'HOCL' ) + id_cl2 = get_spc_ndx( 'CL2' ) + id_cl2o2 = get_spc_ndx( 'CL2O2' ) + id_oclo = get_spc_ndx( 'OCLO' ) + id_hcl = get_spc_ndx( 'HCL' ) + id_brcl = get_spc_ndx( 'BRCL' ) + + id_co2 = get_spc_ndx( 'CO2' ) + id_o3 = get_spc_ndx( 'O3' ) + id_oh = get_spc_ndx( 'OH' ) + id_ho2 = get_spc_ndx( 'HO2' ) + id_h2o2 = get_spc_ndx( 'H2O2' ) + id_so4_a1 = get_spc_ndx( 'so4_a1' ) + id_so4_a2 = get_spc_ndx( 'so4_a2' ) + id_so4_a3 = get_spc_ndx( 'so4_a3' ) + id_num_a2 = get_spc_ndx( 'num_a2' ) + id_num_a3 = get_spc_ndx( 'num_a3' ) + id_dst_a3 = get_spc_ndx( 'dst_a3' ) + id_ncl_a3 = get_spc_ndx( 'ncl_a3' ) + + id_f = get_spc_ndx( 'F' ) + id_hf = get_spc_ndx( 'HF' ) + id_cofcl = get_spc_ndx( 'COFCL' ) + id_cof2 = get_spc_ndx( 'COF2' ) + + id_ccl4 = get_spc_ndx( 'CCL4' ) + id_cfc11 = get_spc_ndx( 'CFC11' ) + + id_cfc113 = get_spc_ndx( 'CFC113' ) + id_cfc114 = get_spc_ndx( 'CFC114' ) + id_cfc115 = get_spc_ndx( 'CFC115' ) + + id_ch3ccl3 = get_spc_ndx( 'CH3CCL3' ) + id_cfc12 = get_spc_ndx( 'CFC12' ) + id_ch3cl = get_spc_ndx( 'CH3CL' ) + + id_hcfc22 = get_spc_ndx( 'HCFC22' ) + id_hcfc141b= get_spc_ndx( 'HCFC141B' ) + id_hcfc142b= get_spc_ndx( 'HCFC142B' ) + + id_cf2clbr = get_spc_ndx( 'CF2CLBR' ) + id_cf3br = get_spc_ndx( 'CF3BR' ) + id_ch3br = get_spc_ndx( 'CH3BR' ) + id_h1202 = get_spc_ndx( 'H1202' ) + id_h2402 = get_spc_ndx( 'H2402' ) + id_ch2br2 = get_spc_ndx( 'CH2BR2' ) + id_chbr3 = get_spc_ndx( 'CHBR3' ) + + id_br = get_spc_ndx( 'BR' ) + id_bro = get_spc_ndx( 'BRO' ) + id_hbr = get_spc_ndx( 'HBR' ) + id_hobr = get_spc_ndx( 'HOBR' ) + id_ch4 = get_spc_ndx( 'CH4' ) + id_h2o = get_spc_ndx( 'H2O' ) + id_h2 = get_spc_ndx( 'H2' ) + id_o = get_spc_ndx( 'O' ) + id_o2 = get_spc_ndx( 'O2' ) + id_h = get_spc_ndx( 'H' ) + + id_pan = get_spc_ndx( 'PAN' ) + id_onit = get_spc_ndx( 'ONIT' ) + id_mpan = get_spc_ndx( 'MPAN' ) + id_isopno3 = get_spc_ndx( 'ISOPNO3' ) + id_onitr = get_spc_ndx( 'ONITR' ) + id_nh4no3 = get_spc_ndx( 'NH4NO3' ) + + id_honitr = get_spc_ndx( 'HONITR' ) + id_alknit = get_spc_ndx( 'ALKNIT' ) + id_isopnita = get_spc_ndx( 'ISOPNITA' ) + id_isopnitb = get_spc_ndx( 'ISOPNITB' ) + id_isopnooh = get_spc_ndx( 'ISOPNOOH' ) + id_nc4ch2oh = get_spc_ndx( 'NC4CH2OH' ) + id_nc4cho = get_spc_ndx( 'NC4CHO' ) + id_noa = get_spc_ndx( 'NOA' ) + id_nterpooh = get_spc_ndx( 'NTERPOOH' ) + id_pbznit = get_spc_ndx( 'PBZNIT' ) + id_terpnit = get_spc_ndx( 'TERPNIT' ) + id_ndep = get_spc_ndx( 'NDEP' ) + id_nhdep = get_spc_ndx( 'NHDEP' ) + + id_so2 = get_spc_ndx( 'SO2' ) + id_so4 = get_spc_ndx( 'SO4' ) + id_h2so4 = get_spc_ndx( 'H2SO4' ) + + id_nh3 = get_spc_ndx( 'NH3' ) + id_nh4 = get_spc_ndx( 'NH4' ) + id_nh4no3 = get_spc_ndx( 'NH4NO3' ) + + id_dst01 = get_spc_ndx( 'DST01' ) + id_dst02 = get_spc_ndx( 'DST02' ) + id_dst03 = get_spc_ndx( 'DST03' ) + id_dst04 = get_spc_ndx( 'DST04' ) + id_sslt01 = get_spc_ndx( 'SSLT01' ) + id_sslt02 = get_spc_ndx( 'SSLT02' ) + id_sslt03 = get_spc_ndx( 'SSLT03' ) + id_sslt04 = get_spc_ndx( 'SSLT04' ) + id_soa = get_spc_ndx( 'SOA' ) + id_so4 = get_spc_ndx( 'SO4' ) + id_oc1 = get_spc_ndx( 'OC1' ) + id_oc2 = get_spc_ndx( 'OC2' ) + id_cb1 = get_spc_ndx( 'CB1' ) + id_cb2 = get_spc_ndx( 'CB2' ) + + rid_jno = get_rxt_ndx( 'jno' ) + rid_jno_i = get_rxt_ndx( 'jno_i' ) + + id_soam = get_spc_ndx( 'SOAM' ) + id_soai = get_spc_ndx( 'SOAI' ) + id_soat = get_spc_ndx( 'SOAT' ) + id_soab = get_spc_ndx( 'SOAB' ) + id_soax = get_spc_ndx( 'SOAX' ) + + +!... NOY species + nox_species = (/ id_n, id_no, id_no2 /) + noy_species = (/ id_n, id_no, id_no2, id_no3, id_n2o5, id_hno3, id_ho2no2, id_clono2, & + id_brono2, id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3, & + id_honitr, id_alknit, id_isopnita, id_isopnitb, id_isopnooh, id_nc4ch2oh, & + id_nc4cho, id_noa, id_nterpooh, id_pbznit, id_terpnit /) +!... HOX species + hox_species = (/ id_h, id_oh, id_ho2, id_h2o2 /) + +!... CLOY species + clox_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo /) + cloy_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl /) + tcly_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl, & + id_ccl4, id_cfc11, id_cfc113, id_cfc114, id_cfc115, id_ch3ccl3, id_cfc12, id_ch3cl, & + id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr /) + +!... FOY species + foy_species = (/ id_F, id_hf, id_cofcl, id_cof2 /) + tfy_species = (/ id_f, id_hf, id_cofcl, id_cof2, id_cfc11, id_cfc12, id_cfc113, id_cfc114, id_cfc115, & + id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr, id_cf3br, id_h1202, id_h2402 /) + +!... BROY species + brox_species = (/ id_br, id_bro, id_brcl, id_hobr /) + broy_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr /) + tbry_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr, id_cf2clbr, id_cf3br, id_ch3br, id_h1202, & + id_h2402, id_ch2br2, id_chbr3 /) + + sox_species = (/ id_so2, id_so4, id_h2so4 /) + nhx_species = (/ id_nh3, id_nh4 /) + bulkaero_species(:) = -1 + bulkaero_species(1:20) = (/ id_dst01, id_dst02, id_dst03, id_dst04, & + id_sslt01, id_sslt02, id_sslt03, id_sslt04, & + id_soa, id_so4, id_oc1, id_oc2, id_cb1, id_cb2, id_nh4no3, & + id_soam,id_soai,id_soat,id_soab,id_soax /) + + aer_species(:) = -1 + n = 1 + do m = 1,gas_pcnst + k=0 + if ( any(bulkaero_species(:)==m) ) k=1 + if ( k==0 ) k = index(trim(solsym(m)), '_a') + if ( k==0 ) k = index(trim(solsym(m)), '_c') + if ( k>0 ) then ! must be aerosol species + aer_species(n) = m + n = n+1 + endif + enddo + + toth_species = (/ id_ch4, id_h2o, id_h2 /) + + call addfld( 'NOX', (/ 'lev' /), 'A', 'mol/mol', 'nox (N+NO+NO2)' ) + call addfld( 'NOY', (/ 'lev' /), 'A', 'mol/mol', & + 'noy = total nitrogen (N+NO+NO2+NO3+2N2O5+HNO3+HO2NO2+ORGNOY+NH4NO3' ) + call addfld( 'NOY_SRF', horiz_only, 'A', 'mol/mol', 'surface noy volume mixing ratio' ) + call addfld( 'HOX', (/ 'lev' /), 'A', 'mol/mol', 'HOx (H+OH+HO2+2H2O2)' ) + + call addfld( 'BROX', (/ 'lev' /), 'A', 'mol/mol', 'brox (Br+BrO+BRCl+HOBr)' ) + call addfld( 'BROY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic bromine (Br+BrO+HOBr+BrONO2+HBr+BrCl)' ) + call addfld( 'TBRY', (/ 'lev' /), 'A', 'mol/mol', 'total Br (ORG+INORG) volume mixing ratio' ) + + call addfld( 'CLOX', (/ 'lev' /), 'A', 'mol/mol', 'clox (Cl+CLO+HOCl+2Cl2+2Cl2O2+OClO' ) + call addfld( 'CLOY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic chlorine (Cl+ClO+2Cl2+2Cl2O2+OClO+HOCl+ClONO2+HCl+BrCl)' ) + call addfld( 'TCLY', (/ 'lev' /), 'A', 'mol/mol', 'total Cl (ORG+INORG) volume mixing ratio' ) + + call addfld( 'FOY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic fluorine (F+HF+COFCL+2COF2)' ) + call addfld( 'TFY', (/ 'lev' /), 'A', 'mol/mol', 'total F (ORG+INORG) volume mixing ratio' ) + + call addfld( 'TOTH', (/ 'lev' /), 'A', 'mol/mol', 'total H2 volume mixing ratio' ) + + call addfld( 'NOY_mmr', (/ 'lev' /), 'A', 'kg/kg', 'NOy mass mixing ratio' ) + call addfld( 'SOX_mmr', (/ 'lev' /), 'A', 'kg/kg', 'SOx mass mixing ratio' ) + call addfld( 'NHX_mmr', (/ 'lev' /), 'A', 'kg/kg', 'NHx mass mixing ratio' ) + + do j = 1,NJEUV + write( jchar, '(I2)' ) j + jname = 'jeuv_'//trim(adjustl(jchar)) + rid_jeuv(j) = get_rxt_ndx( trim(jname) ) + enddo + + has_jeuvs = all( rid_jeuv(:) > 0 ) + has_jno_i = rid_jno_i>0 + has_jno = rid_jno>0 + + if ( has_jeuvs ) then + call addfld( 'PION_EUV', (/ 'lev' /), 'I', '/cm^3/s', 'total euv ionization rate' ) + call addfld( 'PEUV1', (/ 'lev' /), 'I', '/cm^3/s', '(j1+j2+j3)*o' ) + call addfld( 'PEUV1e', (/ 'lev' /), 'I', '/cm^3/s', '(j14+j15+j16)*o' ) + call addfld( 'PEUV2', (/ 'lev' /), 'I', '/cm^3/s', 'j4*n' ) + call addfld( 'PEUV3', (/ 'lev' /), 'I', '/cm^3/s', '(j5+j7+j8+j9)*o2' ) + call addfld( 'PEUV3e', (/ 'lev' /), 'I', '/cm^3/s', '(j17+j19+j20+j21)*o2' ) + call addfld( 'PEUV4', (/ 'lev' /), 'I', '/cm^3/s', '(j10+j11)*n2' ) + call addfld( 'PEUV4e', (/ 'lev' /), 'I', '/cm^3/s', '(j22+j23)*n2' ) + call addfld( 'PEUVN2D', (/ 'lev' /), 'I', '/cm^3/s', '(j11+j13)*n2' ) + call addfld( 'PEUVN2De', (/ 'lev' /), 'I', '/cm^3/s', '(j23+j25)*n2' ) + endif + if ( has_jno ) then + call addfld( 'PJNO', (/ 'lev' /), 'I', '/cm^3/s', 'jno*no' ) + endif + if ( has_jno_i ) then + call addfld( 'PJNO_I', (/ 'lev' /), 'I', '/cm^3/s', 'jno_i*no' ) + endif +! +! CCMI +! + call addfld( 'DO3CHM_TRP', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in troposphere', & + flag_xyfill=.True. ) + call addfld( 'DO3CHM_LMS', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in lowermost stratosphere', & + flag_xyfill=.True. ) +! + do m = 1,gas_pcnst + + spc_name = trim(solsym(m)) + + call cnst_get_ind(spc_name, n, abort=.false. ) + if ( n > 0 ) then + attr = cnst_longname(n) + elseif ( trim(spc_name) == 'H2O' ) then + attr = 'water vapor' + else + attr = spc_name + endif + + depvel_name(m) = 'DV_'//trim(spc_name) + depflx_name(m) = 'DF_'//trim(spc_name) + dtchem_name(m) = 'D'//trim(spc_name)//'CHM' + + call addfld( depvel_name(m), horiz_only, 'A', 'cm/s', 'deposition velocity ' ) + call addfld( depflx_name(m), horiz_only, 'A', 'kg/m2/s', 'dry deposition flux ' ) + call addfld( dtchem_name(m), (/ 'lev' /), 'A', 'kg/s', 'net tendency from chem' ) + + if (has_drydep(spc_name).and.history_chemistry) then + call add_default( depflx_name(m), 1, ' ' ) + endif + + if (gas_wetdep_method=='MOZ') then + wetdep_name(m) = 'WD_'//trim(spc_name) + wtrate_name(m) = 'WDR_'//trim(spc_name) + + call addfld( wetdep_name(m), horiz_only, 'A', 'kg/s', spc_name//' wet deposition' ) + call addfld( wtrate_name(m), (/ 'lev' /), 'A', '/s', spc_name//' wet deposition rate' ) + endif + +#if defined OSLO_AERO + wetdep_name_area(m)='WD_A_'//trim(spc_name) + call addfld( wetdep_name_area(m), horiz_only, 'A', 'kg/m2/s ', spc_name//' wet deposition' ) + + !Needed for budget term of gases! Aerosols have their own budget terms + if(n.gt.0) then + if(.NOT. isAerosol(n))then + if(history_chemistry)then + call add_default( wetdep_name_area(m), 1, ' ') + end if + endif + end if +#endif + + if (spc_name(1:3) == 'num') then + unit_basename = ' 1' + else + unit_basename = 'kg' + endif + +!akc6 if ( any( aer_species == m ) ) then +!akc6! if ( any( aer_species == m ) .or. isAerosol(n) ) then +!akc6+ +#ifndef OSLO_AERO + if ( any( aer_species == m ) ) then +#else + if (n.gt.0) then + if ( any( aer_species == m ) .or. isAerosol(n) ) then +!akc6- +#endif + call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") + else + call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") + endif +!akc6+ +#ifdef OSLO_AERO + else + call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") + endif +#endif +!akc6- + if ((m /= id_cly) .and. (m /= id_bry)) then + if (history_aerosol.or.history_chemistry) then + call add_default( spc_name, 1, ' ' ) + endif + if (history_chemspecies_srf) then + call add_default( trim(spc_name)//'_SRF', 1, ' ' ) + endif + endif + + if ( history_cesm_forcing ) then + if (m==id_o3) call add_default( spc_name, 1, ' ') + if (m==id_oh) call add_default( spc_name, 1, ' ') + if (m==id_no3) call add_default( spc_name, 1, ' ') + if (m==id_ho2) call add_default( spc_name, 1, ' ') + + if (m==id_o3) call add_default( spc_name, 8, ' ') + if (m==id_so4_a1) call add_default( spc_name, 8, ' ') + if (m==id_so4_a2) call add_default( spc_name, 8, ' ') + if (m==id_so4_a3) call add_default( spc_name, 8, ' ') + + if (m==id_num_a2) call add_default( spc_name, 8, ' ') + if (m==id_num_a3) call add_default( spc_name, 8, ' ') + if (m==id_dst_a3) call add_default( spc_name, 8, ' ') + if (m==id_ncl_a3) call add_default( spc_name, 8, ' ') + + endif + if ( history_scwaccm_forcing ) then + if (m==id_co2) call add_default( spc_name, 8, ' ') + if (m==id_h) call add_default( spc_name, 8, ' ') + if (m==id_no) call add_default( spc_name, 8, ' ') + if (m==id_o) call add_default( spc_name, 8, ' ') + if (m==id_o2) call add_default( spc_name, 8, ' ') + if (m==id_o3) call add_default( spc_name, 8, ' ') + if (m==id_h2o) call add_default( spc_name, 1, ' ') + if (m==id_ch4 ) call add_default( spc_name, 1, ' ') + if (m==id_n2o ) call add_default( spc_name, 1, ' ') + if (m==id_cfc11 ) call add_default( spc_name, 1, ' ') + if (m==id_cfc12 ) call add_default( spc_name, 1, ' ') + endif + +#ifdef OSLO_AERO + call add_default( spc_name, 1, ' ' ) +#endif + +#if defined OSLO_AERO + !output 3d-field of aersol tracer in cloud water + if(n > 0) then + cloudTracerIndex = getCloudTracerIndexDirect(n) + if(cloudTracerIndex > 0)then + cloudTracerName(1:len(CloudTracerName))=" " + cloudTracerName = getCloudTracerName(n) + call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & + trim(cloudTracerName)//' in cloud water') + call add_default( trim(cloudTracerName), 1, ' ' ) + + !Add column burden of cloud tracers + call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(cloudTracerName)//' column in cloud water') + call add_default('cb_'//trim(cloudTracerName),1,' ') + endif + !..and column burden in clean air + call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(spc_name)//' in column') + call add_default('cb_'//trim(spc_name),1,' ' ) + + if(history_aerosol)then + if(cloudTracerIndex > 0)then + !Output budget-terms for cloud borne aerosols + call add_default (trim(cloudTracerName)//'GVF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') + call add_default (trim(cloudTracerName)//'TBF', 1, ' ') + call add_default (trim(cloudTracerName)//'DDF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') + endif + endif + end if +#endif + + enddo + + call addfld( 'MASS', (/ 'lev' /), 'A', 'kg', 'mass of grid box' ) + call addfld( 'AREA', horiz_only, 'A', 'm2', 'area of grid box' ) +#ifdef OSLO_AERO + do n=1,N_AEROSOL_TYPES + call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& + 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') + call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') + call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& + 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') + call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') + end do +#endif + + call addfld( 'dry_deposition_NOy_as_N', horiz_only, 'I', 'kg/m2/s', 'NOy dry deposition flux ' ) + call addfld( 'DF_SOX', horiz_only, 'I', 'kg/m2/s', 'SOx dry deposition flux ' ) + call addfld( 'dry_deposition_NHx_as_N', horiz_only, 'I', 'kg/m2/s', 'NHx dry deposition flux ' ) + if (gas_wetdep_method=='NEU') then + call addfld( 'wet_deposition_NOy_as_N', horiz_only, 'A', 'kg/m2/s', 'NOy wet deposition' ) + call addfld( 'wet_deposition_NHx_as_N', horiz_only, 'A', 'kg/m2/s', 'NHx wet deposition' ) + elseif (gas_wetdep_method=='MOZ') then + call addfld( 'wet_deposition_NOy_as_N', horiz_only, 'A', 'kg/s', 'NOy wet deposition' ) + call addfld( 'WD_SOX', horiz_only, 'A', 'kg/s', 'SOx wet deposition' ) + call addfld( 'wet_deposition_NHx_as_N', horiz_only, 'A', 'kg/s', 'NHx wet deposition' ) + endif + if ( history_cesm_forcing ) then + call add_default('dry_deposition_NOy_as_N', 1, ' ') + call add_default('dry_deposition_NHx_as_N', 1, ' ') + call add_default('wet_deposition_NOy_as_N', 1, ' ') + call add_default('wet_deposition_NHx_as_N', 1, ' ') + endif + + call species_sums_init() + + end subroutine chm_diags_inti + + subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & + wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) + !-------------------------------------------------------------------- + ! ... utility routine to output chemistry diagnostic variables + !-------------------------------------------------------------------- + + use cam_history, only : outfld + use phys_grid, only : get_area_all_p + use species_sums_diags, only : species_sums_output +#if (defined OSLO_AERO) + use constituents, only : cnst_get_ind + use phys_grid, only : pcols + use commondefinitions + use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName & + , aerosolType, isAerosol + use physics_buffer, only : pbuf_get_field, pbuf_get_index + use physics_buffer, only : physics_buffer_desc +#endif +! +! CCMI +! + use cam_history_support, only : fillvalue + + !-------------------------------------------------------------------- + ! ... dummy arguments + !-------------------------------------------------------------------- + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + real(r8), intent(in) :: vmr(ncol,pver,gas_pcnst) + real(r8), intent(in) :: mmr(ncol,pver,gas_pcnst) + real(r8), intent(in) :: rxt_rates(ncol,pver,rxntot) + real(r8), intent(in) :: invariants(ncol,pver,max(1,nfs)) + real(r8), intent(in) :: depvel(ncol, gas_pcnst) + real(r8), intent(in) :: depflx(ncol, gas_pcnst) + real(r8), intent(in) :: mmr_tend(ncol,pver,gas_pcnst) + real(r8), intent(in) :: pdel(ncol,pver) + real(r8), intent(in) :: pmid(ncol,pver) + integer, intent(in) :: ltrop(ncol) + real(r8), intent(in) :: wetdepflx(ncol, gas_pcnst) + real(r8), intent(out) :: nhx_nitrogen_flx(ncol) ! kgN/m2/sec + real(r8), intent(out) :: noy_nitrogen_flx(ncol) ! kgN/m2/sec + type(physics_buffer_desc), pointer :: pbuf(:) + +#ifdef OSLO_AERO + real(r8), dimension(:,:), pointer :: cloudTracerField + integer :: cloudTracerIndex + character(len=20) :: cloudTracerName + real(r8) :: mass_tmp(pcols,pver) + real(r8) :: cb(pcols) + real(r8) :: cb_aerosol_type(pcols,N_AEROSOL_TYPES) !column burden aerosol types + real(r8) :: mmr_aerosol_type(pcols,pver,N_AEROSOL_TYPES) !concentration aerosol types +#endif + !-------------------------------------------------------------------- + ! ... local variables + !-------------------------------------------------------------------- + integer :: i, k, m, n + real(r8) :: wrk(ncol,pver) + ! real(r8) :: tmp(ncol,pver) + ! real(r8) :: m(ncol,pver) + real(r8) :: un2(ncol) + + real(r8), dimension(ncol,pver) :: vmr_nox, vmr_noy, vmr_clox, vmr_cloy, vmr_tcly, vmr_brox, vmr_broy, vmr_toth + real(r8), dimension(ncol,pver) :: vmr_tbry, vmr_foy, vmr_tfy + real(r8), dimension(ncol,pver) :: mmr_noy, mmr_sox, mmr_nhx, net_chem + real(r8), dimension(ncol) :: df_noy, df_sox, df_nhx, do3chm_trp, do3chm_lms + real(r8), dimension(ncol) :: wd_noy, wd_nhx + real(r8), dimension(ncol,pver) :: vmr_hox + + real(r8) :: area(ncol), mass(ncol,pver) + real(r8) :: wgt + character(len=16) :: spc_name + + + !-------------------------------------------------------------------- + ! ... "diagnostic" groups + !-------------------------------------------------------------------- + vmr_nox(:ncol,:) = 0._r8 + vmr_noy(:ncol,:) = 0._r8 + vmr_hox(:ncol,:) = 0._r8 + vmr_clox(:ncol,:) = 0._r8 + vmr_cloy(:ncol,:) = 0._r8 + vmr_tcly(:ncol,:) = 0._r8 + vmr_brox(:ncol,:) = 0._r8 + vmr_broy(:ncol,:) = 0._r8 + vmr_tbry(:ncol,:) = 0._r8 + vmr_foy(:ncol,:) = 0._r8 + vmr_tfy(:ncol,:) = 0._r8 + vmr_toth(:ncol,:) = 0._r8 + mmr_noy(:ncol,:) = 0._r8 + mmr_sox(:ncol,:) = 0._r8 + mmr_nhx(:ncol,:) = 0._r8 + df_noy(:ncol) = 0._r8 + df_sox(:ncol) = 0._r8 + df_nhx(:ncol) = 0._r8 + + wd_noy(:ncol) = 0._r8 + wd_nhx(:ncol) = 0._r8 + + call get_area_all_p(lchnk, ncol, area) + area = area * rearth**2 + + do k = 1,pver + mass(:ncol,k) = pdel(:ncol,k) * area(:ncol) * rgrav + enddo + + call outfld( 'AREA', area(:ncol), ncol, lchnk ) + call outfld( 'MASS', mass(:ncol,:), ncol, lchnk ) + +#ifdef OSLO_AERO + cb_aerosol_type(:,:) = 0.0_r8 + mmr_aerosol_type(:,:,:) = 0.0_r8 +#endif + do m = 1,gas_pcnst + + !...FOY (counting Fluorines, not chlorines or bromines) + if ( m == id_cfc12 .or. m == id_hcfc22 .or. m == id_cf2clbr .or. m == id_h1202 .or. m == id_hcfc142b & + .or. m == id_cof2 ) then + wgt = 2._r8 + elseif ( m == id_cfc113 .or. m == id_cf3br ) then + wgt = 3._r8 + elseif ( m == id_cfc114 .or. m == id_h2402 ) then + wgt = 4._r8 + elseif ( m == id_cfc115 ) then + wgt = 5._r8 + else + wgt = 1._r8 + endif + if ( any( foy_species == m ) ) then + vmr_foy(:ncol,:) = vmr_foy(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( tfy_species == m ) ) then + vmr_tfy(:ncol,:) = vmr_tfy(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + +!... counting chlorine and bromines, etc... (and total H2 species) + if ( m == id_ch4 .or. m == id_n2o5 .or. m == id_cfc12 .or. m == id_cl2 .or. m == id_cl2o2 .or. m==id_h2o2 ) then + wgt = 2._r8 + elseif (m == id_cfc114 .or. m == id_hcfc141b .or. m == id_h1202 .or. m == id_h2402 .or. m == id_ch2br2 ) then + wgt = 2._r8 + elseif ( m == id_cfc11 .or. m == id_cfc113 .or. m == id_ch3ccl3 .or. m == id_chbr3 ) then + wgt = 3._r8 + elseif ( m == id_ccl4 ) then + wgt = 4._r8 + else + wgt = 1._r8 + endif +!...NOY + if ( any( nox_species == m ) ) then + vmr_nox(:ncol,:) = vmr_nox(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( noy_species == m ) ) then + vmr_noy(:ncol,:) = vmr_noy(:ncol,:) + wgt * vmr(:ncol,:,m) + endif +!...NOY, SOX, NHX + if ( any( noy_species == m ) ) then + mmr_noy(:ncol,:) = mmr_noy(:ncol,:) + wgt * mmr(:ncol,:,m) + endif + if ( any( sox_species == m ) ) then + mmr_sox(:ncol,:) = mmr_sox(:ncol,:) + wgt * mmr(:ncol,:,m) + endif + if ( any( nhx_species == m ) ) then + mmr_nhx(:ncol,:) = mmr_nhx(:ncol,:) + wgt * mmr(:ncol,:,m) + endif +!...CLOY + if ( any( clox_species == m ) ) then + vmr_clox(:ncol,:) = vmr_clox(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( cloy_species == m ) ) then + vmr_cloy(:ncol,:) = vmr_cloy(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( tcly_species == m ) ) then + vmr_tcly(:ncol,:) = vmr_tcly(:ncol,:) + wgt * vmr(:ncol,:,m) + endif +!...BROY + if ( any( brox_species == m ) ) then + vmr_brox(:ncol,:) = vmr_brox(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( broy_species == m ) ) then + vmr_broy(:ncol,:) = vmr_broy(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + if ( any( tbry_species == m ) ) then + vmr_tbry(:ncol,:) = vmr_tbry(:ncol,:) + wgt * vmr(:ncol,:,m) + endif +!...HOY + if ( any ( toth_species == m ) ) then + vmr_toth(:ncol,:) = vmr_toth(:ncol,:) + wgt * vmr(:ncol,:,m) + endif +!...HOx + if ( any( hox_species == m ) ) then + vmr_hox(:ncol,:) = vmr_hox(:ncol,:) + wgt * vmr(:ncol,:,m) + endif + +#if defined OSLO_AERO + spc_name = trim(solsym(m)) + call cnst_get_ind(spc_name, n, abort=.false.) +#endif + +#ifndef OSLO_AERO + if ( any( aer_species == m ) ) then +#else + if (n.gt.0) then + if ( any( aer_species == m ) .or. isAerosol(n) ) then +#endif + call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) + else + call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) + endif +#ifdef OSLO_AERO + else + call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) + end if +#endif +#if defined OSLO_AERO + if(n > 0) then + cloudTracerIndex = getCloudTracerIndexDirect(n) + if(cloudTracerIndex > 0)then + cloudTracerName = getCloudTracerName(n) + call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) + call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) + + !Treat column burden (cloud tracer) + mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) + endif + !Treat column burden (normal tracer) + mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) + + !Sum column burden per aerosol type + if(aerosolType(n) .gt. 0)then + cb_aerosol_type(:ncol,aerosolType(n)) = & + cb_aerosol_type(:ncol,aerosolType(n)) & + + cb(:ncol) + + !Total mass mixing ratio of aerosol type + mmr_aerosol_type(:ncol,:,aerosolType(n)) = & + mmr_aerosol_type(:ncol,:,aerosolType(n)) & + + mmr(:ncol,:,m) + endif + + end if !Check if this is a chemistry tracer +#endif + + call outfld( depvel_name(m), depvel(:ncol,m), ncol ,lchnk ) + call outfld( depflx_name(m), depflx(:ncol,m), ncol ,lchnk ) + + if ( any( noy_species == m ) ) then + df_noy(:ncol) = df_noy(:ncol) + wgt * depflx(:ncol,m)*N_molwgt/adv_mass(m) + endif + if ( any( sox_species == m ) ) then + df_sox(:ncol) = df_sox(:ncol) + wgt * depflx(:ncol,m)*S_molwgt/adv_mass(m) + endif + if ( any( nhx_species == m ) ) then + df_nhx(:ncol) = df_nhx(:ncol) + wgt * depflx(:ncol,m)*N_molwgt/adv_mass(m) + endif + + if ( any( noy_species == m ) ) then + wd_noy(:ncol) = wd_noy(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) + endif + if ( any( nhx_species == m ) ) then + wd_nhx(:ncol) = wd_nhx(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) + endif +! +! add contribution from non-conservation tracers +! + if ( id_ndep == m ) then + wd_noy(:ncol) = wd_noy(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) + end if + if ( id_nhdep == m ) then + wd_nhx(:ncol) = wd_nhx(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) + end if + + do k=1,pver + do i=1,ncol + net_chem(i,k) = mmr_tend(i,k,m) * mass(i,k) + end do + end do + call outfld( dtchem_name(m), net_chem(:ncol,:), ncol, lchnk ) +! +! CCMI +! + if ( trim(dtchem_name(m)) == 'DO3CHM' ) then + do3chm_trp(:) = 0._r8 + do i=1,ncol + do k=ltrop(i),pver + do3chm_trp(i) = do3chm_trp(i) + net_chem(i,k) + end do + end do + where ( do3chm_trp == 0._r8 ) + do3chm_trp = fillvalue + end where + call outfld('DO3CHM_TRP',do3chm_trp(:ncol), ncol, lchnk ) + do3chm_lms(:) = 0._r8 + do i=1,ncol + do k=1,pver + if ( pmid(i,k) > 100.e2_r8 .and. k < ltrop(i) ) then + do3chm_lms(i) = do3chm_lms(i) + net_chem(i,k) + end if + end do + end do + where ( do3chm_lms == 0._r8 ) + do3chm_lms = fillvalue + end where + call outfld('DO3CHM_LMS',do3chm_lms(:ncol), ncol, lchnk ) + end if +! + enddo + +#ifdef OSLO_AERO + do n=1,N_AEROSOL_TYPES + call outfld("mmr_"//trim(aerosol_type_name(n)), mmr_aerosol_type(:ncol,:,n), ncol,lchnk) + call outfld("cb_"//trim(aerosol_type_name(n)), cb_aerosol_type(:ncol,n), ncol,lchnk) + enddo +#endif + call outfld( 'NOX', vmr_nox (:ncol,:), ncol, lchnk ) + call outfld( 'NOY', vmr_noy (:ncol,:), ncol, lchnk ) + call outfld( 'HOX', vmr_hox (:ncol,:), ncol, lchnk ) + call outfld( 'NOY_SRF', vmr_noy(:ncol,pver), ncol, lchnk ) + call outfld( 'CLOX', vmr_clox (:ncol,:), ncol, lchnk ) + call outfld( 'CLOY', vmr_cloy (:ncol,:), ncol, lchnk ) + call outfld( 'BROX', vmr_brox (:ncol,:), ncol, lchnk ) + call outfld( 'BROY', vmr_broy (:ncol,:), ncol, lchnk ) + call outfld( 'TCLY', vmr_tcly (:ncol,:), ncol, lchnk ) + call outfld( 'TBRY', vmr_tbry (:ncol,:), ncol, lchnk ) + call outfld( 'FOY', vmr_foy (:ncol,:), ncol, lchnk ) + call outfld( 'TFY', vmr_tfy (:ncol,:), ncol, lchnk ) + call outfld( 'TOTH', vmr_toth (:ncol,:), ncol, lchnk ) + + call outfld( 'NOY_mmr', mmr_noy(:ncol,:), ncol ,lchnk ) + call outfld( 'SOX_mmr', mmr_sox(:ncol,:), ncol ,lchnk ) + call outfld( 'NHX_mmr', mmr_nhx(:ncol,:), ncol ,lchnk ) + call outfld( 'dry_deposition_NOy_as_N', df_noy(:ncol), ncol ,lchnk ) + call outfld( 'DF_SOX', df_sox(:ncol), ncol ,lchnk ) + call outfld( 'dry_deposition_NHx_as_N', df_nhx(:ncol), ncol ,lchnk ) + if (gas_wetdep_method=='NEU') then + wd_noy(:ncol) = -wd_noy(:ncol) ! downward is possitive + wd_nhx(:ncol) = -wd_nhx(:ncol) + call outfld( 'wet_deposition_NOy_as_N', wd_noy(:ncol), ncol, lchnk ) + call outfld( 'wet_deposition_NHx_as_N', wd_nhx(:ncol), ncol, lchnk ) + end if + + nhx_nitrogen_flx = df_nhx + wd_nhx + noy_nitrogen_flx = df_noy + wd_noy + + !-------------------------------------------------------------------- + ! ... euv ion production + !-------------------------------------------------------------------- + + jeuvs: if ( has_jeuvs ) then + do k = 1,pver + un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) + wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(1)) + rxt_rates(:,k,rid_jeuv(2)) & + + rxt_rates(:,k,rid_jeuv(3)) + rxt_rates(:,k,rid_jeuv(14)) & + + rxt_rates(:,k,rid_jeuv(15)) + rxt_rates(:,k,rid_jeuv(16))) & + + vmr(:,k,id_n)*rxt_rates(:,k,rid_jeuv(4)) & + + vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(5)) + rxt_rates(:,k,rid_jeuv(7)) & + + rxt_rates(:,k,rid_jeuv(8)) + rxt_rates(:,k,rid_jeuv(9)) & + + rxt_rates(:,k,rid_jeuv(17)) + rxt_rates(:,k,rid_jeuv(19)) & + + rxt_rates(:,k,rid_jeuv(20)) + rxt_rates(:,k,rid_jeuv(21))) & + + un2(:)*(rxt_rates(:,k,rid_jeuv(6)) + rxt_rates(:,k,rid_jeuv(10)) & + + rxt_rates(:,k,rid_jeuv(11)) + rxt_rates(:,k,rid_jeuv(18)) & + + rxt_rates(:,k,rid_jeuv(22)) + rxt_rates(:,k,rid_jeuv(23))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PION_EUV', wrk, ncol, lchnk ) + + do k = 1,pver + wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(1)) + rxt_rates(:,k,rid_jeuv(2)) & + + rxt_rates(:,k,rid_jeuv(3))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV1', wrk, ncol, lchnk ) + do k = 1,pver + wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(14)) + rxt_rates(:,k,rid_jeuv(15)) & + + rxt_rates(:,k,rid_jeuv(16))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV1e', wrk, ncol, lchnk ) + do k = 1,pver + wrk(:,k) = vmr(:,k,id_n)*rxt_rates(:,k,rid_jeuv(4)) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV2', wrk, ncol, lchnk ) + do k = 1,pver + wrk(:,k) = vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(5)) + rxt_rates(:,k,rid_jeuv(7)) & + + rxt_rates(:,k,rid_jeuv(8)) + rxt_rates(:,k,rid_jeuv(9))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV3', wrk, ncol, lchnk ) + do k = 1,pver + wrk(:,k) = vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(17)) + rxt_rates(:,k,rid_jeuv(19)) & + + rxt_rates(:,k,rid_jeuv(20)) + rxt_rates(:,k,rid_jeuv(21))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV3e', wrk, ncol, lchnk ) + do k = 1,pver + un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) + wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(6)) + rxt_rates(:,k,rid_jeuv(10)) + rxt_rates(:,k,rid_jeuv(11))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV4', wrk, ncol, lchnk ) + do k = 1,pver + un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) + wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(18)) + rxt_rates(:,k,rid_jeuv(22)) + rxt_rates(:,k,rid_jeuv(23))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUV4e', wrk, ncol, lchnk ) + do k = 1,pver + un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) + wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(11)) + rxt_rates(:,k,rid_jeuv(13))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUVN2D', wrk, ncol, lchnk ) + do k = 1,pver + un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) + wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(23)) + rxt_rates(:,k,rid_jeuv(25))) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PEUVN2De', wrk, ncol, lchnk ) + endif jeuvs + + if ( has_jno_i ) then + do k = 1,pver + wrk(:,k) = vmr(:,k,id_no)*rxt_rates(:,k,rid_jno_i) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PJNO_I', wrk, ncol, lchnk ) + endif + if ( has_jno ) then + do k = 1,pver + wrk(:,k) = vmr(:,k,id_no)*rxt_rates(:,k,rid_jno) + wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) + end do + call outfld( 'PJNO', wrk, ncol, lchnk ) + endif + + call species_sums_output(vmr, mmr, ncol, lchnk) + + end subroutine chm_diags + + subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) + + use cam_history, only : outfld +#ifndef OSLO_AERO + use phys_grid, only : get_wght_all_p +#else + use phys_grid, only : get_wght_all_p, get_area_all_p +#endif + implicit none + + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + real(r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) + real(r8), intent(in) :: mmr(ncol,pver,gas_pcnst) + real(r8), intent(in) :: pdel(ncol,pver) + + real(r8), dimension(ncol) :: noy_wk, sox_wk, nhx_wk, wrk_wd +#ifdef OSLO_AERO + real(r8), dimension(ncol) :: area +#endif OSLO_AERO + integer :: m, k + real(r8) :: wght(ncol) + ! + ! output integrated wet deposition field + ! + noy_wk(:) = 0._r8 + sox_wk(:) = 0._r8 + nhx_wk(:) = 0._r8 + +#ifdef OSLO_AERO + call get_area_all_p(lchnk, ncol, area) + area = area * rearth**2 +#endif OSLO_AERO + + call get_wght_all_p(lchnk, ncol, wght) + + do m = 1,gas_pcnst + ! + ! compute vertical integral + ! + wrk_wd(:ncol) = 0._r8 + do k = 1,pver + wrk_wd(:ncol) = wrk_wd(:ncol) + het_rates(:ncol,k,m) * mmr(:ncol,k,m) * pdel(:ncol,k) + end do + ! + wrk_wd(:ncol) = wrk_wd(:ncol) * rgrav * wght(:ncol) * rearth**2 + ! + if (gas_wetdep_method=='MOZ') then + call outfld( wetdep_name(m), wrk_wd(:ncol), ncol, lchnk ) +#ifdef OSLO_AERO + call outfld( wetdep_name_area(m), wrk_wd(:ncol)/area(:ncol) ,ncol, lchnk ) +#endif + call outfld( wtrate_name(m), het_rates(:ncol,:,m), ncol, lchnk ) + + if ( any(noy_species == m ) ) then + noy_wk(:ncol) = noy_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) + endif + if ( m == id_n2o5 ) then ! 2 NOy molecules in N2O5 + noy_wk(:ncol) = noy_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) + endif + if ( any(sox_species == m ) ) then + sox_wk(:ncol) = sox_wk(:ncol) + wrk_wd(:ncol)*S_molwgt/adv_mass(m) + endif + if ( any(nhx_species == m ) ) then + nhx_wk(:ncol) = nhx_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) + endif + endif + end do + if (gas_wetdep_method=='MOZ') then + call outfld( 'wet_deposition_NOy_as_N', noy_wk(:ncol), ncol, lchnk ) + call outfld( 'WD_SOX', sox_wk(:ncol), ncol, lchnk ) + call outfld( 'wet_deposition_NHx_as_N', nhx_wk(:ncol), ncol, lchnk ) + endif + + end subroutine het_diags + +end module mo_chm_diags diff --git a/src/chemistry/oslo_aero/mo_drydep.F90 b/src/chemistry/oslo_aero/mo_drydep.F90 new file mode 100644 index 0000000000..e81f3d66f7 --- /dev/null +++ b/src/chemistry/oslo_aero/mo_drydep.F90 @@ -0,0 +1,3303 @@ +module mo_drydep + + !--------------------------------------------------------------------- + ! ... Dry deposition velocity input data and code for netcdf input + !--------------------------------------------------------------------- + +!LKE (10/11/2010): added HCN, CH3CN, HCOOH +!LKE (7/30/2015): added new TS1 species (phenooh, iepox, noa, etc.) + + use shr_kind_mod, only : r8 => shr_kind_r8, shr_kind_cl + use chem_mods, only : gas_pcnst + use pmgrid, only : plev, plevp + use spmd_utils, only : masterproc, iam + use ppgrid, only : pcols, begchunk, endchunk + use mo_tracname, only : solsym + use cam_abortutils, only : endrun + use ioFileMod, only : getfil + use pio + use cam_pio_utils, only : cam_pio_openfile, cam_pio_closefile + use cam_logfile, only : iulog + use dyn_grid, only : get_dyn_grid_parm, get_horiz_grid_d + use scamMod, only : single_column + + use seq_drydep_mod, only : nddvels => n_drydep, drydep_list, mapping + use physconst, only : karman + + implicit none + + save + + interface drydep_inti + module procedure dvel_inti_table + module procedure dvel_inti_xactive + module procedure dvel_inti_fromlnd + end interface + + interface drydep + module procedure drydep_table + module procedure drydep_xactive + module procedure drydep_fromlnd + end interface + + private + public :: drydep_inti, drydep, set_soilw, chk_soilw, has_drydep + public :: drydep_update + public :: n_land_type, fraction_landuse, drydep_srf_file + + real(r8) :: dels + real(r8), allocatable :: days(:) ! day of year for soilw + real(r8), allocatable :: dvel(:,:,:,:) ! depvel array interpolated to model grid + real(r8), allocatable :: dvel_interp(:,:,:) ! depvel array interpolated to grid and time + integer :: last, next ! day indicies + integer :: ndays ! # of days in soilw file + integer :: map(gas_pcnst) ! indices for drydep species + integer :: nspecies ! number of depvel species in input file + + integer :: pan_ndx, mpan_ndx, no2_ndx, hno3_ndx, o3_ndx, & + h2o2_ndx, onit_ndx, onitr_ndx, ch4_ndx, ch2o_ndx, & + ch3ooh_ndx, pooh_ndx, ch3coooh_ndx, c2h5ooh_ndx, eooh_ndx, & + c3h7ooh_ndx, rooh_ndx, ch3cocho_ndx, co_ndx, ch3coch3_ndx, & + no_ndx, ho2no2_ndx, glyald_ndx, hyac_ndx, ch3oh_ndx, c2h5oh_ndx, & + hydrald_ndx, h2_ndx, Pb_ndx, o3s_ndx, o3inert_ndx, macrooh_ndx, & + xooh_ndx, ch3cho_ndx, isopooh_ndx + integer :: alkooh_ndx, mekooh_ndx, tolooh_ndx, terpooh_ndx, ch3cooh_ndx + integer :: soa_ndx, so4_ndx, cb1_ndx, cb2_ndx, oc1_ndx, oc2_ndx, nh3_ndx, nh4no3_ndx, & + sa1_ndx, sa2_ndx, sa3_ndx, sa4_ndx, nh4_ndx + integer :: soam_ndx, soai_ndx, soat_ndx, soab_ndx, soax_ndx, & + sogm_ndx, sogi_ndx, sogt_ndx, sogb_ndx, sogx_ndx + + logical :: alkooh_dd, mekooh_dd, tolooh_dd, terpooh_dd, ch3cooh_dd + logical :: soa_dd, so4_dd, cb1_dd, cb2_dd, oc1_dd, oc2_dd, nh3_dd, nh4no3_dd, & + sa1_dd, sa2_dd, sa3_dd, sa4_dd, nh4_dd + logical :: soam_dd, soai_dd, soat_dd, soab_dd, soax_dd, & + sogm_dd, sogi_dd, sogt_dd, sogb_dd, sogx_dd + + logical :: pan_dd, mpan_dd, no2_dd, hno3_dd, o3_dd, isopooh_dd, ch4_dd,& + h2o2_dd, onit_dd, onitr_dd, ch2o_dd, macrooh_dd, xooh_dd, & + ch3ooh_dd, pooh_dd, ch3coooh_dd, c2h5ooh_dd, eooh_dd, ch3cho_dd, c2h5oh_dd, & + c3h7ooh_dd, rooh_dd, ch3cocho_dd, co_dd, ch3coch3_dd, & + glyald_dd, hyac_dd, ch3oh_dd, hydrald_dd, h2_dd, Pb_dd, o3s_dd, o3inert_dd + + integer :: so2_ndx + integer :: ch3cn_ndx, hcn_ndx, hcooh_ndx + logical :: ch3cn_dd, hcn_dd, hcooh_dd + + integer :: o3a_ndx,xpan_ndx,xmpan_ndx,xno2_ndx,xhno3_ndx,xonit_ndx,xonitr_ndx,xno_ndx,xho2no2_ndx,xnh4no3_ndx + logical :: o3a_dd, xpan_dd, xmpan_dd, xno2_dd, xhno3_dd, xonit_dd, xonitr_dd, xno_dd, xho2no2_dd, xnh4no3_dd + +!lke-TS1 + integer :: phenooh_ndx, benzooh_ndx, c6h5ooh_ndx, bzooh_ndx, xylolooh_ndx, xylenooh_ndx + integer :: terp2ooh_ndx, terprod1_ndx, terprod2_ndx, hmprop_ndx, mboooh_ndx, hpald_ndx, iepox_ndx + integer :: noa_ndx, alknit_ndx, isopnita_ndx, isopnitb_ndx, honitr_ndx, isopnooh_ndx + integer :: nc4cho_ndx, nc4ch2oh_ndx, terpnit_ndx, nterpooh_ndx + logical :: phenooh_dd, benzooh_dd, c6h5ooh_dd, bzooh_dd, xylolooh_dd, xylenooh_dd + logical :: terp2ooh_dd, terprod1_dd, terprod2_dd, hmprop_dd, mboooh_dd, hpald_dd, iepox_dd + logical :: noa_dd, alknit_dd, isopnita_dd, isopnitb_dd, honitr_dd, isopnooh_dd + logical :: nc4cho_dd, nc4ch2oh_dd, terpnit_dd, nterpooh_dd + + integer :: cohc_ndx=-1, come_ndx=-1 + integer, parameter :: NTAGS = 50 + integer :: cotag_ndx(NTAGS) + integer :: tag_cnt + + integer :: & + o3_tab_ndx = -1, & + h2o2_tab_ndx = -1, & + ch3ooh_tab_ndx = -1, & + co_tab_ndx = -1, & + ch3cho_tab_ndx = -1 + logical :: & + o3_in_tab = .false., & + h2o2_in_tab = .false., & + ch3ooh_in_tab = .false., & + co_in_tab = .false., & + ch3cho_in_tab = .false. + + real(r8), parameter :: small_value = 1.e-36_r8 + real(r8), parameter :: large_value = 1.e36_r8 + real(r8), parameter :: diffm = 1.789e-5_r8 + real(r8), parameter :: diffk = 1.461e-5_r8 + real(r8), parameter :: difft = 2.060e-5_r8 + real(r8), parameter :: vonkar = karman + real(r8), parameter :: ric = 0.2_r8 + real(r8), parameter :: r = 287.04_r8 + real(r8), parameter :: cp = 1004._r8 + real(r8), parameter :: grav = 9.81_r8 + real(r8), parameter :: p00 = 100000._r8 + real(r8), parameter :: wh2o = 18.0153_r8 + real(r8), parameter :: ph = 1.e-5_r8 + real(r8), parameter :: ph_inv = 1._r8/ph + real(r8), parameter :: rovcp = r/cp + + integer, pointer :: index_season_lai(:,:) + + logical, public :: has_dvel(gas_pcnst) = .false. + integer :: map_dvel(gas_pcnst) = 0 + real(r8) , allocatable :: soilw_3d(:,:,:) + + logical, parameter :: dyn_soilw = .false. + + real(r8), allocatable :: fraction_landuse(:,:,:) + real(r8), allocatable, dimension(:,:,:) :: dep_ra ! [s/m] aerodynamic resistance + real(r8), allocatable, dimension(:,:,:) :: dep_rb ! [s/m] resistance across sublayer + integer, parameter :: n_land_type = 11 + + integer, allocatable :: spc_ndx(:) ! nddvels + real(r8), public :: crb + + type lnd_dvel_type + real(r8), pointer :: dvel(:,:) ! deposition velocity over land (cm/s) + end type lnd_dvel_type + + type(lnd_dvel_type), allocatable :: lnd(:) + character(len=SHR_KIND_CL) :: drydep_srf_file + +contains + + !--------------------------------------------------------------------------- + !--------------------------------------------------------------------------- + subroutine dvel_inti_fromlnd + use mo_chem_utls, only : get_spc_ndx + use cam_abortutils, only : endrun + use chem_mods, only : adv_mass + use seq_drydep_mod, only : dfoxd + + implicit none + + integer :: ispc, l + + allocate(spc_ndx(nddvels)) + allocate( lnd(begchunk:endchunk) ) + + do ispc = 1,nddvels + + spc_ndx(ispc) = get_spc_ndx(drydep_list(ispc)) + if (spc_ndx(ispc) < 1) then + write(*,*) 'drydep_inti: '//trim(drydep_list(ispc))//' is not included in species set' + call endrun('drydep_init: invalid dry deposition species') + endif + + enddo + + crb = (difft/diffm)**(2._r8/3._r8) !.666666_r8 + + endsubroutine dvel_inti_fromlnd + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine drydep_update( state, cam_in ) + use physics_types, only : physics_state + use camsrfexch, only : cam_in_t + use seq_drydep_mod, only : drydep_method, DD_XLND + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in + + if (nddvels<1) return + if (drydep_method /= DD_XLND) return + + lnd(state%lchnk)%dvel => cam_in%depvel + + end subroutine drydep_update + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine drydep_fromlnd( ocnfrac, icefrac, ncdate, sfc_temp, pressure_sfc, & + wind_speed, spec_hum, air_temp, pressure_10m, rain, & + snow, solar_flux, dvelocity, dflx, mmr, & + tv, soilw, rh, ncol, lonndx, latndx, lchnk ) + + !------------------------------------------------------------------------------------- + ! combines the deposition velocities provided by the land model with deposition + ! velocities over ocean and sea ice + !------------------------------------------------------------------------------------- + + use ppgrid, only : pcols + use chem_mods, only : gas_pcnst + +#if (defined OFFLINE_DYN) + use metdata, only: get_met_fields +#endif + + implicit none + + !------------------------------------------------------------------------------------- + ! ... dummy arguments + !------------------------------------------------------------------------------------- + + real(r8), intent(in) :: icefrac(pcols) + real(r8), intent(in) :: ocnfrac(pcols) + + integer, intent(in) :: ncol + integer, intent(in) :: ncdate ! present date (yyyymmdd) + real(r8), intent(in) :: sfc_temp(pcols) ! surface temperature (K) + real(r8), intent(in) :: pressure_sfc(pcols) ! surface pressure (Pa) + real(r8), intent(in) :: wind_speed(pcols) ! 10 meter wind speed (m/s) + real(r8), intent(in) :: spec_hum(pcols) ! specific humidity (kg/kg) + real(r8), intent(in) :: rh(ncol,1) ! relative humidity + real(r8), intent(in) :: air_temp(pcols) ! surface air temperature (K) + real(r8), intent(in) :: pressure_10m(pcols) ! 10 meter pressure (Pa) + real(r8), intent(in) :: rain(pcols) + real(r8), intent(in) :: snow(pcols) ! snow height (m) + real(r8), intent(in) :: soilw(pcols) ! soil moisture fraction + real(r8), intent(in) :: solar_flux(pcols) ! direct shortwave radiation at surface (W/m^2) + real(r8), intent(in) :: tv(pcols) ! potential temperature + real(r8), intent(in) :: mmr(pcols,plev,gas_pcnst) ! constituent concentration (kg/kg) + real(r8), intent(out) :: dvelocity(ncol,gas_pcnst) ! deposition velocity (cm/s) + real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! deposition flux (/cm^2/s) + + integer, intent(in) :: latndx(pcols) ! chunk latitude indicies + integer, intent(in) :: lonndx(pcols) ! chunk longitude indicies + integer, intent(in) :: lchnk ! chunk number + + !------------------------------------------------------------------------------------- + ! ... local variables + !------------------------------------------------------------------------------------- + real(r8) :: ocnice_dvel(ncol,gas_pcnst) + real(r8) :: ocnice_dflx(pcols,gas_pcnst) + + real(r8), dimension(ncol) :: term ! work array + integer :: ispec + real(r8) :: lndfrac(pcols) +#if (defined OFFLINE_DYN) + real(r8) :: met_ocnfrac(pcols) + real(r8) :: met_icefrac(pcols) +#endif + integer :: i + + lndfrac(:ncol) = 1._r8 - ocnfrac(:ncol) - icefrac(:ncol) + + where( lndfrac(:ncol) < 0._r8 ) + lndfrac(:ncol) = 0._r8 + endwhere + +#if (defined OFFLINE_DYN) + call get_met_fields(lndfrac, met_ocnfrac, met_icefrac, lchnk, ncol) +#endif + + !------------------------------------------------------------------------------------- + ! ... initialize + !------------------------------------------------------------------------------------- + dvelocity(:,:) = 0._r8 + + !------------------------------------------------------------------------------------- + ! ... compute the dep velocities over ocean and sea ice + ! land type 7 is used for ocean + ! land type 8 is used for sea ice + !------------------------------------------------------------------------------------- + call drydep_xactive( ncdate, sfc_temp, pressure_sfc, & + wind_speed, spec_hum, air_temp, pressure_10m, rain, & + snow, solar_flux, ocnice_dvel, ocnice_dflx, mmr, & + tv, soilw, rh, ncol, lonndx, latndx, lchnk, & +#if (defined OFFLINE_DYN) + ocnfrc=met_ocnfrac,icefrc=met_icefrac, beglandtype=7, endlandtype=8 ) +#else + ocnfrc=ocnfrac,icefrc=icefrac, beglandtype=7, endlandtype=8 ) +#endif + term(:ncol) = 1.e-2_r8 * pressure_10m(:ncol) / (r*tv(:ncol)) + + do ispec = 1,nddvels + !------------------------------------------------------------------------------------- + ! ... merge the land component with the non-land component + ! ocn and ice already have fractions factored in + !------------------------------------------------------------------------------------- + dvelocity(:ncol,spc_ndx(ispec)) = lnd(lchnk)%dvel(:ncol,ispec)*lndfrac(:ncol) & + + ocnice_dvel(:ncol,spc_ndx(ispec)) + enddo + + !------------------------------------------------------------------------------------- + ! ... special adjustments + !------------------------------------------------------------------------------------- + if( mpan_ndx>0 ) then + dvelocity(:ncol,mpan_ndx) = dvelocity(:ncol,mpan_ndx)/3._r8 + endif + if( xmpan_ndx>0 ) then + dvelocity(:ncol,xmpan_ndx) = dvelocity(:ncol,xmpan_ndx)/3._r8 + endif + if( hcn_ndx>0 ) then + dvelocity(:ncol,hcn_ndx) = ocnice_dvel(:ncol,hcn_ndx) ! should be zero over land + endif + if( ch3cn_ndx>0 ) then + dvelocity(:ncol,ch3cn_ndx) = ocnice_dvel(:ncol,ch3cn_ndx) ! should be zero over land + endif + + ! HCOOH, use CH3COOH dep.vel + if( hcooh_ndx > 0 .and. ch3cooh_ndx > 0 ) then + if( has_dvel(hcooh_ndx) ) then + dvelocity(:ncol,hcooh_ndx) = dvelocity(:ncol,ch3cooh_ndx) + end if + end if + + !------------------------------------------------------------------------------------- + ! ... assign CO tags to CO + ! put this kludge in for now ... + ! -- should be able to set all these via the table mapping in seq_drydep_mod + !------------------------------------------------------------------------------------- + if( cohc_ndx>0 .and. co_ndx>0 ) then + dvelocity(:ncol,cohc_ndx) = dvelocity(:ncol,co_ndx) + dflx(:ncol,cohc_ndx) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,cohc_ndx) + endif + if( come_ndx>0 .and. co_ndx>0 ) then + dvelocity(:ncol,come_ndx) = dvelocity(:ncol,co_ndx) + dflx(:ncol,come_ndx) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,come_ndx) + endif + + if ( co_ndx>0 ) then + do i=1,tag_cnt + dvelocity(:ncol,cotag_ndx(i)) = dvelocity(:ncol,co_ndx) + dflx(:ncol,cotag_ndx(i)) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,cotag_ndx(i)) + enddo + endif + + do ispec = 1,nddvels + !------------------------------------------------------------------------------------- + ! ... compute the deposition flux + !------------------------------------------------------------------------------------- + dflx(:ncol,spc_ndx(ispec)) = dvelocity(:ncol,spc_ndx(ispec)) * term(:ncol) * mmr(:ncol,plev,spc_ndx(ispec)) + end do + + end subroutine drydep_fromlnd + + !--------------------------------------------------------------------------- + !--------------------------------------------------------------------------- + subroutine dvel_inti_table( depvel_file ) + !--------------------------------------------------------------------------- + ! ... Initialize module, depvel arrays, and a few other variables. + ! The depvel fields will be linearly interpolated to the correct time + !--------------------------------------------------------------------------- + + use mo_constants, only : d2r, r2d + use ioFileMod, only : getfil + use string_utils, only : to_lower, GLC + use mo_chem_utls, only : get_spc_ndx + use constituents, only : pcnst + use interpolate_data, only : lininterp_init, lininterp, lininterp_finish,interp_type + use mo_constants, only : pi + use phys_grid, only : get_ncols_p, get_rlat_all_p, get_rlon_all_p + + implicit none + + character(len=*), intent(in) :: depvel_file + + !--------------------------------------------------------------------------- + ! ... Local variables + !--------------------------------------------------------------------------- + integer :: nlat, nlon, nmonth, ndims + integer :: dimid_lat, dimid_lon, dimid_species, dimid_time + integer :: dimid(4), count(4), start(4) + integer :: m, ispecies, nchar, ierr + real(r8) :: scale_factor + + real(r8), allocatable :: dvel_lats(:), dvel_lons(:) + real(r8), allocatable :: dvel_in(:,:,:,:) ! input depvel array + character(len=50) :: units + character(len=20), allocatable :: species_names(:) ! names of depvel species + logical :: found + type(file_desc_t) :: piofile + type(var_desc_t) :: vid, vid_dvel + + character(len=shr_kind_cl) :: locfn + integer :: mm,n + + integer :: i, c, ncols + real(r8) :: to_lats(pcols), to_lons(pcols) + type(interp_type) :: lon_wgts, lat_wgts + real(r8), parameter :: zero=0._r8, twopi=2._r8*pi + + mm = 1 + do m = 1,pcnst + if ( len_trim(drydep_list(m))==0 ) exit + n = get_spc_ndx(drydep_list(m)) + if ( n < 1 ) then + write(iulog,*) 'drydep_inti: '//drydep_list(m)//' is not included in species set' + call endrun('drydep_init: invalid dry deposition species') + endif + enddo + + if( masterproc ) then + write(iulog,*) 'drydep_inti: following species have dry deposition' + do i=1,nddvels + if( len_trim(drydep_list(i)) > 0 ) then + write(iulog,*) 'drydep_inti: '//trim(drydep_list(i))//' is requested to have dry dep' + endif + enddo + write(iulog,*) 'drydep_inti:' + endif + + if ( nddvels < 1 ) return + + !--------------------------------------------------------------------------- + ! ... Setup species maps + !--------------------------------------------------------------------------- + o3a_ndx = get_spc_ndx( 'O3A') + xpan_ndx = get_spc_ndx( 'XPAN') + xmpan_ndx = get_spc_ndx( 'XMPAN') + xno2_ndx = get_spc_ndx( 'XNO2') + xhno3_ndx = get_spc_ndx( 'XHNO3') + xonit_ndx = get_spc_ndx( 'XONIT') + xonitr_ndx = get_spc_ndx( 'XONITR') + xno_ndx = get_spc_ndx( 'XNO') + xho2no2_ndx = get_spc_ndx( 'XHO2NO2') + o3a_dd = has_drydep( 'O3A') + xpan_dd = has_drydep( 'XPAN') + xmpan_dd = has_drydep( 'XMPAN') + xno2_dd = has_drydep( 'XNO2') + xhno3_dd = has_drydep( 'XHNO3') + xonit_dd = has_drydep( 'XONIT') + xonitr_dd = has_drydep( 'XONITR') + xno_dd = has_drydep( 'XNO') + xho2no2_dd = has_drydep( 'XHO2NO2') + + pan_ndx = get_spc_ndx( 'PAN') + mpan_ndx = get_spc_ndx( 'MPAN') + no2_ndx = get_spc_ndx( 'NO2') + hno3_ndx = get_spc_ndx( 'HNO3') + co_ndx = get_spc_ndx( 'CO') + o3_ndx = get_spc_ndx( 'O3') + if( o3_ndx < 1 ) then + o3_ndx = get_spc_ndx( 'OX') + end if + h2o2_ndx = get_spc_ndx( 'H2O2') + onit_ndx = get_spc_ndx( 'ONIT') + onitr_ndx = get_spc_ndx( 'ONITR') + ch4_ndx = get_spc_ndx( 'CH4') + ch2o_ndx = get_spc_ndx( 'CH2O') + ch3ooh_ndx = get_spc_ndx( 'CH3OOH') + ch3cho_ndx = get_spc_ndx( 'CH3CHO') + ch3cocho_ndx = get_spc_ndx( 'CH3COCHO') + pooh_ndx = get_spc_ndx( 'POOH') + ch3coooh_ndx = get_spc_ndx( 'CH3COOOH') + c2h5ooh_ndx = get_spc_ndx( 'C2H5OOH') + eooh_ndx = get_spc_ndx( 'EOOH') + c3h7ooh_ndx = get_spc_ndx( 'C3H7OOH') + rooh_ndx = get_spc_ndx( 'ROOH') + ch3coch3_ndx = get_spc_ndx( 'CH3COCH3') + no_ndx = get_spc_ndx( 'NO') + ho2no2_ndx = get_spc_ndx( 'HO2NO2') + glyald_ndx = get_spc_ndx( 'GLYALD') + hyac_ndx = get_spc_ndx( 'HYAC') + ch3oh_ndx = get_spc_ndx( 'CH3OH') + c2h5oh_ndx = get_spc_ndx( 'C2H5OH') + macrooh_ndx = get_spc_ndx( 'MACROOH') + isopooh_ndx = get_spc_ndx( 'ISOPOOH') + xooh_ndx = get_spc_ndx( 'XOOH') + hydrald_ndx = get_spc_ndx( 'HYDRALD') + h2_ndx = get_spc_ndx( 'H2') + Pb_ndx = get_spc_ndx( 'Pb') + o3s_ndx = get_spc_ndx( 'O3S') + o3inert_ndx = get_spc_ndx( 'O3INERT') + alkooh_ndx = get_spc_ndx( 'ALKOOH') + mekooh_ndx = get_spc_ndx( 'MEKOOH') + tolooh_ndx = get_spc_ndx( 'TOLOOH') + terpooh_ndx = get_spc_ndx( 'TERPOOH') + ch3cooh_ndx = get_spc_ndx( 'CH3COOH') + soam_ndx = get_spc_ndx( 'SOAM' ) + soai_ndx = get_spc_ndx( 'SOAI' ) + soat_ndx = get_spc_ndx( 'SOAT' ) + soab_ndx = get_spc_ndx( 'SOAB' ) + soax_ndx = get_spc_ndx( 'SOAX' ) + sogm_ndx = get_spc_ndx( 'SOGM' ) + sogi_ndx = get_spc_ndx( 'SOGI' ) + sogt_ndx = get_spc_ndx( 'SOGT' ) + sogb_ndx = get_spc_ndx( 'SOGB' ) + sogx_ndx = get_spc_ndx( 'SOGX' ) + soa_ndx = get_spc_ndx( 'SOA' ) + so4_ndx = get_spc_ndx( 'SO4' ) + cb1_ndx = get_spc_ndx( 'CB1' ) + cb2_ndx = get_spc_ndx( 'CB2' ) + oc1_ndx = get_spc_ndx( 'OC1' ) + oc2_ndx = get_spc_ndx( 'OC2' ) + nh3_ndx = get_spc_ndx( 'NH3' ) + nh4no3_ndx = get_spc_ndx( 'NH4NO3' ) + xnh4no3_ndx = get_spc_ndx( 'XNH4NO3' ) + sa1_ndx = get_spc_ndx( 'SA1' ) + sa2_ndx = get_spc_ndx( 'SA2' ) + sa3_ndx = get_spc_ndx( 'SA3' ) + sa4_ndx = get_spc_ndx( 'SA4' ) + nh4_ndx = get_spc_ndx( 'NH4' ) + alkooh_dd = has_drydep( 'ALKOOH') + mekooh_dd = has_drydep( 'MEKOOH') + tolooh_dd = has_drydep( 'TOLOOH') + terpooh_dd = has_drydep( 'TERPOOH') + ch3cooh_dd = has_drydep( 'CH3COOH') + soam_dd = has_drydep( 'SOAM' ) + soai_dd = has_drydep( 'SOAI' ) + soat_dd = has_drydep( 'SOAT' ) + soab_dd = has_drydep( 'SOAB' ) + soax_dd = has_drydep( 'SOAX' ) + sogm_dd = has_drydep( 'SOGM' ) + sogi_dd = has_drydep( 'SOGI' ) + sogt_dd = has_drydep( 'SOGT' ) + sogb_dd = has_drydep( 'SOGB' ) + sogx_dd = has_drydep( 'SOGX' ) + soa_dd = has_drydep( 'SOA' ) + so4_dd = has_drydep( 'SO4' ) + cb1_dd = has_drydep( 'CB1' ) + cb2_dd = has_drydep( 'CB2' ) + oc1_dd = has_drydep( 'OC1' ) + oc2_dd = has_drydep( 'OC2' ) + nh3_dd = has_drydep( 'NH3' ) + nh4no3_dd = has_drydep( 'NH4NO3' ) + xnh4no3_dd = has_drydep( 'XNH4NO3' ) + sa1_dd = has_drydep( 'SA1' ) + sa2_dd = has_drydep( 'SA2' ) + sa3_dd = has_drydep( 'SA3' ) + sa4_dd = has_drydep( 'SA4' ) + nh4_dd = has_drydep( 'NH4' ) + pan_dd = has_drydep( 'PAN') + mpan_dd = has_drydep( 'MPAN') + no2_dd = has_drydep( 'NO2') + hno3_dd = has_drydep( 'HNO3') + co_dd = has_drydep( 'CO') + o3_dd = has_drydep( 'O3') + if( .not. o3_dd ) then + o3_dd = has_drydep( 'OX') + end if + h2o2_dd = has_drydep( 'H2O2') + onit_dd = has_drydep( 'ONIT') + onitr_dd = has_drydep( 'ONITR') + ch4_dd = has_drydep( 'CH4') + ch2o_dd = has_drydep( 'CH2O') + ch3ooh_dd = has_drydep( 'CH3OOH') + ch3cho_dd = has_drydep( 'CH3CHO') + c2h5oh_dd = has_drydep( 'C2H5OH') + eooh_dd = has_drydep( 'EOOH') + ch3cocho_dd = has_drydep( 'CH3COCHO') + pooh_dd = has_drydep( 'POOH') + ch3coooh_dd = has_drydep( 'CH3COOOH') + c2h5ooh_dd = has_drydep( 'C2H5OOH') + c3h7ooh_dd = has_drydep( 'C3H7OOH') + rooh_dd = has_drydep( 'ROOH') + ch3coch3_dd = has_drydep( 'CH3COCH3') + glyald_dd = has_drydep( 'GLYALD') + hyac_dd = has_drydep( 'HYAC') + ch3oh_dd = has_drydep( 'CH3OH') + macrooh_dd = has_drydep( 'MACROOH') + isopooh_dd = has_drydep( 'ISOPOOH') + xooh_dd = has_drydep( 'XOOH') + hydrald_dd = has_drydep( 'HYDRALD') + h2_dd = has_drydep( 'H2') + Pb_dd = has_drydep( 'Pb') + o3s_dd = has_drydep( 'O3S') + o3inert_dd = has_drydep( 'O3INERT') + ch3cn_dd = has_drydep( 'CH3CN') + hcn_dd = has_drydep( 'HCN') + hcooh_dd = has_drydep( 'HCOOH') + ch3cn_ndx = get_spc_ndx( 'CH3CN') + hcn_ndx = get_spc_ndx( 'HCN') + hcooh_ndx = get_spc_ndx( 'HCOOH' ) + + if( masterproc ) then + write(iulog,*) 'dvel_inti: diagnostics' + write(iulog,'(10i5)') pan_ndx, mpan_ndx, no2_ndx, hno3_ndx, o3_ndx, & + h2o2_ndx, onit_ndx, onitr_ndx, ch4_ndx, ch2o_ndx, & + ch3ooh_ndx, pooh_ndx, ch3coooh_ndx, c2h5ooh_ndx, eooh_ndx, & + c3h7ooh_ndx, rooh_ndx, ch3cocho_ndx, co_ndx, ch3coch3_ndx, & + no_ndx, ho2no2_ndx, glyald_ndx, hyac_ndx, ch3oh_ndx, c2h5oh_ndx, & + hydrald_ndx, h2_ndx, Pb_ndx, o3s_ndx, o3inert_ndx, macrooh_ndx, & + xooh_ndx, ch3cho_ndx, isopooh_ndx, noa_ndx, alknit_ndx, isopnita_ndx, & + honitr_ndx, isopnooh_ndx, nc4cho_ndx, nc4ch2oh_ndx, terpnit_ndx, nterpooh_ndx + write(iulog,*) pan_dd, mpan_dd, no2_dd, hno3_dd, o3_dd, isopooh_dd, ch4_dd,& + h2o2_dd, onit_dd, onitr_dd, ch2o_dd, macrooh_dd, xooh_dd, & + ch3ooh_dd, pooh_dd, ch3coooh_dd, c2h5ooh_dd, eooh_dd, ch3cho_dd, c2h5oh_dd, & + c3h7ooh_dd, rooh_dd, ch3cocho_dd, co_dd, ch3coch3_dd, & + glyald_dd, hyac_dd, ch3oh_dd, hydrald_dd, h2_dd, Pb_dd, o3s_dd, o3inert_dd, & + noa_dd, alknit_dd, isopnita_dd, & + honitr_dd, isopnooh_dd, nc4cho_dd, nc4ch2oh_dd, terpnit_dd, nterpooh_dd + endif + !--------------------------------------------------------------------------- + ! ... Open NetCDF file + !--------------------------------------------------------------------------- + call getfil (depvel_file, locfn, 0) + call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) + + !--------------------------------------------------------------------------- + ! ... Get variable ID for dep vel array + !--------------------------------------------------------------------------- + ierr = pio_inq_varid( piofile, 'dvel', vid_dvel ) + + !--------------------------------------------------------------------------- + ! ... Inquire about dimensions + !--------------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'lon', dimid_lon ) + ierr = pio_inq_dimlen( piofile, dimid_lon, nlon ) + ierr = pio_inq_dimid( piofile, 'lat', dimid_lat ) + ierr = pio_inq_dimlen( piofile, dimid_lat, nlat ) + ierr = pio_inq_dimid( piofile, 'species', dimid_species ) + ierr = pio_inq_dimlen( piofile, dimid_species, nspecies ) + ierr = pio_inq_dimid( piofile, 'time', dimid_time ) + ierr = pio_inq_dimlen( piofile, dimid_time, nmonth ) + if(masterproc) write(iulog,*) 'dvel_inti: dimensions (nlon,nlat,nspecies,nmonth) = ',nlon,nlat,nspecies,nmonth + + !--------------------------------------------------------------------------- + ! ... Check dimensions of dvel variable. Must be (lon, lat, species, month). + !--------------------------------------------------------------------------- + ierr = pio_inq_varndims( piofile, vid_dvel, ndims ) + + if( masterproc .and. ndims /= 4 ) then + write(iulog,*) 'dvel_inti: dvel has ',ndims,' dimensions. Expecting 4.' + call endrun + end if + ierr = pio_inq_vardimid( piofile, vid_dvel, dimid ) + + if( dimid(1) /= dimid_lon .or. dimid(2) /= dimid_lat .or. & + dimid(3) /= dimid_species .or. dimid(4) /= dimid_time ) then + write(iulog,*) 'dvel_inti: Dimensions in wrong order for dvel' + write(iulog,*) '... Expecting (lon, lat, species, month)' + call endrun + end if + + !--------------------------------------------------------------------------- + ! ... Allocate depvel lats, lons and read + !--------------------------------------------------------------------------- + allocate( dvel_lats(nlat), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: Failed to allocate dvel_lats vector' + call endrun + end if + allocate( dvel_lons(nlon), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: Failed to allocate dvel_lons vector' + call endrun + end if + + ierr = pio_inq_varid( piofile, 'lat', vid ) + ierr = pio_get_var( piofile, vid, dvel_lats ) + ierr = pio_inq_varid( piofile, 'lon', vid ) + ierr = pio_get_var( piofile, vid, dvel_lons ) + + !--------------------------------------------------------------------------- + ! ... Set the transform from inputs lats to simulation lats + !--------------------------------------------------------------------------- + dvel_lats(:nlat) = d2r * dvel_lats(:nlat) + dvel_lons(:nlon) = d2r * dvel_lons(:nlon) + + !--------------------------------------------------------------------------- + ! ... Allocate dvel and read data from file + !--------------------------------------------------------------------------- + allocate( dvel_in(nlon, nlat ,nspecies, nmonth), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: Failed to allocate dvel_in' + call endrun + end if + start = (/ 1, 1, 1, 1 /) + count = (/ nlon, nlat, nspecies, nmonth /) + + ierr = pio_get_var( piofile, vid_dvel, start, count, dvel_in ) + + + !--------------------------------------------------------------------------- + ! ... Check units of deposition velocity. If necessary, convert to cm/s. + !--------------------------------------------------------------------------- + units(:) = ' ' + ierr = pio_get_att( piofile, vid_dvel, 'units', units ) + if( to_lower(trim(units(:GLC(units)))) == 'm/s' ) then +#ifdef DEBUG + if(masterproc) write(iulog,*) 'dvel_inti: depvel units = m/s. Converting to cm/s' +#endif + scale_factor = 100._r8 + elseif( to_lower(trim(units(:GLC(units)))) == 'cm/s' ) then +#ifdef DEBUG + if(masterproc) write(iulog,*) 'dvel_inti: depvel units = cm/s' +#endif + scale_factor = 1._r8 + else +#ifdef DEBUG + if(masterproc) then + write(iulog,*) 'dvel_inti: Warning! depvel units unknown = ', to_lower(trim(units)) + write(iulog,*) ' ... proceeding with scale_factor=1' + end if +#endif + scale_factor = 1._r8 + end if + + dvel_in(:,:,:,:) = scale_factor*dvel_in(:,:,:,:) + + !--------------------------------------------------------------------------- + ! ... Regrid deposition velocities + !--------------------------------------------------------------------------- + allocate( dvel(pcols,begchunk:endchunk,nspecies,nmonth),stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: Failed to allocate dvel' + call endrun + end if + + do c=begchunk,endchunk + ncols = get_ncols_p(c) + call get_rlat_all_p(c, pcols, to_lats) + call get_rlon_all_p(c, pcols, to_lons) + call lininterp_init(dvel_lons, nlon, to_lons, ncols, 2, lon_wgts, zero, twopi) + call lininterp_init(dvel_lats, nlat, to_lats, ncols, 1, lat_wgts) + + do ispecies = 1,nspecies + do m = 1,12 + call lininterp( dvel_in( :,:,ispecies,m ), nlon, nlat, dvel(:,c,ispecies,m), ncols,lon_wgts,lat_wgts) + end do + end do + + call lininterp_finish(lat_wgts) + call lininterp_finish(lon_wgts) + end do + + deallocate( dvel_in ) + deallocate( dvel_lats, dvel_lons ) + + !--------------------------------------------------------------------------- + ! ... Read in species names and determine mapping to tracer numbers + !--------------------------------------------------------------------------- + allocate( species_names(nspecies), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: species_names allocation error = ',ierr + call endrun + end if + ierr = pio_inq_varid( piofile, 'species_name', vid ) + ierr = pio_inq_varndims( piofile, vid, ndims ) + + ierr = pio_inq_vardimid( piofile, vid, dimid ) + + ierr = pio_inq_dimlen( piofile, dimid(1), nchar ) + map(:) = 0 + do ispecies = 1,nspecies + start(:2) = (/ 1, ispecies /) + count(:2) = (/ nchar, 1 /) + species_names(ispecies)(:) = ' ' + ierr = pio_get_var( piofile, vid, start(1:2), count(1:2), species_names(ispecies:ispecies) ) + if( species_names(ispecies) == 'O3' ) then + o3_in_tab = .true. + o3_tab_ndx = ispecies + else if( species_names(ispecies) == 'H2O2' ) then + h2o2_in_tab = .true. + h2o2_tab_ndx = ispecies + else if( species_names(ispecies) == 'CH3OOH' ) then + ch3ooh_in_tab = .true. + ch3ooh_tab_ndx = ispecies + else if( species_names(ispecies) == 'CO' ) then + co_in_tab = .true. + co_tab_ndx = ispecies + else if( species_names(ispecies) == 'CH3CHO' ) then + ch3cho_in_tab = .true. + ch3cho_tab_ndx = ispecies + end if + found = .false. + do m = 1,gas_pcnst + if( species_names(ispecies) == solsym(m) .or. & + (species_names(ispecies) == 'O3' .and. solsym(m) == 'OX') .or. & + (species_names(ispecies) == 'HNO4' .and. solsym(m) == 'HO2NO2') ) then + if ( has_drydep( solsym(m) ) ) then + map(m) = ispecies + found = .true. +#ifdef DEBUG + if( masterproc ) then + write(iulog,*) 'dvel_inti: ispecies, m, tracnam = ',ispecies,m,trim(solsym(m)) + end if +#endif + exit + end if + end if + end do + if( .not. found ) then + write(iulog,*) 'dvel_inti: Warning! DVEL species ',trim(species_names(ispecies)),' not found' + endif + end do + deallocate( species_names ) + + call cam_pio_closefile( piofile ) + + !--------------------------------------------------------------------------- + ! ... Allocate dvel_interp array + !--------------------------------------------------------------------------- + allocate( dvel_interp(pcols,begchunk:endchunk,nspecies),stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'dvel_inti: Failed to allocate dvel_interp; error = ',ierr + call endrun + end if + + end subroutine dvel_inti_table + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine interpdvel( calday, ncol, lchnk ) + !--------------------------------------------------------------------------- + ! ... Interpolate the fields whose values are required at the + ! begining of a timestep. + !--------------------------------------------------------------------------- + + use time_manager, only : get_calday + + implicit none + + !--------------------------------------------------------------------------- + ! ... Dummy arguments + !--------------------------------------------------------------------------- + real(r8), intent(in) :: calday ! Interpolate the input data to calday + integer, intent(in) :: ncol, lchnk + + !--------------------------------------------------------------------------- + ! ... Local variables + !--------------------------------------------------------------------------- + integer :: m, last, next + integer :: dates(12) = (/ 116, 214, 316, 415, 516, 615, & + 716, 816, 915, 1016, 1115, 1216 /) + real(r8) :: calday_loc, last_days, next_days + real(r8), save :: dys(12) + logical, save :: entered = .false. + + if( .not. entered ) then + do m = 1,12 + dys(m) = get_calday( dates(m), 0 ) + end do + entered = .true. + end if + + if( calday < dys(1) ) then + next = 1 + last = 12 + else if( calday >= dys(12) ) then + next = 1 + last = 12 + else + do m = 11,1,-1 + if( calday >= dys(m) ) then + exit + end if + end do + last = m + next = m + 1 + end if + + last_days = dys( last ) + next_days = dys( next ) + calday_loc = calday + + if( next_days < last_days ) then + next_days = next_days + 365._r8 + end if + if( calday_loc < last_days ) then + calday_loc = calday_loc + 365._r8 + end if + + do m = 1,nspecies + call intp2d( last_days, next_days, calday_loc, ncol, lchnk, & + dvel(:,lchnk,m,last), & + dvel(:,lchnk,m,next), & + dvel_interp(:,lchnk,m) ) + end do + + end subroutine interpdvel + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine intp2d( t1, t2, tint, ncol, lchnk, f1, f2, fint ) + !----------------------------------------------------------------------- + ! ... Linearly interpolate between f1(t1) and f2(t2) to fint(tint). + !----------------------------------------------------------------------- + + implicit none + + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + real(r8), intent(in) :: & + t1, & ! time level of f1 + t2, & ! time level of f2 + tint ! interpolant time + real(r8), dimension(pcols), intent(in) :: & + f1, & ! field at time t1 + f2 ! field at time t2 + + integer, intent(in) :: ncol, lchnk + + real(r8), intent(out) :: & + fint(pcols) ! field at time tint + + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + real(r8) :: factor + + factor = (tint - t1)/(t2 - t1) + + fint(:ncol) = f1(:ncol) + (f2(:ncol) - f1(:ncol))*factor + + end subroutine intp2d + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine drydep_table( calday, tsurf, zen_angle, & + depvel, dflx, q, p, & + tv, ncol, icefrac, ocnfrac, lchnk ) + !-------------------------------------------------------- + ! ... Form the deposition velocities for this + ! latitude slice + !-------------------------------------------------------- + + use physconst, only : rair,pi + use dycore, only : dycore_is + + implicit none + + !-------------------------------------------------------- + ! ... Dummy arguments + !-------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunk + real(r8), intent(in) :: q(pcols,plev,gas_pcnst) ! tracer mmr (kg/kg) + real(r8), intent(in) :: p(pcols) ! midpoint pressure in surface layer (Pa) + real(r8), intent(in) :: tv(pcols) ! virtual temperature in surface layer (K) + real(r8), intent(in) :: calday ! time of year in days + real(r8), intent(in) :: tsurf(pcols) ! surface temperature (K) + real(r8), intent(in) :: zen_angle(ncol) ! zenith angle (radians) + real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! flux due to dry deposition (kg/m^2/sec) + real(r8), intent(out) :: depvel(ncol,gas_pcnst) ! deposition vel (cm/s) + + real(r8), intent(in) :: icefrac(pcols) ! sea-ice areal fraction + real(r8), intent(in) :: ocnfrac(pcols) ! ocean areal fraction + + integer, intent(in) :: lchnk + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: m, i + real(r8), dimension(ncol) :: vel, glace, temp_fac, wrk, tmp + real(r8), dimension(ncol) :: o3_tab_dvel + real(r8), dimension(ncol) :: ocean + + real(r8), parameter :: pid2 = .5_r8 * pi + + if(dycore_is('UNSTRUCTURED')) then + call endrun( 'Option not supported for unstructured atmosphere grids ') + end if + + !----------------------------------------------------------------------- + ! ... Note the factor 1.e-2 in the wrk array calculation is + ! to transform the incoming dep vel from cm/s to m/s + !----------------------------------------------------------------------- + wrk(:ncol) = 1.e-2_r8 * p(:ncol) / (rair * tv(:ncol)) + + !-------------------------------------------------------- + ! ... Initialize all deposition velocities to zero + !-------------------------------------------------------- + depvel(:,:) = 0._r8 + + !-------------------------------------------------------- + ! ... Time interpolate primary depvel array + ! (also seaice and npp) + !-------------------------------------------------------- + call interpdvel( calday, ncol, lchnk ) + + if( o3_in_tab ) then + do i=1,ncol + o3_tab_dvel(i) = dvel_interp(i,lchnk,o3_tab_ndx) + enddo + end if + + !-------------------------------------------------------- + ! ... Set deposition velocities + !-------------------------------------------------------- + do m = 1,gas_pcnst + if( map(m) /= 0 ) then + do i = 1,ncol + depvel(i,m) = dvel_interp(i,lchnk,map(m)) + dflx(i,m) = wrk(i) * depvel(i,m) * q(i,plev,m) + enddo + end if + end do + + !-------------------------------------------------------- + ! ... Set some variables needed for some dvel calculations + !-------------------------------------------------------- + temp_fac(:ncol) = min( 1._r8, max( 0._r8, (tsurf(:ncol) - 268._r8) / 5._r8 ) ) + ocean(:ncol) = icefrac(:ncol)+ocnfrac(:ncol) + glace(:ncol) = icefrac(:ncol) + (1._r8 - ocean(:ncol)) * (1._r8 - temp_fac(:ncol)) + glace(:ncol) = min( 1._r8,glace(:ncol) ) + + !-------------------------------------------------------- + ! ... Set pan & mpan + !-------------------------------------------------------- + if( o3_in_tab ) then + tmp(:ncol) = o3_tab_dvel(:ncol) / 3._r8 + else + tmp(:) = 0._r8 + end if + if( pan_dd ) then + if( map(pan_ndx) == 0 ) then + depvel(:ncol,pan_ndx) = tmp(:ncol) + dflx(:ncol,pan_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,pan_ndx) + end if + end if + if( mpan_dd ) then + if( map(mpan_ndx) == 0 ) then + depvel(:ncol,mpan_ndx) = tmp(:ncol) + dflx(:ncol,mpan_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,mpan_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Set no2 dvel + !-------------------------------------------------------- + if( no2_dd ) then + if( map(no2_ndx) == 0 .and. o3_in_tab ) then + depvel(:ncol,no2_ndx) = (.6_r8*o3_tab_dvel(:ncol) + .055_r8*ocean(:ncol)) * .9_r8 + dflx(:ncol,no2_ndx) = wrk(:) * depvel(:ncol,no2_ndx) * q(:ncol,plev,no2_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Set hno3 dvel + !-------------------------------------------------------- + tmp(:ncol) = (2._r8 - ocnfrac(:ncol)) * (1._r8 - glace(:ncol)) + .05_r8 * glace(:ncol) + if( hno3_dd ) then + if( map(hno3_ndx) == 0 ) then + depvel(:ncol,hno3_ndx) = tmp(:ncol) + dflx(:ncol,hno3_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hno3_ndx) + else + tmp(:ncol) = depvel(:ncol,hno3_ndx) + end if + end if + if( onitr_dd ) then + if( map(onitr_ndx) == 0 ) then + depvel(:ncol,onitr_ndx) = tmp(:ncol) + dflx(:ncol,onitr_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,onitr_ndx) + end if + end if + if( isopooh_dd ) then + if( map(isopooh_ndx) == 0 ) then + depvel(:ncol,isopooh_ndx) = tmp(:ncol) + dflx(:ncol,isopooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,isopooh_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Set h2o2 dvel + !-------------------------------------------------------- + if( .not. h2o2_in_tab ) then + if( o3_in_tab ) then + tmp(:ncol) = .05_r8*glace(:ncol) + ocean(:ncol) - icefrac(:ncol) & + + (1._r8 - (glace(:) + ocean(:ncol)) + icefrac(:ncol)) & + *max( 1._r8,1._r8/(.5_r8 + 1._r8/(6._r8*o3_tab_dvel(:ncol))) ) + else + tmp(:ncol) = 0._r8 + end if + else + do i=1,ncol + tmp(i) = dvel_interp(i,lchnk,h2o2_tab_ndx) + enddo + end if + if( h2o2_dd ) then + if( map(h2o2_ndx) == 0 ) then + depvel(:ncol,h2o2_ndx) = tmp(:ncol) + dflx(:ncol,h2o2_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,h2o2_ndx) + end if + end if + !-------------------------------------------------------- + ! ... Set hcn dvel + !-------------------------------------------------------- + if( hcn_dd ) then + if( map(hcn_ndx) == 0 ) then + depvel(:ncol,hcn_ndx) = ocnfrac(:ncol)*0.2_r8 + endif + endif + !-------------------------------------------------------- + ! ... Set ch3cn dvel + !-------------------------------------------------------- + if( ch3cn_dd ) then + if( map(ch3cn_ndx) == 0 ) then + depvel(:,ch3cn_ndx) = ocnfrac(:ncol)*0.2_r8 + endif + endif + !-------------------------------------------------------- + ! ... Set onit + !-------------------------------------------------------- + if( onit_dd ) then + if( map(onit_ndx) == 0 ) then + depvel(:ncol,onit_ndx) = tmp(:ncol) + dflx(:ncol,onit_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,onit_ndx) + end if + end if + if( ch3cocho_dd ) then + if( map(ch3cocho_ndx) == 0 ) then + depvel(:ncol,ch3cocho_ndx) = tmp(:ncol) + dflx(:ncol,ch3cocho_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3cocho_ndx) + end if + end if + if( ch3ooh_in_tab ) then + do i=1,ncol + tmp(i) = dvel_interp(i,lchnk,ch3ooh_tab_ndx) + enddo + else + tmp(:ncol) = .5_r8 * tmp(:ncol) + end if + if( ch3ooh_dd ) then + if( map(ch3ooh_ndx) == 0 ) then + depvel(:ncol,ch3ooh_ndx) = tmp(:ncol) + dflx(:ncol,ch3ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3ooh_ndx) + end if + end if + if( pooh_dd ) then + if( map(pooh_ndx) == 0 ) then + depvel(:ncol,pooh_ndx) = tmp(:ncol) + dflx(:ncol,pooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,pooh_ndx) + end if + end if + if( ch3coooh_dd ) then + if( map(ch3coooh_ndx) == 0 ) then + depvel(:ncol,ch3coooh_ndx) = tmp(:ncol) + dflx(:ncol,ch3coooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3coooh_ndx) + end if + end if + if( c2h5ooh_dd ) then + if( map(c2h5ooh_ndx) == 0 ) then + depvel(:ncol,c2h5ooh_ndx) = tmp(:ncol) + dflx(:ncol,c2h5ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c2h5ooh_ndx) + end if + end if + if( c3h7ooh_dd ) then + if( map(c3h7ooh_ndx) == 0 ) then + depvel(:ncol,c3h7ooh_ndx) = tmp(:ncol) + dflx(:ncol,c3h7ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c3h7ooh_ndx) + end if + end if + if( rooh_dd ) then + if( map(rooh_ndx) == 0 ) then + depvel(:ncol,rooh_ndx) = tmp(:ncol) + dflx(:ncol,rooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,rooh_ndx) + end if + end if + if( macrooh_dd ) then + if( map(macrooh_ndx) == 0 ) then + depvel(:ncol,macrooh_ndx) = tmp(:ncol) + dflx(:ncol,macrooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,macrooh_ndx) + end if + end if + if( xooh_dd ) then + if( map(xooh_ndx) == 0 ) then + depvel(:ncol,xooh_ndx) = tmp(:ncol) + dflx(:ncol,xooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,xooh_ndx) + end if + end if + if( ch3oh_dd ) then + if( map(ch3oh_ndx) == 0 ) then + depvel(:ncol,ch3oh_ndx) = tmp(:ncol) + dflx(:ncol,ch3oh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3oh_ndx) + end if + end if + if( c2h5oh_dd ) then + if( map(c2h5oh_ndx) == 0 ) then + depvel(:ncol,c2h5oh_ndx) = tmp(:ncol) + dflx(:ncol,c2h5oh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c2h5oh_ndx) + end if + end if + if( alkooh_dd ) then + if( map(alkooh_ndx) == 0 ) then + depvel(:ncol,alkooh_ndx) = tmp(:ncol) + dflx(:ncol,alkooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,alkooh_ndx) + end if + end if + if( mekooh_dd ) then + if( map(mekooh_ndx) == 0 ) then + depvel(:ncol,mekooh_ndx) = tmp(:ncol) + dflx(:ncol,mekooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,mekooh_ndx) + end if + end if + if( tolooh_dd ) then + if( map(tolooh_ndx) == 0 ) then + depvel(:ncol,tolooh_ndx) = tmp(:ncol) + dflx(:ncol,tolooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,tolooh_ndx) + end if + end if + if( o3_in_tab ) then + tmp(:ncol) = o3_tab_dvel(:ncol) + else + tmp(:ncol) = 0._r8 + end if + if( ch2o_dd ) then + if( map(ch2o_ndx) == 0 ) then + depvel(:ncol,ch2o_ndx) = tmp(:ncol) + dflx(:ncol,ch2o_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch2o_ndx) + end if + end if + + if( hydrald_dd ) then + if( map(hydrald_ndx) == 0 ) then + depvel(:ncol,hydrald_ndx) = tmp(:ncol) + dflx(:ncol,hydrald_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hydrald_ndx) + end if + end if + if( ch3cooh_dd ) then + if( map(ch3cooh_ndx) == 0 ) then + depvel(:ncol,ch3cooh_ndx) = depvel(:ncol,ch2o_ndx) + dflx(:ncol,ch3cooh_ndx) = wrk(:ncol) * depvel(:ncol,ch3cooh_ndx) * q(:ncol,plev,ch3cooh_ndx) + end if + end if + if( eooh_dd ) then + if( map(eooh_ndx) == 0 ) then + depvel(:ncol,eooh_ndx) = depvel(:ncol,ch2o_ndx) + dflx(:ncol,eooh_ndx) = wrk(:ncol) * depvel(:ncol,eooh_ndx) * q(:ncol,plev,eooh_ndx) + end if + end if + ! HCOOH - set to CH3COOH + if( hcooh_dd ) then + if( map(hcooh_ndx) == 0 ) then + depvel(:ncol,hcooh_ndx) = depvel(:ncol,ch2o_ndx) + dflx(:ncol,hcooh_ndx) = wrk(:ncol) * depvel(:ncol,hcooh_ndx) * q(:ncol,plev,hcooh_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Set co and related species dep vel + !-------------------------------------------------------- + if( co_in_tab ) then + do i=1,ncol + tmp(i) = dvel_interp(i,lchnk,co_tab_ndx) + enddo + else + tmp(:) = 0._r8 + end if + if( co_dd ) then + if( map(co_ndx) == 0 ) then + depvel(:ncol,co_ndx) = tmp(:ncol) + dflx(:ncol,co_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,co_ndx) + end if + end if + if( ch3coch3_dd ) then + if( map(ch3coch3_ndx) == 0 ) then + depvel(:ncol,ch3coch3_ndx) = tmp(:ncol) + dflx(:ncol,ch3coch3_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3coch3_ndx) + end if + end if + if( hyac_dd ) then + if( map(hyac_ndx) == 0 ) then + depvel(:ncol,hyac_ndx) = tmp(:ncol) + dflx(:ncol,hyac_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hyac_ndx) + end if + end if + if( h2_dd ) then + if( map(h2_ndx) == 0 ) then + depvel(:ncol,h2_ndx) = tmp(:ncol) * 1.5_r8 ! Hough(1991) + dflx(:ncol,h2_ndx) = wrk(:ncol) * depvel(:ncol,h2_ndx) * q(:ncol,plev,h2_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Set glyald + !-------------------------------------------------------- + if( glyald_dd ) then + if( map(glyald_ndx) == 0 ) then + if( ch3cho_dd ) then + depvel(:ncol,glyald_ndx) = depvel(:ncol,ch3cho_ndx) + else if( ch3cho_in_tab ) then + do i=1,ncol + depvel(i,glyald_ndx) = dvel_interp(i,lchnk,ch3cho_tab_ndx) + enddo + else + depvel(:ncol,glyald_ndx) = 0._r8 + end if + dflx(:ncol,glyald_ndx) = wrk(:ncol) * depvel(:ncol,glyald_ndx) * q(:ncol,plev,glyald_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... Lead deposition + !-------------------------------------------------------- + if( Pb_dd ) then + if( map(Pb_ndx) == 0 ) then + depvel(:ncol,Pb_ndx) = ocean(:ncol) * .05_r8 + (1._r8 - ocean(:ncol)) * .2_r8 + dflx(:ncol,Pb_ndx) = wrk(:ncol) * depvel(:ncol,Pb_ndx) * q(:ncol,plev,Pb_ndx) + end if + end if + + !-------------------------------------------------------- + ! ... diurnal dependence for OX dvel + !-------------------------------------------------------- + if( o3_dd .or. o3s_dd .or. o3inert_dd ) then + if( o3_dd .or. o3_in_tab ) then + if( o3_dd ) then + tmp(:ncol) = max( 1._r8,sqrt( (depvel(:ncol,o3_ndx) - .2_r8)**3/.27_r8 + 4._r8*depvel(:ncol,o3_ndx) + .67_r8 ) ) + vel(:ncol) = depvel(:ncol,o3_ndx) + else if( o3_in_tab ) then + tmp(:ncol) = max( 1._r8,sqrt( (o3_tab_dvel(:ncol) - .2_r8)**3/.27_r8 + 4._r8*o3_tab_dvel(:ncol) + .67_r8 ) ) + vel(:ncol) = o3_tab_dvel(:ncol) + end if + where( abs( zen_angle(:) ) > pid2 ) + vel(:) = vel(:) / tmp(:) + elsewhere + vel(:) = vel(:) * tmp(:) + endwhere + + else + vel(:ncol) = 0._r8 + end if + if( o3_dd ) then + depvel(:ncol,o3_ndx) = vel(:ncol) + dflx(:ncol,o3_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3_ndx) + end if + !-------------------------------------------------------- + ! ... Set stratospheric O3 deposition + !-------------------------------------------------------- + if( o3s_dd ) then + depvel(:ncol,o3s_ndx) = vel(:ncol) + dflx(:ncol,o3s_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3s_ndx) + end if + if( o3inert_dd ) then + depvel(:ncol,o3inert_ndx) = vel(:ncol) + dflx(:ncol,o3inert_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3inert_ndx) + end if + end if + + if( xno2_dd ) then + if( map(xno2_ndx) == 0 ) then + depvel(:ncol,xno2_ndx) = depvel(:ncol,no2_ndx) + dflx(:ncol,xno2_ndx) = wrk(:ncol) * depvel(:ncol,xno2_ndx) * q(:ncol,plev,xno2_ndx) + end if + endif + if( o3a_dd ) then + if( map(o3a_ndx) == 0 ) then + depvel(:ncol,o3a_ndx) = depvel(:ncol,o3_ndx) + dflx(:ncol,o3a_ndx) = wrk(:ncol) * depvel(:ncol,o3a_ndx) * q(:ncol,plev,o3a_ndx) + end if + endif + if( xhno3_dd ) then + if( map(xhno3_ndx) == 0 ) then + depvel(:ncol,xhno3_ndx) = depvel(:ncol,hno3_ndx) + dflx(:ncol,xhno3_ndx) = wrk(:ncol) * depvel(:ncol,xhno3_ndx) * q(:ncol,plev,xhno3_ndx) + end if + endif + if( xnh4no3_dd ) then + if( map(xnh4no3_ndx) == 0 ) then + depvel(:ncol,xnh4no3_ndx) = depvel(:ncol,nh4no3_ndx) + dflx(:ncol,xnh4no3_ndx) = wrk(:ncol) * depvel(:ncol,xnh4no3_ndx) * q(:ncol,plev,xnh4no3_ndx) + end if + endif + if( xpan_dd ) then + if( map(xpan_ndx) == 0 ) then + depvel(:ncol,xpan_ndx) = depvel(:ncol,pan_ndx) + dflx(:ncol,xpan_ndx) = wrk(:ncol) * depvel(:ncol,xpan_ndx) * q(:ncol,plev,xpan_ndx) + end if + endif + if( xmpan_dd ) then + if( map(xmpan_ndx) == 0 ) then + depvel(:ncol,xmpan_ndx) = depvel(:ncol,mpan_ndx) + dflx(:ncol,xmpan_ndx) = wrk(:ncol) * depvel(:ncol,xmpan_ndx) * q(:ncol,plev,xmpan_ndx) + end if + endif + if( xonit_dd ) then + if( map(xonit_ndx) == 0 ) then + depvel(:ncol,xonit_ndx) = depvel(:ncol,onit_ndx) + dflx(:ncol,xonit_ndx) = wrk(:ncol) * depvel(:ncol,xonit_ndx) * q(:ncol,plev,xonit_ndx) + end if + endif + if( xonitr_dd ) then + if( map(xonitr_ndx) == 0 ) then + depvel(:ncol,xonitr_ndx) = depvel(:ncol,onitr_ndx) + dflx(:ncol,xonitr_ndx) = wrk(:ncol) * depvel(:ncol,xonitr_ndx) * q(:ncol,plev,xonitr_ndx) + end if + endif + if( xno_dd ) then + if( map(xno_ndx) == 0 ) then + depvel(:ncol,xno_ndx) = depvel(:ncol,no_ndx) + dflx(:ncol,xno_ndx) = wrk(:ncol) * depvel(:ncol,xno_ndx) * q(:ncol,plev,xno_ndx) + end if + endif + if( xho2no2_dd ) then + if( map(xho2no2_ndx) == 0 ) then + depvel(:ncol,xho2no2_ndx) = depvel(:ncol,ho2no2_ndx) + dflx(:ncol,xho2no2_ndx) = wrk(:ncol) * depvel(:ncol,xho2no2_ndx) * q(:ncol,plev,xho2no2_ndx) + end if + endif + !lke-TS1 + if( phenooh_dd ) then + if( map(phenooh_ndx) == 0 ) then + depvel(:ncol,phenooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,phenooh_ndx) = wrk(:ncol) * depvel(:ncol,phenooh_ndx) * q(:ncol,plev,phenooh_ndx) + end if + endif + if( benzooh_dd ) then + if( map(benzooh_ndx) == 0 ) then + depvel(:ncol,benzooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,benzooh_ndx) = wrk(:ncol) * depvel(:ncol,benzooh_ndx) * q(:ncol,plev,benzooh_ndx) + end if + endif + if( c6h5ooh_dd ) then + if( map(c6h5ooh_ndx) == 0 ) then + depvel(:ncol,c6h5ooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,c6h5ooh_ndx) = wrk(:ncol) * depvel(:ncol,c6h5ooh_ndx) * q(:ncol,plev,c6h5ooh_ndx) + end if + endif + if( bzooh_dd ) then + if( map(bzooh_ndx) == 0 ) then + depvel(:ncol,bzooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,bzooh_ndx) = wrk(:ncol) * depvel(:ncol,bzooh_ndx) * q(:ncol,plev,bzooh_ndx) + end if + endif + if( xylolooh_dd ) then + if( map(xylolooh_ndx) == 0 ) then + depvel(:ncol,xylolooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,xylolooh_ndx) = wrk(:ncol) * depvel(:ncol,xylolooh_ndx) * q(:ncol,plev,xylolooh_ndx) + end if + endif + if( xylenooh_dd ) then + if( map(xylenooh_ndx) == 0 ) then + depvel(:ncol,xylenooh_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,xylenooh_ndx) = wrk(:ncol) * depvel(:ncol,xylenooh_ndx) * q(:ncol,plev,xylenooh_ndx) + end if + endif + if( terpooh_dd ) then + if( map(terpooh_ndx) == 0 ) then + depvel(:ncol,terpooh_ndx) = depvel(:ncol,isopooh_ndx) + dflx(:ncol,terpooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,terpooh_ndx) + end if + end if + if( terp2ooh_dd ) then + if( map(terp2ooh_ndx) == 0 ) then + depvel(:ncol,terp2ooh_ndx) = depvel(:ncol,isopooh_ndx) + dflx(:ncol,terp2ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,terp2ooh_ndx) + end if + end if + if( terprod1_dd ) then + if( map(terprod1_ndx) == 0 ) then + depvel(:ncol,terprod1_ndx) = depvel(:ncol,hyac_ndx) + dflx(:ncol,terprod1_ndx) = wrk(:ncol) * depvel(:ncol,terprod1_ndx) * q(:ncol,plev,terprod1_ndx) + end if + endif + if( terprod2_dd ) then + if( map(terprod2_ndx) == 0 ) then + depvel(:ncol,terprod2_ndx) = depvel(:ncol,hyac_ndx) + dflx(:ncol,terprod2_ndx) = wrk(:ncol) * depvel(:ncol,terprod2_ndx) * q(:ncol,plev,terprod2_ndx) + end if + endif + if( hmprop_dd ) then + if( map(hmprop_ndx) == 0 ) then + depvel(:ncol,hmprop_ndx) = depvel(:ncol,glyald_ndx) + dflx(:ncol,hmprop_ndx) = wrk(:ncol) * depvel(:ncol,hmprop_ndx) * q(:ncol,plev,hmprop_ndx) + end if + endif + if( mboooh_dd ) then + if( map(mboooh_ndx) == 0 ) then + depvel(:ncol,mboooh_ndx) = depvel(:ncol,isopooh_ndx) + dflx(:ncol,mboooh_ndx) = wrk(:ncol) * depvel(:ncol,mboooh_ndx) * q(:ncol,plev,mboooh_ndx) + end if + endif + if( hpald_dd ) then + if( map(hpald_ndx) == 0 ) then + depvel(:ncol,hpald_ndx) = depvel(:ncol,ch3ooh_ndx) + dflx(:ncol,hpald_ndx) = wrk(:ncol) * depvel(:ncol,hpald_ndx) * q(:ncol,plev,hpald_ndx) + end if + endif + if( iepox_dd ) then + if( map(iepox_ndx) == 0 ) then + depvel(:ncol,iepox_ndx) = depvel(:ncol,hyac_ndx) + dflx(:ncol,iepox_ndx) = wrk(:ncol) * depvel(:ncol,iepox_ndx) * q(:ncol,plev,iepox_ndx) + end if + endif + if( noa_dd ) then + if( map(noa_ndx) == 0 ) then + depvel(:ncol,noa_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,noa_ndx) = wrk(:ncol) * depvel(:ncol,noa_ndx) * q(:ncol,plev,noa_ndx) + end if + endif + if( alknit_dd ) then + if( map(alknit_ndx) == 0 ) then + depvel(:ncol,alknit_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,alknit_ndx) = wrk(:ncol) * depvel(:ncol,alknit_ndx) * q(:ncol,plev,alknit_ndx) + end if + endif + if( isopnita_dd ) then + if( map(isopnita_ndx) == 0 ) then + depvel(:ncol,isopnita_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,isopnita_ndx) = wrk(:ncol) * depvel(:ncol,isopnita_ndx) * q(:ncol,plev,isopnita_ndx) + end if + endif + if( isopnitb_dd ) then + if( map(isopnitb_ndx) == 0 ) then + depvel(:ncol,isopnitb_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,isopnitb_ndx) = wrk(:ncol) * depvel(:ncol,isopnitb_ndx) * q(:ncol,plev,isopnitb_ndx) + end if + endif + if( honitr_dd ) then + if( map(honitr_ndx) == 0 ) then + depvel(:ncol,honitr_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,honitr_ndx) = wrk(:ncol) * depvel(:ncol,honitr_ndx) * q(:ncol,plev,honitr_ndx) + end if + endif + if( isopnooh_dd ) then + if( map(isopnooh_ndx) == 0 ) then + depvel(:ncol,isopnooh_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,isopnooh_ndx) = wrk(:ncol) * depvel(:ncol,isopnooh_ndx) * q(:ncol,plev,isopnooh_ndx) + end if + endif + if( nc4cho_dd ) then + if( map(nc4cho_ndx) == 0 ) then + depvel(:ncol,nc4cho_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,nc4cho_ndx) = wrk(:ncol) * depvel(:ncol,nc4cho_ndx) * q(:ncol,plev,nc4cho_ndx) + end if + endif + if( nc4ch2oh_dd ) then + if( map(nc4ch2oh_ndx) == 0 ) then + depvel(:ncol,nc4ch2oh_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,nc4ch2oh_ndx) = wrk(:ncol) * depvel(:ncol,nc4ch2oh_ndx) * q(:ncol,plev,nc4ch2oh_ndx) + end if + endif + if( terpnit_dd ) then + if( map(terpnit_ndx) == 0 ) then + depvel(:ncol,terpnit_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,terpnit_ndx) = wrk(:ncol) * depvel(:ncol,terpnit_ndx) * q(:ncol,plev,terpnit_ndx) + end if + endif + if( nterpooh_dd ) then + if( map(nterpooh_ndx) == 0 ) then + depvel(:ncol,nterpooh_ndx) = depvel(:ncol,h2o2_ndx) + dflx(:ncol,nterpooh_ndx) = wrk(:ncol) * depvel(:ncol,nterpooh_ndx) * q(:ncol,plev,nterpooh_ndx) + end if + endif + + + end subroutine drydep_table + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ) + !------------------------------------------------------------------------------------- + ! ... intialize interactive drydep + !------------------------------------------------------------------------------------- + use dycore, only : dycore_is + use mo_constants, only : r2d + use chem_mods, only : adv_mass + use mo_chem_utls, only : get_spc_ndx + use seq_drydep_mod,only : drydep_method, DD_XATM, DD_XLND + use phys_control, only : phys_getopts + + implicit none + + !------------------------------------------------------------------------------------- + ! ... dummy arguments + !------------------------------------------------------------------------------------- + character(len=*), intent(in) :: depvel_lnd_file, clim_soilw_file, season_wes_file + + !------------------------------------------------------------------------------------- + ! ... local variables + !------------------------------------------------------------------------------------- + integer :: i, j, ii, jj, jl, ju + integer :: nlon_veg, nlat_veg, npft_veg + integer :: nlat_lai, npft_lai, pos_min, imin + integer :: dimid + integer :: m, n, l, id + integer :: length1, astat + integer, allocatable :: wk_lai(:,:,:) + integer, allocatable :: index_season_lai_j(:,:) + integer :: k, num_max, k_max + integer :: num_seas(5) + integer :: plon, plat + integer :: ierr, ndx + + real(r8) :: spc_mass + real(r8) :: diff_min, target_lat + real(r8), allocatable :: vegetation_map(:,:,:) + real(r8), pointer :: soilw_map(:,:,:) + real(r8), allocatable :: work(:,:) + real(r8), allocatable :: landmask(:,:) + real(r8), allocatable :: urban(:,:) + real(r8), allocatable :: lake(:,:) + real(r8), allocatable :: wetland(:,:) + real(r8), allocatable :: lon_veg(:) + real(r8), allocatable :: lon_veg_edge(:) + real(r8), allocatable :: lat_veg(:) + real(r8), allocatable :: lat_veg_edge(:) + real(r8), allocatable :: lat_lai(:) + real(r8), allocatable :: clat(:) + character(len=32) :: test_name + character(len=4) :: tag_name + type(file_desc_t) :: piofile + type(var_desc_t) :: vid + logical :: do_soilw + + character(len=shr_kind_cl) :: locfn + logical :: prog_modal_aero + + ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep + call phys_getopts(prog_modal_aero_out=prog_modal_aero) +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. +#endif + + call dvel_inti_fromlnd() + + if( masterproc ) then + write(iulog,*) 'drydep_inti: following species have dry deposition' + do i=1,nddvels + if( len_trim(drydep_list(i)) > 0 ) then + write(iulog,*) 'drydep_inti: '//trim(drydep_list(i))//' is requested to have dry dep' + endif + enddo + write(iulog,*) 'drydep_inti:' + endif + + !------------------------------------------------------------------------------------- + ! ... get species indices + !------------------------------------------------------------------------------------- + xpan_ndx = get_spc_ndx( 'XPAN' ) + xmpan_ndx = get_spc_ndx( 'XMPAN' ) + o3a_ndx = get_spc_ndx( 'O3A' ) + + ch4_ndx = get_spc_ndx( 'CH4' ) + h2_ndx = get_spc_ndx( 'H2' ) + co_ndx = get_spc_ndx( 'CO' ) + Pb_ndx = get_spc_ndx( 'Pb' ) + pan_ndx = get_spc_ndx( 'PAN' ) + mpan_ndx = get_spc_ndx( 'MPAN' ) + o3_ndx = get_spc_ndx( 'OX' ) + if( o3_ndx < 0 ) then + o3_ndx = get_spc_ndx( 'O3' ) + end if + so2_ndx = get_spc_ndx( 'SO2' ) + alkooh_ndx = get_spc_ndx( 'ALKOOH') + mekooh_ndx = get_spc_ndx( 'MEKOOH') + tolooh_ndx = get_spc_ndx( 'TOLOOH') + terpooh_ndx = get_spc_ndx( 'TERPOOH') + ch3cooh_ndx = get_spc_ndx( 'CH3COOH') + soa_ndx = get_spc_ndx( 'SOA' ) + so4_ndx = get_spc_ndx( 'SO4' ) + cb1_ndx = get_spc_ndx( 'CB1' ) + cb2_ndx = get_spc_ndx( 'CB2' ) + oc1_ndx = get_spc_ndx( 'OC1' ) + oc2_ndx = get_spc_ndx( 'OC2' ) + nh3_ndx = get_spc_ndx( 'NH3' ) + nh4no3_ndx = get_spc_ndx( 'NH4NO3' ) + sa1_ndx = get_spc_ndx( 'SA1' ) + sa2_ndx = get_spc_ndx( 'SA2' ) + sa3_ndx = get_spc_ndx( 'SA3' ) + sa4_ndx = get_spc_ndx( 'SA4' ) + nh4_ndx = get_spc_ndx( 'NH4' ) + alkooh_dd = has_drydep( 'ALKOOH') + mekooh_dd = has_drydep( 'MEKOOH') + tolooh_dd = has_drydep( 'TOLOOH') + terpooh_dd = has_drydep( 'TERPOOH') + ch3cooh_dd = has_drydep( 'CH3COOH') + soa_dd = has_drydep( 'SOA' ) + so4_dd = has_drydep( 'SO4' ) + cb1_dd = has_drydep( 'CB1' ) + cb2_dd = has_drydep( 'CB2' ) + oc1_dd = has_drydep( 'OC1' ) + oc2_dd = has_drydep( 'OC2' ) + nh3_dd = has_drydep( 'NH3' ) + nh4no3_dd = has_drydep( 'NH4NO3' ) + sa1_dd = has_drydep( 'SA1' ) + sa2_dd = has_drydep( 'SA2' ) + sa3_dd = has_drydep( 'SA3' ) + sa4_dd = has_drydep( 'SA4' ) + nh4_dd = has_drydep( 'NH4' ) +! + soam_ndx = get_spc_ndx( 'SOAM' ) + soai_ndx = get_spc_ndx( 'SOAI' ) + soat_ndx = get_spc_ndx( 'SOAT' ) + soab_ndx = get_spc_ndx( 'SOAB' ) + soax_ndx = get_spc_ndx( 'SOAX' ) + sogm_ndx = get_spc_ndx( 'SOGM' ) + sogi_ndx = get_spc_ndx( 'SOGI' ) + sogt_ndx = get_spc_ndx( 'SOGT' ) + sogb_ndx = get_spc_ndx( 'SOGB' ) + sogx_ndx = get_spc_ndx( 'SOGX' ) + soam_dd = has_drydep ( 'SOAM' ) + soai_dd = has_drydep ( 'SOAI' ) + soat_dd = has_drydep ( 'SOAT' ) + soab_dd = has_drydep ( 'SOAB' ) + soax_dd = has_drydep ( 'SOAX' ) + sogm_dd = has_drydep ( 'SOGM' ) + sogi_dd = has_drydep ( 'SOGI' ) + sogt_dd = has_drydep ( 'SOGT' ) + sogb_dd = has_drydep ( 'SOGB' ) + sogx_dd = has_drydep ( 'SOGX' ) +! + hcn_ndx = get_spc_ndx( 'HCN') + ch3cn_ndx = get_spc_ndx( 'CH3CN') + +!lke-TS1 + phenooh_ndx = get_spc_ndx( 'PHENOOH') + benzooh_ndx = get_spc_ndx( 'BENZOOH') + c6h5ooh_ndx = get_spc_ndx( 'C6H5OOH') + bzooh_ndx = get_spc_ndx( 'BZOOH') + xylolooh_ndx = get_spc_ndx( 'XYLOLOOH') + xylenooh_ndx = get_spc_ndx( 'XYLENOOH') + terp2ooh_ndx = get_spc_ndx( 'TERP2OOH') + terprod1_ndx = get_spc_ndx( 'TERPROD1') + terprod2_ndx = get_spc_ndx( 'TERPROD2') + hmprop_ndx = get_spc_ndx( 'HMPROP') + mboooh_ndx = get_spc_ndx( 'MBOOOH') + hpald_ndx = get_spc_ndx( 'HPALD') + iepox_ndx = get_spc_ndx( 'IEPOX') + noa_ndx = get_spc_ndx( 'NOA') + alknit_ndx = get_spc_ndx( 'ALKNIT') + isopnita_ndx = get_spc_ndx( 'ISOPNITA') + isopnitb_ndx = get_spc_ndx( 'ISOPNITB') + honitr_ndx = get_spc_ndx( 'HONITR') + isopnooh_ndx = get_spc_ndx( 'ISOPNOOH') + nc4cho_ndx = get_spc_ndx( 'NC4CHO') + nc4ch2oh_ndx = get_spc_ndx( 'NC4CH2OH') + terpnit_ndx = get_spc_ndx( 'TERPNIT') + nterpooh_ndx = get_spc_ndx( 'NTERPOOH') + phenooh_dd = has_drydep( 'PHENOOH') + benzooh_dd = has_drydep( 'BENZOOH') + c6h5ooh_dd = has_drydep( 'C6H5OOH') + bzooh_dd = has_drydep( 'BZOOH') + xylolooh_dd = has_drydep( 'XYLOLOOH') + xylenooh_dd = has_drydep( 'XYLENOOH') + terp2ooh_dd = has_drydep( 'TERP2OOH') + terprod1_dd = has_drydep( 'TERPROD1') + terprod2_dd = has_drydep( 'TERPROD2') + hmprop_dd = has_drydep( 'HMPROP') + mboooh_dd = has_drydep( 'MBOOOH') + hpald_dd = has_drydep( 'HPALD') + iepox_dd = has_drydep( 'IEPOX') + noa_dd = has_drydep( 'NOA') + alknit_dd = has_drydep( 'ALKNIT') + isopnita_dd = has_drydep( 'ISOPNITA') + isopnitb_dd = has_drydep( 'ISOPNITB') + honitr_dd = has_drydep( 'HONITR') + isopnooh_dd = has_drydep( 'ISOPNOOH') + nc4cho_dd = has_drydep( 'NC4CHO') + nc4ch2oh_dd = has_drydep( 'NC4CH2OH') + terpnit_dd = has_drydep( 'TERPNIT') + nterpooh_dd = has_drydep( 'NTERPOOH') +! + cohc_ndx = get_spc_ndx( 'COhc' ) + come_ndx = get_spc_ndx( 'COme' ) + + tag_cnt=0 + cotag_ndx(:)=-1 + do i = 1,NTAGS + write(tag_name,'(a2,i2.2)') 'CO',i + ndx = get_spc_ndx(tag_name) + if (ndx>0) then + tag_cnt = tag_cnt+1 + cotag_ndx(tag_cnt) = ndx + endif + enddo + + o3s_ndx = get_spc_ndx( 'O3S' ) + + do i=1,nddvels + if ( mapping(i) > 0 ) then + test_name = drydep_list(i) + m = get_spc_ndx( test_name ) + has_dvel(m) = .true. + map_dvel(m) = i + endif + enddo + + if( all( .not. has_dvel(:) ) ) then + return + end if + + !--------------------------------------------------------------------------- + ! ... allocate module variables + !--------------------------------------------------------------------------- + allocate( dep_ra(pcols,n_land_type,begchunk:endchunk),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate dep_ra; error = ',astat + call endrun + end if + allocate( dep_rb(pcols,n_land_type,begchunk:endchunk),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate dep_rb; error = ',astat + call endrun + end if + + if (drydep_method == DD_XLND .and. (.not.prog_modal_aero)) then + return + endif + + do_soilw = .not. dyn_soilw .and. (has_drydep( 'H2' ) .or. has_drydep( 'CO' )) + allocate( fraction_landuse(pcols,n_land_type, begchunk:endchunk),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate fraction_landuse; error = ',astat + call endrun + end if + if(do_soilw) then + allocate(soilw_3d(pcols,12,begchunk:endchunk),stat=astat) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate soilw_3d error = ',astat + call endrun + end if + end if + + plon = get_dyn_grid_parm('plon') + plat = get_dyn_grid_parm('plat') + allocate( index_season_lai_j(n_land_type,12),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate index_season_lai_j; error = ',astat + call endrun + end if + if(dycore_is('UNSTRUCTURED') ) then + call get_landuse_and_soilw_from_file(do_soilw) + allocate( index_season_lai(plon,12),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate index_season_lai; error = ',astat + call endrun + end if + else + allocate( index_season_lai(plat,12),stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate index_season_lai; error = ',astat + call endrun + end if + !--------------------------------------------------------------------------- + ! ... read landuse map + !--------------------------------------------------------------------------- + call getfil (depvel_lnd_file, locfn, 0) + call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) + !--------------------------------------------------------------------------- + ! ... get the dimensions + !--------------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'lon', dimid ) + ierr = pio_inq_dimlen( piofile, dimid, nlon_veg ) + ierr = pio_inq_dimid( piofile, 'lat', dimid ) + ierr = pio_inq_dimlen( piofile, dimid, nlat_veg ) + ierr = pio_inq_dimid( piofile, 'pft', dimid ) + ierr = pio_inq_dimlen( piofile, dimid, npft_veg ) + !--------------------------------------------------------------------------- + ! ... allocate arrays + !--------------------------------------------------------------------------- + allocate( vegetation_map(nlon_veg,nlat_veg,npft_veg), work(nlon_veg,nlat_veg), stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat + call endrun + end if + allocate( urban(nlon_veg,nlat_veg), lake(nlon_veg,nlat_veg), & + landmask(nlon_veg,nlat_veg), wetland(nlon_veg,nlat_veg), stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat + call endrun + end if + allocate( lon_veg(nlon_veg), lat_veg(nlat_veg), & + lon_veg_edge(nlon_veg+1), lat_veg_edge(nlat_veg+1), stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate vegation lon, lat arrays; error = ',astat + call endrun + end if + !--------------------------------------------------------------------------- + ! ... read the vegetation map and landmask + !--------------------------------------------------------------------------- + ierr = pio_inq_varid( piofile, 'PCT_PFT', vid ) + ierr = pio_get_var( piofile, vid, vegetation_map ) + + ierr = pio_inq_varid( piofile, 'LANDMASK', vid ) + ierr = pio_get_var( piofile, vid, landmask ) + + ierr = pio_inq_varid( piofile, 'PCT_URBAN', vid ) + ierr = pio_get_var( piofile, vid, urban ) + + ierr = pio_inq_varid( piofile, 'PCT_LAKE', vid ) + ierr = pio_get_var( piofile, vid, lake ) + + ierr = pio_inq_varid( piofile, 'PCT_WETLAND', vid ) + ierr = pio_get_var( piofile, vid, wetland ) + + call cam_pio_closefile( piofile ) + + !--------------------------------------------------------------------------- + ! scale vegetation, urban, lake, and wetland to fraction + !--------------------------------------------------------------------------- + vegetation_map(:,:,:) = .01_r8 * vegetation_map(:,:,:) + wetland(:,:) = .01_r8 * wetland(:,:) + lake(:,:) = .01_r8 * lake(:,:) + urban(:,:) = .01_r8 * urban(:,:) +#ifdef DEBUG + if(masterproc) then + write(iulog,*) 'minmax vegetation_map ',minval(vegetation_map),maxval(vegetation_map) + write(iulog,*) 'minmax wetland ',minval(wetland),maxval(wetland) + write(iulog,*) 'minmax landmask ',minval(landmask),maxval(landmask) + end if +#endif + !--------------------------------------------------------------------------- + ! ... define lat-lon of vegetation map (1x1) + !--------------------------------------------------------------------------- + lat_veg(:) = (/ (-89.5_r8 + (i-1),i=1,nlat_veg ) /) + lon_veg(:) = (/ ( 0.5_r8 + (i-1),i=1,nlon_veg ) /) + lat_veg_edge(:) = (/ (-90.0_r8 + (i-1),i=1,nlat_veg+1) /) + lon_veg_edge(:) = (/ ( 0.0_r8 + (i-1),i=1,nlon_veg+1) /) + !--------------------------------------------------------------------------- + ! ... read soilw table if necessary + !--------------------------------------------------------------------------- + + if( do_soilw ) then + call soilw_inti( clim_soilw_file, nlon_veg, nlat_veg, soilw_map ) + end if + + !--------------------------------------------------------------------------- + ! ... regrid to model grid + !--------------------------------------------------------------------------- + + call interp_map( plon, plat, nlon_veg, nlat_veg, npft_veg, lat_veg, lat_veg_edge, & + lon_veg, lon_veg_edge, landmask, urban, lake, & + wetland, vegetation_map, soilw_map, do_soilw ) + + deallocate( vegetation_map, work, stat=astat ) + deallocate( lon_veg, lat_veg, lon_veg_edge, lat_veg_edge, stat=astat ) + deallocate( landmask, urban, lake, wetland, stat=astat ) + if( do_soilw ) then + deallocate( soilw_map, stat=astat ) + end if + endif ! Unstructured grid + + if (drydep_method == DD_XLND) then + return + endif + + !--------------------------------------------------------------------------- + ! ... read LAI based season indeces + !--------------------------------------------------------------------------- + call getfil (season_wes_file, locfn, 0) + call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) + !--------------------------------------------------------------------------- + ! ... get the dimensions + !--------------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'lat', dimid ) + ierr = pio_inq_dimlen( piofile, dimid, nlat_lai ) + ierr = pio_inq_dimid( piofile, 'pft', dimid ) + ierr = pio_inq_dimlen( piofile, dimid, npft_lai ) + !--------------------------------------------------------------------------- + ! ... allocate arrays + !--------------------------------------------------------------------------- + allocate( lat_lai(nlat_lai), wk_lai(nlat_lai,npft_lai,12), stat=astat ) + if( astat /= 0 ) then + write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat + call endrun + end if + !--------------------------------------------------------------------------- + ! ... read the latitude and the season indicies + !--------------------------------------------------------------------------- + ierr = pio_inq_varid( piofile, 'lat', vid ) + ierr = pio_get_var( piofile, vid, lat_lai ) + + ierr = pio_inq_varid( piofile, 'season_wes', vid ) + ierr = pio_get_var( piofile, vid, wk_lai ) + + call cam_pio_closefile( piofile ) + + + if(dycore_is('UNSTRUCTURED') ) then + ! For unstructured grids plon is the 1d horizontal grid size and plat=1 + allocate(clat(plon)) + call get_horiz_grid_d(plon, clat_d_out=clat) + jl = 1 + ju = plon + else + allocate(clat(plat)) + call get_horiz_grid_d(plat, clat_d_out=clat) + jl = 1 + ju = plat + end if + imin = 1 + do j = 1,ju + diff_min = 10._r8 + pos_min = -99 + target_lat = clat(j)*r2d + do i = imin,nlat_lai + if( abs(lat_lai(i) - target_lat) < diff_min ) then + diff_min = abs(lat_lai(i) - target_lat) + pos_min = i + end if + end do + if( pos_min < 0 ) then + write(iulog,*) 'dvel_inti: cannot find ',target_lat,' at j,pos_min,diff_min = ',j,pos_min,diff_min + write(iulog,*) 'dvel_inti: imin,nlat_lai = ',imin,nlat_lai + write(iulog,*) 'dvel_inti: lat_lai' + write(iulog,'(1p,10g12.5)') lat_lai(:) + call endrun + end if + if(dycore_is('UNSTRUCTURED') ) then + imin=1 + else + imin = pos_min + end if + index_season_lai_j(:,:) = wk_lai(pos_min,:,:) + + !--------------------------------------------------------------------------- + ! specify the season as the most frequent in the 11 vegetation classes + ! this was done to remove a banding problem in dvel (JFL Oct 04) + !--------------------------------------------------------------------------- + do m = 1,12 + num_seas = 0 + do l = 1,11 + do k = 1,5 + if( index_season_lai_j(l,m) == k ) then + num_seas(k) = num_seas(k) + 1 + exit + end if + end do + end do + + num_max = -1 + do k = 1,5 + if( num_seas(k) > num_max ) then + num_max = num_seas(k) + k_max = k + endif + end do + + index_season_lai(j,m) = k_max + end do + end do + + deallocate( lat_lai, wk_lai, clat, index_season_lai_j) + + end subroutine dvel_inti_xactive + + !------------------------------------------------------------------------------------- + subroutine get_landuse_and_soilw_from_file(do_soilw) + use ncdio_atm, only : infld + logical, intent(in) :: do_soilw + logical :: readvar + + type(file_desc_t) :: piofile + character(len=shr_kind_cl) :: locfn + logical :: lexist + + call getfil (drydep_srf_file, locfn, 1, lexist) + if(lexist) then + call cam_pio_openfile(piofile, locfn, PIO_NOWRITE) + + call infld('fraction_landuse', piofile, 'ncol','class',1,pcols,1,n_land_type, begchunk,endchunk, & + fraction_landuse, readvar, gridname='physgrid') + if (.not. readvar) then + write(iulog,*)'**************************************' + write(iulog,*)'get_landuse_and_soilw_from_file: INFO:' + write(iulog,*)' fraction_landuse not read from file: ' + write(iulog,*)' ', trim(locfn) + write(iulog,*)' setting all values to zero' + write(iulog,*)'**************************************' + fraction_landuse = 0._r8 + end if + + if(do_soilw) then + call infld('soilw', piofile, 'ncol','month',1,pcols,1,12, begchunk,endchunk, & + soilw_3d, readvar, gridname='physgrid') + end if + + call cam_pio_closefile(piofile) + else + call endrun('Unstructured grids require drydep_srf_file ') + end if + + + end subroutine get_landuse_and_soilw_from_file + + !------------------------------------------------------------------------------------- + subroutine interp_map( plon, plat, nlon_veg, nlat_veg, npft_veg, lat_veg, lat_veg_edge, & + lon_veg, lon_veg_edge, landmask, urban, lake, & + wetland, vegetation_map, soilw_map, do_soilw ) + + use mo_constants, only : r2d + use scamMod, only : latiop,loniop,scmlat,scmlon,scm_cambfb_mode + use shr_scam_mod , only: shr_scam_getCloseLatLon ! Standardized system subroutines + use cam_initfiles, only: initial_file_get_id + use dycore, only : dycore_is + use phys_grid, only : scatter_field_to_chunk + implicit none + + !------------------------------------------------------------------------------------- + ! ... dummy arguments + !------------------------------------------------------------------------------------- + integer, intent(in) :: plon, plat, nlon_veg, nlat_veg, npft_veg + real(r8), pointer :: soilw_map(:,:,:) + real(r8), intent(in) :: landmask(nlon_veg,nlat_veg) + real(r8), intent(in) :: urban(nlon_veg,nlat_veg) + real(r8), intent(in) :: lake(nlon_veg,nlat_veg) + real(r8), intent(in) :: wetland(nlon_veg,nlat_veg) + real(r8), intent(in) :: vegetation_map(nlon_veg,nlat_veg,npft_veg) + real(r8), intent(in) :: lon_veg(nlon_veg) + real(r8), intent(in) :: lon_veg_edge(nlon_veg+1) + real(r8), intent(in) :: lat_veg(nlat_veg) + real(r8), intent(in) :: lat_veg_edge(nlat_veg+1) + logical, intent(in) :: do_soilw + + !------------------------------------------------------------------------------------- + ! ... local variables + !------------------------------------------------------------------------------------- + real(r8) :: closelat,closelon + integer :: latidx,lonidx + + integer, parameter :: veg_ext = 20 + type(file_desc_t), pointer :: piofile + integer :: i, j, ii, jj, jl, ju, i_ndx, n + integer, dimension(plon+1) :: ind_lon + integer, dimension(plat+1) :: ind_lat + real(r8) :: total_land + real(r8), dimension(plon+1) :: lon_edge + real(r8), dimension(plat+1) :: lat_edge + real(r8) :: lat1, lat2, lon1, lon2 + real(r8) :: x1, x2, y1, y2, dx, dy + real(r8) :: area, total_area + real(r8), dimension(npft_veg+3) :: fraction + real(r8) :: total_soilw_area + real(r8) :: fraction_soilw + real(r8) :: total_soilw(12) + + real(r8), dimension(-veg_ext:nlon_veg+veg_ext) :: lon_veg_edge_ext + integer, dimension(-veg_ext:nlon_veg+veg_ext) :: mapping_ext + + real(r8), allocatable :: lam(:), phi(:), garea(:) + + logical, parameter :: has_npole = .true. + integer :: ploniop,platiop + real(r8) :: tmp_frac_lu(plon,n_land_type,plat), tmp_soilw_3d(plon,12,plat) + + if(dycore_is('UNSTRUCTURED') ) then + ! For unstructured grids plon is the 1d horizontal grid size and plat=1 + allocate(lam(plon), phi(plon)) + call get_horiz_grid_d(plon, clat_d_out=phi) + else + allocate(lam(plon), phi(plat)) + call get_horiz_grid_d(plat, clat_d_out=phi) + endif + call get_horiz_grid_d(plon, clon_d_out=lam) + + + jl = 1 + ju = plon + + if (single_column) then + if (scm_cambfb_mode) then + piofile => initial_file_get_id() + call shr_scam_getCloseLatLon(piofile%fh,scmlat,scmlon,closelat,closelon,latidx,lonidx) + ploniop=size(loniop) + platiop=size(latiop) + else + latidx=1 + lonidx=1 + ploniop=1 + platiop=1 + end if + + lon_edge(1) = loniop(lonidx) * r2d - .5_r8*(loniop(2) - loniop(1)) * r2d + + if (lonidx.lt.ploniop) then + lon_edge(2) = loniop(lonidx+1) * r2d - .5_r8*(loniop(2) - loniop(1)) * r2d + else + lon_edge(2) = lon_edge(1) + (loniop(2) - loniop(1)) * r2d + end if + + lat_edge(1) = latiop(latidx) * r2d - .5_r8*(latiop(2) - latiop(1)) * r2d + + if (latidx.lt.platiop) then + lat_edge(2) = latiop(latidx+1) * r2d - .5_r8*(latiop(2) - latiop(1)) * r2d + else + lat_edge(2) = lat_edge(1) + (latiop(2) - latiop(1)) * r2d + end if + else + do i = 1,plon + lon_edge(i) = lam(i) * r2d - .5_r8*(lam(2) - lam(1)) * r2d + end do + lon_edge(plon+1) = lon_edge(plon) + (lam(2) - lam(1)) * r2d + if( .not. has_npole ) then + do j = 1,plat+1 + lat_edge(j) = phi(j) * r2d - .5_r8*(phi(2) - phi(1)) * r2d + end do + else + do j = 1,plat + lat_edge(j) = phi(j) * r2d - .5_r8*(phi(2) - phi(1)) * r2d + end do + lat_edge(plat+1) = lat_edge(plat) + (phi(2) - phi(1)) * r2d + end if + end if + do j = 1,plat+1 + lat_edge(j) = min( lat_edge(j), 90._r8 ) + lat_edge(j) = max( lat_edge(j),-90._r8 ) + end do + + !------------------------------------------------------------------------------------- + ! wrap around the longitudes + !------------------------------------------------------------------------------------- + do i = -veg_ext,0 + lon_veg_edge_ext(i) = lon_veg_edge(nlon_veg+i) - 360._r8 + mapping_ext (i) = nlon_veg+i + end do + do i = 1,nlon_veg + lon_veg_edge_ext(i) = lon_veg_edge(i) + mapping_ext (i) = i + end do + do i = nlon_veg+1,nlon_veg+veg_ext + lon_veg_edge_ext(i) = lon_veg_edge(i-nlon_veg) + 360._r8 + mapping_ext (i) = i-nlon_veg + end do +#ifdef DEBUG + write(iulog,*) 'interp_map : lon_edge ',lon_edge + write(iulog,*) 'interp_map : lat_edge ',lat_edge + write(iulog,*) 'interp_map : mapping_ext ',mapping_ext +#endif + do j = 1,plon+1 + lon1 = lon_edge(j) + do i = -veg_ext,nlon_veg+veg_ext + dx = lon_veg_edge_ext(i ) - lon1 + dy = lon_veg_edge_ext(i+1) - lon1 + if( dx*dy <= 0._r8 ) then + ind_lon(j) = i + exit + end if + end do + end do + + do j = 1,plat+1 + lat1 = lat_edge(j) + do i = 1,nlat_veg + dx = lat_veg_edge(i ) - lat1 + dy = lat_veg_edge(i+1) - lat1 + if( dx*dy <= 0._r8 ) then + ind_lat(j) = i + exit + end if + end do + end do +#ifdef DEBUG + write(iulog,*) 'interp_map : ind_lon ',ind_lon + write(iulog,*) 'interp_map : ind_lat ',ind_lat +#endif + lat_loop : do j = 1,plat + lon_loop : do i = 1,plon + total_area = 0._r8 + fraction = 0._r8 + total_soilw(:) = 0._r8 + total_soilw_area = 0._r8 + do jj = ind_lat(j),ind_lat(j+1) + y1 = max( lat_edge(j),lat_veg_edge(jj) ) + y2 = min( lat_edge(j+1),lat_veg_edge(jj+1) ) + dy = (y2 - y1)/(lat_veg_edge(jj+1) - lat_veg_edge(jj)) + do ii =ind_lon(i),ind_lon(i+1) + i_ndx = mapping_ext(ii) + x1 = max( lon_edge(i),lon_veg_edge_ext(ii) ) + x2 = min( lon_edge(i+1),lon_veg_edge_ext(ii+1) ) + dx = (x2 - x1)/(lon_veg_edge_ext(ii+1) - lon_veg_edge_ext(ii)) + area = dx * dy + total_area = total_area + area + !----------------------------------------------------------------- + ! ... special case for ocean grid point + !----------------------------------------------------------------- + if( nint(landmask(i_ndx,jj)) == 0 ) then + fraction(npft_veg+1) = fraction(npft_veg+1) + area + else + do n = 1,npft_veg + fraction(n) = fraction(n) + vegetation_map(i_ndx,jj,n) * area + end do + fraction(npft_veg+1) = fraction(npft_veg+1) + area * lake (i_ndx,jj) + fraction(npft_veg+2) = fraction(npft_veg+2) + area * wetland(i_ndx,jj) + fraction(npft_veg+3) = fraction(npft_veg+3) + area * urban (i_ndx,jj) + !----------------------------------------------------------------- + ! ... check if land accounts for the whole area. + ! If not, the remaining area is in the ocean + !----------------------------------------------------------------- + total_land = sum(vegetation_map(i_ndx,jj,:)) & + + urban (i_ndx,jj) & + + lake (i_ndx,jj) & + + wetland(i_ndx,jj) + if( total_land < 1._r8 ) then + fraction(npft_veg+1) = fraction(npft_veg+1) + (1._r8 - total_land) * area + end if + !------------------------------------------------------------------------------------- + ! ... compute weighted average of soilw over grid (non-water only) + !------------------------------------------------------------------------------------- + if( do_soilw ) then + fraction_soilw = total_land - (lake(i_ndx,jj) + wetland(i_ndx,jj)) + total_soilw_area = total_soilw_area + fraction_soilw * area + total_soilw(:) = total_soilw(:) + fraction_soilw * area * soilw_map(i_ndx,jj,:) + end if + end if + end do + end do + !------------------------------------------------------------------------------------- + ! ... divide by total area of grid box + !------------------------------------------------------------------------------------- + fraction(:) = fraction(:)/total_area + !------------------------------------------------------------------------------------- + ! ... make sure we don't have too much or too little + !------------------------------------------------------------------------------------- + if( abs( sum(fraction) - 1._r8) > .001_r8 ) then + fraction(:) = fraction(:)/sum(fraction) + end if + !------------------------------------------------------------------------------------- + ! ... map to Wesely land classification + !------------------------------------------------------------------------------------- + + + + + tmp_frac_lu(i, 1, j) = fraction(20) + tmp_frac_lu(i, 2, j) = sum(fraction(16:17)) + tmp_frac_lu(i, 3, j) = sum(fraction(13:15)) + tmp_frac_lu(i, 4, j) = sum(fraction( 5: 9)) + tmp_frac_lu(i, 5, j) = sum(fraction( 2: 4)) + tmp_frac_lu(i, 6, j) = fraction(19) + tmp_frac_lu(i, 7, j) = fraction(18) + tmp_frac_lu(i, 8, j) = fraction( 1) + tmp_frac_lu(i, 9, j) = 0._r8 + tmp_frac_lu(i,10, j) = 0._r8 + tmp_frac_lu(i,11, j) = sum(fraction(10:12)) + if( do_soilw ) then + if( total_soilw_area > 0._r8 ) then + tmp_soilw_3d(i,:,j) = total_soilw(:)/total_soilw_area + else + tmp_soilw_3d(i,:,j) = -99._r8 + end if + end if + end do lon_loop + end do lat_loop + !------------------------------------------------------------------------------------- + ! ... reshape according to lat-lon blocks + !------------------------------------------------------------------------------------- + call scatter_field_to_chunk(1,n_land_type,1,plon,tmp_frac_lu,fraction_landuse) + if(do_soilw) call scatter_field_to_chunk(1,12,1,plon,tmp_soilw_3d,soilw_3d) + !------------------------------------------------------------------------------------- + ! ... make sure there are no out of range values + !------------------------------------------------------------------------------------- + where (fraction_landuse < 0._r8) fraction_landuse = 0._r8 + where (fraction_landuse > 1._r8) fraction_landuse = 1._r8 + + end subroutine interp_map + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine drydep_xactive( ncdate, sfc_temp, pressure_sfc, & + wind_speed, spec_hum, air_temp, pressure_10m, rain, & + snow, solar_flux, dvel, dflx, mmr, & + tv, soilw, rh, ncol, lonndx, latndx, lchnk, & + ocnfrc, icefrc, beglandtype, endlandtype ) + !------------------------------------------------------------------------------------- + ! code based on wesely (atmospheric environment, 1989, vol 23, p. 1293-1304) for + ! calculation of r_c, and on walcek et. al. (atmospheric enviroment, 1986, + ! vol. 20, p. 949-964) for calculation of r_a and r_b + ! + ! as suggested in walcek (u_i)(u*_i) = (u_a)(u*_a) + ! is kept constant where i represents a subgrid environment and a the + ! grid average environment. thus the calculation proceeds as follows: + ! va the grid averaged wind is calculated on dots + ! z0(i) the grid averaged roughness coefficient is calculated + ! ri(i) the grid averaged richardson number is calculated + ! --> the grid averaged (u_a)(u*_a) is calculated + ! --> subgrid scale u*_i is calculated assuming (u_i) given as above + ! --> final deposotion velocity is weighted average of subgrid scale velocities + ! + ! code written by P. Hess, rewritten in fortran 90 by JFL (August 2000) + ! modified by JFL to be used in MOZART-2 (October 2002) + !------------------------------------------------------------------------------------- + + use seq_drydep_mod, only: z0, rgso, rgss, h2_a, h2_b, h2_c, ri, rclo, rcls, rlu, rac + use seq_drydep_mod, only: seq_drydep_setHCoeff, foxd, drat + use physconst, only: tmelt + use seq_drydep_mod, only: drydep_method, DD_XLND + + implicit none + + !------------------------------------------------------------------------------------- + ! ... dummy arguments + !------------------------------------------------------------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: ncdate ! present date (yyyymmdd) + real(r8), intent(in) :: sfc_temp(pcols) ! surface temperature (K) + real(r8), intent(in) :: pressure_sfc(pcols) ! surface pressure (Pa) + real(r8), intent(in) :: wind_speed(pcols) ! 10 meter wind speed (m/s) + real(r8), intent(in) :: spec_hum(pcols) ! specific humidity (kg/kg) + real(r8), intent(in) :: rh(ncol,1) ! relative humidity + real(r8), intent(in) :: air_temp(pcols) ! surface air temperature (K) + real(r8), intent(in) :: pressure_10m(pcols) ! 10 meter pressure (Pa) + real(r8), intent(in) :: rain(pcols) + real(r8), intent(in) :: snow(pcols) ! snow height (m) + real(r8), intent(in) :: soilw(pcols) ! soil moisture fraction + real(r8), intent(in) :: solar_flux(pcols) ! direct shortwave radiation at surface (W/m^2) + real(r8), intent(in) :: tv(pcols) ! potential temperature + real(r8), intent(in) :: mmr(pcols,plev,gas_pcnst) ! constituent concentration (kg/kg) + real(r8), intent(out) :: dvel(ncol,gas_pcnst) ! deposition velocity (cm/s) + real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! deposition flux (/cm^2/s) + + integer, intent(in) :: latndx(pcols) ! chunk latitude indicies + integer, intent(in) :: lonndx(pcols) ! chunk longitude indicies + integer, intent(in) :: lchnk ! chunk number + + integer, intent(in), optional :: beglandtype + integer, intent(in), optional :: endlandtype + + real(r8), intent(in), optional :: ocnfrc(pcols) + real(r8), intent(in), optional :: icefrc(pcols) + + !------------------------------------------------------------------------------------- + ! ... local variables + !------------------------------------------------------------------------------------- + real(r8), parameter :: scaling_to_cm_per_s = 100._r8 + real(r8), parameter :: rain_threshold = 1.e-7_r8 ! of the order of 1cm/day expressed in m/s + + integer :: i, ispec, lt, m + integer :: sndx + integer :: month + + real(r8) :: slope = 0._r8 + real(r8) :: z0water ! revised z0 over water + real(r8) :: p ! pressure at midpoint first layer + real(r8) :: pg ! surface pressure + real(r8) :: es ! saturation vapor pressure + real(r8) :: ws ! saturation mixing ratio + real(r8) :: hvar ! constant to compute xmol + real(r8) :: h ! constant to compute xmol + real(r8) :: psih ! stability correction factor + real(r8) :: rs ! constant for calculating rsmx + real(r8) :: rmx ! resistance by vegetation + real(r8) :: zovl ! ratio of z to m-o length + real(r8) :: cvarb ! cvar averaged over landtypes + real(r8) :: bb ! b averaged over landtypes + real(r8) :: ustarb ! ustar averaged over landtypes + real(r8) :: tc(ncol) ! temperature in celsius + real(r8) :: cts(ncol) ! correction to rlu rcl and rgs for frost + + !------------------------------------------------------------------------------------- + ! local arrays: dependent on location and species + !------------------------------------------------------------------------------------- + real(r8), dimension(ncol,nddvels) :: heff + + !------------------------------------------------------------------------------------- + ! local arrays: dependent on location only + !------------------------------------------------------------------------------------- + integer :: index_season(ncol,n_land_type) + real(r8), dimension(ncol) :: tha ! atmospheric virtual potential temperature + real(r8), dimension(ncol) :: thg ! ground virtual potential temperature + real(r8), dimension(ncol) :: z ! height of lowest level + real(r8), dimension(ncol) :: va ! magnitude of v on cross points + real(r8), dimension(ncol) :: ribn ! richardson number + real(r8), dimension(ncol) :: qs ! saturation specific humidity + real(r8), dimension(ncol) :: crs ! multiplier to calculate crs + real(r8), dimension(ncol) :: rdc ! part of lower canopy resistance + real(r8), dimension(ncol) :: uustar ! u*ustar (assumed constant over grid) + real(r8), dimension(ncol) :: z0b ! average roughness length over grid + real(r8), dimension(ncol) :: wrk ! work array + real(r8), dimension(ncol) :: term ! work array + real(r8), dimension(ncol) :: resc ! work array + real(r8), dimension(ncol) :: lnd_frc ! work array + logical, dimension(ncol) :: unstable + logical, dimension(ncol) :: has_rain + logical, dimension(ncol) :: has_dew + + !------------------------------------------------------------------------------------- + ! local arrays: dependent on location and landtype + !------------------------------------------------------------------------------------- + real(r8), dimension(ncol,n_land_type) :: rds ! resistance for deposition of sulfate + real(r8), dimension(ncol,n_land_type) :: b ! buoyancy parameter for unstable conditions + real(r8), dimension(ncol,n_land_type) :: cvar ! height parameter + real(r8), dimension(ncol,n_land_type) :: ustar ! friction velocity + real(r8), dimension(ncol,n_land_type) :: xmol ! monin-obukhov length + + !------------------------------------------------------------------------------------- + ! local arrays: dependent on location, landtype and species + !------------------------------------------------------------------------------------- + real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rsmx ! vegetative resistance (plant mesophyll) + real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rclx ! lower canopy resistance + real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rlux ! vegetative resistance (upper canopy) + real(r8), dimension(ncol,n_land_type) :: rlux_o3 ! vegetative resistance (upper canopy) + real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rgsx ! ground resistance + real(r8) :: pmid(ncol,1) ! for seasalt aerosols + real(r8) :: tfld(ncol,1) ! for seasalt aerosols + real(r8) :: fact, vds + real(r8) :: rc ! combined surface resistance + real(r8) :: var_soilw, dv_soil_h2, fact_h2 ! h2 dvel wrking variables + logical :: fr_lnduse(ncol,n_land_type) ! wrking array + real(r8) :: dewm ! multiplier for rs when dew occurs + + real(r8) :: lcl_frc_landuse(ncol,n_land_type) + + integer :: beglt, endlt + + !------------------------------------------------------------------------------------- + ! jfl : mods for PAN + !------------------------------------------------------------------------------------- + real(r8) :: dv_pan + real(r8) :: c0_pan(11) = (/ 0.000_r8, 0.006_r8, 0.002_r8, 0.009_r8, 0.015_r8, & + 0.006_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.002_r8, 0.002_r8 /) + real(r8) :: k_pan (11) = (/ 0.000_r8, 0.010_r8, 0.005_r8, 0.004_r8, 0.003_r8, & + 0.005_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.075_r8, 0.002_r8 /) + + if (present( beglandtype)) then + beglt = beglandtype + else + beglt = 1 + endif + if (present( endlandtype)) then + endlt = endlandtype + else + endlt = n_land_type + endif + + !------------------------------------------------------------------------------------- + ! initialize + !------------------------------------------------------------------------------------- + do m = 1,gas_pcnst + dvel(:,m) = 0._r8 + end do + + if( all( .not. has_dvel(:) ) ) then + return + end if + + !------------------------------------------------------------------------------------- + ! define species-dependent parameters (temperature dependent) + !------------------------------------------------------------------------------------- + call seq_drydep_setHCoeff( ncol, sfc_temp, heff ) + + do lt = 1,n_land_type + dep_ra (:,lt,lchnk) = 0._r8 + dep_rb (:,lt,lchnk) = 0._r8 + rds(:,lt) = 0._r8 + end do + + !------------------------------------------------------------------------------------- + ! ... set month + !------------------------------------------------------------------------------------- + month = mod( ncdate,10000 )/100 + + !------------------------------------------------------------------------------------- + ! define which season (relative to Northern hemisphere climate) + !------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------- + ! define season index based on fixed LAI + !------------------------------------------------------------------------------------- + if ( drydep_method == DD_XLND ) then + index_season = 4 + else + do i = 1,ncol + index_season(i,:) = index_season_lai(latndx(i),month) + end do + endif + !------------------------------------------------------------------------------------- + ! special case for snow covered terrain + !------------------------------------------------------------------------------------- + do i = 1,ncol + if( snow(i) > .01_r8 ) then + index_season(i,:) = 4 + end if + end do + !------------------------------------------------------------------------------------- + ! scale rain and define logical arrays + !------------------------------------------------------------------------------------- + has_rain(:ncol) = rain(:ncol) > rain_threshold + + !------------------------------------------------------------------------------------- + ! loop over longitude points + !------------------------------------------------------------------------------------- + col_loop : do i = 1,ncol + p = pressure_10m(i) + pg = pressure_sfc(i) + !------------------------------------------------------------------------------------- + ! potential temperature + !------------------------------------------------------------------------------------- + tha(i) = air_temp(i) * (p00/p )**rovcp * (1._r8 + .61_r8*spec_hum(i)) + thg(i) = sfc_temp(i) * (p00/pg)**rovcp * (1._r8 + .61_r8*spec_hum(i)) + !------------------------------------------------------------------------------------- + ! height of 1st level + !------------------------------------------------------------------------------------- + z(i) = - r/grav * air_temp(i) * (1._r8 + .61_r8*spec_hum(i)) * log(p/pg) + !------------------------------------------------------------------------------------- + ! wind speed + !------------------------------------------------------------------------------------- + va(i) = max( .01_r8,wind_speed(i) ) + !------------------------------------------------------------------------------------- + ! Richardson number + !------------------------------------------------------------------------------------- + ribn(i) = z(i) * grav * (tha(i) - thg(i))/thg(i) / (va(i)*va(i)) + ribn(i) = min( ribn(i),ric ) + unstable(i) = ribn(i) < 0._r8 + !------------------------------------------------------------------------------------- + ! saturation vapor pressure (Pascals) + ! saturation mixing ratio + ! saturation specific humidity + !------------------------------------------------------------------------------------- + es = 611._r8*exp( 5414.77_r8*(sfc_temp(i) - tmelt)/(tmelt*sfc_temp(i)) ) + ws = .622_r8*es/(pg - es) + qs(i) = ws/(1._r8 + ws) + has_dew(i) = .false. + if( qs(i) <= spec_hum(i) ) then + has_dew(i) = .true. + end if + if( sfc_temp(i) < tmelt ) then + has_dew(i) = .false. + end if + !------------------------------------------------------------------------------------- + ! constant in determining rs + !------------------------------------------------------------------------------------- + tc(i) = sfc_temp(i) - tmelt + if( sfc_temp(i) > tmelt .and. sfc_temp(i) < 313.15_r8 ) then + crs(i) = (1._r8 + (200._r8/(solar_flux(i) + .1_r8))**2) * (400._r8/(tc(i)*(40._r8 - tc(i)))) + else + crs(i) = large_value + end if + !------------------------------------------------------------------------------------- + ! rdc (lower canopy res) + !------------------------------------------------------------------------------------- + rdc(i) = 100._r8*(1._r8 + 1000._r8/(solar_flux(i) + 10._r8))/(1._r8 + 1000._r8*slope) + end do col_loop + + !------------------------------------------------------------------------------------- + ! ... form working arrays + !------------------------------------------------------------------------------------- + do lt = 1,n_land_type + do i=1,ncol + if ( drydep_method == DD_XLND ) then + lcl_frc_landuse(i,lt) = 0._r8 + else + lcl_frc_landuse(i,lt) = fraction_landuse(i,lt,lchnk) + endif + enddo + end do + if ( present(ocnfrc) .and. present(icefrc) ) then + do i=1,ncol + ! land type 7 is used for ocean + ! land type 8 is used for sea ice + lcl_frc_landuse(i,7) = ocnfrc(i) + lcl_frc_landuse(i,8) = icefrc(i) + enddo + endif + do lt = 1,n_land_type + do i=1,ncol + fr_lnduse(i,lt) = lcl_frc_landuse(i,lt) > 0._r8 + enddo + end do + + !------------------------------------------------------------------------------------- + ! find grid averaged z0: z0bar (the roughness length) z_o=exp[S(f_i*ln(z_oi))] + ! this is calculated so as to find u_i, assuming u*u=u_i*u_i + !------------------------------------------------------------------------------------- + z0b(:) = 0._r8 + do lt = 1,n_land_type + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + z0b(i) = z0b(i) + lcl_frc_landuse(i,lt) * log( z0(index_season(i,lt),lt) ) + end if + end do + end do + + !------------------------------------------------------------------------------------- + ! find the constant velocity uu*=(u_i)(u*_i) + !------------------------------------------------------------------------------------- + do i = 1,ncol + z0b(i) = exp( z0b(i) ) + cvarb = vonkar/log( z(i)/z0b(i) ) + !------------------------------------------------------------------------------------- + ! unstable and stable cases + !------------------------------------------------------------------------------------- + if( unstable(i) ) then + bb = 9.4_r8*(cvarb**2)*sqrt( abs(ribn(i))*z(i)/z0b(i) ) + ustarb = cvarb * va(i) * sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8 + 7.4_r8*bb)) ) + else + ustarb = cvarb * va(i)/(1._r8 + 4.7_r8*ribn(i)) + end if + uustar(i) = va(i)*ustarb + end do + + !------------------------------------------------------------------------------------- + ! calculate the friction velocity for each land type u_i=uustar/u*_i + !------------------------------------------------------------------------------------- + do lt = beglt,endlt + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + if( unstable(i) ) then + cvar(i,lt) = vonkar/log( z(i)/z0(index_season(i,lt),lt) ) + b(i,lt) = 9.4_r8*(cvar(i,lt)**2)* sqrt( abs(ribn(i))*z(i)/z0(index_season(i,lt),lt) ) + ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)*sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8 + 7.4_r8*b(i,lt))) ) ) + else + cvar(i,lt) = vonkar/log( z(i)/z0(index_season(i,lt),lt) ) + ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)/(1._r8 + 4.7_r8*ribn(i)) ) + end if + end if + end do + end do + + !------------------------------------------------------------------------------------- + ! revise calculation of friction velocity and z0 over water + !------------------------------------------------------------------------------------- + lt = 7 + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + if( unstable(i) ) then + z0water = (.016_r8*(ustar(i,lt)**2)/grav) + diffk/(9.1_r8*ustar(i,lt)) + cvar(i,lt) = vonkar/(log( z(i)/z0water )) + b(i,lt) = 9.4_r8*(cvar(i,lt)**2)*sqrt( abs(ribn(i))*z(i)/z0water ) + ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)* sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8+ 7.4_r8*b(i,lt))) ) ) + else + z0water = (.016_r8*(ustar(i,lt)**2)/grav) + diffk/(9.1_r8*ustar(i,lt)) + cvar(i,lt) = vonkar/(log(z(i)/z0water)) + ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)/(1._r8 + 4.7_r8*ribn(i)) ) + end if + end if + end do + + !------------------------------------------------------------------------------------- + ! compute monin-obukhov length for unstable and stable conditions/ sublayer resistance + !------------------------------------------------------------------------------------- + do lt = beglt,endlt + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + hvar = (va(i)/0.74_r8) * (tha(i) - thg(i)) * (cvar(i,lt)**2) + if( unstable(i) ) then ! unstable + h = hvar*(1._r8 - (9.4_r8*ribn(i)/(1._r8 + 5.3_r8*b(i,lt)))) + else + h = hvar/((1._r8+4.7_r8*ribn(i))**2) + end if + xmol(i,lt) = thg(i) * ustar(i,lt) * ustar(i,lt) / (vonkar * grav * h) + end if + end do + end do + + !------------------------------------------------------------------------------------- + ! psih + !------------------------------------------------------------------------------------- + do lt = beglt,endlt + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + if( xmol(i,lt) < 0._r8 ) then + zovl = z(i)/xmol(i,lt) + zovl = max( -1._r8,zovl ) + psih = exp( .598_r8 + .39_r8*log( -zovl ) - .09_r8*(log( -zovl ))**2 ) + vds = 2.e-3_r8*ustar(i,lt) * (1._r8 + (300/(-xmol(i,lt)))**0.666_r8) + else + zovl = z(i)/xmol(i,lt) + zovl = min( 1._r8,zovl ) + psih = -5._r8 * zovl + vds = 2.e-3_r8*ustar(i,lt) + end if + dep_ra (i,lt,lchnk) = (vonkar - psih*cvar(i,lt))/(ustar(i,lt)*vonkar*cvar(i,lt)) + dep_rb (i,lt,lchnk) = (2._r8/(vonkar*ustar(i,lt))) * crb + rds(i,lt) = 1._r8/vds + end if + end do + end do + + !------------------------------------------------------------------------------------- + ! surface resistance : depends on both land type and species + ! land types are computed seperately, then resistance is computed as average of values + ! following wesely rc=(1/(rs+rm) + 1/rlu +1/(rdc+rcl) + 1/(rac+rgs))**-1 + ! + ! compute rsmx = 1/(rs+rm) : multiply by 3 if surface is wet + !------------------------------------------------------------------------------------- + species_loop1 : do ispec = 1,gas_pcnst + if( has_dvel(ispec) ) then + m = map_dvel(ispec) + do lt = beglt,endlt + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + sndx = index_season(i,lt) + if( ispec == o3_ndx .or. ispec == o3a_ndx .or. ispec == so2_ndx ) then + rmx = 0._r8 + else + rmx = 1._r8/(heff(i,m)/3000._r8 + 100._r8*foxd(m)) + end if + cts(i) = 1000._r8*exp( - tc(i) - 4._r8 ) ! correction for frost + rgsx(i,lt,ispec) = cts(i) + 1._r8/((heff(i,m)/(1.e5_r8*rgss(sndx,lt))) + (foxd(m)/rgso(sndx,lt))) + !------------------------------------------------------------------------------------- + ! special case for H2 and CO;; CH4 is set ot a fraction of dv(H2) + !------------------------------------------------------------------------------------- + if( ispec == h2_ndx .or. ispec == co_ndx .or. ispec == ch4_ndx ) then + if( ispec == co_ndx ) then + fact_h2 = 1.0_r8 + elseif ( ispec == h2_ndx ) then + fact_h2 = 0.5_r8 + elseif ( ispec == ch4_ndx ) then + fact_h2 = 50.0_r8 + end if + !------------------------------------------------------------------------------------- + ! no deposition on snow, ice, desert, and water + !------------------------------------------------------------------------------------- + if( lt == 1 .or. lt == 7 .or. lt == 8 .or. sndx == 4 ) then + rgsx(i,lt,ispec) = large_value + else + var_soilw = max( .1_r8,min( soilw(i),.3_r8 ) ) + if( lt == 3 ) then + var_soilw = log( var_soilw ) + end if + dv_soil_h2 = h2_c(lt) + var_soilw*(h2_b(lt) + var_soilw*h2_a(lt)) + if( dv_soil_h2 > 0._r8 ) then + rgsx(i,lt,ispec) = fact_h2/(dv_soil_h2*1.e-4_r8) + end if + end if + end if + if( lt == 7 ) then + rclx(i,lt,ispec) = large_value + rsmx(i,lt,ispec) = large_value + rlux(i,lt,ispec) = large_value + else + rs = ri(sndx,lt)*crs(i) + if ( has_dew(i) .or. has_rain(i) ) then + dewm = 3._r8 + else + dewm = 1._r8 + end if + rsmx(i,lt,ispec) = (dewm*rs*drat(m) + rmx) + !------------------------------------------------------------------------------------- + ! jfl : special case for PAN + !------------------------------------------------------------------------------------- + if( ispec == pan_ndx .or. ispec == xpan_ndx ) then + dv_pan = c0_pan(lt) * (1._r8 - exp( -k_pan(lt)*(dewm*rs*drat(m))*1.e-2_r8 )) + if( dv_pan > 0._r8 .and. sndx /= 4 ) then + rsmx(i,lt,ispec) = ( 1._r8/dv_pan ) + end if + end if + rclx(i,lt,ispec) = cts(i) + 1._r8/((heff(i,m)/(1.e5_r8*rcls(sndx,lt))) + (foxd(m)/rclo(sndx,lt))) + rlux(i,lt,ispec) = cts(i) + rlu(sndx,lt)/(1.e-5_r8*heff(i,m) + foxd(m)) + end if + end if + end do + end do + end if + end do species_loop1 + + do lt = beglt,endlt + if( lt /= 7 ) then + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + sndx = index_season(i,lt) + !------------------------------------------------------------------------------------- + ! ... no effect if sfc_temp < O C + !------------------------------------------------------------------------------------- + if( sfc_temp(i) > tmelt ) then + if( has_dew(i) ) then + rlux_o3(i,lt) = 3000._r8*rlu(sndx,lt)/(1000._r8 + rlu(sndx,lt)) + if( o3_ndx > 0 ) then + rlux(i,lt,o3_ndx) = rlux_o3(i,lt) + endif + if( o3a_ndx > 0 ) then + rlux(i,lt,o3a_ndx) = rlux_o3(i,lt) + endif + end if + if( has_rain(i) ) then + ! rlux(i,lt,o3_ndx) = 1./(1.e-3 + (1./(3.*rlu(sndx,lt)))) + rlux_o3(i,lt) = 3000._r8*rlu(sndx,lt)/(1000._r8 + 3._r8*rlu(sndx,lt)) + if( o3_ndx > 0 ) then + rlux(i,lt,o3_ndx) = rlux_o3(i,lt) + endif + if( o3a_ndx > 0 ) then + rlux(i,lt,o3a_ndx) = rlux_o3(i,lt) + endif + end if + end if + + if ( o3_ndx > 0 ) then + rclx(i,lt,o3_ndx) = cts(i) + rclo(index_season(i,lt),lt) + rlux(i,lt,o3_ndx) = cts(i) + rlux(i,lt,o3_ndx) + end if + if ( o3a_ndx > 0 ) then + rclx(i,lt,o3a_ndx) = cts(i) + rclo(index_season(i,lt),lt) + rlux(i,lt,o3a_ndx) = cts(i) + rlux(i,lt,o3a_ndx) + end if + + end if + end do + end if + end do + + species_loop2 : do ispec = 1,gas_pcnst + m = map_dvel(ispec) + if( has_dvel(ispec) ) then + if( ispec /= o3_ndx .and. ispec /= o3a_ndx .and. ispec /= so2_ndx ) then + do lt = beglt,endlt + if( lt /= 7 ) then + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + !------------------------------------------------------------------------------------- + ! no effect if sfc_temp < O C + !------------------------------------------------------------------------------------- + if( sfc_temp(i) > tmelt ) then + if( has_dew(i) ) then + rlux(i,lt,ispec) = 1._r8/((1._r8/(3._r8*rlux(i,lt,ispec))) & + + 1.e-7_r8*heff(i,m) + foxd(m)/rlux_o3(i,lt)) + end if + end if + + end if + end do + end if + end do + else if( ispec == so2_ndx ) then + do lt = beglt,endlt + if( lt /= 7 ) then + do i = 1,ncol + if( fr_lnduse(i,lt) ) then + !------------------------------------------------------------------------------------- + ! no effect if sfc_temp < O C + !------------------------------------------------------------------------------------- + if( sfc_temp(i) > tmelt ) then + if( qs(i) <= spec_hum(i) ) then + rlux(i,lt,ispec) = 100._r8 + end if + if( has_rain(i) ) then + ! rlux(i,lt,ispec) = 1./(2.e-4 + (1./(3.*rlu(index_season(i,lt),lt)))) + rlux(i,lt,ispec) = 15._r8*rlu(index_season(i,lt),lt)/(5._r8 + 3.e-3_r8*rlu(index_season(i,lt),lt)) + end if + end if + rclx(i,lt,ispec) = cts(i) + rcls(index_season(i,lt),lt) + rlux(i,lt,ispec) = cts(i) + rlux(i,lt,ispec) + + end if + end do + end if + end do + do i = 1,ncol + if( fr_lnduse(i,1) .and. (has_dew(i) .or. has_rain(i)) ) then + rlux(i,1,ispec) = 50._r8 + end if + end do + end if + end if + end do species_loop2 + + !------------------------------------------------------------------------------------- + ! compute rc + !------------------------------------------------------------------------------------- + term(:ncol) = 1.e-2_r8 * pressure_10m(:ncol) / (r*tv(:ncol)) + species_loop3 : do ispec = 1,gas_pcnst + if( has_dvel(ispec) ) then + wrk(:) = 0._r8 + lt_loop: do lt = beglt,endlt + do i = 1,ncol + if (fr_lnduse(i,lt)) then + resc(i) = 1._r8/( 1._r8/rsmx(i,lt,ispec) + 1._r8/rlux(i,lt,ispec) & + + 1._r8/(rdc(i) + rclx(i,lt,ispec)) & + + 1._r8/(rac(index_season(i,lt),lt) + rgsx(i,lt,ispec))) + + resc(i) = max( 10._r8,resc(i) ) + + lnd_frc(i) = lcl_frc_landuse(i,lt) + endif + enddo + !------------------------------------------------------------------------------------- + ! ... compute average deposition velocity + !------------------------------------------------------------------------------------- + select case( solsym(ispec) ) + case( 'SO2' ) + if( lt == 7 ) then + where( fr_lnduse(:ncol,lt) ) + ! assume no surface resistance for SO2 over water` + wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk)) + endwhere + else + where( fr_lnduse(:ncol,lt) ) + wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk) + resc(:)) + endwhere + end if + + ! JFL - increase in dry deposition of SO2 to improve bias over US/Europe + wrk(:) = wrk(:) * 2._r8 + + case( 'SO4' ) + where( fr_lnduse(:ncol,lt) ) + wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + rds(:,lt)) + endwhere + case( 'NH4', 'NH4NO3', 'XNH4NO3' ) + where( fr_lnduse(:ncol,lt) ) + wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + 0.5_r8*rds(:,lt)) + endwhere + + !------------------------------------------------------------------------------------- + ! ... special case for Pb (for consistency with offline code) + !------------------------------------------------------------------------------------- + case( 'Pb' ) + if( lt == 7 ) then + where( fr_lnduse(:ncol,lt) ) + wrk(:) = wrk(:) + lnd_frc(:) * 0.05e-2_r8 + endwhere + else + where( fr_lnduse(:ncol,lt) ) + wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.2e-2_r8 + endwhere + end if + + !------------------------------------------------------------------------------------- + ! ... special case for carbon aerosols + !------------------------------------------------------------------------------------- + case( 'CB1', 'CB2', 'OC1', 'OC2', 'SOAM', 'SOAI', 'SOAT', 'SOAB','SOAX' ) + if ( drydep_method == DD_XLND ) then + where( fr_lnduse(:ncol,lt) ) + wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.10e-2_r8 + endwhere + else + wrk(:ncol) = 0.10e-2_r8 + endif + + !------------------------------------------------------------------------------------- + ! deposition over ocean for HCN, CH3CN + ! velocity estimated from aircraft measurements (E.Apel, INTEX-B) + !------------------------------------------------------------------------------------- + case( 'HCN','CH3CN' ) + if( lt == 7 ) then ! over ocean only + where( fr_lnduse(:ncol,lt) .and. snow(:ncol) < 0.01_r8 ) + wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.2e-2_r8 + endwhere + end if + case default + where( fr_lnduse(:ncol,lt) ) + wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk) + resc(:ncol)) + endwhere + end select + end do lt_loop + dvel(:ncol,ispec) = wrk(:ncol) * scaling_to_cm_per_s + dflx(:ncol,ispec) = term(:ncol) * dvel(:ncol,ispec) * mmr(:ncol,plev,ispec) + end if + + end do species_loop3 + + if ( beglt > 1 ) return + + !------------------------------------------------------------------------------------- + ! ... special adjustments + !------------------------------------------------------------------------------------- + if( mpan_ndx > 0 ) then + if( has_dvel(mpan_ndx) ) then + dvel(:ncol,mpan_ndx) = dvel(:ncol,mpan_ndx)/3._r8 + dflx(:ncol,mpan_ndx) = term(:ncol) * dvel(:ncol,mpan_ndx) * mmr(:ncol,plev,mpan_ndx) + end if + end if + if( xmpan_ndx > 0 ) then + if( has_dvel(xmpan_ndx) ) then + dvel(:ncol,xmpan_ndx) = dvel(:ncol,xmpan_ndx)/3._r8 + dflx(:ncol,xmpan_ndx) = term(:ncol) * dvel(:ncol,xmpan_ndx) * mmr(:ncol,plev,xmpan_ndx) + end if + end if + + ! HCOOH, use CH3COOH dep.vel + if( hcooh_ndx > 0) then + if( has_dvel(hcooh_ndx) ) then + dvel(:ncol,hcooh_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,hcooh_ndx) = term(:ncol) * dvel(:ncol,hcooh_ndx) * mmr(:ncol,plev,hcooh_ndx) + end if + end if +! +! SOG species +! + if( sogm_ndx > 0) then + if( has_dvel(sogm_ndx) ) then + dvel(:ncol,sogm_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,sogm_ndx) = term(:ncol) * dvel(:ncol,sogm_ndx) * mmr(:ncol,plev,sogm_ndx) + end if + end if + if( sogi_ndx > 0) then + if( has_dvel(sogi_ndx) ) then + dvel(:ncol,sogi_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,sogi_ndx) = term(:ncol) * dvel(:ncol,sogi_ndx) * mmr(:ncol,plev,sogi_ndx) + end if + end if + if( sogt_ndx > 0) then + if( has_dvel(sogt_ndx) ) then + dvel(:ncol,sogt_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,sogt_ndx) = term(:ncol) * dvel(:ncol,sogt_ndx) * mmr(:ncol,plev,sogt_ndx) + end if + end if + if( sogb_ndx > 0) then + if( has_dvel(sogb_ndx) ) then + dvel(:ncol,sogb_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,sogb_ndx) = term(:ncol) * dvel(:ncol,sogb_ndx) * mmr(:ncol,plev,sogb_ndx) + end if + end if + if( sogx_ndx > 0) then + if( has_dvel(sogx_ndx) ) then + dvel(:ncol,sogx_ndx) = dvel(:ncol,ch3cooh_ndx) + dflx(:ncol,sogx_ndx) = term(:ncol) * dvel(:ncol,sogx_ndx) * mmr(:ncol,plev,sogx_ndx) + end if + end if +! + end subroutine drydep_xactive + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine soilw_inti( ncfile, nlon_veg, nlat_veg, soilw_map ) + !------------------------------------------------------------------ + ! ... read primary soil moisture table + !------------------------------------------------------------------ + + use time_manager, only : get_calday + + implicit none + + !------------------------------------------------------------------ + ! ... dummy args + !------------------------------------------------------------------ + integer, intent(in) :: & + nlon_veg, & + nlat_veg + real(r8), pointer :: soilw_map(:,:,:) + character(len=*), intent(in) :: ncfile ! file name of netcdf file containing data + + !------------------------------------------------------------------ + ! ... local variables + !------------------------------------------------------------------ + integer :: gndx = 0 + integer :: nlat, & ! # of lats in soilw file + nlon ! # of lons in soilw file + integer :: i, ip, k, m + integer :: j, jl, ju + integer :: lev, day, ierr + type(file_desc_t) :: piofile + type(var_desc_t) :: vid + + integer :: dimid_lat, dimid_lon, dimid_time + integer :: dates(12) = (/ 116, 214, 316, 415, 516, 615, & + 716, 816, 915, 1016, 1115, 1216 /) + + character(len=shr_kind_cl) :: locfn + + !----------------------------------------------------------------------- + ! ... open netcdf file + !----------------------------------------------------------------------- + call getfil (ncfile, locfn, 0) + call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) + + !----------------------------------------------------------------------- + ! ... get longitudes + !----------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'lon', dimid_lon ) + ierr = pio_inq_dimlen( piofile, dimid_lon, nlon ) + if( nlon /= nlon_veg ) then + write(iulog,*) 'soilw_inti: soil and vegetation lons differ; ',nlon, nlon_veg + call endrun + end if + !----------------------------------------------------------------------- + ! ... get latitudes + !----------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'lat', dimid_lat ) + ierr = pio_inq_dimlen( piofile, dimid_lat, nlat ) + if( nlat /= nlat_veg ) then + write(iulog,*) 'soilw_inti: soil and vegetation lats differ; ',nlat, nlat_veg + call endrun + end if + !----------------------------------------------------------------------- + ! ... set times (days of year) + !----------------------------------------------------------------------- + ierr = pio_inq_dimid( piofile, 'time', dimid_time ) + ierr = pio_inq_dimlen( piofile, dimid_time, ndays ) + if( ndays /= 12 ) then + write(iulog,*) 'soilw_inti: dataset not a cyclical year' + call endrun + end if + allocate( days(ndays),stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'soilw_inti: days allocation error = ',ierr + call endrun + end if + do m = 1,min(12,ndays) + days(m) = get_calday( dates(m), 0 ) + end do + + !------------------------------------------------------------------ + ! ... allocate arrays + !------------------------------------------------------------------ + allocate( soilw_map(nlon,nlat,ndays), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'soilw_inti: soilw_map allocation error = ',ierr + call endrun + end if + + !------------------------------------------------------------------ + ! ... read in the soil moisture + !------------------------------------------------------------------ + ierr = pio_inq_varid( piofile, 'SOILW', vid ) + ierr = pio_get_var( piofile, vid, soilw_map ) + !------------------------------------------------------------------ + ! ... close file + !------------------------------------------------------------------ + call cam_pio_closefile( piofile ) + + end subroutine soilw_inti + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine chk_soilw( calday ) + !-------------------------------------------------------------------- + ! ... check timing for ub values + !-------------------------------------------------------------------- + + use mo_constants, only : dayspy + + implicit none + + !-------------------------------------------------------------------- + ! ... dummy args + !-------------------------------------------------------------------- + real(r8), intent(in) :: calday + + !-------------------------------------------------------------------- + ! ... local variables + !-------------------------------------------------------------------- + integer :: m, upper + real(r8) :: numer, denom + + !-------------------------------------------------------- + ! ... setup the time interpolation + !-------------------------------------------------------- + if( calday < days(1) ) then + next = 1 + last = ndays + else + if( days(ndays) < dayspy ) then + upper = ndays + else + upper = ndays - 1 + end if + do m = upper,1,-1 + if( calday >= days(m) ) then + exit + end if + end do + last = m + next = mod( m,ndays ) + 1 + end if + numer = calday - days(last) + denom = days(next) - days(last) + if( numer < 0._r8 ) then + numer = dayspy + numer + end if + if( denom < 0._r8 ) then + denom = dayspy + denom + end if + dels = max( min( 1._r8,numer/denom ),0._r8 ) + + end subroutine chk_soilw + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + subroutine set_soilw( soilw, lchnk, calday ) + !-------------------------------------------------------------------- + ! ... set the soil moisture + !-------------------------------------------------------------------- + + implicit none + + !-------------------------------------------------------------------- + ! ... dummy args + !-------------------------------------------------------------------- + real(r8), intent(inout) :: soilw(pcols) + integer, intent(in) :: lchnk ! chunk indice + real(r8), intent(in) :: calday + + + integer :: i, ilon,ilat + + call chk_soilw( calday ) + + soilw(:) = soilw_3d(:,last,lchnk) + dels *( soilw_3d(:,next,lchnk) - soilw_3d(:,last,lchnk)) + + end subroutine set_soilw + + !------------------------------------------------------------------------------------- + !------------------------------------------------------------------------------------- + function has_drydep( name ) + + implicit none + + character(len=*), intent(in) :: name + + logical :: has_drydep + integer :: i + + has_drydep = .false. + + do i=1,nddvels + if ( trim(name) == trim(drydep_list(i)) ) then + has_drydep = .true. + exit + endif + enddo + + endfunction has_drydep + +end module mo_drydep diff --git a/src/chemistry/oslo_aero/mo_extfrc.F90 b/src/chemistry/oslo_aero/mo_extfrc.F90 new file mode 100644 index 0000000000..85efe5e92e --- /dev/null +++ b/src/chemistry/oslo_aero/mo_extfrc.F90 @@ -0,0 +1,416 @@ +module mo_extfrc + !--------------------------------------------------------------- + ! ... insitu forcing module + !--------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + use ppgrid, only : pver, pverp + use chem_mods, only : gas_pcnst, extcnt, extfrc_lst, frc_from_dataset, adv_mass + use spmd_utils, only : masterproc + use cam_abortutils,only : endrun + use cam_history, only : addfld, outfld, add_default, horiz_only + use cam_history_support,only : max_fieldname_len + use cam_logfile, only : iulog + use tracer_data, only : trfld,trfile + use mo_constants, only : avogadro + + implicit none + + type :: forcing + integer :: frc_ndx + real(r8) :: scalefactor + character(len=265):: filename + character(len=16) :: species + integer :: nsectors + character(len=32),pointer :: sectors(:) + type(trfld), pointer :: fields(:) + type(trfile) :: file + end type forcing + + private + public :: extfrc_inti + public :: extfrc_set + public :: extfrc_timestep_init + + save + + integer, parameter :: time_span = 1 + + character(len=256) :: filename + + type(forcing), allocatable :: forcings(:) + integer :: n_frc_files = 0 + +contains + + subroutine extfrc_inti( extfrc_specifier, extfrc_type_in, extfrc_cycle_yr, extfrc_fixed_ymd, extfrc_fixed_tod) + + !----------------------------------------------------------------------- + ! ... initialize the surface forcings + !----------------------------------------------------------------------- + use cam_pio_utils, only : cam_pio_openfile, cam_pio_closefile + use pio, only : pio_inquire, pio_inq_varndims + use pio, only : pio_inq_varname, pio_nowrite, file_desc_t + use pio, only : pio_get_att, PIO_NOERR, PIO_GLOBAL + use pio, only : pio_seterrorhandling, PIO_BCAST_ERROR,PIO_INTERNAL_ERROR + use mo_chem_utls, only : get_extfrc_ndx + use chem_mods, only : frc_from_dataset + use tracer_data, only : trcdata_init + use phys_control, only : phys_getopts + use string_utils, only : GLC + use m_MergeSorts, only : IndexSort + + implicit none + + !----------------------------------------------------------------------- + ! ... dummy arguments + !----------------------------------------------------------------------- + character(len=*), dimension(:), intent(in) :: extfrc_specifier + character(len=*), intent(in) :: extfrc_type_in + integer , intent(in) :: extfrc_cycle_yr + integer , intent(in) :: extfrc_fixed_ymd + integer , intent(in) :: extfrc_fixed_tod + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: astat + integer :: j, l, m, n, i,mm ! Indices + character(len=16) :: spc_name + character(len=256) :: frc_fnames(gas_pcnst) + real(r8) :: frc_scalefactor(gas_pcnst) + character(len=16) :: frc_species(gas_pcnst) + integer :: frc_indexes(gas_pcnst) + integer :: indx(gas_pcnst) + + integer :: vid, ndims, nvars, isec, ierr + type(file_desc_t) :: ncid + character(len=32) :: varname + + character(len=1), parameter :: filelist = '' + character(len=1), parameter :: datapath = '' + logical , parameter :: rmv_file = .false. + logical :: history_aerosol + logical :: history_chemistry + logical :: history_cesm_forcing + + character(len=32) :: extfrc_type = ' ' + character(len=80) :: file_interp_type = ' ' + character(len=256) :: tmp_string = ' ' + character(len=32) :: xchr = ' ' + real(r8) :: xdbl + + !----------------------------------------------------------------------- + + call phys_getopts( & + history_aerosol_out = history_aerosol, & + history_chemistry_out = history_chemistry, & + history_cesm_forcing_out = history_cesm_forcing ) + + !----------------------------------------------------------------------- + ! ... species has insitu forcing ? + !----------------------------------------------------------------------- + + !write(iulog,*) 'Species with insitu forcings' + mm = 0 + indx(:) = 0 + + count_emis: do n=1,gas_pcnst + + if ( len_trim(extfrc_specifier(n) ) == 0 ) then + exit count_emis + endif + + i = scan(extfrc_specifier(n),'->') + spc_name = trim(adjustl(extfrc_specifier(n)(:i-1))) + + ! need to parse out scalefactor ... + tmp_string = adjustl(extfrc_specifier(n)(i+2:)) + j = scan( tmp_string, '*' ) + if (j>0) then + xchr = tmp_string(1:j-1) ! get the multipler (left of the '*') + read( xchr, * ) xdbl ! convert the string to a real + tmp_string = adjustl(tmp_string(j+1:)) ! get the filepath name (right of the '*') + else + xdbl = 1._r8 + endif + filename = trim(tmp_string) + + m = get_extfrc_ndx( spc_name ) + + if ( m < 1 ) then + call endrun('extfrc_inti: '//trim(spc_name)// ' does not have an external source') + endif + + if ( .not. frc_from_dataset(m) ) then + call endrun('extfrc_inti: '//trim(spc_name)//' cannot have external forcing from additional dataset') + endif + + mm = mm+1 + frc_species(mm) = spc_name + frc_fnames(mm) = filename + frc_indexes(mm) = m + frc_scalefactor(mm) = xdbl + + indx(n)=n + + enddo count_emis + + n_frc_files = mm + + if( n_frc_files < 1 ) then + if (masterproc) write(iulog,*) 'There are no species with insitu forcings' + return + end if + + if (masterproc) write(iulog,*) ' ' + + !----------------------------------------------------------------------- + ! ... allocate forcings type array + !----------------------------------------------------------------------- + allocate( forcings(n_frc_files), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'extfrc_inti: failed to allocate forcings array; error = ',astat + call endrun('extfrc_inti: failed to allocate forcings array') + end if + + !----------------------------------------------------------------------- + ! Sort the input files so that the emissions sources are summed in the + ! same order regardless of the order of the input files in the namelist + !----------------------------------------------------------------------- + if (n_frc_files > 0) then + call IndexSort(n_frc_files, indx, frc_fnames) + end if + + !----------------------------------------------------------------------- + ! ... setup the forcing type array + !----------------------------------------------------------------------- + do m=1,n_frc_files + forcings(m)%frc_ndx = frc_indexes(indx(m)) + forcings(m)%species = frc_species(indx(m)) + forcings(m)%filename = frc_fnames(indx(m)) + forcings(m)%scalefactor = frc_scalefactor(indx(m)) + enddo + + do n= 1,extcnt + if (frc_from_dataset(n)) then + spc_name = extfrc_lst(n) + call addfld( trim(spc_name)//'_XFRC', (/ 'lev' /), 'A', 'molec/cm3/s', & + 'external forcing for '//trim(spc_name) ) + call addfld( trim(spc_name)//'_CLXF', horiz_only, 'A', 'molec/cm2/s', & + 'vertically integrated external forcing for '//trim(spc_name) ) + call addfld( trim(spc_name)//'_CMXF', horiz_only, 'A', 'kg/m2/s', & + 'vertically integrated external forcing for '//trim(spc_name) ) + if ( history_aerosol .or. history_chemistry ) then + call add_default( trim(spc_name)//'_CLXF', 1, ' ' ) + call add_default( trim(spc_name)//'_CMXF', 1, ' ' ) + endif + if ( history_cesm_forcing .and. spc_name == 'NO2' ) then + call add_default( trim(spc_name)//'_CLXF', 1, ' ' ) + call add_default( trim(spc_name)//'_CMXF', 1, ' ' ) + endif + endif + enddo + + if (masterproc) then + !----------------------------------------------------------------------- + ! ... diagnostics + !----------------------------------------------------------------------- + write(iulog,*) ' ' + write(iulog,*) 'extfrc_inti: diagnostics' + write(iulog,*) ' ' + write(iulog,*) 'extfrc timing specs' + write(iulog,*) 'type = ',extfrc_type + if( extfrc_type == 'FIXED' ) then + write(iulog,*) ' fixed date = ', extfrc_fixed_ymd + write(iulog,*) ' fixed time = ', extfrc_fixed_tod + else if( extfrc_type == 'CYCLICAL' ) then + write(iulog,*) ' cycle year = ',extfrc_cycle_yr + end if + write(iulog,*) ' ' + write(iulog,*) 'there are ',n_frc_files,' species with external forcing files' + do m = 1,n_frc_files + write(iulog,*) ' ' + write(iulog,*) 'forcing type ',m + write(iulog,*) 'species = ',trim(forcings(m)%species) + write(iulog,*) 'frc ndx = ',forcings(m)%frc_ndx + write(iulog,*) 'filename= ',trim(forcings(m)%filename) + end do + write(iulog,*) ' ' + endif + + !----------------------------------------------------------------------- + ! read emis files to determine number of sectors + !----------------------------------------------------------------------- + frcing_loop: do m = 1, n_frc_files + + forcings(m)%nsectors = 0 + + call cam_pio_openfile ( ncid, trim(forcings(m)%filename), PIO_NOWRITE) + ierr = pio_inquire (ncid, nVariables=nvars) + + do vid = 1,nvars + + ierr = pio_inq_varndims (ncid, vid, ndims) + + if( ndims < 4 ) then + cycle + elseif( ndims > 4 ) then + ierr = pio_inq_varname (ncid, vid, varname) + write(iulog,*) 'extfrc_inti: Skipping variable ', trim(varname),', ndims = ',ndims, & + ' , species=',trim(forcings(m)%species) + cycle + end if + + forcings(m)%nsectors = forcings(m)%nsectors+1 + + enddo + + allocate( forcings(m)%sectors(forcings(m)%nsectors), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'extfrc_inti: failed to allocate forcings(m)%sectors array; error = ',astat + call endrun + end if + + isec = 1 + do vid = 1,nvars + + ierr = pio_inq_varndims (ncid, vid, ndims) + if( ndims == 4 ) then + ierr = pio_inq_varname(ncid, vid, forcings(m)%sectors(isec)) + isec = isec+1 + endif + + enddo + + ! Global attribute 'input_method' overrides the ext_frc_type namelist setting on + ! a file-by-file basis. If the ext_frc file does not contain the 'input_method' + ! attribute then the ext_frc_type namelist setting is used. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ierr = pio_get_att(ncid, PIO_GLOBAL, 'input_method', file_interp_type) + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + if ( ierr == PIO_NOERR) then + l = GLC(file_interp_type) + extfrc_type(1:l) = file_interp_type(1:l) + extfrc_type(l+1:) = ' ' + else + extfrc_type = trim(extfrc_type_in) + endif + + call cam_pio_closefile (ncid) + + allocate(forcings(m)%file%in_pbuf(size(forcings(m)%sectors))) + forcings(m)%file%in_pbuf(:) = .false. + call trcdata_init( forcings(m)%sectors, & + forcings(m)%filename, filelist, datapath, & + forcings(m)%fields, & + forcings(m)%file, & + rmv_file, extfrc_cycle_yr, extfrc_fixed_ymd, extfrc_fixed_tod, trim(extfrc_type) ) + + enddo frcing_loop + + + end subroutine extfrc_inti + + subroutine extfrc_timestep_init( pbuf2d, state ) + !----------------------------------------------------------------------- + ! ... check serial case for time span + !----------------------------------------------------------------------- + + use physics_types,only : physics_state + use ppgrid, only : begchunk, endchunk + use tracer_data, only : advance_trcdata + use physics_buffer, only : physics_buffer_desc + + implicit none + + type(physics_state), intent(in):: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: m + + do m = 1,n_frc_files + call advance_trcdata( forcings(m)%fields, forcings(m)%file, state, pbuf2d ) + end do + + end subroutine extfrc_timestep_init + + subroutine extfrc_set( lchnk, zint, frcing, ncol ) + + !-------------------------------------------------------- + ! ... form the external forcing + !-------------------------------------------------------- + use mo_chem_utls, only : get_spc_ndx + + implicit none + + !-------------------------------------------------------- + ! ... dummy arguments + !-------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunk + integer, intent(in) :: lchnk ! chunk index + real(r8), intent(in) :: zint(ncol, pverp) ! interface geopot above surface (km) + real(r8), intent(inout) :: frcing(ncol,pver,extcnt) ! insitu forcings (molec/cm^3/s) + + !-------------------------------------------------------- + ! ... local variables + !-------------------------------------------------------- + integer :: m, n + character(len=max_fieldname_len) :: xfcname + real(r8) :: frcing_col(1:ncol), frcing_col_kg(1:ncol) + integer :: k, isec + real(r8),parameter :: km_to_cm = 1.e5_r8 + real(r8),parameter :: cm2_to_m2 = 1.e4_r8 + real(r8),parameter :: kg_to_g = 1.e-3_r8 + real(r8) :: molec_to_kg + integer :: spc_ndx + + if( n_frc_files < 1 .or. extcnt < 1 ) then + return + end if + + frcing(:,:,:) = 0._r8 + + !-------------------------------------------------------- + ! ... set non-zero forcings + !-------------------------------------------------------- + file_loop : do m = 1,n_frc_files + + n = forcings(m)%frc_ndx + + do isec = 1,forcings(m)%nsectors + frcing(:ncol,:,n) = frcing(:ncol,:,n) + forcings(m)%scalefactor*forcings(m)%fields(isec)%data(:ncol,:,lchnk) + enddo + + enddo file_loop + + frc_loop : do n = 1,extcnt + if (frc_from_dataset(n)) then + + xfcname = trim(extfrc_lst(n))//'_XFRC' + call outfld( xfcname, frcing(:ncol,:,n), ncol, lchnk ) + + spc_ndx = get_spc_ndx( extfrc_lst(n) ) + molec_to_kg = adv_mass( spc_ndx ) / avogadro *cm2_to_m2 * kg_to_g + + frcing_col(:ncol) = 0._r8 + frcing_col_kg(:ncol) = 0._r8 + do k = 1,pver + frcing_col(:ncol) = frcing_col(:ncol) + frcing(:ncol,k,n)*(zint(:ncol,k)-zint(:ncol,k+1))*km_to_cm + frcing_col_kg(:ncol) = frcing_col_kg(:ncol) + frcing(:ncol,k,n)*(zint(:ncol,k)-zint(:ncol,k+1))*km_to_cm*molec_to_kg + enddo + + xfcname = trim(extfrc_lst(n))//'_CLXF' + call outfld( xfcname, frcing_col(:ncol), ncol, lchnk ) + xfcname = trim(extfrc_lst(n))//'_CMXF' + call outfld( xfcname, frcing_col_kg(:ncol), ncol, lchnk ) + endif + end do frc_loop + + end subroutine extfrc_set + + +end module mo_extfrc diff --git a/src/chemistry/oslo_aero/mo_gas_phase_chemdr.F90 b/src/chemistry/oslo_aero/mo_gas_phase_chemdr.F90 new file mode 100644 index 0000000000..cd3388b1f0 --- /dev/null +++ b/src/chemistry/oslo_aero/mo_gas_phase_chemdr.F90 @@ -0,0 +1,1237 @@ +module mo_gas_phase_chemdr + + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_const_mod, only : pi => shr_const_pi + use constituents, only : pcnst + use cam_history, only : fieldname_len + use chem_mods, only : phtcnt, rxntot, gas_pcnst + use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts + use dust_model, only : dust_names, ndust => dust_nbin + use ppgrid, only : pcols, pver + use phys_control, only : phys_getopts + use carma_flags_mod, only : carma_hetchem_feedback + use chem_prod_loss_diags, only: chem_prod_loss_diags_init, chem_prod_loss_diags_out + + implicit none + save + + private + public :: gas_phase_chemdr, gas_phase_chemdr_inti + public :: map2chm + + integer :: map2chm(pcnst) = 0 ! index map to/from chemistry/constituents list + + integer :: synoz_ndx, so4_ndx, h2o_ndx, o2_ndx, o_ndx, hno3_ndx, hcl_ndx, dst_ndx, cldice_ndx, snow_ndx + integer :: o3_ndx, o3s_ndx + integer :: het1_ndx + integer :: ndx_cldfr, ndx_cmfdqr, ndx_nevapr, ndx_cldtop, ndx_prain + integer :: ndx_h2so4 +#ifdef OSLO_AERO + logical :: inv_o3, inv_oh, inv_no3, inv_ho2 + integer :: id_o3, id_oh, id_no3, id_ho2 +#endif +! +! CCMI +! + integer :: st80_25_ndx + integer :: st80_25_tau_ndx + integer :: aoa_nh_ndx + integer :: aoa_nh_ext_ndx + integer :: nh_5_ndx + integer :: nh_50_ndx + integer :: nh_50w_ndx + integer :: sad_pbf_ndx + integer :: cb1_ndx,cb2_ndx,oc1_ndx,oc2_ndx,dst1_ndx,dst2_ndx,sslt1_ndx,sslt2_ndx + integer :: soa_ndx,soai_ndx,soam_ndx,soat_ndx,soab_ndx,soax_ndx + + character(len=fieldname_len),dimension(rxt_tag_cnt) :: tag_names + character(len=fieldname_len),dimension(extcnt) :: extfrc_name + + logical :: pm25_srf_diag + logical :: pm25_srf_diag_soa + + logical :: convproc_do_aer + integer :: ele_temp_ndx, ion_temp_ndx + +contains + + subroutine gas_phase_chemdr_inti() + + use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx, get_inv_ndx + use cam_history, only : addfld,add_default,horiz_only + use mo_chm_diags, only : chm_diags_inti + use constituents, only : cnst_get_ind + use physics_buffer, only : pbuf_get_index + use rate_diags, only : rate_diags_init + use cam_abortutils, only : endrun + + implicit none + + character(len=3) :: string + integer :: n, m, err, ii + logical :: history_cesm_forcing + character(len=16) :: unitstr + !----------------------------------------------------------------------- + logical :: history_scwaccm_forcing + + call phys_getopts( history_scwaccm_forcing_out = history_scwaccm_forcing ) + + call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) + +#if defined(OSLO_AERO) + inv_o3 = get_inv_ndx('O3') > 0 + inv_oh = get_inv_ndx('OH') > 0 + inv_no3 = get_inv_ndx('NO3') > 0 + inv_ho2 = get_inv_ndx('HO2') > 0 + if (inv_o3) then + id_o3 = get_inv_ndx('O3') + endif + if (inv_oh) then + id_oh = get_inv_ndx('OH') + endif + if (inv_no3) then + id_no3 = get_inv_ndx('NO3') + endif + if (inv_ho2) then + id_ho2 = get_inv_ndx('HO2') + endif +#endif + + ndx_h2so4 = get_spc_ndx('H2SO4') +! +! CCMI +! + st80_25_ndx = get_spc_ndx ('ST80_25') + st80_25_tau_ndx = get_rxt_ndx ('ST80_25_tau') + aoa_nh_ndx = get_spc_ndx ('AOA_NH') + aoa_nh_ext_ndx = get_extfrc_ndx('AOA_NH') + nh_5_ndx = get_spc_ndx('NH_5') + nh_50_ndx = get_spc_ndx('NH_50') + nh_50w_ndx = get_spc_ndx('NH_50W') +! + cb1_ndx = get_spc_ndx('CB1') + cb2_ndx = get_spc_ndx('CB2') + oc1_ndx = get_spc_ndx('OC1') + oc2_ndx = get_spc_ndx('OC2') + dst1_ndx = get_spc_ndx('DST01') + dst2_ndx = get_spc_ndx('DST02') + sslt1_ndx = get_spc_ndx('SSLT01') + sslt2_ndx = get_spc_ndx('SSLT02') + soa_ndx = get_spc_ndx('SOA') + soam_ndx = get_spc_ndx('SOAM') + soai_ndx = get_spc_ndx('SOAI') + soat_ndx = get_spc_ndx('SOAT') + soab_ndx = get_spc_ndx('SOAB') + soax_ndx = get_spc_ndx('SOAX') + + pm25_srf_diag = cb1_ndx>0 .and. cb2_ndx>0 .and. oc1_ndx>0 .and. oc2_ndx>0 & + .and. dst1_ndx>0 .and. dst2_ndx>0 .and. sslt1_ndx>0 .and. sslt2_ndx>0 & + .and. soa_ndx>0 + + pm25_srf_diag_soa = cb1_ndx>0 .and. cb2_ndx>0 .and. oc1_ndx>0 .and. oc2_ndx>0 & + .and. dst1_ndx>0 .and. dst2_ndx>0 .and. sslt1_ndx>0 .and. sslt2_ndx>0 & + .and. soam_ndx>0 .and. soai_ndx>0 .and. soat_ndx>0 .and. soab_ndx>0 .and. soax_ndx>0 + + if ( pm25_srf_diag .or. pm25_srf_diag_soa) then + call addfld('PM25_SRF',horiz_only,'I','kg/kg','bottom layer PM2.5 mixing ratio' ) + endif + call addfld('U_SRF',horiz_only,'I','m/s','bottom layer wind velocity' ) + call addfld('V_SRF',horiz_only,'I','m/s','bottom layer wind velocity' ) + call addfld('Q_SRF',horiz_only,'I','kg/kg','bottom layer specific humidity' ) +! + het1_ndx= get_rxt_ndx('het1') + o3_ndx = get_spc_ndx('O3') + o3s_ndx = get_spc_ndx('O3S') + o_ndx = get_spc_ndx('O') + o2_ndx = get_spc_ndx('O2') + so4_ndx = get_spc_ndx('SO4') + h2o_ndx = get_spc_ndx('H2O') + hno3_ndx = get_spc_ndx('HNO3') + hcl_ndx = get_spc_ndx('HCL') + dst_ndx = get_spc_ndx( dust_names(1) ) + synoz_ndx = get_extfrc_ndx( 'SYNOZ' ) + call cnst_get_ind( 'CLDICE', cldice_ndx ) + call cnst_get_ind( 'SNOWQM', snow_ndx, abort=.false. ) + + + do m = 1,extcnt + WRITE(UNIT=string, FMT='(I2.2)') m + extfrc_name(m) = 'extfrc_'// trim(string) + call addfld( extfrc_name(m), (/ 'lev' /), 'I', ' ', 'ext frcing' ) + end do + + do n = 1,rxt_tag_cnt + tag_names(n) = trim(rxt_tag_lst(n)) + if (n<=phtcnt) then + call addfld( tag_names(n), (/ 'lev' /), 'I', '/s', 'photolysis rate constant' ) + else + ii = n-phtcnt + select case(num_rnts(ii)) + case(1) + unitstr='/s' + case(2) + unitstr='cm3/molecules/s' + case(3) + unitstr='cm6/molecules2/s' + case default + call endrun('gas_phase_chemdr_inti: invalid value in num_rnts used to set units in reaction rate constant') + end select + call addfld( tag_names(n), (/ 'lev' /), 'I', unitstr, 'reaction rate constant' ) + endif + if (history_scwaccm_forcing) then + select case (trim(tag_names(n))) + case ('jh2o_a', 'jh2o_b', 'jh2o_c' ) + call add_default( tag_names(n), 1, ' ') + end select + endif + enddo + + call addfld( 'DTCBS', horiz_only, 'I', ' ','photolysis diagnostic black carbon OD' ) + call addfld( 'DTOCS', horiz_only, 'I', ' ','photolysis diagnostic organic carbon OD' ) + call addfld( 'DTSO4', horiz_only, 'I', ' ','photolysis diagnostic SO4 OD' ) + call addfld( 'DTSOA', horiz_only, 'I', ' ','photolysis diagnostic SOA OD' ) + call addfld( 'DTANT', horiz_only, 'I', ' ','photolysis diagnostic NH4SO4 OD' ) + call addfld( 'DTSAL', horiz_only, 'I', ' ','photolysis diagnostic salt OD' ) + call addfld( 'DTDUST', horiz_only, 'I', ' ','photolysis diagnostic dust OD' ) + call addfld( 'DTTOTAL', horiz_only, 'I', ' ','photolysis diagnostic total aerosol OD' ) + call addfld( 'FRACDAY', horiz_only, 'I', ' ','photolysis diagnostic fraction of day' ) + + call addfld( 'QDSAD', (/ 'lev' /), 'I', '/s', 'water vapor sad delta' ) + call addfld( 'SAD_STRAT', (/ 'lev' /), 'I', 'cm2/cm3', 'stratospheric aerosol SAD' ) + call addfld( 'SAD_SULFC', (/ 'lev' /), 'I', 'cm2/cm3', 'chemical sulfate aerosol SAD' ) + call addfld( 'SAD_SAGE', (/ 'lev' /), 'I', 'cm2/cm3', 'SAGE sulfate aerosol SAD' ) + call addfld( 'SAD_LNAT', (/ 'lev' /), 'I', 'cm2/cm3', 'large-mode NAT aerosol SAD' ) + call addfld( 'SAD_ICE', (/ 'lev' /), 'I', 'cm2/cm3', 'water-ice aerosol SAD' ) + call addfld( 'RAD_SULFC', (/ 'lev' /), 'I', 'cm', 'chemical sad sulfate' ) + call addfld( 'RAD_LNAT', (/ 'lev' /), 'I', 'cm', 'large nat radius' ) + call addfld( 'RAD_ICE', (/ 'lev' /), 'I', 'cm', 'sad ice' ) + call addfld( 'SAD_TROP', (/ 'lev' /), 'I', 'cm2/cm3', 'tropospheric aerosol SAD' ) + call addfld( 'SAD_AERO', (/ 'lev' /), 'I', 'cm2/cm3', 'aerosol surface area density' ) + if (history_cesm_forcing) then + call add_default ('SAD_AERO',8,' ') + endif + call addfld( 'REFF_AERO', (/ 'lev' /), 'I', 'cm', 'aerosol effective radius' ) + call addfld( 'SULF_TROP', (/ 'lev' /), 'I', 'mol/mol', 'tropospheric aerosol SAD' ) + call addfld( 'QDSETT', (/ 'lev' /), 'I', '/s', 'water vapor settling delta' ) + call addfld( 'QDCHEM', (/ 'lev' /), 'I', '/s', 'water vapor chemistry delta') + call addfld( 'HNO3_TOTAL', (/ 'lev' /), 'I', 'mol/mol', 'total HNO3' ) + call addfld( 'HNO3_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HNO3' ) + call addfld( 'HNO3_NAT', (/ 'lev' /), 'I', 'mol/mol', 'NAT condensed HNO3' ) + call addfld( 'HNO3_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hno3' ) + call addfld( 'H2O_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase h2o' ) + call addfld( 'HCL_TOTAL', (/ 'lev' /), 'I', 'mol/mol', 'total hcl' ) + call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) + call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) + + !++IH: Adding extra fields for oxi-output (before and after diurnal variations.) + call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) + call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) + call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) + call addfld ('OH_aft ', (/ 'lev' /), 'A','unit', 'OH invariants after adding diurnal variations' ) + call addfld ('HO2_aft ', (/ 'lev' /), 'A','unit', 'HO2 invariants after adding diurnal variations' ) + call addfld ('NO3_aft ', (/ 'lev' /), 'A','unit', 'NO3 invariants after adding diurnal variations' ) + + call add_default ('OH_bef ', 1, ' ') + call add_default ('HO2_bef ', 1, ' ') + call add_default ('NO3_bef ', 1, ' ') + call add_default ('OH_aft ', 1, ' ') + call add_default ('HO2_aft ', 1, ' ') + call add_default ('NO3_aft ', 1, ' ') + !--IH + + if (het1_ndx>0) then + call addfld( 'het1_total', (/ 'lev' /), 'I', '/s', 'total N2O5 + H2O het rate constant' ) + endif + call addfld( 'SZA', horiz_only, 'I', 'degrees', 'solar zenith angle' ) + + call chm_diags_inti() + call rate_diags_init() + +!----------------------------------------------------------------------- +! get pbuf indicies +!----------------------------------------------------------------------- + ndx_cldfr = pbuf_get_index('CLD') + ndx_cmfdqr = pbuf_get_index('RPRDTOT') + ndx_nevapr = pbuf_get_index('NEVAPR') + ndx_prain = pbuf_get_index('PRAIN') + ndx_cldtop = pbuf_get_index('CLDTOP') + + sad_pbf_ndx= pbuf_get_index('VOLC_SAD',errcode=err) ! prescribed strat aerosols (volcanic) + if (.not.sad_pbf_ndx>0) sad_pbf_ndx = pbuf_get_index('SADSULF',errcode=err) ! CARMA's version of strat aerosols + + ele_temp_ndx = pbuf_get_index('TElec',errcode=err)! electron temperature index + ion_temp_ndx = pbuf_get_index('TIon',errcode=err) ! ion temperature index + + ! diagnostics for stratospheric heterogeneous reactions + call addfld( 'GAMMA_HET1', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'GAMMA_HET2', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'GAMMA_HET3', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'GAMMA_HET4', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'GAMMA_HET5', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'GAMMA_HET6', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) + call addfld( 'WTPER', (/ 'lev' /), 'I', '%', 'H2SO4 Weight Percent' ) + + call chem_prod_loss_diags_init + + end subroutine gas_phase_chemdr_inti + + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & + phis, zm, zi, calday, & + tfld, pmid, pdel, pint, & + cldw, troplev, troplevchem, & + ncldwtr, ufld, vfld, & + delt, ps, xactive_prates, & + fsds, ts, asdir, ocnfrac, icefrac, & + precc, precl, snowhland, ghg_chem, latmapback, & + drydepflx, wetdepflx, cflx, fire_sflx, fire_ztop, nhx_nitrogen_flx, noy_nitrogen_flx, qtend, pbuf) + + !----------------------------------------------------------------------- + ! ... Chem_solver advances the volumetric mixing ratio + ! forward one time step via a combination of explicit, + ! ebi, hov, fully implicit, and/or rodas algorithms. + !----------------------------------------------------------------------- + + use chem_mods, only : nabscol, nfs, indexm, clscnt4 + use physconst, only : rga + use mo_photo, only : set_ub_col, setcol, table_photo, xactive_photo + use mo_exp_sol, only : exp_sol + use mo_imp_sol, only : imp_sol + use mo_setrxt, only : setrxt + use mo_adjrxt, only : adjrxt + use mo_phtadj, only : phtadj + use llnl_O1D_to_2OH_adj,only : O1D_to_2OH_adj + use mo_usrrxt, only : usrrxt + use mo_setinv, only : setinv + use mo_negtrc, only : negtrc + use mo_sulf, only : sulf_interp + use mo_setext, only : setext + use fire_emissions, only : fire_emissions_vrt + use mo_sethet, only : sethet + use mo_drydep, only : drydep, set_soilw + use seq_drydep_mod, only : DD_XLND, DD_XATM, DD_TABL, drydep_method + use mo_fstrat, only : set_fstrat_vals, set_fstrat_h2o + use noy_ubc, only : noy_ubc_set + use mo_flbc, only : flbc_set + use phys_grid, only : get_rlat_all_p, get_rlon_all_p, get_lat_all_p, get_lon_all_p + use mo_mean_mass, only : set_mean_mass + use cam_history, only : outfld + use wv_saturation, only : qsat + use constituents, only : cnst_mw + use mo_drydep, only : has_drydep + use time_manager, only : get_ref_date + use mo_ghg_chem, only : ghg_chem_set_rates, ghg_chem_set_flbc + use mo_sad, only : sad_strat_calc + use charge_neutrality, only : charge_balance + use mo_strato_rates, only : ratecon_sfstrat + use mo_aero_settling, only : strat_aer_settling + use shr_orb_mod, only : shr_orb_decl + use cam_control_mod, only : lambm0, eccen, mvelpp, obliqr + use mo_strato_rates, only : has_strato_chem + use short_lived_species,only: set_short_lived_species,get_short_lived_species + use mo_chm_diags, only : chm_diags, het_diags + use perf_mod, only : t_startf, t_stopf + use gas_wetdep_opts, only : gas_wetdep_method +#if (defined OSLO_AERO) + use oxi_diurnal_var, only : set_diurnal_invariants +#endif + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx + use infnan, only : nan, assignment(=) + use rate_diags, only : rate_diags_calc + use mo_mass_xforms, only : mmr2vmr, vmr2mmr, h2o_to_vmr, mmr2vmri + use orbit, only : zenith +! +! LINOZ +! + use lin_strat_chem, only : do_lin_strat_chem, lin_strat_chem_solve + use linoz_data, only : has_linoz_data +! +! for aqueous chemistry and aerosol growth +! + use aero_model, only : aero_model_gasaerexch + + use aero_model, only : aero_model_strat_surfarea + + implicit none + + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: lchnk ! chunk index + integer, intent(in) :: ncol ! number columns in chunk + integer, intent(in) :: imozart ! gas phase start index in q + real(r8), intent(in) :: delt ! timestep (s) + real(r8), intent(in) :: calday ! day of year + real(r8), intent(in) :: ps(pcols) ! surface pressure + real(r8), intent(in) :: phis(pcols) ! surface geopotential + real(r8),target,intent(in) :: tfld(pcols,pver) ! midpoint temperature (K) + real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! pressure delta about midpoints (Pa) + real(r8), intent(in) :: ufld(pcols,pver) ! zonal velocity (m/s) + real(r8), intent(in) :: vfld(pcols,pver) ! meridional velocity (m/s) + real(r8), intent(in) :: cldw(pcols,pver) ! cloud water (kg/kg) + real(r8), intent(in) :: ncldwtr(pcols,pver) ! droplet number concentration (#/kg) + real(r8), intent(in) :: zm(pcols,pver) ! midpoint geopotential height above the surface (m) + real(r8), intent(in) :: zi(pcols,pver+1) ! interface geopotential height above the surface (m) + real(r8), intent(in) :: pint(pcols,pver+1) ! interface pressures (Pa) + real(r8), intent(in) :: q(pcols,pver,pcnst) ! species concentrations (kg/kg) + real(r8),pointer, intent(in) :: fire_sflx(:,:) ! fire emssions surface flux (kg/m^2/s) + real(r8),pointer, intent(in) :: fire_ztop(:) ! top of vertical distribution of fire emssions (m) + logical, intent(in) :: xactive_prates + real(r8), intent(in) :: fsds(pcols) ! longwave down at sfc + real(r8), intent(in) :: icefrac(pcols) ! sea-ice areal fraction + real(r8), intent(in) :: ocnfrac(pcols) ! ocean areal fraction + real(r8), intent(in) :: asdir(pcols) ! albedo: shortwave, direct + real(r8), intent(in) :: ts(pcols) ! sfc temp (merged w/ocean if coupled) + real(r8), intent(in) :: precc(pcols) ! + real(r8), intent(in) :: precl(pcols) ! + real(r8), intent(in) :: snowhland(pcols) ! + logical, intent(in) :: ghg_chem + integer, intent(in) :: latmapback(pcols) + integer, intent(in) :: troplev(pcols) ! trop/strat separation vertical index + integer, intent(in) :: troplevchem(pcols) ! trop/strat chemistry separation vertical index + real(r8), intent(inout) :: qtend(pcols,pver,pcnst) ! species tendencies (kg/kg/s) + real(r8), intent(inout) :: cflx(pcols,pcnst) ! constituent surface flux (kg/m^2/s) + real(r8), intent(out) :: drydepflx(pcols,pcnst) ! dry deposition flux (kg/m^2/s) + real(r8), intent(in) :: wetdepflx(pcols,pcnst) ! wet deposition flux (kg/m^2/s) + real(r8), intent(out) :: nhx_nitrogen_flx(pcols) + real(r8), intent(out) :: noy_nitrogen_flx(pcols) + + type(physics_buffer_desc), pointer :: pbuf(:) + + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + real(r8), parameter :: m2km = 1.e-3_r8 + real(r8), parameter :: Pa2mb = 1.e-2_r8 + + real(r8), pointer :: prain(:,:) + real(r8), pointer :: nevapr(:,:) + real(r8), pointer :: cmfdqr(:,:) + real(r8), pointer :: cldfr(:,:) + real(r8), pointer :: cldtop(:) + + integer :: i, k, m, n + integer :: tim_ndx + real(r8) :: delt_inverse + real(r8) :: esfact + integer :: latndx(pcols) ! chunk lat indicies + integer :: lonndx(pcols) ! chunk lon indicies + real(r8) :: invariants(ncol,pver,nfs) + real(r8) :: col_dens(ncol,pver,max(1,nabscol)) ! column densities (molecules/cm^2) + real(r8) :: col_delta(ncol,0:pver,max(1,nabscol)) ! layer column densities (molecules/cm^2) + real(r8) :: extfrc(ncol,pver,max(1,extcnt)) + real(r8) :: vmr(ncol,pver,gas_pcnst) ! xported species (vmr) + real(r8) :: reaction_rates(ncol,pver,max(1,rxntot)) ! reaction rates + real(r8) :: depvel(ncol,gas_pcnst) ! dry deposition velocity (cm/s) + real(r8) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! washout rate (1/s) + real(r8), dimension(ncol,pver) :: & + h2ovmr, & ! water vapor volume mixing ratio + mbar, & ! mean wet atmospheric mass ( amu ) + zmid, & ! midpoint geopotential in km + zmidr, & ! midpoint geopotential in km realitive to surf + sulfate, & ! trop sulfate aerosols + pmb ! pressure at midpoints ( hPa ) + real(r8), dimension(ncol,pver) :: & + cwat, & ! cloud water mass mixing ratio (kg/kg) + wrk + real(r8), dimension(ncol,pver+1) :: & + zintr ! interface geopotential in km realitive to surf + real(r8), dimension(ncol,pver+1) :: & + zint ! interface geopotential in km + real(r8), dimension(ncol) :: & + zen_angle, & ! solar zenith angles + zsurf, & ! surface height (m) + rlats, rlons ! chunk latitudes and longitudes (radians) + real(r8) :: sza(ncol) ! solar zenith angles (degrees) + real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor + real(r8) :: relhum(ncol,pver) ! relative humidity + real(r8) :: satv(ncol,pver) ! wrk array for relative humidity + real(r8) :: satq(ncol,pver) ! wrk array for relative humidity + + integer :: j + integer :: ltrop_sol(pcols) ! tropopause vertical index used in chem solvers + real(r8), pointer :: strato_sad(:,:) ! stratospheric sad (1/cm) + + real(r8) :: sad_trop(pcols,pver) ! total tropospheric sad (cm^2/cm^3) + real(r8) :: reff(pcols,pver) ! aerosol effective radius (cm) + real(r8) :: reff_strat(pcols,pver) ! stratospheric aerosol effective radius (cm) + + real(r8) :: tvs(pcols) + integer :: ncdate,yr,mon,day,sec + real(r8) :: wind_speed(pcols) ! surface wind speed (m/s) + logical, parameter :: dyn_soilw = .false. + logical :: table_soilw + real(r8) :: soilw(pcols) + real(r8) :: prect(pcols) + real(r8) :: sflx(pcols,gas_pcnst) + real(r8) :: wetdepflx_diag(pcols,gas_pcnst) + real(r8) :: dust_vmr(ncol,pver,ndust) + real(r8) :: dt_diag(pcols,8) ! od diagnostics + real(r8) :: fracday(pcols) ! fraction of day + real(r8) :: o2mmr(ncol,pver) ! o2 concentration (kg/kg) + real(r8) :: ommr(ncol,pver) ! o concentration (kg/kg) + real(r8) :: mmr(pcols,pver,gas_pcnst) ! chem working concentrations (kg/kg) + real(r8) :: mmr_new(pcols,pver,gas_pcnst) ! chem working concentrations (kg/kg) + real(r8) :: hno3_gas(ncol,pver) ! hno3 gas phase concentration (mol/mol) + real(r8) :: hno3_cond(ncol,pver,2) ! hno3 condensed phase concentration (mol/mol) + real(r8) :: hcl_gas(ncol,pver) ! hcl gas phase concentration (mol/mol) + real(r8) :: hcl_cond(ncol,pver) ! hcl condensed phase concentration (mol/mol) + real(r8) :: h2o_gas(ncol,pver) ! h2o gas phase concentration (mol/mol) + real(r8) :: h2o_cond(ncol,pver) ! h2o condensed phase concentration (mol/mol) + real(r8) :: cldice(pcols,pver) ! cloud water "ice" (kg/kg) + real(r8) :: radius_strat(ncol,pver,3) ! radius of sulfate, nat, & ice ( cm ) + real(r8) :: sad_strat(ncol,pver,3) ! surf area density of sulfate, nat, & ice ( cm^2/cm^3 ) + real(r8) :: mmr_tend(pcols,pver,gas_pcnst) ! chemistry species tendencies (kg/kg/s) + real(r8) :: qh2o(pcols,pver) ! specific humidity (kg/kg) + real(r8) :: delta + + ! for aerosol formation.... + real(r8) :: del_h2so4_gasprod(ncol,pver) + real(r8) :: vmr0(ncol,pver,gas_pcnst) + +! +! CCMI +! + real(r8) :: xlat + real(r8) :: pm25(ncol) + + real(r8) :: dlats(ncol) + + real(r8), dimension(ncol,pver) :: & ! aerosol reaction diagnostics + gprob_n2o5, & + gprob_cnt_hcl, & + gprob_cnt_h2o, & + gprob_bnt_h2o, & + gprob_hocl_hcl, & + gprob_hobr_hcl, & + wtper + + real(r8), pointer :: ele_temp_fld(:,:) ! electron temperature pointer + real(r8), pointer :: ion_temp_fld(:,:) ! ion temperature pointer + real(r8) :: prod_out(ncol,pver,max(1,clscnt4)) + real(r8) :: loss_out(ncol,pver,max(1,clscnt4)) + + if ( ele_temp_ndx>0 .and. ion_temp_ndx>0 ) then + call pbuf_get_field(pbuf, ele_temp_ndx, ele_temp_fld) + call pbuf_get_field(pbuf, ion_temp_ndx, ion_temp_fld) + else + ele_temp_fld => tfld + ion_temp_fld => tfld + endif + + ! initialize to NaN to hopefully catch user defined rxts that go unset + reaction_rates(:,:,:) = nan + + delt_inverse = 1._r8 / delt + !----------------------------------------------------------------------- + ! ... Get chunck latitudes and longitudes + !----------------------------------------------------------------------- + call get_lat_all_p( lchnk, ncol, latndx ) + call get_lon_all_p( lchnk, ncol, lonndx ) + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + tim_ndx = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ndx_prain, prain, start=(/1,1/), kount=(/ncol,pver/)) + call pbuf_get_field(pbuf, ndx_cldfr, cldfr, start=(/1,1,tim_ndx/), kount=(/ncol,pver,1/) ) + call pbuf_get_field(pbuf, ndx_cmfdqr, cmfdqr, start=(/1,1/), kount=(/ncol,pver/)) + call pbuf_get_field(pbuf, ndx_nevapr, nevapr, start=(/1,1/), kount=(/ncol,pver/)) + call pbuf_get_field(pbuf, ndx_cldtop, cldtop ) + + reff_strat(:,:) = 0._r8 + + dlats(:) = rlats(:)*rad2deg ! convert to degrees + + !----------------------------------------------------------------------- + ! ... Calculate cosine of zenith angle + ! then cast back to angle (radians) + !----------------------------------------------------------------------- + call zenith( calday, rlats, rlons, zen_angle, ncol , delt) !+tht delt + zen_angle(:) = acos( zen_angle(:) ) + + sza(:) = zen_angle(:) * rad2deg + call outfld( 'SZA', sza, ncol, lchnk ) + + !----------------------------------------------------------------------- + ! ... Xform geopotential height from m to km + ! and pressure from Pa to mb + !----------------------------------------------------------------------- + zsurf(:ncol) = rga * phis(:ncol) + do k = 1,pver + zintr(:ncol,k) = m2km * zi(:ncol,k) + zmidr(:ncol,k) = m2km * zm(:ncol,k) + zmid(:ncol,k) = m2km * (zm(:ncol,k) + zsurf(:ncol)) + zint(:ncol,k) = m2km * (zi(:ncol,k) + zsurf(:ncol)) + pmb(:ncol,k) = Pa2mb * pmid(:ncol,k) + end do + zint(:ncol,pver+1) = m2km * (zi(:ncol,pver+1) + zsurf(:ncol)) + zintr(:ncol,pver+1)= m2km * zi(:ncol,pver+1) + + !----------------------------------------------------------------------- + ! ... map incoming concentrations to working array + !----------------------------------------------------------------------- + do m = 1,pcnst + n = map2chm(m) + if( n > 0 ) then + mmr(:ncol,:,n) = q(:ncol,:,m) + end if + end do + + call get_short_lived_species( mmr, lchnk, ncol, pbuf ) + + !----------------------------------------------------------------------- + ! ... Set atmosphere mean mass + !----------------------------------------------------------------------- + call set_mean_mass( ncol, mmr, mbar ) + + !----------------------------------------------------------------------- + ! ... Xform from mmr to vmr + !----------------------------------------------------------------------- + call mmr2vmr( mmr(:ncol,:,:), vmr(:ncol,:,:), mbar(:ncol,:), ncol ) + +! +! CCMI +! +! reset STE tracer to specific vmr of 200 ppbv +! + if ( st80_25_ndx > 0 ) then + where ( pmid(:ncol,:) < 80.e+2_r8 ) + vmr(:ncol,:,st80_25_ndx) = 200.e-9_r8 + end where + end if +! +! reset AOA_NH, NH_5, NH_50, NH_50W surface mixing ratios between 30N and 50N +! + if ( aoa_nh_ndx>0 ) then + do j=1,ncol + xlat = dlats(j) + if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then + vmr(j,pver,aoa_nh_ndx) = 0._r8 + end if + end do + end if + if ( nh_5_ndx>0 ) then + do j=1,ncol + xlat = dlats(j) + if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then + vmr(j,pver,nh_5_ndx) = 100.e-9_r8 + end if + end do + end if + if ( nh_50_ndx>0 ) then + do j=1,ncol + xlat = dlats(j) + if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then + vmr(j,pver,nh_50_ndx) = 100.e-9_r8 + end if + end do + end if + if ( nh_50w_ndx>0 ) then + do j=1,ncol + xlat = dlats(j) + if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then + vmr(j,pver,nh_50w_ndx) = 100.e-9_r8 + end if + end do + end if + + if (h2o_ndx>0) then + !----------------------------------------------------------------------- + ! ... store water vapor in wrk variable + !----------------------------------------------------------------------- + qh2o(:ncol,:) = mmr(:ncol,:,h2o_ndx) + h2ovmr(:ncol,:) = vmr(:ncol,:,h2o_ndx) + else + qh2o(:ncol,:) = q(:ncol,:,1) + !----------------------------------------------------------------------- + ! ... Xform water vapor from mmr to vmr and set upper bndy values + !----------------------------------------------------------------------- + call h2o_to_vmr( q(:ncol,:,1), h2ovmr(:ncol,:), mbar(:ncol,:), ncol ) + + call set_fstrat_h2o( h2ovmr, pmid, troplev, calday, ncol, lchnk ) + + endif + + !----------------------------------------------------------------------- + ! ... force ion/electron balance + !----------------------------------------------------------------------- + call charge_balance( ncol, vmr ) + + !----------------------------------------------------------------------- + ! ... Set the "invariants" + !----------------------------------------------------------------------- + call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) + + !----------------------------------------------------------------------- +#if defined (OSLO_AERO) + ! ... Set the "day/night cycle for prescribed oxidants" + !----------------------------------------------------------------------- + + !++IH + call outfld('OH_bef', invariants(:,:,id_oh), ncol, lchnk) + call outfld('HO2_bef', invariants(:,:,id_ho2), ncol, lchnk) + call outfld('NO3_bef', invariants(:,:,id_no3), ncol, lchnk) + !--IH + + if (inv_oh.or.inv_ho2.or.inv_no3) & !++IH: added inv_no3 + call set_diurnal_invariants(invariants,delt,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2,inv_no3,id_no3) !++IH: added inv_no3 and id_no3 + + !++IH + call outfld('OH_aft', invariants(:,:,id_oh), ncol, lchnk) + call outfld('HO2_aft', invariants(:,:,id_ho2), ncol, lchnk) + call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) + !--IH + +#endif + ! ... stratosphere aerosol surface area + !----------------------------------------------------------------------- + if (sad_pbf_ndx>0) then + call pbuf_get_field(pbuf, sad_pbf_ndx, strato_sad) + else + allocate(strato_sad(pcols,pver)) + strato_sad(:,:) = 0._r8 + + ! Prognostic modal stratospheric sulfate: compute dry strato_sad + call aero_model_strat_surfarea( ncol, mmr, pmid, tfld, troplevchem, pbuf, strato_sad, reff_strat ) + + endif + + stratochem: if ( has_strato_chem ) then + !----------------------------------------------------------------------- + ! ... initialize condensed and gas phases; all hno3 to gas + !----------------------------------------------------------------------- + hcl_cond(:,:) = 0.0_r8 + hcl_gas (:,:) = 0.0_r8 + do k = 1,pver + hno3_gas(:,k) = vmr(:,k,hno3_ndx) + h2o_gas(:,k) = h2ovmr(:,k) + hcl_gas(:,k) = vmr(:,k,hcl_ndx) + wrk(:,k) = h2ovmr(:,k) + if (snow_ndx>0) then + cldice(:ncol,k) = q(:ncol,k,cldice_ndx) + q(:ncol,k,snow_ndx) + else + cldice(:ncol,k) = q(:ncol,k,cldice_ndx) + endif + end do + do m = 1,2 + do k = 1,pver + hno3_cond(:,k,m) = 0._r8 + end do + end do + + call mmr2vmri( cldice(:ncol,:), h2o_cond(:ncol,:), mbar(:ncol,:), cnst_mw(cldice_ndx), ncol ) + + !----------------------------------------------------------------------- + ! ... call SAD routine + !----------------------------------------------------------------------- + call sad_strat_calc( lchnk, invariants(:ncol,:,indexm), pmb, tfld, hno3_gas, & + hno3_cond, h2o_gas, h2o_cond, hcl_gas, hcl_cond, strato_sad(:ncol,:), radius_strat, & + sad_strat, ncol, pbuf ) + +! NOTE: output of total HNO3 is before vmr is set to gas-phase. + call outfld( 'HNO3_TOTAL', vmr(:ncol,:,hno3_ndx), ncol ,lchnk ) + + + do k = 1,pver + vmr(:,k,hno3_ndx) = hno3_gas(:,k) + h2ovmr(:,k) = h2o_gas(:,k) + vmr(:,k,h2o_ndx) = h2o_gas(:,k) + wrk(:,k) = (h2ovmr(:,k) - wrk(:,k))*delt_inverse + end do + + call outfld( 'QDSAD', wrk(:,:), ncol, lchnk ) +! + call outfld( 'SAD_STRAT', strato_sad(:ncol,:), ncol, lchnk ) + call outfld( 'SAD_SULFC', sad_strat(:,:,1), ncol, lchnk ) + call outfld( 'SAD_LNAT', sad_strat(:,:,2), ncol, lchnk ) + call outfld( 'SAD_ICE', sad_strat(:,:,3), ncol, lchnk ) +! + call outfld( 'RAD_SULFC', radius_strat(:,:,1), ncol, lchnk ) + call outfld( 'RAD_LNAT', radius_strat(:,:,2), ncol, lchnk ) + call outfld( 'RAD_ICE', radius_strat(:,:,3), ncol, lchnk ) +! + call outfld( 'HNO3_GAS', vmr(:ncol,:,hno3_ndx), ncol, lchnk ) + call outfld( 'HNO3_STS', hno3_cond(:,:,1), ncol, lchnk ) + call outfld( 'HNO3_NAT', hno3_cond(:,:,2), ncol, lchnk ) +! + call outfld( 'HCL_TOTAL', vmr(:ncol,:,hcl_ndx), ncol, lchnk ) + call outfld( 'HCL_GAS', hcl_gas (:,:), ncol ,lchnk ) + call outfld( 'HCL_STS', hcl_cond(:,:), ncol ,lchnk ) + + !----------------------------------------------------------------------- + ! ... call aerosol reaction rates + !----------------------------------------------------------------------- + call ratecon_sfstrat( ncol, invariants(:,:,indexm), pmid, tfld, & + radius_strat(:,:,1), sad_strat(:,:,1), sad_strat(:,:,2), & + sad_strat(:,:,3), h2ovmr, vmr, reaction_rates, & + gprob_n2o5, gprob_cnt_hcl, gprob_cnt_h2o, gprob_bnt_h2o, & + gprob_hocl_hcl, gprob_hobr_hcl, wtper ) + + call outfld( 'GAMMA_HET1', gprob_n2o5 (:ncol,:), ncol, lchnk ) + call outfld( 'GAMMA_HET2', gprob_cnt_h2o (:ncol,:), ncol, lchnk ) + call outfld( 'GAMMA_HET3', gprob_bnt_h2o (:ncol,:), ncol, lchnk ) + call outfld( 'GAMMA_HET4', gprob_cnt_hcl (:ncol,:), ncol, lchnk ) + call outfld( 'GAMMA_HET5', gprob_hocl_hcl(:ncol,:), ncol, lchnk ) + call outfld( 'GAMMA_HET6', gprob_hobr_hcl(:ncol,:), ncol, lchnk ) + call outfld( 'WTPER', wtper (:ncol,:), ncol, lchnk ) + + endif stratochem + +! NOTE: For gas-phase solver only. +! ratecon_sfstrat needs total hcl. + if (hcl_ndx>0) then + vmr(:,:,hcl_ndx) = hcl_gas(:,:) + endif + + !----------------------------------------------------------------------- + ! ... Set the column densities at the upper boundary + !----------------------------------------------------------------------- + call set_ub_col( col_delta, vmr, invariants, pint(:,1), pdel, ncol, lchnk) + + !----------------------------------------------------------------------- + ! ... Set rates for "tabular" and user specified reactions + !----------------------------------------------------------------------- + call setrxt( reaction_rates, tfld, invariants(1,1,indexm), ncol ) + + sulfate(:,:) = 0._r8 + if ( .not. carma_hetchem_feedback ) then + if( so4_ndx < 1 ) then ! get offline so4 field if not prognostic + call sulf_interp( ncol, lchnk, sulfate ) + else + sulfate(:,:) = vmr(:,:,so4_ndx) + endif + endif + + !----------------------------------------------------------------- + ! ... zero out sulfate above tropopause + !----------------------------------------------------------------- + do k = 1, pver + do i = 1, ncol + if (k < troplevchem(i)) then + sulfate(i,k) = 0.0_r8 + end if + end do + end do + + call outfld( 'SULF_TROP', sulfate(:ncol,:), ncol, lchnk ) + + !----------------------------------------------------------------- + ! ... compute the relative humidity + !----------------------------------------------------------------- + call qsat(tfld(:ncol,:), pmid(:ncol,:), satv, satq) + + do k = 1,pver + relhum(:,k) = .622_r8 * h2ovmr(:,k) / satq(:,k) + relhum(:,k) = max( 0._r8,min( 1._r8,relhum(:,k) ) ) + end do + + cwat(:ncol,:pver) = cldw(:ncol,:pver) + + call usrrxt( reaction_rates, tfld, ion_temp_fld, ele_temp_fld, invariants, h2ovmr, & + pmid, invariants(:,:,indexm), sulfate, mmr, relhum, strato_sad, & + troplevchem, dlats, ncol, sad_trop, reff, cwat, mbar, pbuf ) + + call outfld( 'SAD_TROP', sad_trop(:ncol,:), ncol, lchnk ) + + ! Add trop/strat components of SAD for output + sad_trop(:ncol,:)=sad_trop(:ncol,:)+strato_sad(:ncol,:) + call outfld( 'SAD_AERO', sad_trop(:ncol,:), ncol, lchnk ) + + ! Add trop/strat components of effective radius for output + reff(:ncol,:)=reff(:ncol,:)+reff_strat(:ncol,:) + call outfld( 'REFF_AERO', reff(:ncol,:), ncol, lchnk ) + + if (het1_ndx>0) then + call outfld( 'het1_total', reaction_rates(:,:,het1_ndx), ncol, lchnk ) + endif + + if (ghg_chem) then + call ghg_chem_set_rates( reaction_rates, latmapback, zen_angle, ncol, lchnk ) + endif + + do i = phtcnt+1,rxt_tag_cnt + call outfld( tag_names(i), reaction_rates(:ncol,:,rxt_tag_map(i)), ncol, lchnk ) + enddo + + call adjrxt( reaction_rates, invariants, invariants(1,1,indexm), ncol,pver ) + + !----------------------------------------------------------------------- + ! ... Compute the photolysis rates at time = t(n+1) + !----------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! ... Set the column densities + !----------------------------------------------------------------------- + call setcol( col_delta, col_dens, vmr, pdel, ncol ) + + !----------------------------------------------------------------------- + ! ... Calculate the photodissociation rates + !----------------------------------------------------------------------- + + esfact = 1._r8 + call shr_orb_decl( calday, eccen, mvelpp, lambm0, obliqr , & + delta, esfact ) + + + if ( xactive_prates ) then + if ( dst_ndx > 0 ) then + dust_vmr(:ncol,:,1:ndust) = vmr(:ncol,:,dst_ndx:dst_ndx+ndust-1) + else + dust_vmr(:ncol,:,:) = 0._r8 + endif + + !----------------------------------------------------------------- + ! ... compute the photolysis rates + !----------------------------------------------------------------- + call xactive_photo( reaction_rates, vmr, tfld, cwat, cldfr, & + pmid, zmidr, col_dens, zen_angle, asdir, & + invariants(1,1,indexm), ps, ts, & + esfact, relhum, dust_vmr, dt_diag, fracday, ncol, lchnk ) + + call outfld('DTCBS', dt_diag(:ncol,1), ncol, lchnk ) + call outfld('DTOCS', dt_diag(:ncol,2), ncol, lchnk ) + call outfld('DTSO4', dt_diag(:ncol,3), ncol, lchnk ) + call outfld('DTANT', dt_diag(:ncol,4), ncol, lchnk ) + call outfld('DTSAL', dt_diag(:ncol,5), ncol, lchnk ) + call outfld('DTDUST', dt_diag(:ncol,6), ncol, lchnk ) + call outfld('DTSOA', dt_diag(:ncol,7), ncol, lchnk ) + call outfld('DTTOTAL', dt_diag(:ncol,8), ncol, lchnk ) + call outfld('FRACDAY', fracday(:ncol), ncol, lchnk ) + + else + !----------------------------------------------------------------- + ! ... lookup the photolysis rates from table + !----------------------------------------------------------------- + call table_photo( reaction_rates, pmid, pdel, tfld, zmid, zint, & + col_dens, zen_angle, asdir, cwat, cldfr, & + esfact, vmr, invariants, ncol, lchnk, pbuf ) + endif + + do i = 1,phtcnt + call outfld( tag_names(i), reaction_rates(:ncol,:,rxt_tag_map(i)), ncol, lchnk ) + enddo + + !----------------------------------------------------------------------- + ! ... Adjust the photodissociation rates + !----------------------------------------------------------------------- + call O1D_to_2OH_adj( reaction_rates, invariants, invariants(:,:,indexm), ncol, tfld ) + call phtadj( reaction_rates, invariants, invariants(:,:,indexm), ncol,pver ) + + !----------------------------------------------------------------------- + ! ... Compute the extraneous frcing at time = t(n+1) + !----------------------------------------------------------------------- + if ( o2_ndx > 0 .and. o_ndx > 0 ) then + do k = 1,pver + o2mmr(:ncol,k) = mmr(:ncol,k,o2_ndx) + ommr(:ncol,k) = mmr(:ncol,k,o_ndx) + end do + endif + call setext( extfrc, zint, zintr, cldtop, & + zmid, lchnk, tfld, o2mmr, ommr, & + pmid, mbar, rlats, calday, ncol, rlons, pbuf ) + ! include forcings from fire emissions ... + call fire_emissions_vrt( ncol, lchnk, zint, fire_sflx, fire_ztop, extfrc ) + + do m = 1,extcnt + if( m /= synoz_ndx .and. m /= aoa_nh_ext_ndx ) then + do k = 1,pver + extfrc(:ncol,k,m) = extfrc(:ncol,k,m) / invariants(:ncol,k,indexm) + end do + endif + call outfld( extfrc_name(m), extfrc(:ncol,:,m), ncol, lchnk ) + end do + + !----------------------------------------------------------------------- + ! ... Form the washout rates + !----------------------------------------------------------------------- + if ( gas_wetdep_method=='MOZ' ) then + call sethet( het_rates, pmid, zmid, phis, tfld, & + cmfdqr, prain, nevapr, delt, invariants(:,:,indexm), & + vmr, ncol, lchnk ) + if (.not. convproc_do_aer) then + call het_diags( het_rates(:ncol,:,:), mmr(:ncol,:,:), pdel(:ncol,:), lchnk, ncol ) + endif + else + het_rates = 0._r8 + end if +! +! CCMI +! +! set loss to below the tropopause only +! + if ( st80_25_tau_ndx > 0 ) then + do i = 1,ncol + reaction_rates(i,1:troplev(i),st80_25_tau_ndx) = 0._r8 + enddo + end if + + if ( has_linoz_data ) then + ltrop_sol(:ncol) = troplev(:ncol) + else + ltrop_sol(:ncol) = 0 ! apply solver to all levels + endif + + ! save h2so4 before gas phase chem (for later new particle nucleation) + if (ndx_h2so4 > 0) then + del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) + else + del_h2so4_gasprod(:,:) = 0.0_r8 + endif + + vmr0(:ncol,:,:) = vmr(:ncol,:,:) ! mixing ratios before chemistry changes + + !======================================================================= + ! ... Call the class solution algorithms + !======================================================================= + !----------------------------------------------------------------------- + ! ... Solve for "Explicit" species + !----------------------------------------------------------------------- + call exp_sol( vmr, reaction_rates, het_rates, extfrc, delt, invariants(1,1,indexm), ncol, lchnk, ltrop_sol ) + + !----------------------------------------------------------------------- + ! ... Solve for "Implicit" species + !----------------------------------------------------------------------- + if ( has_strato_chem ) wrk(:,:) = vmr(:,:,h2o_ndx) + call t_startf('imp_sol') + ! + call imp_sol( vmr, reaction_rates, het_rates, extfrc, delt, & + ncol,pver, lchnk, prod_out, loss_out ) + + call t_stopf('imp_sol') + + call chem_prod_loss_diags_out( ncol, lchnk, vmr, reaction_rates, prod_out, loss_out, invariants(:ncol,:,indexm) ) + if( h2o_ndx>0) call outfld( 'H2O_GAS', vmr(1,1,h2o_ndx), ncol ,lchnk ) + + ! reset O3S to O3 in the stratosphere ... + if ( o3_ndx > 0 .and. o3s_ndx > 0 ) then + do i = 1,ncol + vmr(i,1:troplev(i),o3s_ndx) = vmr(i,1:troplev(i),o3_ndx) + end do + end if + + if (convproc_do_aer) then + call vmr2mmr( vmr(:ncol,:,:), mmr_new(:ncol,:,:), mbar(:ncol,:), ncol ) + ! mmr_new = average of mmr values before and after imp_sol + mmr_new(:ncol,:,:) = 0.5_r8*( mmr(:ncol,:,:) + mmr_new(:ncol,:,:) ) + call het_diags( het_rates(:ncol,:,:), mmr_new(:ncol,:,:), pdel(:ncol,:), lchnk, ncol ) + endif + + ! save h2so4 change by gas phase chem (for later new particle nucleation) + if (ndx_h2so4 > 0) then + del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_gasprod(1:ncol,:) + endif + +! +! Aerosol processes ... +! + + call aero_model_gasaerexch( imozart-1, ncol, lchnk, troplevchem, delt, reaction_rates, & + tfld, pmid, pdel, mbar, relhum, & + zm, qh2o, cwat, cldfr, ncldwtr, & + invariants(:,:,indexm), invariants, del_h2so4_gasprod, & + vmr0, vmr, pbuf ) + + if ( has_strato_chem ) then + + wrk(:ncol,:) = (vmr(:ncol,:,h2o_ndx) - wrk(:ncol,:))*delt_inverse + call outfld( 'QDCHEM', wrk(:ncol,:), ncol, lchnk ) + call outfld( 'HNO3_GAS', vmr(:ncol,:,hno3_ndx), ncol ,lchnk ) + + !----------------------------------------------------------------------- + ! ... aerosol settling + ! first settle hno3(2) using radius ice + ! secnd settle hno3(3) using radius large nat + !----------------------------------------------------------------------- + wrk(:,:) = vmr(:,:,h2o_ndx) +#ifdef ALT_SETTL + where( h2o_cond(:,:) > 0._r8 ) + settl_rad(:,:) = radius_strat(:,:,3) + elsewhere + settl_rad(:,:) = 0._r8 + endwhere + call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & + hno3_cond(1,1,2), settl_rad, ncol, lchnk, 1 ) + + where( h2o_cond(:,:) == 0._r8 ) + settl_rad(:,:) = radius_strat(:,:,2) + elsewhere + settl_rad(:,:) = 0._r8 + endwhere + call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & + hno3_cond(1,1,2), settl_rad, ncol, lchnk, 2 ) +#else + call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & + hno3_cond(1,1,2), radius_strat(1,1,2), ncol, lchnk, 2 ) +#endif + + !----------------------------------------------------------------------- + ! ... reform total hno3 and hcl = gas + all condensed + !----------------------------------------------------------------------- +! NOTE: vmr for hcl and hno3 is gas-phase at this point. +! hno3_cond(:,k,1) = STS; hno3_cond(:,k,2) = NAT + + do k = 1,pver + vmr(:,k,hno3_ndx) = vmr(:,k,hno3_ndx) + hno3_cond(:,k,1) & + + hno3_cond(:,k,2) + vmr(:,k,hcl_ndx) = vmr(:,k,hcl_ndx) + hcl_cond(:,k) + + end do + + wrk(:,:) = (vmr(:,:,h2o_ndx) - wrk(:,:))*delt_inverse + call outfld( 'QDSETT', wrk(:,:), ncol, lchnk ) + + endif + +! +! LINOZ +! + if ( do_lin_strat_chem ) then + call lin_strat_chem_solve( ncol, lchnk, vmr(:,:,o3_ndx), col_dens(:,:,1), tfld, zen_angle, pmid, delt, rlats, troplev ) + end if + + !----------------------------------------------------------------------- + ! ... Check for negative values and reset to zero + !----------------------------------------------------------------------- + call negtrc( 'After chemistry ', vmr, ncol ) + + !----------------------------------------------------------------------- + ! ... Set upper boundary mmr values + !----------------------------------------------------------------------- + call set_fstrat_vals( vmr, pmid, pint, troplev, calday, ncol,lchnk ) + + !----------------------------------------------------------------------- + ! ... Set fixed lower boundary mmr values + !----------------------------------------------------------------------- + call flbc_set( vmr, ncol, lchnk, map2chm ) + + !----------------------------------------------------------------------- + ! set NOy UBC + !----------------------------------------------------------------------- + call noy_ubc_set( lchnk, ncol, vmr ) + + if ( ghg_chem ) then + call ghg_chem_set_flbc( vmr, ncol ) + endif + + !----------------------------------------------------------------------- + ! force ion/electron balance -- ext forcings likely do not conserve charge + !----------------------------------------------------------------------- + call charge_balance( ncol, vmr ) + + !----------------------------------------------------------------------- + ! ... Xform from vmr to mmr + !----------------------------------------------------------------------- + call vmr2mmr( vmr(:ncol,:,:), mmr_tend(:ncol,:,:), mbar(:ncol,:), ncol ) + + call set_short_lived_species( mmr_tend, lchnk, ncol, pbuf ) + + !----------------------------------------------------------------------- + ! ... Form the tendencies + !----------------------------------------------------------------------- + do m = 1,gas_pcnst + mmr_new(:ncol,:,m) = mmr_tend(:ncol,:,m) + mmr_tend(:ncol,:,m) = (mmr_tend(:ncol,:,m) - mmr(:ncol,:,m))*delt_inverse + enddo + + do m = 1,pcnst + n = map2chm(m) + if( n > 0 ) then + qtend(:ncol,:,m) = qtend(:ncol,:,m) + mmr_tend(:ncol,:,n) + end if + end do + + tvs(:ncol) = tfld(:ncol,pver) * (1._r8 + qh2o(:ncol,pver)) + + sflx(:,:) = 0._r8 + call get_ref_date(yr, mon, day, sec) + ncdate = yr*10000 + mon*100 + day + wind_speed(:ncol) = sqrt( ufld(:ncol,pver)*ufld(:ncol,pver) + vfld(:ncol,pver)*vfld(:ncol,pver) ) + prect(:ncol) = precc(:ncol) + precl(:ncol) + + if ( drydep_method == DD_XLND ) then + soilw = -99 + call drydep( ocnfrac, icefrac, ncdate, ts, ps, & + wind_speed, qh2o(:,pver), tfld(:,pver), pmid(:,pver), prect, & + snowhland, fsds, depvel, sflx, mmr, & + tvs, soilw, relhum(:,pver:pver), ncol, lonndx, latndx, lchnk ) + else if ( drydep_method == DD_XATM ) then + table_soilw = has_drydep( 'H2' ) .or. has_drydep( 'CO' ) + if( .not. dyn_soilw .and. table_soilw ) then + call set_soilw( soilw, lchnk, calday ) + end if + call drydep( ncdate, ts, ps, & + wind_speed, qh2o(:,pver), tfld(:,pver), pmid(:,pver), prect, & + snowhland, fsds, depvel, sflx, mmr, & + tvs, soilw, relhum(:,pver:pver), ncol, lonndx, latndx, lchnk ) + else if ( drydep_method == DD_TABL ) then + call drydep( calday, ts, zen_angle, & + depvel, sflx, mmr, pmid(:,pver), & + tvs, ncol, icefrac, ocnfrac, lchnk ) + endif + + drydepflx(:,:) = 0._r8 + do m = 1,pcnst + n = map2chm( m ) + if ( n > 0 ) then + cflx(:ncol,m) = cflx(:ncol,m) - sflx(:ncol,n) + drydepflx(:ncol,m) = sflx(:ncol,n) + wetdepflx_diag(:ncol,n) = wetdepflx(:ncol,m) + endif + end do + + call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & + reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & + mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & + nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol), pbuf ) + + call rate_diags_calc( reaction_rates(:,:,:), vmr(:,:,:), invariants(:,:,indexm), ncol, lchnk ) +! +! jfl +! +! surface vmr +! + if ( pm25_srf_diag ) then + pm25(:ncol) = mmr_new(:ncol,pver,cb1_ndx) & + + mmr_new(:ncol,pver,cb2_ndx) & + + mmr_new(:ncol,pver,oc1_ndx) & + + mmr_new(:ncol,pver,oc2_ndx) & + + mmr_new(:ncol,pver,dst1_ndx) & + + mmr_new(:ncol,pver,dst2_ndx) & + + mmr_new(:ncol,pver,sslt1_ndx) & + + mmr_new(:ncol,pver,sslt2_ndx) & + + mmr_new(:ncol,pver,soa_ndx) & + + mmr_new(:ncol,pver,so4_ndx) + call outfld('PM25_SRF',pm25(:ncol) , ncol, lchnk ) + endif + if ( pm25_srf_diag_soa ) then + pm25(:ncol) = mmr_new(:ncol,pver,cb1_ndx) & + + mmr_new(:ncol,pver,cb2_ndx) & + + mmr_new(:ncol,pver,oc1_ndx) & + + mmr_new(:ncol,pver,oc2_ndx) & + + mmr_new(:ncol,pver,dst1_ndx) & + + mmr_new(:ncol,pver,dst2_ndx) & + + mmr_new(:ncol,pver,sslt1_ndx) & + + mmr_new(:ncol,pver,sslt2_ndx) & + + mmr_new(:ncol,pver,soam_ndx) & + + mmr_new(:ncol,pver,soai_ndx) & + + mmr_new(:ncol,pver,soat_ndx) & + + mmr_new(:ncol,pver,soab_ndx) & + + mmr_new(:ncol,pver,soax_ndx) & + + mmr_new(:ncol,pver,so4_ndx) + call outfld('PM25_SRF',pm25(:ncol) , ncol, lchnk ) + endif +! +! + call outfld('Q_SRF',qh2o(:ncol,pver) , ncol, lchnk ) + call outfld('U_SRF',ufld(:ncol,pver) , ncol, lchnk ) + call outfld('V_SRF',vfld(:ncol,pver) , ncol, lchnk ) + +! + if (.not.sad_pbf_ndx>0) then + deallocate(strato_sad) + endif + + end subroutine gas_phase_chemdr + +end module mo_gas_phase_chemdr diff --git a/src/chemistry/oslo_aero/mo_neu_wetdep.F90 b/src/chemistry/oslo_aero/mo_neu_wetdep.F90 new file mode 100644 index 0000000000..eae583761a --- /dev/null +++ b/src/chemistry/oslo_aero/mo_neu_wetdep.F90 @@ -0,0 +1,1793 @@ +! +! code written by J.-F. Lamarque, S. Walters and F. Vitt +! based on the original code from J. Neu developed for UC Irvine +! model +! +! LKE 2/23/2018 - correct setting flag for mass-limited (HNO3,etc.) vs Henry's Law washout +! +module mo_neu_wetdep +! + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + use constituents, only : pcnst + use spmd_utils, only : masterproc + use cam_abortutils, only : endrun + use seq_drydep_mod, only : n_species_table, species_name_table, dheff + use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt +#ifdef OSLO_AERO + use phys_control, only: phys_getopts + use mo_constants, only: rgrav + use phys_control, only: phys_getopts +#endif +! + implicit none +! + private + public :: neu_wetdep_init + public :: neu_wetdep_tend +! + save +! + integer, allocatable, dimension(:) :: mapping_to_heff,mapping_to_mmr + real(r8),allocatable, dimension(:) :: mol_weight + logical ,allocatable, dimension(:) :: ice_uptake + integer :: index_cldice,index_cldliq,nh3_ndx,co2_ndx + logical :: debug = .false. + integer :: hno3_ndx = 0 + integer :: h2o2_ndx = 0 +! +! diagnostics +! + logical :: do_diag = .false. + integer, parameter :: kdiag = 18 +! + real(r8), parameter :: zero = 0._r8 + real(r8), parameter :: one = 1._r8 +! + logical :: do_neu_wetdep +! + real(r8), parameter :: TICE=263._r8 + +contains + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! +subroutine neu_wetdep_init +! + use constituents, only : cnst_get_ind,cnst_mw + use cam_history, only : addfld, add_default, horiz_only + use phys_control, only : phys_getopts +! + integer :: m,l + character*20 :: test_name + + logical :: history_chemistry + + call phys_getopts(history_chemistry_out=history_chemistry) + + do_neu_wetdep = gas_wetdep_method == 'NEU' .and. gas_wetdep_cnt>0 + + if (.not.do_neu_wetdep) return + + allocate( mapping_to_heff(gas_wetdep_cnt) ) + allocate( mapping_to_mmr(gas_wetdep_cnt) ) + allocate( ice_uptake(gas_wetdep_cnt) ) + allocate( mol_weight(gas_wetdep_cnt) ) + +! +! find mapping to heff table +! + if ( debug ) then + print '(a,i4)','gas_wetdep_cnt=',gas_wetdep_cnt + print '(a,i4)','n_species_table=',n_species_table + end if + mapping_to_heff = -99 + do m=1,gas_wetdep_cnt +! + test_name = gas_wetdep_list(m) + if ( debug ) print '(i4,a)',m,trim(test_name) +! +! mapping based on the MOZART4 wet removal subroutine; +! this might need to be redone (JFL: Sep 2010) +! + select case( trim(test_name) ) +! +! CCMI: added SO2t and NH_50W +! + case( 'HYAC', 'CH3COOH' , 'HCOOH', 'EOOH', 'IEPOX' ) + test_name = 'CH2O' + case ( 'SOGB','SOGI','SOGM','SOGT','SOGX' ) + test_name = 'H2O2' + case ( 'SO2t' ) + test_name = 'SO2' + case ( 'CLONO2','BRONO2','HCL','HOCL','HOBR','HBR', 'Pb', 'MACROOH', 'ISOPOOH', 'XOOH', 'H2SO4', 'HF', 'COF2', 'COFCL') + test_name = 'HNO3' + case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) + test_name = 'HNO3' + case ( 'ALKOOH', 'MEKOOH', 'TOLOOH' ) + test_name = 'CH3OOH' + case( 'PHENOOH', 'BENZOOH', 'C6H5OOH', 'BZOOH', 'XYLOLOOH', 'XYLENOOH', 'HPALD' ) + test_name = 'CH3OOH' + case( 'TERPOOH', 'TERP2OOH', 'MBOOOH' ) + test_name = 'HNO3' + case( 'TERPROD1', 'TERPROD2' ) + test_name = 'CH2O' + case( 'HMPROP' ) + test_name = 'GLYALD' + case( 'NOA', 'ALKNIT', 'ISOPNITA', 'ISOPNITB', 'HONITR', 'ISOPNOOH' ) + test_name = 'H2O2' + case( 'NC4CHO', 'NC4CH2OH', 'TERPNIT', 'NTERPOOH' ) + test_name = 'H2O2' + case( 'SOAGbb0' ) ! Henry's Law coeff. added for VBS SOA's, biomass burning is the same as fossil fuels + test_name = 'SOAGff0' + case( 'SOAGbb1' ) + test_name = 'SOAGff1' + case( 'SOAGbb2' ) + test_name = 'SOAGff2' + case( 'SOAGbb3' ) + test_name = 'SOAGff3' + case( 'SOAGbb4' ) + test_name = 'SOAGff4' + end select +! + do l = 1,n_species_table +! +! if ( debug ) print '(i4,a)',l,trim(species_name_table(l)) +! + if( trim(test_name) == trim( species_name_table(l) ) ) then + mapping_to_heff(m) = l + if ( debug ) print '(a,a,i4)','mapping to heff of ',trim(species_name_table(l)),l + exit + end if + end do + if ( mapping_to_heff(m) == -99 ) then + if (masterproc) print *,'problem with mapping_to_heff of ',trim(test_name) +! call endrun() + end if +! +! special cases for NH3 and CO2 +! + if ( trim(test_name) == 'NH3' ) then + nh3_ndx = m + end if + if ( trim(test_name) == 'CO2' ) then + co2_ndx = m + end if + if ( trim(gas_wetdep_list(m)) == 'HNO3' ) then + hno3_ndx = m + end if +! + end do + + if (any ( mapping_to_heff(:) == -99 )) call endrun('mo_neu_wet->depwetdep_init: unmapped species error' ) +! + if ( debug ) then + print '(a,i4)','co2_ndx',co2_ndx + print '(a,i4)','nh3_ndx',nh3_ndx + end if +! +! find mapping to species +! + mapping_to_mmr = -99 + do m=1,gas_wetdep_cnt + if ( debug ) print '(i4,a)',m,trim(gas_wetdep_list(m)) + call cnst_get_ind(gas_wetdep_list(m), mapping_to_mmr(m), abort=.false. ) + if ( debug ) print '(a,i4)','mapping_to_mmr ',mapping_to_mmr(m) + if ( mapping_to_mmr(m) <= 0 ) then + print *,'problem with mapping_to_mmr of ',gas_wetdep_list(m) + call endrun('problem with mapping_to_mmr of '//trim(gas_wetdep_list(m))) + end if + end do +! +! define species-dependent arrays +! + do m=1,gas_wetdep_cnt +! + mol_weight(m) = cnst_mw(mapping_to_mmr(m)) + if ( debug ) print '(i4,a,f8.4)',m,' mol_weight ',mol_weight(m) + ice_uptake(m) = .false. + if ( trim(gas_wetdep_list(m)) == 'HNO3' ) then + ice_uptake(m) = .true. + end if +! +! + end do +! +! indices for cloud quantities +! + call cnst_get_ind( 'CLDICE', index_cldice ) + call cnst_get_ind( 'CLDLIQ', index_cldliq ) +! +! define output +! + do m=1,gas_wetdep_cnt + call addfld ('DTWR_'//trim(gas_wetdep_list(m)),(/ 'lev' /), 'A','kg/kg/s','wet removal Neu scheme tendency') + call addfld ('WD_'//trim(gas_wetdep_list(m)),horiz_only, 'A','kg/m2/s','vertical integrated wet deposition flux') + call addfld ('HEFF_'//trim(gas_wetdep_list(m)),(/ 'lev' /), 'A','M/atm','Effective Henrys Law coeff.') + if (history_chemistry) then + call add_default('DTWR_'//trim(gas_wetdep_list(m)), 1, ' ') + call add_default('WD_'//trim(gas_wetdep_list(m)), 1, ' ') + end if + end do +! + if ( do_diag ) then + call addfld ('QT_RAIN_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') + call addfld ('QT_RIME_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') + call addfld ('QT_WASH_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') + call addfld ('QT_EVAP_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') + if (history_chemistry) then + call add_default('QT_RAIN_HNO3',1,' ') + call add_default('QT_RIME_HNO3',1,' ') + call add_default('QT_WASH_HNO3',1,' ') + call add_default('QT_EVAP_HNO3',1,' ') + end if + end if +! + return +! +end subroutine neu_wetdep_init +! +subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & + prain, nevapr, cld, cmfdqr, wd_tend, wd_tend_int) +! + use ppgrid, only : pcols, pver +!!DEK + use phys_grid, only : get_area_all_p, get_rlat_all_p + use shr_const_mod, only : SHR_CONST_REARTH,SHR_CONST_G + use cam_history, only : outfld +! + implicit none +! + integer, intent(in) :: lchnk,ncol + real(r8), intent(in) :: mmr(pcols,pver,pcnst) ! mass mixing ratio (kg/kg) + real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! pressure delta about midpoints (Pa) + real(r8), intent(in) :: zint(pcols,pver+1) ! interface geopotential height above the surface (m) + real(r8), intent(in) :: tfld(pcols,pver) ! midpoint temperature (K) + real(r8), intent(in) :: delt ! timestep (s) +! + real(r8), intent(in) :: prain(ncol, pver) + real(r8), intent(in) :: nevapr(ncol, pver) + real(r8), intent(in) :: cld(ncol, pver) + real(r8), intent(in) :: cmfdqr(ncol, pver) + real(r8), intent(inout) :: wd_tend(pcols,pver,pcnst) + real(r8), intent(inout) :: wd_tend_int(pcols,pcnst) +! +! local arrays and variables +! + integer :: i,k,l,kk,m,id + real(r8), parameter :: rearth = SHR_CONST_REARTH ! radius earth (m) + real(r8), parameter :: gravit = SHR_CONST_G ! m/s^2 + real(r8), dimension(ncol) :: area, wk_out + real(r8), dimension(ncol,pver) :: cldice,cldliq,cldfrc,totprec,totevap,delz,delp,p + real(r8), dimension(ncol,pver) :: rls,evaprate,mass_in_layer,temp + real(r8), dimension(ncol,pver,gas_wetdep_cnt) :: trc_mass,heff,dtwr + real(r8), dimension(ncol,pver,gas_wetdep_cnt) :: wd_mmr + logical , dimension(gas_wetdep_cnt) :: tckaqb + integer , dimension(ncol) :: test_flag +! +! arrays for HNO3 diagnostics +! + real(r8), dimension(ncol,pver) :: qt_rain,qt_rime,qt_wash,qt_evap +! +! for Henry's law calculations +! + real(r8), parameter :: t0 = 298._r8 + real(r8), parameter :: ph = 1.e-5_r8 + real(r8), parameter :: ph_inv = 1._r8/ph + real(r8) :: e298, dhr + real(r8), dimension(ncol) :: dk1s,dk2s,wrk +!!DEK + real(r8) :: pi + real(r8) :: lats(pcols) + +#ifdef OSLO_AERO + real(r8) :: wrk_wd(pcols) + logical history_aerosol +#endif + +call phys_getopts( history_aerosol_out = history_aerosol) +! +! from cam/src/physics/cam/stratiform.F90 +! +!!DEK + pi = 4._r8*atan(1.0_r8) + + if (.not.do_neu_wetdep) return +! +! don't do anything if there are no species to be removed +! + if ( gas_wetdep_cnt == 0 ) return +! +! reset output variables +! + wd_tend_int = 0._r8 +! +! get area (in radians square) +! + call get_area_all_p(lchnk, ncol, area) + area = area * rearth**2 ! in m^2 +! +! reverse order along the vertical before calling +! J. Neu's wet removal subroutine +! + do k=1,pver + kk = pver - k + 1 + do i=1,ncol +! + mass_in_layer(i,k) = area(i) * pdel(i,kk)/gravit ! kg +! + cldice (i,k) = mmr(i,kk,index_cldice) ! kg/kg + cldliq (i,k) = mmr(i,kk,index_cldliq) ! kg/kg + cldfrc (i,k) = cld(i,kk) ! unitless +! + totprec(i,k) = (prain(i,kk)+cmfdqr(i,kk)) & + * mass_in_layer(i,k) ! kg/s + totevap(i,k) = nevapr(i,kk) * mass_in_layer(i,k) ! kg/s +! + delz(i,k) = zint(i,kk) - zint(i,kk+1) ! in m +! + temp(i,k) = tfld(i,kk) +! +! convert tracer mass to kg to kg/kg +! + trc_mass(i,k,:) = mmr(i,kk,mapping_to_mmr(:)) * mass_in_layer(i,k) +! + delp(i,k) = pdel(i,kk) * 0.01_r8 ! in hPa + p (i,k) = pmid(i,kk) * 0.01_r8 ! in hPa +! + end do + end do +! +! define array for tendency calculation (on model grid) +! + dtwr(1:ncol,:,:) = mmr(1:ncol,:,mapping_to_mmr(:)) +! +! compute 1) integrated precipitation flux across the interfaces (rls) +! 2) evaporation rate +! + rls (:,pver) = 0._r8 + evaprate (:,pver) = 0._r8 + do k=pver-1,1,-1 + rls (:,k) = max(0._r8,totprec(:,k)-totevap(:,k)+rls(:,k+1)) + !evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+totprec(:,k)+1.e-36_r8)) + evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) + end do +! +! compute effective Henry's law coefficients +! code taken from models/drv/shr/seq_drydep_mod.F90 +! + heff = 0._r8 + do k=1,pver +! + kk = pver - k + 1 +! + wrk(:) = (t0-tfld(1:ncol,kk))/(t0*tfld(1:ncol,kk)) +! + do m=1,gas_wetdep_cnt +! + l = mapping_to_heff(m) + id = 6*(l - 1) + e298 = dheff(id+1) + dhr = dheff(id+2) + heff(:,k,m) = e298*exp( dhr*wrk(:) ) + test_flag = -99 + if( dheff(id+3) /= 0._r8 .and. dheff(id+5) == 0._r8 ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + where( heff(:,k,m) /= 0._r8 ) + heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph_inv) + elsewhere + test_flag = 1 + heff(:,k,m) = dk1s(:)*ph_inv + endwhere + end if +! + if (k.eq.1 .and. maxval(test_flag) > 0 .and. debug ) print '(a,i4)','heff for m=',m +! + if( dheff(id+5) /= 0._r8 ) then + if( nh3_ndx > 0 .or. co2_ndx > 0 ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + e298 = dheff(id+5) + dhr = dheff(id+6) + dk2s(:) = e298*exp( dhr*wrk(:) ) + if( m == co2_ndx ) then + heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph_inv)*(1._r8 + dk2s(:)*ph_inv) + else if( m == nh3_ndx ) then + heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph/dk2s(:)) + else + write(iulog,*) 'error in assigning henrys law coefficients' + write(iulog,*) 'species ',m + end if + end if + end if +! + end do + end do +! + if ( debug ) then + print '(a,50f8.2)','tckaqb ',tckaqb + print '(a,50e12.4)','heff ',heff(1,1,:) + print '(a,50i4)' ,'ice_uptake ',ice_uptake + print '(a,50f8.2)','mol_weight ',mol_weight(:) + print '(a,50f8.2)','temp ',temp(1,:) + print '(a,50f8.2)','p ',p (1,:) + end if +! +! call J. Neu's subroutine +! + do i=1,ncol +! + call washo(pver,gas_wetdep_cnt,delt,trc_mass(i,:,:),mass_in_layer(i,:),p(i,:),delz(i,:) & + ,rls(i,:),cldliq(i,:),cldice(i,:),cldfrc(i,:),temp(i,:),evaprate(i,:) & + ,area(i),heff(i,:,:),mol_weight(:),tckaqb(:),ice_uptake(:) & + ,qt_rain(i,:),qt_rime(i,:),qt_wash(i,:),qt_evap(i,:) ) +! + end do +! +! compute tendencies and convert back to mmr +! on original vertical grid +! + do k=1,pver + kk = pver - k + 1 + do i=1,ncol +! +! convert tracer mass from kg +! + wd_mmr(i,kk,:) = trc_mass(i,k,:) / mass_in_layer(i,k) +! + end do + end do +! +! tendency calculation (on model grid) +! + dtwr(1:ncol,:,:) = wd_mmr(1:ncol,:,:) - dtwr(1:ncol,:,:) + dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt + +!!DEK polarward of 60S, 60N and <200hPa set to zero! + call get_rlat_all_p(lchnk, pcols, lats ) + do k = 1, pver + do i= 1, ncol + if ( abs( lats(i)*180._r8/pi ) > 60._r8 ) then + if ( pmid(i,k) < 20000._r8) then + dtwr(i,k,:) = 0._r8 + endif + endif + end do + end do +! +! output tendencies +! + do m=1,gas_wetdep_cnt + wd_tend(1:ncol,:,mapping_to_mmr(m)) = wd_tend(1:ncol,:,mapping_to_mmr(m)) + dtwr(1:ncol,:,m) + call outfld( 'DTWR_'//trim(gas_wetdep_list(m)),dtwr(:,:,m),ncol,lchnk ) + + call outfld( 'HEFF_'//trim(gas_wetdep_list(m)),heff(:,pver:1:-1,m),ncol,lchnk ) +! +! vertical integrated wet deposition rate [kg/m2/s] +! + wk_out = 0._r8 + do k=1,pver + kk = pver - k + 1 + wk_out(1:ncol) = wk_out(1:ncol) + (dtwr(1:ncol,k,m) * mass_in_layer(1:ncol,kk)/area(1:ncol)) + end do + call outfld( 'WD_'//trim(gas_wetdep_list(m)),wk_out,ncol,lchnk ) +! +! to be used in mo_chm_diags to compute wet_deposition_NOy_as_N and wet_deposition_NHx_as_N (units: kg/m2/s) +! + if ( debug) print *,'mo_neu ',mapping_to_mmr(m),(wk_out(1:ncol)) + wd_tend_int(1:ncol,mapping_to_mmr(m)) = wk_out(1:ncol) +! + end do + +!This is output normally in mo_chm_diags, but +!if neu wetdep, we have to output it here! +#ifdef OSLO_AERO + if(history_aerosol)then + do m=1,gas_wetdep_cnt + wrk_wd(:ncol) = 0.0_r8 + do k=1,pver + !Note sign: tendency is negative, so this becomes a positive flux! + wrk_wd(:ncol) = wrk_wd(:ncol) & + - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec + end do + call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) + end do + end if +#endif +! + if ( do_diag ) then + call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) + call outfld('QT_RIME_HNO3', qt_rime, ncol, lchnk ) + call outfld('QT_WASH_HNO3', qt_wash, ncol, lchnk ) + call outfld('QT_EVAP_HNO3', qt_evap, ncol, lchnk ) + end if +! + return +end subroutine neu_wetdep_tend + +!----------------------------------------------------------------------- +! +! Original code from Jessica Neu +! Updated by S. Walters and J.-F. Lamarque (March-April 2011) +! +!----------------------------------------------------------------------- + + subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & + RLS,CLWC,CIWC,CFR,TEM,EVAPRATE,GAREA,HSTAR,TCMASS,TCKAQB, & + TCNION, qt_rain, qt_rime, qt_wash, qt_evap) +! + implicit none + +!----------------------------------------------------------------------- +!---p-conde 5.4 (2007) -----called from main----- +!---called from pmain to calculate rainout and washout of tracers +!---revised by JNEU 8/2007 +!--- +!-LAER has been removed - no scavenging for aerosols +!-LAER could be used as LWASHTYP +!---WILL THIS WORK FOR T42->T21??????????? +!----------------------------------------------------------------------- + + integer LPAR, NTRACE + real(r8), intent(inout) :: QTTJFL(LPAR,NTRACE) + real(r8), intent(in) :: DTSCAV, QM(LPAR),POFL(LPAR),DELZ(LPAR),GAREA + real(r8), intent(in) :: RLS(LPAR),CLWC(LPAR),CIWC(LPAR),CFR(LPAR),TEM(LPAR), & + EVAPRATE(LPAR) + real(r8), intent(in) :: HSTAR(LPAR,NTRACE),TCMASS(NTRACE) + logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) +! + real(r8), intent(inout) :: qt_rain(lpar) + real(r8), intent(inout) :: qt_rime(lpar) + real(r8), intent(inout) :: qt_wash(lpar) + real(r8), intent(inout) :: qt_evap(lpar) +! + integer I,J,L,N,LE, LM1 + real(r8), dimension(LPAR) :: CFXX + real(r8), dimension(LPAR) :: QTT, QTTNEW + + real(r8) WRK, RNEW_TST + real(r8) CLWX + real(r8) RNEW,RPRECIP,DELTARIMEMASS,DELTARIME,RAMPCT + real(r8) MASSLOSS + real(r8) DOR,DNEW,DEMP,COLEFFSNOW,RHOSNOW + real(r8) WEMP,REMP,RRAIN,RWASH + real(r8) QTPRECIP,QTRAIN,QTCXA,QTAX,QTOC + + real(r8) FAMA,RAMA,DAMA,FCA,RCA,DCA + real(r8) FAX,RAX,DAX,FCXA,RCXA,DCXA,FCXB,RCXB,DCXB + real(r8) RAXADJ,FAXADJ,RAXADJF + real(r8) QTDISCF,QTDISRIME,QTDISCXA + real(r8) QTEVAPAXP,QTEVAPAXW,QTEVAPAX + real(r8) QTWASHAX + real(r8) QTEVAPCXAP,QTEVAPCXAW,QTEVAPCXA + real(r8) QTWASHCXA,QTRIMECXA + real(r8) QTRAINCXA,QTRAINCXB + real(r8) QTTOPCA,QTTOPAA,QTTOPCAX,QTTOPAAX + + real(r8) AMPCT,AMCLPCT,CLNEWPCT,CLNEWAMPCT,CLOLDPCT,CLOLDAMPCT + real(r8) RAXLOC,RCXALOC,RCXBLOC,RCALOC,RAMALOC,RCXPCT + + real(r8) QTNETLCXA,QTNETLCXB,QTNETLAX,QTNETL + real(r8) QTDISSTAR + + + real(r8), parameter :: CFMIN=0.1_r8 + real(r8), parameter :: CWMIN=1.0e-5_r8 + real(r8), parameter :: DMIN=1.0e-1_r8 !mm + real(r8), parameter :: VOLPOW=1._r8/3._r8 + real(r8), parameter :: RHORAIN=1.0e3_r8 !kg/m3 + real(r8), parameter :: RHOSNOWFIX=1.0e2_r8 !kg/m3 + real(r8), parameter :: COLEFFRAIN=0.7_r8 + real(r8), parameter :: TMIX=258._r8 + real(r8), parameter :: TFROZ=240._r8 + real(r8), parameter :: COLEFFAER=0.05_r8 +! +! additional work arrays and diagnostics +! + real(r8) :: rls_wrk(lpar) + real(r8) :: rnew_wrk(lpar) + real(r8) :: rca_wrk(lpar) + real(r8) :: fca_wrk(lpar) + real(r8) :: rcxa_wrk(lpar) + real(r8) :: fcxa_wrk(lpar) + real(r8) :: rcxb_wrk(lpar) + real(r8) :: fcxb_wrk(lpar) + real(r8) :: rax_wrk(lpar,2) + real(r8) :: fax_wrk(lpar,2) + real(r8) :: rama_wrk(lpar) + real(r8) :: fama_wrk(lpar) + real(r8) :: deltarime_wrk(lpar) + real(r8) :: clwx_wrk(lpar) + real(r8) :: frc(lpar,3) + real(r8) :: rlsog(lpar) +! + logical :: is_hno3 + logical :: rls_flag(lpar) + logical :: rnew_flag(lpar) + logical :: cf_trigger(lpar) + logical :: freezing(lpar) +! + real(r8), parameter :: four = 4._r8 + real(r8), parameter :: adj_factor = one + 10._r8*epsilon( one ) +! + integer :: LWASHTYP,LICETYP +! + if ( debug ) then + print '(a,50f8.2)','tckaqb ',tckaqb + print '(a,50e12.4)','hstar ',hstar(1,:) + print '(a,50i4)' ,'ice_uptake ',TCNION + print '(a,50f8.2)','mol_weight ',TCMASS(:) + print '(a,50f8.2)','temp ',tem(:) + print '(a,50f8.2)','p ',pofl(:) + end if + +!----------------------------------------------------------------------- + LE = LPAR-1 +! + rls_flag(1:le) = rls(1:le) > zero + freezing(1:le) = tem(1:le) < tice + rlsog(1:le) = rls(1:le)/garea +! +species_loop : & + do N = 1,NTRACE + QTT(:lpar) = QTTJFL(:lpar,N) + QTTNEW(:lpar) = QTTJFL(:lpar,N) + is_hno3 = n == hno3_ndx + if( is_hno3 ) then + qt_rain(:lpar) = zero + qt_rime(:lpar) = zero + qt_wash(:lpar) = zero + qt_evap(:lpar) = zero + rca_wrk(:lpar) = zero + fca_wrk(:lpar) = zero + rcxa_wrk(:lpar) = zero + fcxa_wrk(:lpar) = zero + rcxb_wrk(:lpar) = zero + fcxb_wrk(:lpar) = zero + rls_wrk(:lpar) = zero + rnew_wrk(:lpar) = zero + cf_trigger(:lpar) = .false. + clwx_wrk(:lpar) = -9999._r8 + deltarime_wrk(:lpar) = -9999._r8 + rax_wrk(:lpar,:) = zero + fax_wrk(:lpar,:) = zero + endif + +!----------------------------------------------------------------------- +! check whether soluble in ice +!----------------------------------------------------------------------- + if( TCNION(N) ) then + LICETYP = 1 + else + LICETYP = 2 + end if + +!----------------------------------------------------------------------- +! initialization +!----------------------------------------------------------------------- + QTTOPAA = zero + QTTOPCA = zero + + RCA = zero + FCA = zero + DCA = zero + RAMA = zero + FAMA = zero + DAMA = zero + + AMPCT = zero + AMCLPCT = zero + CLNEWPCT = zero + CLNEWAMPCT = zero + CLOLDPCT = zero + CLOLDAMPCT = zero +!----------------------------------------------------------------------- +! Check whether precip in top layer - if so, require CF ge 0.2 +!----------------------------------------------------------------------- + if( RLS(LE) > zero ) then + CFXX(LE) = max( CFMIN,CFR(LE) ) + else + CFXX(LE) = CFR(LE) + endif + + rnew_flag(1:le) = .false. + +level_loop : & + do L = LE,1,-1 + LM1 = L - 1 + FAX = zero + RAX = zero + DAX = zero + FCXA = zero + FCXB = zero + DCXA = zero + DCXB = zero + RCXA = zero + RCXB = zero + + QTDISCF = zero + QTDISRIME = zero + QTDISCXA = zero + + QTEVAPAXP = zero + QTEVAPAXW = zero + QTEVAPAX = zero + QTWASHAX = zero + + QTEVAPCXAP = zero + QTEVAPCXAW = zero + QTEVAPCXA = zero + QTRIMECXA = zero + QTWASHCXA = zero + QTRAINCXA = zero + QTRAINCXB = zero + + RAMPCT = zero + RCXPCT = zero + + RCXALOC = zero + RCXBLOC = zero + RAXLOC = zero + RAMALOC = zero + RCALOC = zero + + RPRECIP = zero + DELTARIMEMASS = zero + DELTARIME = zero + DOR = zero + DNEW = zero + + QTTOPAAX = zero + QTTOPCAX = zero + +has_rls : & + if( rls_flag(l) ) then +!----------------------------------------------------------------------- +!-----Evaporate ambient precip and decrease area------------------------- +!-----If ice, diam=diam falling from above If rain, diam=4mm (not used) +!-----Evaporate tracer contained in evaporated precip +!-----Can't evaporate more than we start with----------------------------- +!-----Don't do washout until we adjust ambient precip to match Rbot if needed +!------(after RNEW if statements) +!----------------------------------------------------------------------- + FAX = max( zero,FAMA*(one - evaprate(l)) ) + RAX = RAMA !kg/m2/s + if ( debug ) then + if( (l == 3 .or. l == 2) ) then + write(*,*) 'washout: l,rls,fax = ',l,rls(l),fax + endif + endif + if( FAMA > zero ) then + if( freezing(l) ) then + DAX = DAMA !mm + else + DAX = four !mm - not necessary + endif + else + DAX = zero + endif + + if( RAMA > zero ) then + QTEVAPAXP = min( QTTOPAA,EVAPRATE(L)*QTTOPAA ) + else + QTEVAPAXP = zero + endif + if( is_hno3 ) then + rax_wrk(l,1) = rax + fax_wrk(l,1) = fax + endif + + +!----------------------------------------------------------------------- +! Determine how much the in-cloud precip rate has increased------ +!----------------------------------------------------------------------- + WRK = RAX*FAX + RCA*FCA + if( WRK > 0._r8 ) then + RNEW_TST = RLS(L)/(GAREA * WRK) + else + RNEW_TST = 10._r8 + endif + RNEW = RLSOG(L) - (RAX*FAX + RCA*FCA) !GBA*CF + rnew_wrk(l) = rnew_tst + if ( debug ) then + if( is_hno3 .and. l == kdiag-1 ) then + write(*,*) ' ' + write(*,*) 'washout: rls,rax,fax,rca,fca' + write(*,'(1p,5g15.7)') rls(l),rax,fax,rca,fca + write(*,*) ' ' + endif + endif +!----------------------------------------------------------------------- +! if RNEW>0, there is growth and/or new precip formation +!----------------------------------------------------------------------- +has_rnew: if( rlsog(l) > adj_factor*(rax*fax + rca*fca) ) then +!----------------------------------------------------------------------- +! Min cloudwater requirement for cloud with new precip +! Min CF is set at top for LE, at end for other levels +! CWMIN is only needed for new precip formation - do not need for RNEW<0 +!----------------------------------------------------------------------- + if( cfxx(l) == zero ) then + if ( do_diag ) then + write(*,*) 'cfxx(l) == zero',l + write(*,*) qttjfl(:,n) + write(*,*) qm(:) + write(*,*) pofl(:) + write(*,*) delz(:) + write(*,*) rls(:) + write(*,*) clwc(:) + write(*,*) ciwc(:) + write(*,*) cfr(:) + write(*,*) tem(:) + write(*,*) evaprate(:) + write(*,*) hstar(:,n) + end if +! +! if we are here,, that means that there is +! a inconsistency and this will lead to a division +! by 0 later on! This column should then be skipped +! + QTTJFL(:lpar,n) = QTT(:lpar) + cycle species_loop +! +! call endrun() +! + endif + rnew_flag(l) = .true. + CLWX = max( CLWC(L)+CIWC(L),CWMIN*CFXX(L) ) + if( is_hno3 ) then + clwx_wrk(l) = clwx + endif +!----------------------------------------------------------------------- +! Area of old cloud and new cloud +!----------------------------------------------------------------------- + FCXA = FCA + FCXB = max( zero,CFXX(L)-FCXA ) +!----------------------------------------------------------------------- +! ICE +! For ice and mixed phase, grow precip in old cloud by riming +! Use only portion of cloudwater in old cloud fraction +! and rain above old cloud fraction +! COLEFF from Lohmann and Roeckner (1996), Loss rate from Rotstayn (1997) +!----------------------------------------------------------------------- +is_freezing : & + if( freezing(l) ) then + COLEFFSNOW = exp( 2.5e-2_r8*(TEM(L) - TICE) ) + if( TEM(L) <= TFROZ ) then + RHOSNOW = RHOSNOWFIX + else + RHOSNOW = 0.303_r8*(TEM(L) - TFROZ)*RHOSNOWFIX + endif + if( FCXA > zero ) then + if( DCA > zero ) then + DELTARIMEMASS = CLWX*QM(L)*(FCXA/CFXX(L))* & + (one - exp( (-COLEFFSNOW/(DCA*1.e-3_r8))*((RCA)/(2._r8*RHOSNOW))*DTSCAV )) !uses GBA R + else + DELTARIMEMASS = zero + endif + else + DELTARIMEMASS = zero + endif +!----------------------------------------------------------------------- +! Increase in precip rate due to riming (kg/m2/s): +! Limit to total increase in R in cloud +!----------------------------------------------------------------------- + if( FCXA > zero ) then + DELTARIME = min( RNEW/FCXA,DELTARIMEMASS/(FCXA*GAREA*DTSCAV) ) !GBA + else + DELTARIME = zero + endif + if( is_hno3 ) then + deltarime_wrk(l) = deltarime + endif +!----------------------------------------------------------------------- +! Find diameter of rimed precip, must be at least .1mm +!----------------------------------------------------------------------- + if( RCA > zero ) then + DOR = max( DMIN,(((RCA+DELTARIME)/RCA)**VOLPOW)*DCA ) + else + DOR = zero + endif +!----------------------------------------------------------------------- +! If there is some in-cloud precip left, we have new precip formation +! Will be spread over whole cloud fraction +!----------------------------------------------------------------------- +! Calculate precip rate in old and new cloud fractions +!----------------------------------------------------------------------- + RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !kg/m2/s !GBA +!----------------------------------------------------------------------- +! Calculate precip rate in old and new cloud fractions +!----------------------------------------------------------------------- + RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA + RCXB = RPRECIP !kg/m2/s GBA + +!----------------------------------------------------------------------- +! Find diameter of new precip from empirical relation using Rprecip +! in given area of box- use density of water, not snow, to convert kg/s +! to mm/s -> as given in Field and Heymsfield +! Also calculate diameter of mixed precip,DCXA, from empirical relation +! using total R in FCXA - this will give larger particles than averaging DOR and +! DNEW in the next level +! DNEW and DCXA must be at least .1mm +!----------------------------------------------------------------------- + if( RPRECIP > zero ) then + WEMP = (CLWX*QM(L))/(GAREA*CFXX(L)*DELZ(L)) !kg/m3 + REMP = RPRECIP/((RHORAIN/1.e3_r8)) !mm/s local + DNEW = DEMPIRICAL( WEMP, REMP ) + if ( debug ) then + if( is_hno3 .and. l >= 15 ) then + write(*,*) ' ' + write(*,*) 'washout: wemp,remp.dnew @ l = ',l + write(*,'(1p,3g15.7)') wemp,remp,dnew + write(*,*) ' ' + endif + endif + DNEW = max( DMIN,DNEW ) + if( FCXB > zero ) then + DCXB = DNEW + else + DCXB = zero + endif + else + DCXB = zero + endif + + if( FCXA > zero ) then + WEMP = (CLWX*QM(L)*(FCXA/CFXX(L)))/(GAREA*FCXA*DELZ(L)) !kg/m3 + REMP = RCXA/((RHORAIN/1.e3_r8)) !mm/s local + DEMP = DEMPIRICAL( WEMP, REMP ) + DCXA = ((RCA+DELTARIME)/RCXA)*DOR + (RPRECIP/RCXA)*DNEW + DCXA = max( DEMP,DCXA ) + DCXA = max( DMIN,DCXA ) + else + DCXA = zero + endif + if ( debug ) then + if( is_hno3 .and. l >= 15 ) then + write(*,*) ' ' + write(*,*) 'washout: rca,rcxa,deltarime,dor,rprecip,dnew @ l = ',l + write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew + write(*,*) 'washout: dcxa,dcxb,wemp,remp,demp' + write(*,'(1p,5g15.7)') dcxa,dcxb,wemp,remp,demp + write(*,*) ' ' + end if + endif + + if( QTT(L) > zero ) then +!----------------------------------------------------------------------- +! ICE SCAVENGING +!----------------------------------------------------------------------- +! For ice, rainout only hno3/aerosols using new precip +! Tracer dissolved given by Kaercher and Voigt (2006) for T<258K +! For T>258K, use Henry's Law with Retention coefficient +! Rain out in whole CF +!----------------------------------------------------------------------- + if( RPRECIP > zero ) then + if( LICETYP == 1 ) then + RRAIN = RPRECIP*GAREA !kg/s local + call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & + TEM(L),POFL(L),QM(L), & + QTT(L)*CFXX(L),QTDISCF ) + call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & + QM(L), QTT(L), QTDISCF, QTRAIN ) + WRK = QTRAIN/CFXX(L) + QTRAINCXA = FCXA*WRK + QTRAINCXB = FCXB*WRK + elseif( LICETYP == 2 ) then + QTRAINCXA = zero + QTRAINCXB = zero + endif + if( debug .and. is_hno3 .and. l == kdiag ) then + write(*,*) ' ' + write(*,*) 'washout: Ice Scavenging' + write(*,*) 'washout: qtraincxa, qtraincxb, fcxa, fcxb, qt_rain, cfxx(l), wrk @ level = ',l + write(*,'(1p,7g15.7)') qtraincxa, qtraincxb, fcxa, fcxb, qt_rain(l), cfxx(l), wrk + write(*,*) ' ' + endif + endif +!----------------------------------------------------------------------- +! For ice, accretion removal for hno3 and aerosols is propotional to riming, +! no accretion removal for gases +! remove only in mixed portion of cloud +! Limit DELTARIMEMASS to RNEW*DTSCAV for ice - evaporation of rimed ice to match +! RNEW precip rate would result in HNO3 escaping from ice (no trapping) +!----------------------------------------------------------------------- + if( DELTARIME > zero ) then + if( LICETYP == 1 ) then + if( TEM(L) <= TFROZ ) then + RHOSNOW = RHOSNOWFIX + else + RHOSNOW = 0.303_r8*(TEM(L) - TFROZ)*RHOSNOWFIX + endif + QTCXA = QTT(L)*FCXA + call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & + HSTAR(L,N), TEM(L), POFL(L), & + QM(L), QTCXA, QTDISRIME ) + QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) + if ( debug ) then + if( is_hno3 .and. l >= 15 ) then + write(*,*) ' ' + write(*,*) 'washout: fcxa,dca,rca,qtdisstar @ l = ',l + write(*,'(1p,4g15.7)') fcxa,dca,rca,qtdisstar + write(*,*) ' ' + endif + endif + QTRIMECXA = QTCXA* & + (one - exp((-COLEFFSNOW/(DCA*1.e-3_r8))* & + (RCA/(2._r8*RHOSNOW))* & !uses GBA R + (QTDISSTAR/QTCXA)*DTSCAV)) + QTRIMECXA = min( QTRIMECXA, & + ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) + elseif( LICETYP == 2 ) then + QTRIMECXA = zero + endif + endif + else + QTRAINCXA = zero + QTRAINCXB = zero + QTRIMECXA = zero + endif +!----------------------------------------------------------------------- +! For ice, no washout in interstitial cloud air +!----------------------------------------------------------------------- + QTWASHCXA = zero + QTEVAPCXA = zero + +!----------------------------------------------------------------------- +! RAIN +! For rain, accretion increases rain rate but diameter remains constant +! Diameter is 4mm (not used) +!----------------------------------------------------------------------- + else is_freezing + if( FCXA > zero ) then + DELTARIMEMASS = (CLWX*QM(L))*(FCXA/CFXX(L))* & + (one - exp( -0.24_r8*COLEFFRAIN*((RCA)**0.75_r8)*DTSCAV )) !local + else + DELTARIMEMASS = zero + endif +!----------------------------------------------------------------------- +! Increase in precip rate due to riming (kg/m2/s): +! Limit to total increase in R in cloud +!----------------------------------------------------------------------- + if( FCXA > zero ) then + DELTARIME = min( RNEW/FCXA,DELTARIMEMASS/(FCXA*GAREA*DTSCAV) ) !GBA + else + DELTARIME = zero + endif +!----------------------------------------------------------------------- +! If there is some in-cloud precip left, we have new precip formation +!----------------------------------------------------------------------- + RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !GBA + + RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA + RCXB = RPRECIP !kg/m2/s GBA + DCXA = FOUR + if( FCXB > zero ) then + DCXB = FOUR + else + DCXB = zero + endif +!----------------------------------------------------------------------- +! RAIN SCAVENGING +! For rain, rainout both hno3/aerosols and gases using new precip +!----------------------------------------------------------------------- + if( QTT(L) > zero ) then + if( RPRECIP > zero ) then + RRAIN = (RPRECIP*GAREA) !kg/s local + call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & + TEM(L), POFL(L), QM(L), & + QTT(L)*CFXX(L), QTDISCF ) + call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & + QM(L), QTT(L), QTDISCF, QTRAIN ) + WRK = QTRAIN/CFXX(L) + QTRAINCXA = FCXA*WRK + QTRAINCXB = FCXB*WRK + if( debug .and. is_hno3 .and. l == kdiag ) then + write(*,*) ' ' + write(*,*) 'washout: Rain Scavenging' + write(*,*) 'washout: qtraincxa, qtraincxb, fcxa, fcxb, qt_rain, cfxx(l), wrk @ level = ',l + write(*,'(1p,7g15.7)') qtraincxa, qtraincxb, fcxa, fcxb, qt_rain(l), cfxx(l), wrk + write(*,*) ' ' + endif + endif +!----------------------------------------------------------------------- +! For rain, accretion removal is propotional to riming +! caclulate for hno3/aerosols and gases +! Remove only in mixed portion of cloud +! Limit DELTARIMEMASS to RNEW*DTSCAV +!----------------------------------------------------------------------- + if( DELTARIME > zero ) then + QTCXA = QTT(L)*FCXA + call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & + HSTAR(L,N), TEM(L), POFL(L), & + QM(L), QTCXA, QTDISRIME ) + QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) + QTRIMECXA = QTCXA* & + (one - exp(-0.24_r8*COLEFFRAIN* & + ((RCA)**0.75_r8)* & !local + (QTDISSTAR/QTCXA)*DTSCAV)) + QTRIMECXA = min( QTRIMECXA, & + ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) + else + QTRIMECXA = zero + endif + else + QTRAINCXA = zero + QTRAINCXB = zero + QTRIMECXA = zero + endif +!----------------------------------------------------------------------- +! For rain, washout gases and HNO3/aerosols using rain from above old cloud +! Washout for HNO3/aerosols is only on non-dissolved portion, impaction-style +! Washout for gases is on non-dissolved portion, limited by QTTOP+QTRIME +!----------------------------------------------------------------------- + if( RCA > zero ) then + QTPRECIP = FCXA*QTT(L) - QTDISRIME + if( HSTAR(L,N) > 1.e4_r8 ) then + if( QTPRECIP > zero ) then + QTWASHCXA = QTPRECIP*(one - exp( -0.24_r8*COLEFFAER*((RCA)**0.75_r8)*DTSCAV )) !local + else + QTWASHCXA = zero + endif + QTEVAPCXA = zero + else + RWASH = RCA*GAREA !kg/s local + if( QTPRECIP > zero ) then + call WASHGAS( RWASH, FCA, DTSCAV, QTTOPCA+QTRIMECXA, & + HSTAR(L,N), TEM(L), POFL(L), & + QM(L), QTPRECIP, QTWASHCXA, QTEVAPCXA ) + else + QTWASHCXA = zero + QTEVAPCXA = zero + endif + endif + endif + endif is_freezing +!----------------------------------------------------------------------- +! If RNEW zero ) then + RCXA = min( RCA,RLS(L)/(GAREA*FCXA) ) !kg/m2/s GBA + if( FAX > zero .and. ((RCXA+1.e-12_r8) < RLS(L)/(GAREA*FCXA)) ) then + RAXADJF = RLS(L)/GAREA - RCXA*FCXA + RAMPCT = RAXADJF/(RAX*FAX) + FAXADJ = RAMPCT*FAX + if( FAXADJ > zero ) then + RAXADJ = RAXADJF/FAXADJ + else + RAXADJ = zero + endif + else + RAXADJ = zero + RAMPCT = zero + FAXADJ = zero + endif + else + RCXA = zero + if( FAX > zero ) then + RAXADJF = RLS(L)/GAREA + RAMPCT = RAXADJF/(RAX*FAX) + FAXADJ = RAMPCT*FAX + if( FAXADJ > zero ) then + RAXADJ = RAXADJF/FAXADJ + else + RAXADJ = zero + endif + else + RAXADJ = zero + RAMPCT = zero + FAXADJ = zero + endif + endif + + QTEVAPAXP = min( QTTOPAA,QTTOPAA - (RAMPCT*(QTTOPAA-QTEVAPAXP)) ) + FAX = FAXADJ + RAX = RAXADJ + if ( debug ) then + if( (l == 3 .or. l == 2) ) then + write(*,*) 'washout: l,fcxa,fax = ',l,fcxa,fax + endif + endif + +!----------------------------------------------------------------------- +! IN-CLOUD EVAPORATION/WASHOUT +! If precip out the bottom of the cloud is 0, evaporate everything +! If there is no cloud, QTTOPCA=0, so nothing happens +!----------------------------------------------------------------------- + if( RCXA <= zero ) then + QTEVAPCXA = QTTOPCA + RCXA = zero + DCXA = zero + else +!----------------------------------------------------------------------- +! If rain out the bottom of the cloud is >0 (but .le. RCA): +! For ice, decrease particle size, +! no washout +! no evap for non-ice gases (b/c there is nothing in ice) +! TTmix, hno3&aerosols are incorporated into ice structure: +! do not release +! For rain, assume full evaporation of some raindrops +! proportional evaporation for all species +! washout for gases using Rbot +! impact washout for hno3/aerosol portion in gas phase +!----------------------------------------------------------------------- +! if (TEM(L) < TICE ) then +is_freezing_a : & + if( freezing(l) ) then + QTWASHCXA = zero + DCXA = ((RCXA/RCA)**VOLPOW)*DCA + if( LICETYP == 1 ) then + if( TEM(L) <= TMIX ) then + MASSLOSS = (RCA-RCXA)*FCXA*GAREA*DTSCAV +!----------------------------------------------------------------------- +! note-QTT doesn't matter b/c T<258K +!----------------------------------------------------------------------- + call DISGAS( (MASSLOSS/QM(L)), FCXA, TCMASS(N), & + HSTAR(L,N), TEM(L), POFL(L), & + QM(L), QTT(L), QTEVAPCXA ) + QTEVAPCXA = min( QTTOPCA,QTEVAPCXA ) + else + QTEVAPCXA = zero + endif + elseif( LICETYP == 2 ) then + QTEVAPCXA = zero + endif + else is_freezing_a + QTEVAPCXAP = (RCA - RCXA)/RCA*QTTOPCA + DCXA = FOUR + QTCXA = FCXA*QTT(L) + if( HSTAR(L,N) > 1.e4_r8 ) then + if( QTT(L) > zero ) then + call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & + HSTAR(L,N), TEM(L), POFL(L), & + QM(L), QTCXA, QTDISCXA ) + if( QTCXA > QTDISCXA ) then + QTWASHCXA = (QTCXA - QTDISCXA)*(one - exp( -0.24_r8*COLEFFAER*((RCXA)**0.75_r8)*DTSCAV )) !local + else + QTWASHCXA = zero + endif + QTEVAPCXAW = zero + else + QTWASHCXA = zero + QTEVAPCXAW = zero + endif + else + RWASH = RCXA*GAREA !kg/s local + call WASHGAS( RWASH, FCXA, DTSCAV, QTTOPCA, HSTAR(L,N), & + TEM(L), POFL(L), QM(L), & + QTCXA-QTDISCXA, QTWASHCXA, QTEVAPCXAW ) + endif + QTEVAPCXA = QTEVAPCXAP + QTEVAPCXAW + endif is_freezing_a + endif + endif has_rnew + +!----------------------------------------------------------------------- +! AMBIENT WASHOUT +! Ambient precip is finalized - if it is rain, washout +! no ambient washout for ice, since gases are in vapor phase +!----------------------------------------------------------------------- + if( RAX > zero ) then + if( .not. freezing(l) ) then + QTAX = FAX*QTT(L) + if( HSTAR(L,N) > 1.e4_r8 ) then + QTWASHAX = QTAX* & + (one - exp(-0.24_r8*COLEFFAER* & + ((RAX)**0.75_r8)*DTSCAV)) !local + QTEVAPAXW = zero + else + RWASH = RAX*GAREA !kg/s local + call WASHGAS( RWASH, FAX, DTSCAV, QTTOPAA, HSTAR(L,N), & + TEM(L), POFL(L), QM(L), QTAX, & + QTWASHAX, QTEVAPAXW ) + endif + else + QTEVAPAXW = zero + QTWASHAX = zero + endif + else + QTEVAPAXW = zero + QTWASHAX = zero + endif + QTEVAPAX = QTEVAPAXP + QTEVAPAXW + +!----------------------------------------------------------------------- +! END SCAVENGING +! Require CF if our ambient evaporation rate would give less +! precip than R from model. +!----------------------------------------------------------------------- + if( do_diag .and. is_hno3 ) then + rls_wrk(l) = rls(l)/garea + rca_wrk(l) = rca + fca_wrk(l) = fca + rcxa_wrk(l) = rcxa + fcxa_wrk(l) = fcxa + rcxb_wrk(l) = rcxb + fcxb_wrk(l) = fcxb + rax_wrk(l,2) = rax + fax_wrk(l,2) = fax + endif +upper_level : & + if( L > 1 ) then + FAMA = max( FCXA + FCXB + FAX - CFR(LM1),zero ) + if( FAX > zero ) then + RAXLOC = RAX/FAX + else + RAXLOC = zero + endif + if( FCXA > zero ) then + RCXALOC = RCXA/FCXA + else + RCXALOC = zero + endif + if( FCXB > zero ) then + RCXBLOC = RCXB/FCXB + else + RCXBLOC = zero + endif + + if( CFR(LM1) >= CFMIN ) then + CFXX(LM1) = CFR(LM1) + else + if( adj_factor*RLSOG(LM1) >= (RCXA*FCXA + RCXB*FCXB + RAX*FAX)*(one - EVAPRATE(LM1)) ) then + CFXX(LM1) = CFMIN + cf_trigger(lm1) = .true. + else + CFXX(LM1) = CFR(LM1) + endif + if( is_hno3 .and. lm1 == kdiag .and. debug ) then + write(*,*) ' ' + write(*,*) 'washout: rls,garea,rcxa,fcxa,rcxb,fcxb,rax,fax' + write(*,'(1p,8g15.7)') rls(lm1),garea,rcxa,fcxa,rcxb,fcxb,rax,fax + write(*,*) ' ' + endif + endif +!----------------------------------------------------------------------- +! Figure out what will go into ambient and cloud below +! Don't do for lowest level +!----------------------------------------------------------------------- + if( FAX > zero ) then + RAXLOC = RAX/FAX + AMPCT = max( zero,min( one,(CFXX(L) + FAX - CFXX(LM1))/FAX ) ) + AMCLPCT = one - AMPCT + else + RAXLOC = zero + AMPCT = zero + AMCLPCT = zero + endif + if( FCXB > zero ) then + RCXBLOC = RCXB/FCXB + CLNEWPCT = max( zero,min( (CFXX(LM1) - FCXA)/FCXB,one ) ) + CLNEWAMPCT = one - CLNEWPCT + else + RCXBLOC = zero + CLNEWPCT = zero + CLNEWAMPCT = zero + endif + if( FCXA > zero ) then + RCXALOC = RCXA/FCXA + CLOLDPCT = max( zero,min( CFXX(LM1)/FCXA,one ) ) + CLOLDAMPCT = one - CLOLDPCT + else + RCXALOC = zero + CLOLDPCT = zero + CLOLDAMPCT = zero + endif +!----------------------------------------------------------------------- +! Remix everything for the next level +!----------------------------------------------------------------------- + FCA = min( CFXX(LM1),FCXA*CLOLDPCT + CLNEWPCT*FCXB + AMCLPCT*FAX ) + if( FCA > zero ) then +!----------------------------------------------------------------------- +! Maintain cloud core by reducing NC and AM area going into cloud below +!----------------------------------------------------------------------- + RCA = (RCXA*FCXA*CLOLDPCT + RCXB*FCXB*CLNEWPCT + RAX*FAX*AMCLPCT)/FCA + if ( debug ) then + if( is_hno3 ) then + write(*,*) ' ' + write(*,*) 'washout: rcxa,fcxa,cloldpctrca,rca,fca,dcxa @ l = ',l + write(*,'(1p,6g15.7)') rcxa,fcxa,cloldpct,rca,fca,dcxa + write(*,*) 'washout: rcxb,fcxb,clnewpct,dcxb' + write(*,'(1p,4g15.7)') rcxb,fcxb,clnewpct,dcxb + write(*,*) 'washout: rax,fax,amclpct,dax' + write(*,'(1p,4g15.7)') rax,fax,amclpct,dax + write(*,*) ' ' + endif + endif + + if (RCA > zero) then + DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & + (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & + (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX + else + DCA = zero + FCA = zero + endif + + else + FCA = zero + DCA = zero + RCA = zero + endif + + FAMA = FCXA + FCXB + FAX - CFXX(LM1) + if( FAMA > zero ) then + RAMA = (RCXA*FCXA*CLOLDAMPCT + RCXB*FCXB*CLNEWAMPCT + RAX*FAX*AMPCT)/FAMA + if( RAMA > zero ) then + DAMA = (RCXA*FCXA*CLOLDAMPCT)/(RAMA*FAMA)*DCXA + & + (RCXB*FCXB*CLNEWAMPCT)/(RAMA*FAMA)*DCXB + & + (RAX*FAX*AMPCT)/(RAMA*FAMA)*DAX + else + FAMA = zero + DAMA = zero + endif + else + FAMA = zero + DAMA = zero + RAMA = zero + endif + else upper_level + AMPCT = zero + AMCLPCT = zero + CLNEWPCT = zero + CLNEWAMPCT = zero + CLOLDPCT = zero + CLOLDAMPCT = zero + endif upper_level + else has_rls + RNEW = zero + QTEVAPCXA = QTTOPCA + QTEVAPAX = QTTOPAA + if( L > 1 ) then + if( RLS(LM1) > zero ) then + CFXX(LM1) = max( CFMIN,CFR(LM1) ) +! if( CFR(LM1) >= CFMIN ) then +! CFXX(LM1) = CFR(LM1) +! else +! CFXX(LM1) = CFMIN +! endif + else + CFXX(LM1) = CFR(LM1) + endif + endif + AMPCT = zero + AMCLPCT = zero + CLNEWPCT = zero + CLNEWAMPCT = zero + CLOLDPCT = zero + CLOLDAMPCT = zero + RCA = zero + RAMA = zero + FCA = zero + FAMA = zero + DCA = zero + DAMA = zero + endif has_rls + + if( do_diag .and. is_hno3 ) then + fama_wrk(l) = fama + rama_wrk(l) = rama + endif +!----------------------------------------------------------------------- +! Net loss can not exceed QTT in each region +!----------------------------------------------------------------------- + QTNETLCXA = QTRAINCXA + QTRIMECXA + QTWASHCXA - QTEVAPCXA + QTNETLCXA = min( QTT(L)*FCXA,QTNETLCXA ) + + QTNETLCXB =QTRAINCXB + QTNETLCXB = min( QTT(L)*FCXB,QTNETLCXB ) + + QTNETLAX = QTWASHAX - QTEVAPAX + QTNETLAX = min( QTT(L)*FAX,QTNETLAX ) + + QTTNEW(L) = QTT(L) - (QTNETLCXA + QTNETLCXB + QTNETLAX) + + if( do_diag .and. is_hno3 ) then + qt_rain(l) = qtraincxa + qtraincxb + qt_rime(l) = qtrimecxa + qt_wash(l) = qtwashcxa + qtwashax + qt_evap(l) = qtevapcxa + qtevapax + frc(l,1) = qtnetlcxa + frc(l,2) = qtnetlcxb + frc(l,3) = qtnetlax + endif + if( debug .and. is_hno3 .and. l == kdiag ) then + write(*,*) ' ' + write(*,*) 'washout: qtraincxa, qtraincxb, qtrimecxa @ level = ',l + write(*,'(1p,3g15.7)') qtraincxa, qtraincxb, qtrimecxa + write(*,*) ' ' + endif + if ( debug ) then + if( (l == 3 .or. l == 2) ) then + write(*,*) 'washout: hno3, hno3, qtnetlca,b, qtnetlax @ level = ',l + write(*,'(1p,5g15.7)') qttnew(l), qtt(l), qtnetlcxa, qtnetlcxb, qtnetlax + write(*,*) 'washout: qtwashax, qtevapax,fax,fama' + write(*,'(1p,5g15.7)') qtwashax, qtevapax, fax, fama + endif + endif + + QTTOPCAX = (QTTOPCA + QTNETLCXA)*CLOLDPCT + QTNETLCXB*CLNEWPCT + (QTTOPAA + QTNETLAX)*AMCLPCT + QTTOPAAX = (QTTOPCA + QTNETLCXA)*CLOLDAMPCT + QTNETLCXB*CLNEWAMPCT + (QTTOPAA + QTNETLAX)*AMPCT + QTTOPCA = QTTOPCAX + QTTOPAA = QTTOPAAX + end do level_loop + + if ( debug ) then + if( is_hno3 ) then + write(*,*) ' ' + write(*,*) 'washout: clwx_wrk' + write(*,'(1p,5g15.7)') clwx_wrk(1:le) + write(*,*) 'washout: cfr' + write(*,'(1p,5g15.7)') cfr(1:le) + write(*,*) 'washout: cfxx' + write(*,'(1p,5g15.7)') cfxx(1:le) + write(*,*) 'washout: cf trigger' + write(*,'(10l4)') cf_trigger(1:le) + write(*,*) 'washout: evaprate' + write(*,'(1p,5g15.7)') evaprate(1:le) + write(*,*) 'washout: rls' + write(*,'(1p,5g15.7)') rls(1:le) + write(*,*) 'washout: rls/garea' + write(*,'(1p,5g15.7)') rls_wrk(1:le) + write(*,*) 'washout: rnew_wrk' + write(*,'(1p,5g15.7)') rnew_wrk(1:le) + write(*,*) 'washout: rnew_flag' + write(*,'(10l4)') rnew_flag(1:le) + write(*,*) 'washout: deltarime_wrk' + write(*,'(1p,5g15.7)') deltarime_wrk(1:le) + write(*,*) 'washout: rama_wrk' + write(*,'(1p,5g15.7)') rama_wrk(1:le) + write(*,*) 'washout: fama_wrk' + write(*,'(1p,5g15.7)') fama_wrk(1:le) + write(*,*) 'washout: rca_wrk' + write(*,'(1p,5g15.7)') rca_wrk(1:le) + write(*,*) 'washout: fca_wrk' + write(*,'(1p,5g15.7)') fca_wrk(1:le) + write(*,*) 'washout: rcxa_wrk' + write(*,'(1p,5g15.7)') rcxa_wrk(1:le) + write(*,*) 'washout: fcxa_wrk' + write(*,'(1p,5g15.7)') fcxa_wrk(1:le) + write(*,*) 'washout: rcxb_wrk' + write(*,'(1p,5g15.7)') rcxb_wrk(1:le) + write(*,*) 'washout: fcxb_wrk' + write(*,'(1p,5g15.7)') fcxb_wrk(1:le) + write(*,*) 'washout: rax1_wrk' + write(*,'(1p,5g15.7)') rax_wrk(1:le,1) + write(*,*) 'washout: fax1_wrk' + write(*,'(1p,5g15.7)') fax_wrk(1:le,1) + write(*,*) 'washout: rax2_wrk' + write(*,'(1p,5g15.7)') rax_wrk(1:le,2) + write(*,*) 'washout: fax2_wrk' + write(*,'(1p,5g15.7)') fax_wrk(1:le,2) + write(*,*) 'washout: rls_flag' + write(*,'(1p,10l4)') rls_flag(1:le) + write(*,*) 'washout: freezing' + write(*,'(1p,10l4)') freezing(1:le) + write(*,*) 'washout: qtnetlcxa' + write(*,'(1p,5g15.7)') frc(1:le,1) + write(*,*) 'washout: qtnetlcxb' + write(*,'(1p,5g15.7)') frc(1:le,2) + write(*,*) 'washout: qtnetlax' + write(*,'(1p,5g15.7)') frc(1:le,3) + write(*,*) ' ' + endif + endif +!----------------------------------------------------------------------- +! reload new tracer mass and rescale moments: check upper limits (LE) +!----------------------------------------------------------------------- + QTTJFL(:le,N) = QTTNEW(:le) + + end do species_loop +! + return + end subroutine washo +!--------------------------------------------------------------------- + subroutine DISGAS (CLWX,CFX,MOLMASS,HSTAR,TM,PR,QM,QT,QTDIS) +!--------------------------------------------------------------------- + implicit none + real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction + real(r8), intent(in) :: MOLMASS !molecular mass of tracer + real(r8), intent(in) :: HSTAR !Henry's Law coeffs A*exp(-B/T) + real(r8), intent(in) :: TM !temperature of box (K) + real(r8), intent(in) :: PR !pressure of box (hPa) + real(r8), intent(in) :: QM !air mass in box (kg) + real(r8), intent(in) :: QT !tracer in box (kg) + real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase + + real(r8) MUEMP + real(r8), parameter :: INV298 = 1._r8/298._r8 + real(r8), parameter :: TMIX=258._r8 + real(r8), parameter :: RETEFF=0.5_r8 +!---Next calculate rate of uptake of tracer + +!---effective Henry's Law constant: H* = moles-T / liter-precip / press(atm-T) +!---p(atm of tracer-T) = (QT/QM) * (.029/MolWt-T) * pressr(hPa)/1000 +!---limit temperature effects to T above freezing +!----MU from fit to Kaercher and Voigt (2006) + + if(TM .ge. TICE) then + QTDIS=(HSTAR*(QT/(QM*CFX))*0.029_r8*(PR/1.0e3_r8))*(CLWX*QM) + elseif (TM .le. TMIX) then + MUEMP=exp(-14.2252_r8+(1.55704e-1_r8*TM)-(7.1929e-4_r8*(TM**2.0_r8))) + QTDIS=MUEMP*(MOLMASS/18._r8)*(CLWX*QM) + else + QTDIS=RETEFF*((HSTAR*(QT/(QM*CFX))*0.029_r8*(PR/1.0e3_r8))*(CLWX*QM)) + endif + + return + end subroutine DISGAS + +!----------------------------------------------------------------------- + subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) +!----------------------------------------------------------------------- +!---New trace-gas rainout from large-scale precip with two time scales, +!---one based on precip formation from cloud water and one based on +!---Henry's Law solubility: correct limit for delta-t +!--- +!---NB this code does not consider the aqueous dissociation (eg, C-q) +!--- that makes uptake of HNO3 and H2SO4 so complete. To do so would +!--- require that we keep track of the pH of the falling rain. +!---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! +!---ALSO the possible formation of other soluble species from, eg, CH2O, H2O2 +!--- can be considered with enhanced values of KHA. +!--- +!---Does NOT now use RMC (moist conv rain) but could, assuming 30% coverage +!----------------------------------------------------------------------- + implicit none + real(r8), intent(in) :: RRAIN !new rain formation in box (kg/s) + real(r8), intent(in) :: DTSCAV !time step (s) + real(r8), intent(in) :: CLWX,CFX !cloud water and cloud fraction + real(r8), intent(in) :: QM !air mass in box (kg) + real(r8), intent(in) :: QT !tracer in box (kg) + real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) + real(r8), intent(out) :: QTRAIN !tracer picked up by new rain + + real(r8) QTLF,QTDISSTAR + + + + + + QTDISSTAR=(QTDIS*(QT*CFX))/(QTDIS+(QT*CFX)) + +!---Tracer Loss frequency (1/s) within cloud fraction: + QTLF = (RRAIN*QTDISSTAR)/(CLWX*QM*QT*CFX) + +!---in time = DTSCAV, the amount of QTT scavenged is calculated +!---from CF*AMOUNT OF UPTAKE + QTRAIN = QT*CFX*(1._r8 - exp(-DTSCAV*QTLF)) + + return + end subroutine RAINGAS + + +!----------------------------------------------------------------------- + subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & + QT,QTWASH,QTEVAP) +!----------------------------------------------------------------------- +!---for most gases below-cloud washout assume Henry-Law equilib with precip +!---assumes that precip is liquid, if frozen, do not call this sub +!---since solubility is moderate, fraction of box with rain does not matter +!---NB this code does not consider the aqueous dissociation (eg, C-q) +!--- that makes uptake of HNO3 and H2SO4 so complete. To do so would +!--- require that we keep track of the pH of the falling rain. +!---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! +!---ALSO the possible formation of other soluble species from, eg, CH2O, H2O2 +!--- can be considered with enhanced values of KHA. +!----------------------------------------------------------------------- + implicit none + real(r8), intent(in) :: RWASH ! precip leaving bottom of box (kg/s) + real(r8), intent(in) :: BOXF ! fraction of box with washout + real(r8), intent(in) :: DTSCAV ! time step (s) + real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box +! over time step (kg) + real(r8), intent(in) :: HSTAR ! Henry's Law coeffs A*exp(-B/T) + real(r8), intent(in) :: TM ! temperature of box (K) + real(r8), intent(in) :: PR ! pressure of box (hPa) + real(r8), intent(in) :: QT ! tracer in box (kg) + real(r8), intent(in) :: QM ! air mass in box (kg) + real(r8), intent(out) :: QTWASH ! tracer picked up by precip (kg) + real(r8), intent(out) :: QTEVAP ! tracer evaporated from precip (kg) + + real(r8), parameter :: INV298 = 1._r8/298._r8 + real(r8) :: FWASH, QTMAX, QTDIF + +!---effective Henry's Law constant: H* = moles-T / liter-precip / press(atm-T) +!---p(atm of tracer-T) = (QT/QM) * (.029/MolWt-T) * pressr(hPa)/1000 +!---limit temperature effects to T above freezing + +! +! jfl +! +! added test for BOXF = 0. +! + if ( BOXF == 0._r8 ) then + QTWASH = 0._r8 + QTEVAP = 0._r8 + return + end if + +!---effective washout frequency (1/s): + FWASH = (RWASH*HSTAR*29.e-6_r8*PR)/(QM*BOXF) +!---equilib amount of T (kg) in rain thru bottom of box over time step + QTMAX = QT*FWASH*DTSCAV + if (QTMAX .gt. QTRTOP) then +!---more of tracer T can go into rain + QTDIF = min (QT, QTMAX-QTRTOP) + QTWASH = QTDIF * (1._r8 - exp(-DTSCAV*FWASH)) + QTEVAP=0._r8 + else +!--too much of T in rain, must degas/evap T + QTWASH = 0._r8 + QTEVAP = QTRTOP - QTMAX + endif + + return + end subroutine WASHGAS + +!----------------------------------------------------------------------- + function DEMPIRICAL (CWATER,RRATE) +!----------------------------------------------------------------------- + use shr_spfn_mod, only: shr_spfn_gamma + + implicit none + real(r8), intent(in) :: CWATER + real(r8), intent(in) :: RRATE + + real(r8) :: DEMPIRICAL + + real(r8) RRATEX,WX,THETA,PHI,ETA,BETA,ALPHA,BEE + real(r8) GAMTHETA,GAMBETA + + + + RRATEX=RRATE*3600._r8 !mm/hr + WX=CWATER*1.0e3_r8 !g/m3 + + if(RRATEX .gt. 0.04_r8) then + THETA=exp(-1.43_r8*dlog10(7._r8*RRATEX))+2.8_r8 + else + THETA=5._r8 + endif + PHI=RRATEX/(3600._r8*10._r8) !cgs units + ETA=exp((3.01_r8*THETA)-10.5_r8) + BETA=THETA/(1._r8+0.638_r8) + ALPHA=exp(4._r8*(BETA-3.5_r8)) + BEE=(.638_r8*THETA/(1._r8+.638_r8))-1.0_r8 + GAMTHETA = shr_spfn_gamma(THETA) + GAMBETA = shr_spfn_gamma(BETA+1._r8) + DEMPIRICAL=(((WX*ETA*GAMTHETA)/(1.0e6_r8*ALPHA*PHI*GAMBETA))** & + (-1._r8/BEE))*10._r8 ! in mm (wx/1e6 for cgs) + + + return + end function DEMPIRICAL +! +end module mo_neu_wetdep diff --git a/src/chemistry/oslo_aero/mo_setsox.F90 b/src/chemistry/oslo_aero/mo_setsox.F90 new file mode 100644 index 0000000000..669d8e7e17 --- /dev/null +++ b/src/chemistry/oslo_aero/mo_setsox.F90 @@ -0,0 +1,884 @@ + +module MO_SETSOX + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + + private + public :: sox_inti, setsox + public :: has_sox + + save + logical :: inv_o3 + integer :: id_msa + + integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 + integer :: id_so4, id_h2so4 + + logical :: has_sox = .true. + logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ox, inv_nh4no3, inv_ho2 + + logical :: cloud_borne = .false. + logical :: modal_aerosols = .false. + +contains + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine sox_inti + !----------------------------------------------------------------------- + ! ... initialize the hetero sox routine + !----------------------------------------------------------------------- + + use mo_chem_utls, only : get_spc_ndx, get_inv_ndx + use spmd_utils, only : masterproc + use phys_control, only : phys_getopts + use sox_cldaero_mod, only : sox_cldaero_init + + implicit none + + + call phys_getopts( & + prog_modal_aero_out=modal_aerosols ) + + cloud_borne = modal_aerosols + +#ifdef OSLO_AERO + cloud_borne = .TRUE. + modal_aerosols = .TRUE. +#endif + + !----------------------------------------------------------------- + ! ... get species indicies + !----------------------------------------------------------------- + + if (cloud_borne) then + id_h2so4 = get_spc_ndx( 'H2SO4' ) + else + id_so4 = get_spc_ndx( 'SO4' ) + endif + id_msa = get_spc_ndx( 'MSA' ) + + inv_so2 = .false. + id_so2 = get_inv_ndx( 'SO2' ) + inv_so2 = id_so2 > 0 + if ( .not. inv_so2 ) then + id_so2 = get_spc_ndx( 'SO2' ) + endif + + inv_NH3 = .false. + id_NH3 = get_inv_ndx( 'NH3' ) + inv_NH3 = id_NH3 > 0 + if ( .not. inv_NH3 ) then + id_NH3 = get_spc_ndx( 'NH3' ) + endif + + inv_HNO3 = .false. + id_HNO3 = get_inv_ndx( 'HNO3' ) + inv_HNO3 = id_hno3 > 0 + if ( .not. inv_HNO3 ) then + id_HNO3 = get_spc_ndx( 'HNO3' ) + endif + + inv_H2O2 = .false. + id_H2O2 = get_inv_ndx( 'H2O2' ) + inv_H2O2 = id_H2O2 > 0 + if ( .not. inv_H2O2 ) then + id_H2O2 = get_spc_ndx( 'H2O2' ) + endif + + inv_HO2 = .false. + id_HO2 = get_inv_ndx( 'HO2' ) + inv_HO2 = id_HO2 > 0 + if ( .not. inv_HO2 ) then + id_HO2 = get_spc_ndx( 'HO2' ) + endif + + inv_o3 = get_inv_ndx( 'O3' ) > 0 + if (inv_o3) then + id_o3 = get_inv_ndx( 'O3' ) + else + id_o3 = get_spc_ndx( 'O3' ) + endif + inv_ho2 = get_inv_ndx( 'HO2' ) > 0 + if (inv_ho2) then + id_ho2 = get_inv_ndx( 'HO2' ) + else + id_ho2 = get_spc_ndx( 'HO2' ) + endif + + has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) + if (cloud_borne) then + has_sox = has_sox .and. (id_h2so4>0) + else + has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) + endif + + if (masterproc) then + write(iulog,*) 'sox_inti: has_sox = ',has_sox + endif + + if( has_sox ) then + if (masterproc) then + write(iulog,*) '-----------------------------------------' + write(iulog,*) 'mozart will do sox aerosols' + write(iulog,*) '-----------------------------------------' + endif + else + return + end if + + call sox_cldaero_init() + + end subroutine sox_inti + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine SETSOX( & + ncol, & + lchnk, & + loffset,& + dtime, & + press, & + pdel, & + tfld, & + mbar, & + lwc, & + cldfrc, & + cldnum, & + xhnm, & + invariants, & + qcw, & + qin, & + xphlwc, & + aqso4, & + aqh2so4,& + aqso4_h2o2, & + aqso4_o3, & + yph_in, & + aqso4_h2o2_3d, & + aqso4_o3_3d & + ) + + !----------------------------------------------------------------------- + ! ... Compute heterogeneous reactions of SOX + ! + ! (0) using initial PH to calculate PH + ! (a) HENRYs law constants + ! (b) PARTIONING + ! (c) PH values + ! + ! (1) using new PH to repeat + ! (a) HENRYs law constants + ! (b) PARTIONING + ! (c) REACTION rates + ! (d) PREDICTION + !----------------------------------------------------------------------- + ! + use ppgrid, only : pcols, pver + use chem_mods, only : gas_pcnst, nfs + use chem_mods, only : adv_mass + use physconst, only : mwdry, gravit + use mo_constants, only : pi + use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj + use cldaero_mod, only : cldaero_conc_t + + ! + implicit none + ! + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! num of columns in chunk + integer, intent(in) :: lchnk ! chunk id + integer, intent(in) :: loffset ! offset of chem tracers in the advected tracers array + real(r8), intent(in) :: dtime ! time step (sec) + real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: tfld(:,:) ! temperature + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) + real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction + real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) + real(r8), intent(in) :: xhnm(:,:) ! total atms density ( /cm**3) + real(r8), intent(in) :: invariants(:,:,:) + real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) + real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) + real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc + + real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + real(r8), intent(in), optional :: yph_in ! ph value + real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) + + + !----------------------------------------------------------------------- + ! ... Local variables + ! + ! xhno3 ... in mixing ratio + !----------------------------------------------------------------------- + integer, parameter :: itermax = 20 + real(r8), parameter :: ph0 = 5.0_r8 ! INITIAL PH VALUES + real(r8), parameter :: const0 = 1.e3_r8/6.023e23_r8 + real(r8), parameter :: xa0 = 11._r8 + real(r8), parameter :: xb0 = -.1_r8 + real(r8), parameter :: xa1 = 1.053_r8 + real(r8), parameter :: xb1 = -4.368_r8 + real(r8), parameter :: xa2 = 1.016_r8 + real(r8), parameter :: xb2 = -2.54_r8 + real(r8), parameter :: xa3 = .816e-32_r8 + real(r8), parameter :: xb3 = .259_r8 + + real(r8), parameter :: kh0 = 9.e3_r8 ! HO2(g) -> Ho2(a) + real(r8), parameter :: kh1 = 2.05e-5_r8 ! HO2(a) -> H+ + O2- + real(r8), parameter :: kh2 = 8.6e5_r8 ! HO2(a) + ho2(a) -> h2o2(a) + o2 + real(r8), parameter :: kh3 = 1.e8_r8 ! HO2(a) + o2- -> h2o2(a) + o2 + real(r8), parameter :: Ra = 8314._r8/101325._r8 ! universal constant (atm)/(M-K) + real(r8), parameter :: xkw = 1.e-14_r8 ! water acidity + + ! + real(r8) :: xdelso4hp(ncol,pver) + + integer :: k, i, iter, file + real(r8) :: wrk, delta + real(r8) :: xph0, aden, xk, xe, x2 + real(r8) :: tz, xl, px, qz, pz, es, qs, patm + real(r8) :: Eso2, Eso4, Ehno3, Eco2, Eh2o, Enh3 + real(r8) :: so2g, h2o2g, co2g, o3g + real(r8) :: hno3a, nh3a, so2a, h2o2a, co2a, o3a + real(r8) :: rah2o2, rao3, pso4, ccc + real(r8) :: cnh3, chno3, com, com1, com2, xra + + real(r8) :: hno3g(ncol,pver), nh3g(ncol,pver) + ! + !----------------------------------------------------------------------- + ! for Ho2(g) -> H2o2(a) formation + ! schwartz JGR, 1984, 11589 + !----------------------------------------------------------------------- + real(r8) :: kh4 ! kh2+kh3 + real(r8) :: xam ! air density /cm3 + real(r8) :: ho2s ! ho2s = ho2(a)+o2- + real(r8) :: r1h2o2 ! prod(h2o2) by ho2 in mole/L(w)/s + real(r8) :: r2h2o2 ! prod(h2o2) by ho2 in mix/s + + real(r8), dimension(ncol,pver) :: & + xhno3, xh2o2, xso2, xso4, xno3, & + xnh3, xnh4, xo3, & + cfact, & + xph, xho2, & + xh2so4, xmsa, xso4_init, & + hehno3, & ! henry law const for hno3 + heh2o2, & ! henry law const for h2o2 + heso2, & ! henry law const for so2 + henh3, & ! henry law const for nh3 + heo3 !!, & ! henry law const for o3 + + real(r8) :: patm_x + + real(r8), dimension(ncol) :: work1 + logical :: converged + + real(r8), pointer :: xso4c(:,:) + real(r8), pointer :: xnh4c(:,:) + real(r8), pointer :: xno3c(:,:) + type(cldaero_conc_t), pointer :: cldconc + + real(r8) :: fact1_hno3, fact2_hno3, fact3_hno3 + real(r8) :: fact1_so2, fact2_so2, fact3_so2, fact4_so2 + real(r8) :: fact1_nh3, fact2_nh3, fact3_nh3 + real(r8) :: tmp_hp, tmp_hso3, tmp_hco3, tmp_nh4, tmp_no3 + real(r8) :: tmp_oh, tmp_so3, tmp_so4 + real(r8) :: tmp_neg, tmp_pos + real(r8) :: yph, yph_lo, yph_hi + real(r8) :: ynetpos, ynetpos_lo, ynetpos_hi + + !----------------------------------------------------------------- + ! ... NOTE: The press array is in pascals and must be + ! mutiplied by 10 to yield dynes/cm**2. + !----------------------------------------------------------------- + !================================================================== + ! ... First set the PH + !================================================================== + ! ... Initial values + ! The values of so2, so4 are after (1) SLT, and CHEM + !----------------------------------------------------------------- + xph0 = 10._r8**(-ph0) ! initial PH value + + do k = 1,pver + cfact(:,k) = xhnm(:,k) & ! /cm3(a) + * 1.e6_r8 & ! /m3(a) + * 1.38e-23_r8/287._r8 & ! Kg(a)/m3(a) + * 1.e-3_r8 ! Kg(a)/L(a) + end do + + cldconc => sox_cldaero_create_obj( cldfrc,qcw,lwc, cfact, ncol, loffset ) + xso4c => cldconc%so4c + xnh4c => cldconc%nh4c + xno3c => cldconc%no3c + + xso4(:,:) = 0._r8 + xno3(:,:) = 0._r8 + xnh4(:,:) = 0._r8 + + do k = 1,pver + xph(:,k) = xph0 ! initial PH value + + if ( inv_so2 ) then + xso2 (:,k) = invariants(:,k,id_so2)/xhnm(:,k) ! mixing ratio + else + xso2 (:,k) = qin(:,k,id_so2) ! mixing ratio + endif + + if (id_hno3 > 0) then + xhno3(:,k) = qin(:,k,id_hno3) + else + xhno3(:,k) = 0.0_r8 + endif + + if ( inv_h2o2 ) then + xh2o2 (:,k) = invariants(:,k,id_h2o2)/xhnm(:,k) ! mixing ratio + else + xh2o2 (:,k) = qin(:,k,id_h2o2) ! mixing ratio + endif + + if (id_nh3 > 0) then + xnh3 (:,k) = qin(:,k,id_nh3) + else + xnh3 (:,k) = 0.0_r8 + endif + + if ( inv_o3 ) then + xo3 (:,k) = invariants(:,k,id_o3)/xhnm(:,k) ! mixing ratio + else + xo3 (:,k) = qin(:,k,id_o3) ! mixing ratio + endif + if ( inv_ho2 ) then + xho2 (:,k) = invariants(:,k,id_ho2)/xhnm(:,k)! mixing ratio + else + xho2 (:,k) = qin(:,k,id_ho2) ! mixing ratio + endif + + if (cloud_borne) then + xh2so4(:,k) = qin(:,k,id_h2so4) + else + xso4 (:,k) = qin(:,k,id_so4) ! mixing ratio + endif + if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) + + end do + + !----------------------------------------------------------------- + ! ... Temperature dependent Henry constants + !----------------------------------------------------------------- + ver_loop0: do k = 1,pver !! pver loop for STEP 0 + col_loop0: do i = 1,ncol + + if (cloud_borne .and. cldfrc(i,k)>0._r8) then + xso4(i,k) = xso4c(i,k) / cldfrc(i,k) + xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) + xno3(i,k) = xno3c(i,k) / cldfrc(i,k) + endif + xl = cldconc%xlwc(i,k) + + if( xl >= 1.e-8_r8 ) then + work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 + + !----------------------------------------------------------------- + ! 21-mar-2011 changes by rce + ! ph calculation now uses bisection method to solve the electro-neutrality equation + ! 3-mode aerosols (where so4 is assumed to be nh4hso4) + ! old code set xnh4c = so4c + ! new code sets xnh4c = 0, then uses a -1 charge (instead of -2) + ! for so4 when solving the electro-neutrality equation + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + ! calculations done before iterating + !----------------------------------------------------------------- + + !----------------------------------------------------------------- + pz = .01_r8*press(i,k) !! pressure in mb + tz = tfld(i,k) + patm = pz/1013._r8 + xam = press(i,k)/(1.38e-23_r8*tz) !air density /M3 + + !----------------------------------------------------------------- + ! ... hno3 + !----------------------------------------------------------------- + ! previous code + ! hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) + ! px = hehno3(i,k) * Ra * tz * xl + ! hno3g = xhno3(i,k)/(1._r8 + px) + ! Ehno3 = xk*xe*hno3g *patm + ! equivalent new code + ! hehno3 = xk + xk*xe/hplus + ! hno3g = xhno3/(1 + px) + ! = xhno3/(1 + hehno3*ra*tz*xl) + ! = xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) + ! ehno3 = hno3g*xk*xe*patm + ! = xk*xe*patm*xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) + ! = ( fact1_hno3 )/(1 + fact2_hno3 *(1 + fact3_hno3/hplus) + ! [hno3-] = ehno3/hplus + xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) + xe = 15.4_r8 + fact1_hno3 = xk*xe*patm*xhno3(i,k) + fact2_hno3 = xk*ra*tz*xl + fact3_hno3 = xe + + !----------------------------------------------------------------- + ! ... so2 + !----------------------------------------------------------------- + ! previous code + ! heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) + ! px = heso2(i,k) * Ra * tz * xl + ! so2g = xso2(i,k)/(1._r8+ px) + ! Eso2 = xk*xe*so2g *patm + ! equivalent new code + ! heso2 = xk + xk*xe/hplus * xk*xe*x2/hplus**2 + ! so2g = xso2/(1 + px) + ! = xso2/(1 + heso2*ra*tz*xl) + ! = xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) + ! eso2 = so2g*xk*xe*patm + ! = xk*xe*patm*xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) + ! = ( fact1_so2 )/(1 + fact2_so2 *(1 + (fact3_so2/hplus)*(1 + fact4_so2/hplus) + ! [hso3-] + 2*[so3--] = (eso2/hplus)*(1 + 2*x2/hplus) + xk = 1.23_r8 *EXP( 3120._r8*work1(i) ) + xe = 1.7e-2_r8*EXP( 2090._r8*work1(i) ) + x2 = 6.0e-8_r8*EXP( 1120._r8*work1(i) ) + fact1_so2 = xk*xe*patm*xso2(i,k) + fact2_so2 = xk*ra*tz*xl + fact3_so2 = xe + fact4_so2 = x2 + + !----------------------------------------------------------------- + ! ... nh3 + !----------------------------------------------------------------- + ! previous code + ! henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/xkw) + ! px = henh3(i,k) * Ra * tz * xl + ! nh3g = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) + ! Enh3 = xk*xe*nh3g/xkw *patm + ! equivalent new code + ! henh3 = xk + xk*xe*hplus/xkw + ! nh3g = xnh34/(1 + px) + ! = xnh34/(1 + henh3*ra*tz*xl) + ! = xnh34/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) + ! enh3 = nh3g*xk*xe*patm/xkw + ! = ((xk*xe*patm/xkw)*xnh34)/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) + ! = ( fact1_nh3 )/(1 + fact2_nh3 *(1 + fact3_nh3*hplus) + ! [nh4+] = enh3*hplus + xk = 58._r8 *EXP( 4085._r8*work1(i) ) + xe = 1.7e-5_r8*EXP( -4325._r8*work1(i) ) + + fact1_nh3 = (xk*xe*patm/xkw)*(xnh3(i,k)+xnh4(i,k)) + fact2_nh3 = xk*ra*tz*xl + fact3_nh3 = xe/xkw + + !----------------------------------------------------------------- + ! ... h2o effects + !----------------------------------------------------------------- + Eh2o = xkw + + !----------------------------------------------------------------- + ! ... co2 effects + !----------------------------------------------------------------- + co2g = 330.e-6_r8 !330 ppm = 330.e-6 atm + xk = 3.1e-2_r8*EXP( 2423._r8*work1(i) ) + xe = 4.3e-7_r8*EXP(-913._r8 *work1(i) ) + Eco2 = xk*xe*co2g *patm + + !----------------------------------------------------------------- + ! ... so4 effect + !----------------------------------------------------------------- + Eso4 = xso4(i,k)*xhnm(i,k) & ! /cm3(a) + *const0/xl + + + !----------------------------------------------------------------- + ! now use bisection method to solve electro-neutrality equation + ! + ! during the iteration loop, + ! yph_lo = lower ph value that brackets the root (i.e., correct ph) + ! yph_hi = upper ph value that brackets the root (i.e., correct ph) + ! yph = current ph value + ! yposnet_lo and yposnet_hi = net positive ions for + ! yph_lo and yph_hi + !----------------------------------------------------------------- + do iter = 1,itermax + + if (.not. present(yph_in)) then + if (iter == 1) then + ! 1st iteration ph = lower bound value + yph_lo = 2.0_r8 + yph_hi = yph_lo + yph = yph_lo + else if (iter == 2) then + ! 2nd iteration ph = upper bound value + yph_hi = 7.0_r8 + yph = yph_hi + else + ! later iteration ph = mean of the two bracketing values + yph = 0.5_r8*(yph_lo + yph_hi) + end if + else + yph = yph_in + end if + + ! calc current [H+] from ph + xph(i,k) = 10.0_r8**(-yph) + + + !----------------------------------------------------------------- + ! ... hno3 + !----------------------------------------------------------------- + Ehno3 = fact1_hno3/(1.0_r8 + fact2_hno3*(1.0_r8 + fact3_hno3/xph(i,k))) + + !----------------------------------------------------------------- + ! ... so2 + !----------------------------------------------------------------- + Eso2 = fact1_so2/(1.0_r8 + fact2_so2*(1.0_r8 + (fact3_so2/xph(i,k)) & + *(1.0_r8 + fact4_so2/xph(i,k)))) + + !----------------------------------------------------------------- + ! ... nh3 + !----------------------------------------------------------------- + Enh3 = fact1_nh3/(1.0_r8 + fact2_nh3*(1.0_r8 + fact3_nh3*xph(i,k))) + + tmp_nh4 = Enh3 * xph(i,k) + tmp_hso3 = Eso2 / xph(i,k) + tmp_so3 = tmp_hso3 * 2.0_r8*fact4_so2/xph(i,k) + tmp_hco3 = Eco2 / xph(i,k) + tmp_oh = Eh2o / xph(i,k) + tmp_no3 = Ehno3 / xph(i,k) + tmp_so4 = cldconc%so4_fact*Eso4 + tmp_pos = xph(i,k) + tmp_nh4 + tmp_neg = tmp_oh + tmp_hco3 + tmp_no3 + tmp_hso3 + tmp_so3 + tmp_so4 + + ynetpos = tmp_pos - tmp_neg + + + ! yposnet = net positive ions/charge + ! if the correct ph is bracketed by yph_lo and yph_hi (with yph_lo < yph_hi), + ! then you will have yposnet_lo > 0 and yposnet_hi < 0 + converged = .false. + if (iter > 2) then + if (ynetpos == 0.0_r8) then + ! the exact solution was found (very unlikely) + tmp_hp = xph(i,k) + converged = .true. + exit + else if (ynetpos >= 0.0_r8) then + ! net positive ions are >= 0 for both yph and yph_lo + ! so replace yph_lo with yph + yph_lo = yph + ynetpos_lo = ynetpos + else + ! net positive ions are <= 0 for both yph and yph_hi + ! so replace yph_hi with yph + yph_hi = yph + ynetpos_hi = ynetpos + end if + + if (abs(yph_hi - yph_lo) .le. 0.005_r8) then + ! |yph_hi - yph_lo| <= convergence criterion, so set + ! final ph to their midpoint and exit + ! (.005 absolute error in pH gives .01 relative error in H+) + tmp_hp = xph(i,k) + yph = 0.5_r8*(yph_hi + yph_lo) + xph(i,k) = 10.0_r8**(-yph) + converged = .true. + exit + else + ! do another iteration + converged = .false. + end if + + else if (iter == 1) then + if (ynetpos <= 0.0_r8) then + ! the lower and upper bound ph values (2.0 and 7.0) do not bracket + ! the correct ph, so use the lower bound + tmp_hp = xph(i,k) + converged = .true. + exit + end if + ynetpos_lo = ynetpos + + else ! (iter == 2) + if (ynetpos >= 0.0_r8) then + ! the lower and upper bound ph values (2.0 and 7.0) do not bracket + ! the correct ph, so use they upper bound + tmp_hp = xph(i,k) + converged = .true. + exit + end if + ynetpos_hi = ynetpos + end if + + end do ! iter + + if( .not. converged ) then + write(iulog,*) 'SETSOX: pH failed to converge @ (',i,',',k,'), % change=', & + 100._r8*delta + end if + else + xph(i,k) = 1.e-7_r8 + end if + end do col_loop0 + end do ver_loop0 ! end pver loop for STEP 0 + + !============================================================== + ! ... Now use the actual PH + !============================================================== + ver_loop1: do k = 1,pver + col_loop1: do i = 1,ncol + work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 + tz = tfld(i,k) + + xl = cldconc%xlwc(i,k) + + patm = press(i,k)/101300._r8 ! press is in pascal + xam = press(i,k)/(1.38e-23_r8*tz) ! air density /M3 + + !----------------------------------------------------------------------- + ! ... hno3 + !----------------------------------------------------------------------- + xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) + xe = 15.4_r8 + hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) + + !----------------------------------------------------------------- + ! ... h2o2 + !----------------------------------------------------------------- + xk = 7.4e4_r8 *EXP( 6621._r8*work1(i) ) + xe = 2.2e-12_r8 *EXP(-3730._r8*work1(i) ) + heh2o2(i,k) = xk*(1._r8 + xe/xph(i,k)) + + !----------------------------------------------------------------- + ! ... so2 + !----------------------------------------------------------------- + xk = 1.23_r8 *EXP( 3120._r8*work1(i) ) + xe = 1.7e-2_r8*EXP( 2090._r8*work1(i) ) + x2 = 6.0e-8_r8*EXP( 1120._r8*work1(i) ) + + wrk = xe/xph(i,k) + heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) + + !----------------------------------------------------------------- + ! ... nh3 + !----------------------------------------------------------------- + xk = 58._r8 *EXP( 4085._r8*work1(i) ) + xe = 1.7e-5_r8*EXP(-4325._r8*work1(i) ) + henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/xkw) + + !----------------------------------------------------------------- + ! ... o3 + !----------------------------------------------------------------- + xk = 1.15e-2_r8 *EXP( 2560._r8*work1(i) ) + heo3(i,k) = xk + + !------------------------------------------------------------------------ + ! ... for Ho2(g) -> H2o2(a) formation + ! schwartz JGR, 1984, 11589 + !------------------------------------------------------------------------ + kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1._r8 + kh1/xph(i,k))**2) + ho2s = kh0*xho2(i,k)*patm*(1._r8 + kh1/xph(i,k)) ! ho2s = ho2(a)+o2- + r1h2o2 = kh4*ho2s*ho2s ! prod(h2o2) in mole/L(w)/s + + if ( cloud_borne ) then + r2h2o2 = r1h2o2*xl & ! mole/L(w)/s * L(w)/fm3(a) = mole/fm3(a)/s + / const0*1.e+6_r8 & ! correct a bug here ???? + / xam + else + r2h2o2 = r1h2o2*xl & ! mole/L(w)/s * L(w)/fm3(a) = mole/fm3(a)/s + * const0 & ! mole/fm3(a)/s * 1.e-3 = mole/cm3(a)/s + / xam ! /cm3(a)/s / air-den = mix-ratio/s + endif + + if ( .not. modal_aerosols ) then + xh2o2(i,k) = xh2o2(i,k) + r2h2o2*dtime ! updated h2o2 by het production + endif + + !----------------------------------------------- + ! ... Partioning + !----------------------------------------------- + + !----------------------------------------------------------------- + ! ... hno3 + !----------------------------------------------------------------- + px = hehno3(i,k) * Ra * tz * xl + hno3g(i,k) = (xhno3(i,k)+xno3(i,k))/(1._r8 + px) + + !------------------------------------------------------------------------ + ! ... h2o2 + !------------------------------------------------------------------------ + px = heh2o2(i,k) * Ra * tz * xl + h2o2g = xh2o2(i,k)/(1._r8+ px) + + !------------------------------------------------------------------------ + ! ... so2 + !------------------------------------------------------------------------ + px = heso2(i,k) * Ra * tz * xl + so2g = xso2(i,k)/(1._r8+ px) + + !------------------------------------------------------------------------ + ! ... o3 + !------------------------------------------------------------------------ + px = heo3(i,k) * Ra * tz * xl + o3g = xo3(i,k)/(1._r8+ px) + + !------------------------------------------------------------------------ + ! ... nh3 + !------------------------------------------------------------------------ + px = henh3(i,k) * Ra * tz * xl + if (id_nh3>0) then + nh3g(i,k) = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) + else + nh3g(i,k) = 0._r8 + endif + + !----------------------------------------------- + ! ... Aqueous phase reaction rates + ! SO2 + H2O2 -> SO4 + ! SO2 + O3 -> SO4 + !----------------------------------------------- + + !------------------------------------------------------------------------ + ! ... S(IV) (HSO3) + H2O2 + !------------------------------------------------------------------------ + rah2o2 = 8.e4_r8 * EXP( -3650._r8*work1(i) ) & + / (.1_r8 + xph(i,k)) + + !------------------------------------------------------------------------ + ! ... S(IV)+ O3 + !------------------------------------------------------------------------ + rao3 = 4.39e11_r8 * EXP(-4131._r8/tz) & + + 2.56e3_r8 * EXP(-996._r8 /tz) /xph(i,k) + + !----------------------------------------------------------------- + ! ... Prediction after aqueous phase + ! so4 + ! When Cloud is present + ! + ! S(IV) + H2O2 = S(VI) + ! S(IV) + O3 = S(VI) + ! + ! reference: + ! (1) Seinfeld + ! (2) Benkovitz + !----------------------------------------------------------------- + + !............................ + ! S(IV) + H2O2 = S(VI) + !............................ + + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED + + if (cloud_borne) then + patm_x = patm + else + patm_x = 1._r8 + endif + + if (modal_aerosols) then + + pso4 = rah2o2 * 7.4e4_r8*EXP(6621._r8*work1(i)) * h2o2g * patm_x & + * 1.23_r8 *EXP(3120._r8*work1(i)) * so2g * patm_x + else + pso4 = rah2o2 * heh2o2(i,k) * h2o2g * patm_x & + * heso2(i,k) * so2g * patm_x ! [M/s] + + endif + + pso4 = pso4 & ! [M/s] = [mole/L(w)/s] + * xl & ! [mole/L(a)/s] + / const0 & ! [/L(a)/s] + / xhnm(i,k) + + + ccc = pso4*dtime + ccc = max(ccc, 1.e-30_r8) + + xso4_init(i,k)=xso4(i,k) + + IF (xh2o2(i,k) .gt. xso2(i,k)) THEN + if (ccc .gt. xso2(i,k)) then + xso4(i,k)=xso4(i,k)+xso2(i,k) + if (cloud_borne) then + xh2o2(i,k)=xh2o2(i,k)-xso2(i,k) + xso2(i,k)=1.e-20_r8 + else ! ???? bug ???? + xso2(i,k)=1.e-20_r8 + xh2o2(i,k)=xh2o2(i,k)-xso2(i,k) + endif + else + xso4(i,k) = xso4(i,k) + ccc + xh2o2(i,k) = xh2o2(i,k) - ccc + xso2(i,k) = xso2(i,k) - ccc + end if + + ELSE + if (ccc .gt. xh2o2(i,k)) then + xso4(i,k)=xso4(i,k)+xh2o2(i,k) + xso2(i,k)=xso2(i,k)-xh2o2(i,k) + xh2o2(i,k)=1.e-20_r8 + else + xso4(i,k) = xso4(i,k) + ccc + xh2o2(i,k) = xh2o2(i,k) - ccc + xso2(i,k) = xso2(i,k) - ccc + end if + END IF + + if (modal_aerosols) then + xdelso4hp(i,k) = xso4(i,k) - xso4_init(i,k) + endif + !........................... + ! S(IV) + O3 = S(VI) + !........................... + + pso4 = rao3 * heo3(i,k)*o3g*patm_x * heso2(i,k)*so2g*patm_x ! [M/s] + + pso4 = pso4 & ! [M/s] = [mole/L(w)/s] + * xl & ! [mole/L(a)/s] + / const0 & ! [/L(a)/s] + / xhnm(i,k) ! [mixing ratio/s] + + ccc = pso4*dtime + ccc = max(ccc, 1.e-30_r8) + + xso4_init(i,k)=xso4(i,k) + + if (ccc .gt. xso2(i,k)) then + xso4(i,k) = xso4(i,k) + xso2(i,k) + xso2(i,k) = 1.e-20_r8 + else + xso4(i,k) = xso4(i,k) + ccc + xso2(i,k) = xso2(i,k) - ccc + end if + + END IF !! WHEN CLOUD IS PRESENTED + + end do col_loop1 + end do ver_loop1 + + call sox_cldaero_update( & + ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & + xdelso4hp, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & + aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) + + xphlwc(:,:) = 0._r8 + do k = 1, pver + do i = 1, ncol + if (cldfrc(i,k)>=1.e-5_r8 .and. lwc(i,k)>=1.e-8_r8) then + xphlwc(i,k) = -1._r8*log10(xph(i,k)) * lwc(i,k) + endif + end do + end do + + call sox_cldaero_destroy_obj(cldconc) + + end subroutine SETSOX + +end module MO_SETSOX diff --git a/src/chemistry/oslo_aero/mo_srf_emissions.F90 b/src/chemistry/oslo_aero/mo_srf_emissions.F90 new file mode 100644 index 0000000000..f4e5549266 --- /dev/null +++ b/src/chemistry/oslo_aero/mo_srf_emissions.F90 @@ -0,0 +1,465 @@ +module mo_srf_emissions + !--------------------------------------------------------------- + ! ... surface emissions module + !--------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : gas_pcnst + use spmd_utils, only : masterproc,iam + use mo_tracname, only : solsym + use cam_abortutils,only : endrun + use ioFileMod, only : getfil + use ppgrid, only : pcols, begchunk, endchunk + use cam_logfile, only : iulog + use tracer_data, only : trfld,trfile +#ifdef OSLO_AERO + use oslo_ocean_intr, only: oslo_dms_inq +#endif + + implicit none + + type :: emission + integer :: spc_ndx + real(r8) :: mw + real(r8) :: scalefactor + character(len=256):: filename + character(len=16) :: species + character(len=8) :: units + integer :: nsectors + character(len=32),pointer :: sectors(:) + type(trfld), pointer :: fields(:) + type(trfile) :: file + end type emission + + private + + public :: srf_emissions_inti, set_srf_emissions, set_srf_emissions_time + + save + + real(r8), parameter :: amufac = 1.65979e-23_r8 ! 1.e4* kg / amu + logical :: has_emis(gas_pcnst) + type(emission), allocatable :: emissions(:) + integer :: n_emis_files + integer :: c10h16_ndx, isop_ndx + integer :: dms_ndx + +contains + + subroutine srf_emissions_inti( srf_emis_specifier, emis_type_in, emis_cycle_yr, emis_fixed_ymd, emis_fixed_tod ) + + !----------------------------------------------------------------------- + ! ... initialize the surface emissions + !----------------------------------------------------------------------- + + use chem_mods, only : adv_mass + use mo_constants, only : d2r, pi, rearth + use string_utils, only : to_upper + use mo_chem_utls, only : get_spc_ndx + use tracer_data, only : trcdata_init + use cam_pio_utils, only : cam_pio_openfile + use pio, only : pio_inquire, pio_nowrite, pio_closefile, pio_inq_varndims + use pio, only : pio_inq_varname, file_desc_t, pio_get_att, PIO_NOERR, PIO_GLOBAL + use pio, only : pio_seterrorhandling, PIO_BCAST_ERROR,PIO_INTERNAL_ERROR + use chem_surfvals, only : flbc_list + use string_utils, only : GLC + use m_MergeSorts, only : IndexSort + + implicit none + + !----------------------------------------------------------------------- + ! ... dummy arguments + !----------------------------------------------------------------------- + character(len=*), intent(in) :: srf_emis_specifier(:) + character(len=*), intent(in) :: emis_type_in + integer, intent(in) :: emis_cycle_yr + integer, intent(in) :: emis_fixed_ymd + integer, intent(in) :: emis_fixed_tod + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: astat + integer :: j, l, m, n, i, nn ! Indices + character(len=16) :: spc_name + character(len=256) :: filename + + character(len=16) :: emis_species(gas_pcnst) + character(len=256) :: emis_filenam(gas_pcnst) + integer :: emis_indexes(gas_pcnst) + integer :: indx(gas_pcnst) + real(r8) :: emis_scalefactor(gas_pcnst) + + integer :: vid, nvars, isec + integer, allocatable :: vndims(:) + type(file_desc_t) :: ncid + character(len=32) :: varname + character(len=256) :: locfn + integer :: ierr + character(len=1), parameter :: filelist = '' + character(len=1), parameter :: datapath = '' + logical , parameter :: rmv_file = .false. + + character(len=32) :: emis_type = ' ' + character(len=80) :: file_interp_type = ' ' + character(len=256) :: tmp_string = ' ' + character(len=32) :: xchr = ' ' + real(r8) :: xdbl + + has_emis(:) = .false. + nn = 0 + indx(:) = 0 + + count_emis: do n=1,gas_pcnst + if ( len_trim(srf_emis_specifier(n) ) == 0 ) then + exit count_emis + endif + + i = scan(srf_emis_specifier(n),'->') + spc_name = trim(adjustl(srf_emis_specifier(n)(:i-1))) + + ! need to parse out scalefactor ... + tmp_string = adjustl(srf_emis_specifier(n)(i+2:)) + j = scan( tmp_string, '*' ) + if (j>0) then + xchr = tmp_string(1:j-1) ! get the multipler (left of the '*') + read( xchr, * ) xdbl ! convert the string to a real + tmp_string = adjustl(tmp_string(j+1:)) ! get the filepath name (right of the '*') + else + xdbl = 1._r8 + endif + filename = trim(tmp_string) + + m = get_spc_ndx(spc_name) + + if (m > 0) then + has_emis(m) = .true. + else + write(iulog,*) 'srf_emis_inti: spc_name ',spc_name,' is not included in the simulation' + call endrun('srf_emis_inti: invalid surface emission specification') + endif + + if (any( flbc_list == spc_name )) then + call endrun('srf_emis_inti: ERROR -- cannot specify both fixed LBC ' & + //'and emissions for the same species: '//trim(spc_name)) + endif + + nn = nn+1 + emis_species(nn) = spc_name + emis_filenam(nn) = filename + emis_indexes(nn) = m + emis_scalefactor(nn) = xdbl + + indx(n)=n + + enddo count_emis + + n_emis_files = nn + + if (masterproc) write(iulog,*) 'srf_emis_inti: n_emis_files = ',n_emis_files + + allocate( emissions(n_emis_files), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'srf_emis_inti: failed to allocate emissions array; error = ',astat + call endrun('srf_emis_inti: failed to allocate emissions array') + end if + + !----------------------------------------------------------------------- + ! Sort the input files so that the emissions sources are summed in the + ! same order regardless of the order of the input files in the namelist + !----------------------------------------------------------------------- + if (n_emis_files > 0) then + call IndexSort(n_emis_files, indx, emis_filenam) + end if + + !----------------------------------------------------------------------- + ! ... setup the emission type array + !----------------------------------------------------------------------- + do m=1,n_emis_files + emissions(m)%spc_ndx = emis_indexes(indx(m)) + emissions(m)%units = 'Tg/y' + emissions(m)%species = emis_species(indx(m)) + emissions(m)%mw = adv_mass(emis_indexes(indx(m))) ! g / mole + emissions(m)%filename = emis_filenam(indx(m)) + emissions(m)%scalefactor = emis_scalefactor(indx(m)) + enddo + + !----------------------------------------------------------------------- + ! read emis files to determine number of sectors + !----------------------------------------------------------------------- + spc_loop: do m = 1, n_emis_files + + emissions(m)%nsectors = 0 + + call getfil (emissions(m)%filename, locfn, 0) + call cam_pio_openfile ( ncid, trim(locfn), PIO_NOWRITE) + ierr = pio_inquire (ncid, nvariables=nvars) + + allocate(vndims(nvars)) + + do vid = 1,nvars + + ierr = pio_inq_varndims (ncid, vid, vndims(vid)) + + if( vndims(vid) < 3 ) then + cycle + elseif( vndims(vid) > 3 ) then + ierr = pio_inq_varname (ncid, vid, varname) + write(iulog,*) 'srf_emis_inti: Skipping variable ', trim(varname),', ndims = ',vndims(vid), & + ' , species=',trim(emissions(m)%species) + cycle + end if + + emissions(m)%nsectors = emissions(m)%nsectors+1 + + enddo + + allocate( emissions(m)%sectors(emissions(m)%nsectors), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'srf_emis_inti: failed to allocate emissions(m)%sectors array; error = ',astat + call endrun + end if + + isec = 1 + + do vid = 1,nvars + if( vndims(vid) == 3 ) then + ierr = pio_inq_varname(ncid, vid, emissions(m)%sectors(isec)) + isec = isec+1 + endif + + enddo + deallocate(vndims) + + ! Global attribute 'input_method' overrides the srf_emis_type namelist setting on + ! a file-by-file basis. If the emis file does not contain the 'input_method' + ! attribute then the srf_emis_type namelist setting is used. + call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) + ierr = pio_get_att(ncid, PIO_GLOBAL, 'input_method', file_interp_type) + call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) + if ( ierr == PIO_NOERR) then + l = GLC(file_interp_type) + emis_type(1:l) = file_interp_type(1:l) + emis_type(l+1:) = ' ' + else + emis_type = trim(emis_type_in) + endif + + call pio_closefile (ncid) + + allocate(emissions(m)%file%in_pbuf(size(emissions(m)%sectors))) + emissions(m)%file%in_pbuf(:) = .false. + + call trcdata_init( emissions(m)%sectors, & + emissions(m)%filename, filelist, datapath, & + emissions(m)%fields, & + emissions(m)%file, & + rmv_file, emis_cycle_yr, emis_fixed_ymd, emis_fixed_tod, trim(emis_type) ) + + enddo spc_loop + + c10h16_ndx = get_spc_ndx('C10H16') + isop_ndx = get_spc_ndx('ISOP') + + dms_ndx = get_spc_ndx('DMS') + + end subroutine srf_emissions_inti + + subroutine set_srf_emissions_time( pbuf2d, state ) + !----------------------------------------------------------------------- + ! ... check serial case for time span + !----------------------------------------------------------------------- + + use physics_types,only : physics_state + use ppgrid, only : begchunk, endchunk + use tracer_data, only : advance_trcdata + use physics_buffer, only : physics_buffer_desc + + implicit none + + type(physics_state), intent(in):: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: m + + do m = 1,n_emis_files + call advance_trcdata( emissions(m)%fields, emissions(m)%file, state, pbuf2d ) + end do + + end subroutine set_srf_emissions_time + + ! adds surf flux specified in file to sflx + subroutine set_srf_emissions( lchnk, ncol, sflx ) + !-------------------------------------------------------- + ! ... form the surface fluxes for this latitude slice + !-------------------------------------------------------- + + use mo_constants, only : pi + use time_manager, only : get_curr_calday + use string_utils, only : to_lower, GLC + use phys_grid, only : get_rlat_all_p, get_rlon_all_p + + implicit none + + !-------------------------------------------------------- + ! ... Dummy arguments + !-------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunk + integer, intent(in) :: lchnk ! chunk index + real(r8), intent(out) :: sflx(:,:) ! surface emissions ( kg/m^2/s ) + + !-------------------------------------------------------- + ! ... local variables + !-------------------------------------------------------- + integer :: i, m, n + real(r8) :: factor + real(r8) :: dayfrac ! fration of day in light + real(r8) :: iso_off ! time iso flux turns off + real(r8) :: iso_on ! time iso flux turns on + + logical :: polar_day,polar_night + real(r8) :: doy_loc + real(r8) :: sunon,sunoff + real(r8) :: loc_angle + real(r8) :: latitude + real(r8) :: declination + real(r8) :: tod + real(r8) :: calday + + real(r8), parameter :: dayspy = 365._r8 + real(r8), parameter :: twopi = 2.0_r8 * pi + real(r8), parameter :: pid2 = 0.5_r8 * pi + real(r8), parameter :: dec_max = 23.45_r8 * pi/180._r8 + + real(r8) :: flux(ncol) + real(r8) :: mfactor + integer :: isec + + character(len=12),parameter :: mks_units(4) = (/ "kg/m2/s ", & + "kg/m2/sec ", & + "kg/m^2/s ", & + "kg/m^2/sec " /) + character(len=12) :: units + + real(r8), dimension(ncol) :: rlats, rlons + + sflx(:,:) = 0._r8 + + !-------------------------------------------------------- + ! ... set non-zero emissions + !-------------------------------------------------------- + emis_loop : do m = 1,n_emis_files + + n = emissions(m)%spc_ndx + + flux(:) = 0._r8 + do isec = 1,emissions(m)%nsectors + flux(:ncol) = flux(:ncol) + emissions(m)%scalefactor*emissions(m)%fields(isec)%data(:ncol,1,lchnk) + enddo + + units = to_lower(trim(emissions(m)%fields(1)%units(:GLC(emissions(m)%fields(1)%units)))) + + if ( any( mks_units(:) == units ) ) then + sflx(:ncol,n) = sflx(:ncol,n) + flux(:ncol) + else + mfactor = amufac * emissions(m)%mw + sflx(:ncol,n) = sflx(:ncol,n) + flux(:ncol) * mfactor + endif + + end do emis_loop + + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + + calday = get_curr_calday() + doy_loc = aint( calday ) + declination = dec_max * cos((doy_loc - 172._r8)*twopi/dayspy) + tod = (calday - doy_loc) + .5_r8 + + !Remove DMS emissions if option is not "from file" + !Online emissions are treated in seasalt module + if(oslo_dms_inq() .eqv. .FALSE.)then !Returns "True" if "emissions from file" + if(dms_ndx .gt. 0)then + sflx(:,dms_ndx) = 0.0_r8 + end if + end if + + do i = 1,ncol + ! + polar_day = .false. + polar_night = .false. + ! + loc_angle = tod * twopi + rlons(i) + loc_angle = mod( loc_angle,twopi ) + latitude = rlats(i) + ! + !------------------------------------------------------------------ + ! determine if in polar day or night + ! if not in polar day or night then + ! calculate terminator longitudes + !------------------------------------------------------------------ + if( abs(latitude) >= (pid2 - abs(declination)) ) then + if( sign(1._r8,declination) == sign(1._r8,latitude) ) then + polar_day = .true. + sunoff = 2._r8*twopi + sunon = -twopi + else + polar_night = .true. + end if + else + sunoff = acos( -tan(declination)*tan(latitude) ) + sunon = twopi - sunoff + end if + + !-------------------------------------------------------- + ! ... adjust alpha-pinene for diurnal variation + !-------------------------------------------------------- + if( c10h16_ndx > 0 ) then + if( has_emis(c10h16_ndx) ) then + if( .not. polar_night .and. .not. polar_day ) then + dayfrac = sunoff / pi + sflx(i,c10h16_ndx) = sflx(i,c10h16_ndx) / (.7_r8 + .3_r8*dayfrac) + if( loc_angle >= sunoff .and. loc_angle <= sunon ) then + sflx(i,c10h16_ndx) = sflx(i,c10h16_ndx) * .7_r8 + endif + end if + end if + end if + + !-------------------------------------------------------- + ! ... adjust isoprene for diurnal variation + !-------------------------------------------------------- + if( isop_ndx > 0 ) then + if( has_emis(isop_ndx) ) then + if( .not. polar_night ) then + if( polar_day ) then + iso_off = .8_r8 * pi + iso_on = 1.2_r8 * pi + else + iso_off = .8_r8 * sunoff + iso_on = 2._r8 * pi - iso_off + end if + if( loc_angle >= iso_off .and. loc_angle <= iso_on ) then + sflx(i,isop_ndx) = 0._r8 + else + factor = loc_angle - iso_on + if( factor <= 0._r8 ) then + factor = factor + 2._r8*pi + end if + factor = factor / (2._r8*iso_off + 1.e-6_r8) + sflx(i,isop_ndx) = sflx(i,isop_ndx) * 2._r8 / iso_off * pi * (sin(pi*factor))**2 + end if + else + sflx(i,isop_ndx) = 0._r8 + end if + end if + end if + + end do + + end subroutine set_srf_emissions + +end module mo_srf_emissions diff --git a/src/chemistry/oslo_aero/mo_usrrxt.F90 b/src/chemistry/oslo_aero/mo_usrrxt.F90 new file mode 100644 index 0000000000..7834085cd8 --- /dev/null +++ b/src/chemistry/oslo_aero/mo_usrrxt.F90 @@ -0,0 +1,1584 @@ +module mo_usrrxt + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + use ppgrid, only : pver, pcols +#ifdef OSLO_AERO +! use aerosoldef, only: nmodes_oslo=> nmodes, lifeCycleNumberMedianRadius + use commondefinitions, only: nmodes_oslo=> nmodes +#endif + + implicit none + + private + public :: usrrxt, usrrxt_inti, usrrxt_hrates + + save + + integer :: usr_O_O2_ndx + integer :: usr_HO2_HO2_ndx + integer :: usr_N2O5_M_ndx + integer :: usr_HNO3_OH_ndx + integer :: usr_HO2NO2_M_ndx + integer :: usr_N2O5_aer_ndx + integer :: usr_NO3_aer_ndx + integer :: usr_NO2_aer_ndx + integer :: usr_CO_OH_a_ndx + integer :: usr_CO_OH_b_ndx + integer :: usr_PAN_M_ndx + integer :: usr_CH3COCH3_OH_ndx + integer :: usr_MCO3_NO2_ndx + integer :: usr_MPAN_M_ndx + integer :: usr_XOOH_OH_ndx + integer :: usr_SO2_OH_ndx + integer :: usr_DMS_OH_ndx + integer :: usr_HO2_aer_ndx + integer :: usr_GLYOXAL_aer_ndx + + integer :: tag_NO2_NO3_ndx + integer :: tag_NO2_OH_ndx + integer :: tag_NO2_HO2_ndx + integer :: tag_C2H4_OH_ndx + integer :: tag_C3H6_OH_ndx + integer :: tag_CH3CO3_NO2_ndx + +!lke-TS1 + integer :: usr_PBZNIT_M_ndx + integer :: tag_ACBZO2_NO2_ndx + integer :: usr_ISOPNITA_aer_ndx + integer :: usr_ISOPNITB_aer_ndx + integer :: usr_ONITR_aer_ndx + integer :: usr_HONITR_aer_ndx + integer :: usr_TERPNIT_aer_ndx + integer :: usr_NTERPOOH_aer_ndx + integer :: usr_NC4CHO_aer_ndx + integer :: usr_NC4CH2OH_aer_ndx +! + integer :: usr_OA_O2_NDX + integer :: usr_XNO2NO3_M_ndx + integer :: usr_NO2XNO3_M_ndx + integer :: usr_XHNO3_OH_ndx + integer :: usr_XHO2NO2_M_ndx + integer :: usr_XNO2NO3_aer_ndx + integer :: usr_NO2XNO3_aer_ndx + integer :: usr_XNO3_aer_ndx + integer :: usr_XNO2_aer_ndx + integer :: usr_XPAN_M_ndx + integer :: usr_XMPAN_M_ndx + integer :: usr_MCO3_XNO2_ndx + + integer :: usr_C2O3_NO2_ndx + integer :: usr_C2H4_OH_ndx + integer :: usr_XO2N_HO2_ndx + integer :: usr_C2O3_XNO2_ndx + + integer :: tag_XO2N_NO_ndx + integer :: tag_XO2_HO2_ndx + integer :: tag_XO2_NO_ndx + + integer :: usr_O_O_ndx + integer :: usr_CL2O2_M_ndx + integer :: usr_SO3_H2O_ndx + integer :: tag_CLO_CLO_M_ndx + + integer :: ion1_ndx, ion2_ndx, ion3_ndx, ion11_ndx + integer :: elec1_ndx, elec2_ndx, elec3_ndx + integer :: elec4_ndx, elec5_ndx, elec6_ndx + integer :: het1_ndx + + integer, parameter :: nean = 3 + integer :: ean_ndx(nean) + integer, parameter :: nrpe = 5 + integer :: rpe_ndx(nrpe) + integer, parameter :: npir = 16 + integer :: pir_ndx(npir) + integer, parameter :: nedn = 2 + integer :: edn_ndx(nedn) + integer, parameter :: nnir = 13 + integer :: nir_ndx(nnir) + integer, parameter :: niira = 112 + integer :: iira_ndx(niira) + integer, parameter :: niirb = 14 + integer :: iirb_ndx(niirb) + + integer :: usr_clm_h2o_m_ndx, usr_clm_hcl_m_ndx + integer :: usr_oh_co_ndx, het_no2_h2o_ndx, usr_oh_dms_ndx, aq_so2_h2o2_ndx, aq_so2_o3_ndx + + integer :: h2o_ndx +! +! jfl +! + integer, parameter :: num_strat_tau = 22 + integer :: usr_strat_tau_ndx(num_strat_tau) +! +!lke++ + integer :: usr_COhc_OH_ndx + integer :: usr_COme_OH_ndx + integer :: usr_CO01_OH_ndx + integer :: usr_CO02_OH_ndx + integer :: usr_CO03_OH_ndx + integer :: usr_CO04_OH_ndx + integer :: usr_CO05_OH_ndx + integer :: usr_CO06_OH_ndx + integer :: usr_CO07_OH_ndx + integer :: usr_CO08_OH_ndx + integer :: usr_CO09_OH_ndx + integer :: usr_CO10_OH_ndx + integer :: usr_CO11_OH_ndx + integer :: usr_CO12_OH_ndx + integer :: usr_CO13_OH_ndx + integer :: usr_CO14_OH_ndx + integer :: usr_CO15_OH_ndx + integer :: usr_CO16_OH_ndx + integer :: usr_CO17_OH_ndx + integer :: usr_CO18_OH_ndx + integer :: usr_CO19_OH_ndx + integer :: usr_CO20_OH_ndx + integer :: usr_CO21_OH_ndx + integer :: usr_CO22_OH_ndx + integer :: usr_CO23_OH_ndx + integer :: usr_CO24_OH_ndx + integer :: usr_CO25_OH_ndx + integer :: usr_CO26_OH_ndx + integer :: usr_CO27_OH_ndx + integer :: usr_CO28_OH_ndx + integer :: usr_CO29_OH_ndx + integer :: usr_CO30_OH_ndx + integer :: usr_CO31_OH_ndx + integer :: usr_CO32_OH_ndx + integer :: usr_CO33_OH_ndx + integer :: usr_CO34_OH_ndx + integer :: usr_CO35_OH_ndx + integer :: usr_CO36_OH_ndx + integer :: usr_CO37_OH_ndx + integer :: usr_CO38_OH_ndx + integer :: usr_CO39_OH_ndx + integer :: usr_CO40_OH_ndx + integer :: usr_CO41_OH_ndx + integer :: usr_CO42_OH_ndx +!lke-- + + real(r8), parameter :: t0 = 300._r8 ! K + real(r8), parameter :: trlim2 = 17._r8/3._r8 ! K + real(r8), parameter :: trlim3 = 15._r8/3._r8 ! K + + logical :: has_ion_rxts, has_d_chem + +contains + + subroutine usrrxt_inti + !----------------------------------------------------------------- + ! ... intialize the user reaction constants module + !----------------------------------------------------------------- + + use mo_chem_utls, only : get_rxt_ndx, get_spc_ndx + use spmd_utils, only : masterproc + + implicit none + + character(len=4) :: xchar + character(len=32) :: rxtname + integer :: i + +! +! full tropospheric chemistry +! + usr_O_O2_ndx = get_rxt_ndx( 'usr_O_O2' ) + usr_HO2_HO2_ndx = get_rxt_ndx( 'usr_HO2_HO2' ) + usr_N2O5_M_ndx = get_rxt_ndx( 'usr_N2O5_M' ) + usr_HNO3_OH_ndx = get_rxt_ndx( 'usr_HNO3_OH' ) + usr_HO2NO2_M_ndx = get_rxt_ndx( 'usr_HO2NO2_M' ) + usr_N2O5_aer_ndx = get_rxt_ndx( 'usr_N2O5_aer' ) + usr_NO3_aer_ndx = get_rxt_ndx( 'usr_NO3_aer' ) + usr_NO2_aer_ndx = get_rxt_ndx( 'usr_NO2_aer' ) + usr_CO_OH_a_ndx = get_rxt_ndx( 'usr_CO_OH_a' ) + usr_CO_OH_b_ndx = get_rxt_ndx( 'usr_CO_OH_b' ) + usr_PAN_M_ndx = get_rxt_ndx( 'usr_PAN_M' ) + usr_CH3COCH3_OH_ndx = get_rxt_ndx( 'usr_CH3COCH3_OH' ) + usr_MCO3_NO2_ndx = get_rxt_ndx( 'usr_MCO3_NO2' ) + usr_MPAN_M_ndx = get_rxt_ndx( 'usr_MPAN_M' ) + usr_XOOH_OH_ndx = get_rxt_ndx( 'usr_XOOH_OH' ) + usr_SO2_OH_ndx = get_rxt_ndx( 'usr_SO2_OH' ) + usr_DMS_OH_ndx = get_rxt_ndx( 'usr_DMS_OH' ) + usr_HO2_aer_ndx = get_rxt_ndx( 'usr_HO2_aer' ) + usr_GLYOXAL_aer_ndx = get_rxt_ndx( 'usr_GLYOXAL_aer' ) + ! + tag_NO2_NO3_ndx = get_rxt_ndx( 'tag_NO2_NO3' ) + tag_NO2_OH_ndx = get_rxt_ndx( 'tag_NO2_OH' ) + tag_NO2_HO2_ndx = get_rxt_ndx( 'tag_NO2_HO2' ) + tag_C2H4_OH_ndx = get_rxt_ndx( 'tag_C2H4_OH' ) + tag_C3H6_OH_ndx = get_rxt_ndx( 'tag_C3H6_OH' ) + tag_CH3CO3_NO2_ndx = get_rxt_ndx( 'tag_CH3CO3_NO2' ) +!lke-TS1 + usr_PBZNIT_M_ndx = get_rxt_ndx( 'usr_PBZNIT_M' ) + tag_ACBZO2_NO2_ndx = get_rxt_ndx( 'tag_ACBZO2_NO2' ) + usr_ISOPNITA_aer_ndx = get_rxt_ndx( 'usr_ISOPNITA_aer' ) + usr_ISOPNITB_aer_ndx = get_rxt_ndx( 'usr_ISOPNITB_aer' ) + usr_ONITR_aer_ndx = get_rxt_ndx( 'usr_ONITR_aer' ) + usr_HONITR_aer_ndx = get_rxt_ndx( 'usr_HONITR_aer' ) + usr_TERPNIT_aer_ndx = get_rxt_ndx( 'usr_TERPNIT_aer' ) + usr_NTERPOOH_aer_ndx = get_rxt_ndx( 'usr_NTERPOOH_aer' ) + usr_NC4CHO_aer_ndx = get_rxt_ndx( 'usr_NC4CHO_aer' ) + usr_NC4CH2OH_aer_ndx = get_rxt_ndx( 'usr_NC4CH2OH_aer' ) + ! + ! additional reactions for O3A/XNO + ! + usr_OA_O2_ndx = get_rxt_ndx( 'usr_OA_O2' ) + usr_XNO2NO3_M_ndx = get_rxt_ndx( 'usr_XNO2NO3_M' ) + usr_NO2XNO3_M_ndx = get_rxt_ndx( 'usr_NO2XNO3_M' ) + usr_XNO2NO3_aer_ndx = get_rxt_ndx( 'usr_XNO2NO3_aer' ) + usr_NO2XNO3_aer_ndx = get_rxt_ndx( 'usr_NO2XNO3_aer' ) + usr_XHNO3_OH_ndx = get_rxt_ndx( 'usr_XHNO3_OH' ) + usr_XNO3_aer_ndx = get_rxt_ndx( 'usr_XNO3_aer' ) + usr_XNO2_aer_ndx = get_rxt_ndx( 'usr_XNO2_aer' ) + usr_MCO3_XNO2_ndx = get_rxt_ndx( 'usr_MCO3_XNO2' ) + usr_XPAN_M_ndx = get_rxt_ndx( 'usr_XPAN_M' ) + usr_XMPAN_M_ndx = get_rxt_ndx( 'usr_XMPAN_M' ) + usr_XHO2NO2_M_ndx = get_rxt_ndx( 'usr_XHO2NO2_M' ) +! +! reduced hydrocarbon chemistry +! + usr_C2O3_NO2_ndx = get_rxt_ndx( 'usr_C2O3_NO2' ) + usr_C2H4_OH_ndx = get_rxt_ndx( 'usr_C2H4_OH' ) + usr_XO2N_HO2_ndx = get_rxt_ndx( 'usr_XO2N_HO2' ) + usr_C2O3_XNO2_ndx = get_rxt_ndx( 'usr_C2O3_XNO2' ) +! + tag_XO2N_NO_ndx = get_rxt_ndx( 'tag_XO2N_NO' ) + tag_XO2_HO2_ndx = get_rxt_ndx( 'tag_XO2_HO2' ) + tag_XO2_NO_ndx = get_rxt_ndx( 'tag_XO2_NO' ) +! +! stratospheric chemistry +! + usr_O_O_ndx = get_rxt_ndx( 'usr_O_O' ) + usr_CL2O2_M_ndx = get_rxt_ndx( 'usr_CL2O2_M' ) + usr_SO3_H2O_ndx = get_rxt_ndx( 'usr_SO3_H2O' ) +! + tag_CLO_CLO_M_ndx = get_rxt_ndx( 'tag_CLO_CLO_M' ) + if (tag_CLO_CLO_M_ndx<0) then ! for backwards compatibility + tag_CLO_CLO_M_ndx = get_rxt_ndx( 'tag_CLO_CLO' ) + endif +! +! reactions to remove BAM aerosols in the stratosphere +! + usr_strat_tau_ndx( 1) = get_rxt_ndx( 'usr_CB1_strat_tau' ) + usr_strat_tau_ndx( 2) = get_rxt_ndx( 'usr_CB2_strat_tau' ) + usr_strat_tau_ndx( 3) = get_rxt_ndx( 'usr_OC1_strat_tau' ) + usr_strat_tau_ndx( 4) = get_rxt_ndx( 'usr_OC2_strat_tau' ) + usr_strat_tau_ndx( 5) = get_rxt_ndx( 'usr_SO4_strat_tau' ) + usr_strat_tau_ndx( 6) = get_rxt_ndx( 'usr_SOA_strat_tau' ) + usr_strat_tau_ndx( 7) = get_rxt_ndx( 'usr_NH4_strat_tau' ) + usr_strat_tau_ndx( 8) = get_rxt_ndx( 'usr_NH4NO3_strat_tau' ) + usr_strat_tau_ndx( 9) = get_rxt_ndx( 'usr_SSLT01_strat_tau' ) + usr_strat_tau_ndx(10) = get_rxt_ndx( 'usr_SSLT02_strat_tau' ) + usr_strat_tau_ndx(11) = get_rxt_ndx( 'usr_SSLT03_strat_tau' ) + usr_strat_tau_ndx(12) = get_rxt_ndx( 'usr_SSLT04_strat_tau' ) + usr_strat_tau_ndx(13) = get_rxt_ndx( 'usr_DST01_strat_tau' ) + usr_strat_tau_ndx(14) = get_rxt_ndx( 'usr_DST02_strat_tau' ) + usr_strat_tau_ndx(15) = get_rxt_ndx( 'usr_DST03_strat_tau' ) + usr_strat_tau_ndx(16) = get_rxt_ndx( 'usr_DST04_strat_tau' ) + usr_strat_tau_ndx(17) = get_rxt_ndx( 'usr_SO2t_strat_tau' ) + usr_strat_tau_ndx(18) = get_rxt_ndx( 'usr_SOAI_strat_tau' ) + usr_strat_tau_ndx(19) = get_rxt_ndx( 'usr_SOAM_strat_tau' ) + usr_strat_tau_ndx(20) = get_rxt_ndx( 'usr_SOAB_strat_tau' ) + usr_strat_tau_ndx(21) = get_rxt_ndx( 'usr_SOAT_strat_tau' ) + usr_strat_tau_ndx(22) = get_rxt_ndx( 'usr_SOAX_strat_tau' ) +! +! stratospheric aerosol chemistry +! + het1_ndx = get_rxt_ndx( 'het1' ) +! +! ion chemistry +! + ion1_ndx = get_rxt_ndx( 'ion_Op_O2' ) + ion2_ndx = get_rxt_ndx( 'ion_Op_N2' ) + ion3_ndx = get_rxt_ndx( 'ion_N2p_Oa' ) + ion11_ndx = get_rxt_ndx( 'ion_N2p_Ob' ) + + elec1_ndx = get_rxt_ndx( 'elec1' ) + elec2_ndx = get_rxt_ndx( 'elec2' ) + elec3_ndx = get_rxt_ndx( 'elec3' ) + + do i = 1,nean + write (xchar,'(i4)') i + rxtname = 'ean'//trim(adjustl(xchar)) + ean_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,nrpe + write (xchar,'(i4)') i + rxtname = 'rpe'//trim(adjustl(xchar)) + rpe_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,npir + write (xchar,'(i4)') i + rxtname = 'pir'//trim(adjustl(xchar)) + pir_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,nedn + write (xchar,'(i4)') i + rxtname = 'edn'//trim(adjustl(xchar)) + edn_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,nnir + write (xchar,'(i4)') i + rxtname = 'nir'//trim(adjustl(xchar)) + nir_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,niira + write (xchar,'(i4)') i + rxtname = 'iira'//trim(adjustl(xchar)) + iira_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + do i = 1,niirb + write (xchar,'(i4)') i + rxtname = 'iirb'//trim(adjustl(xchar)) + iirb_ndx(i) = get_rxt_ndx(trim(rxtname)) + enddo + + usr_clm_h2o_m_ndx = get_rxt_ndx( 'usr_CLm_H2O_M' ) + usr_clm_hcl_m_ndx = get_rxt_ndx( 'usr_CLm_HCL_M' ) + + elec4_ndx = get_rxt_ndx( 'Op2P_ea' ) + elec5_ndx = get_rxt_ndx( 'Op2P_eb' ) + elec6_ndx = get_rxt_ndx( 'Op2D_e' ) + + has_ion_rxts = ion1_ndx>0 .and. ion2_ndx>0 .and. ion3_ndx>0 .and. elec1_ndx>0 & + .and. elec2_ndx>0 .and. elec3_ndx>0 + + has_d_chem = & + all(ean_ndx>0) .and. & + all(rpe_ndx>0) .and. & + all(pir_ndx>0) .and. & + all(edn_ndx>0) .and. & + all(nir_ndx>0) .and. & + all(iira_ndx>0) .and. & + all(iirb_ndx>0) .and. & + usr_clm_h2o_m_ndx>0 .and. usr_clm_hcl_m_ndx>0 + + h2o_ndx = get_spc_ndx( 'H2O' ) + + ! + ! llnl super fast + ! + usr_oh_co_ndx = get_rxt_ndx( 'usr_oh_co' ) + het_no2_h2o_ndx = get_rxt_ndx( 'het_no2_h2o' ) + usr_oh_dms_ndx = get_rxt_ndx( 'usr_oh_dms' ) + aq_so2_h2o2_ndx = get_rxt_ndx( 'aq_so2_h2o2' ) + aq_so2_o3_ndx = get_rxt_ndx( 'aq_so2_o3' ) + +!lke++ +! CO tags +! + usr_COhc_OH_ndx = get_rxt_ndx( 'usr_COhc_OH' ) + usr_COme_OH_ndx = get_rxt_ndx( 'usr_COme_OH' ) + usr_CO01_OH_ndx = get_rxt_ndx( 'usr_CO01_OH' ) + usr_CO02_OH_ndx = get_rxt_ndx( 'usr_CO02_OH' ) + usr_CO03_OH_ndx = get_rxt_ndx( 'usr_CO03_OH' ) + usr_CO04_OH_ndx = get_rxt_ndx( 'usr_CO04_OH' ) + usr_CO05_OH_ndx = get_rxt_ndx( 'usr_CO05_OH' ) + usr_CO06_OH_ndx = get_rxt_ndx( 'usr_CO06_OH' ) + usr_CO07_OH_ndx = get_rxt_ndx( 'usr_CO07_OH' ) + usr_CO08_OH_ndx = get_rxt_ndx( 'usr_CO08_OH' ) + usr_CO09_OH_ndx = get_rxt_ndx( 'usr_CO09_OH' ) + usr_CO10_OH_ndx = get_rxt_ndx( 'usr_CO10_OH' ) + usr_CO11_OH_ndx = get_rxt_ndx( 'usr_CO11_OH' ) + usr_CO12_OH_ndx = get_rxt_ndx( 'usr_CO12_OH' ) + usr_CO13_OH_ndx = get_rxt_ndx( 'usr_CO13_OH' ) + usr_CO14_OH_ndx = get_rxt_ndx( 'usr_CO14_OH' ) + usr_CO15_OH_ndx = get_rxt_ndx( 'usr_CO15_OH' ) + usr_CO16_OH_ndx = get_rxt_ndx( 'usr_CO16_OH' ) + usr_CO17_OH_ndx = get_rxt_ndx( 'usr_CO17_OH' ) + usr_CO18_OH_ndx = get_rxt_ndx( 'usr_CO18_OH' ) + usr_CO19_OH_ndx = get_rxt_ndx( 'usr_CO19_OH' ) + usr_CO20_OH_ndx = get_rxt_ndx( 'usr_CO20_OH' ) + usr_CO21_OH_ndx = get_rxt_ndx( 'usr_CO21_OH' ) + usr_CO22_OH_ndx = get_rxt_ndx( 'usr_CO22_OH' ) + usr_CO23_OH_ndx = get_rxt_ndx( 'usr_CO23_OH' ) + usr_CO24_OH_ndx = get_rxt_ndx( 'usr_CO24_OH' ) + usr_CO25_OH_ndx = get_rxt_ndx( 'usr_CO25_OH' ) + usr_CO26_OH_ndx = get_rxt_ndx( 'usr_CO26_OH' ) + usr_CO27_OH_ndx = get_rxt_ndx( 'usr_CO27_OH' ) + usr_CO28_OH_ndx = get_rxt_ndx( 'usr_CO28_OH' ) + usr_CO29_OH_ndx = get_rxt_ndx( 'usr_CO29_OH' ) + usr_CO30_OH_ndx = get_rxt_ndx( 'usr_CO30_OH' ) + usr_CO31_OH_ndx = get_rxt_ndx( 'usr_CO31_OH' ) + usr_CO32_OH_ndx = get_rxt_ndx( 'usr_CO32_OH' ) + usr_CO33_OH_ndx = get_rxt_ndx( 'usr_CO33_OH' ) + usr_CO34_OH_ndx = get_rxt_ndx( 'usr_CO34_OH' ) + usr_CO35_OH_ndx = get_rxt_ndx( 'usr_CO35_OH' ) + usr_CO36_OH_ndx = get_rxt_ndx( 'usr_CO36_OH' ) + usr_CO37_OH_ndx = get_rxt_ndx( 'usr_CO37_OH' ) + usr_CO38_OH_ndx = get_rxt_ndx( 'usr_CO38_OH' ) + usr_CO39_OH_ndx = get_rxt_ndx( 'usr_CO39_OH' ) + usr_CO40_OH_ndx = get_rxt_ndx( 'usr_CO40_OH' ) + usr_CO41_OH_ndx = get_rxt_ndx( 'usr_CO41_OH' ) + usr_CO42_OH_ndx = get_rxt_ndx( 'usr_CO42_OH' ) +!lke-- + + if (masterproc) then + write(iulog,*) ' ' + write(iulog,*) 'usrrxt_inti: diagnostics ' + write(iulog,'(10i5)') usr_O_O2_ndx,usr_HO2_HO2_ndx,tag_NO2_NO3_ndx,usr_N2O5_M_ndx,tag_NO2_OH_ndx,usr_HNO3_OH_ndx & + ,tag_NO2_HO2_ndx,usr_HO2NO2_M_ndx,usr_N2O5_aer_ndx,usr_NO3_aer_ndx,usr_NO2_aer_ndx & + ,usr_CO_OH_b_ndx,tag_C2H4_OH_ndx,tag_C3H6_OH_ndx,tag_CH3CO3_NO2_ndx,usr_PAN_M_ndx,usr_CH3COCH3_OH_ndx & + ,usr_MCO3_NO2_ndx,usr_MPAN_M_ndx,usr_XOOH_OH_ndx,usr_SO2_OH_ndx,usr_DMS_OH_ndx,usr_HO2_aer_ndx & + ,usr_GLYOXAL_aer_ndx,usr_ISOPNITA_aer_ndx,usr_ISOPNITB_aer_ndx,usr_ONITR_aer_ndx,usr_HONITR_aer_ndx & + ,usr_TERPNIT_aer_ndx,usr_NTERPOOH_aer_ndx,usr_NC4CHO_aer_ndx,usr_NC4CH2OH_aer_ndx + + end if + + end subroutine usrrxt_inti + + subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & + pmid, m, sulfate, mmr, relhum, strato_sad, & + tropchemlev, dlat, ncol, sad_trop, reff_trop, cwat, mbar, pbuf ) + +!----------------------------------------------------------------- +! ... set the user specified reaction rates +!----------------------------------------------------------------- + + use mo_constants, only : pi, avo => avogadro, boltz_cgs, rgas + use chem_mods, only : nfs, rxntot, gas_pcnst, inv_m_ndx=>indexm + use mo_setinv, only : inv_o2_ndx=>o2_ndx, inv_h2o_ndx=>h2o_ndx + use physics_buffer,only : physics_buffer_desc + use carma_flags_mod, only : carma_hetchem_feedback + use aero_model, only : aero_model_surfarea + use rad_constituents,only : rad_cnst_get_info + + implicit none + +!----------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: tropchemlev(pcols) ! trop/strat reaction separation vertical index + real(r8), intent(in) :: dlat(:) ! degrees latitude + real(r8), intent(in) :: temp(pcols,pver) ! temperature (K); neutral temperature + real(r8), intent(in) :: tempi(pcols,pver) ! ionic temperature (K); only used if ion chemistry + real(r8), intent(in) :: tempe(pcols,pver) ! electronic temperature (K); only used if ion chemistry + real(r8), intent(in) :: m(ncol,pver) ! total atm density (/cm^3) + real(r8), intent(in) :: sulfate(ncol,pver) ! sulfate aerosol (mol/mol) + real(r8), intent(in) :: strato_sad(pcols,pver) ! stratospheric aerosol sad (1/cm) + real(r8), intent(in) :: h2ovmr(ncol,pver) ! water vapor (mol/mol) + real(r8), intent(in) :: relhum(ncol,pver) ! relative humidity + real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressure (Pa) + real(r8), intent(in) :: invariants(ncol,pver,nfs) ! invariants density (/cm^3) + real(r8), intent(in) :: mmr(pcols,pver,gas_pcnst) ! species concentrations (kg/kg) + real(r8), intent(in) :: cwat(ncol,pver) !PJC Condensed Water (liquid+ice) (kg/kg) + real(r8), intent(in) :: mbar(ncol,pver) !PJC Molar mass of air (g/mol) + real(r8), intent(inout) :: rxt(ncol,pver,rxntot) ! gas phase rates + real(r8), intent(out) :: sad_trop(pcols,pver) ! tropospheric surface area density (cm2/cm3) + real(r8), intent(out) :: reff_trop(pcols,pver) ! tropospheric effective radius (cm) + type(physics_buffer_desc), pointer :: pbuf(:) + +!----------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------- + + real(r8), parameter :: dg = 0.1_r8 ! mole diffusion =0.1 cm2/s (Dentener, 1993) + +!----------------------------------------------------------------- +! ... reaction probabilities for heterogeneous reactions +!----------------------------------------------------------------- + real(r8), parameter :: gamma_n2o5 = 0.10_r8 ! from Jacob, Atm Env, 34, 2131, 2000 + real(r8), parameter :: gamma_ho2 = 0.20_r8 ! + real(r8), parameter :: gamma_no2 = 0.0001_r8 ! + real(r8), parameter :: gamma_no3 = 0.001_r8 ! + real(r8), parameter :: gamma_glyoxal = 2.0e-4_r8 ! Washenfelder et al, JGR, 2011 +!TS1 species + real(r8), parameter :: gamma_isopnita = 0.005_r8 ! from Fisher et al., ACP, 2016 + real(r8), parameter :: gamma_isopnitb = 0.005_r8 ! + real(r8), parameter :: gamma_onitr = 0.005_r8 ! + real(r8), parameter :: gamma_honitr = 0.005_r8 ! + real(r8), parameter :: gamma_terpnit = 0.01_r8 ! + real(r8), parameter :: gamma_nterpooh = 0.01_r8 ! + real(r8), parameter :: gamma_nc4cho = 0.005_r8 ! + real(r8), parameter :: gamma_nc4ch2oh = 0.005_r8 ! + + + integer :: i, k + integer :: l + real(r8) :: tp(ncol) ! 300/t + real(r8) :: tinv(ncol) ! 1/t + real(r8) :: ko(ncol) + real(r8) :: term1(ncol) + real(r8) :: term2(ncol) + real(r8) :: kinf(ncol) + real(r8) :: fc(ncol) + real(r8) :: xr(ncol) + real(r8) :: sur(ncol) + real(r8) :: sqrt_t(ncol) ! sqrt( temp ) + real(r8) :: sqrt_t_58(ncol) ! sqrt( temp / 58.) + real(r8) :: exp_fac(ncol) ! vector exponential + real(r8) :: lwc(ncol) + real(r8) :: ko_m(ncol) + real(r8) :: k0(ncol) + real(r8) :: kinf_m(ncol) + real(r8) :: o2(ncol) + real(r8) :: c_n2o5, c_ho2, c_no2, c_no3, c_glyoxal +!TS1 species + real(r8) :: c_isopnita, c_isopnitb, c_onitr, c_honitr, c_terpnit, c_nterpooh + real(r8) :: c_nc4cho, c_nc4ch2oh + + real(r8) :: amas + !----------------------------------------------------------------- + ! ... density of sulfate aerosol + !----------------------------------------------------------------- + real(r8), parameter :: gam1 = 0.04_r8 ! N2O5+SUL ->2HNO3 + real(r8), parameter :: wso4 = 98._r8 + real(r8), parameter :: den = 1.15_r8 ! each molecule of SO4(aer) density g/cm3 + !------------------------------------------------- + ! ... volume of sulfate particles + ! assuming mean rm + ! continient 0.05um 0.07um 0.09um + ! ocean 0.09um 0.25um 0.37um + ! 0.16um Blake JGR,7195, 1995 + !------------------------------------------------- + real(r8), parameter :: rm1 = 0.16_r8*1.e-4_r8 ! mean radii in cm + real(r8), parameter :: fare = 4._r8*pi*rm1*rm1 ! each mean particle(r=0.1u) area cm2/cm3 + + !----------------------------------------------------------------------- + ! ... Aqueous phase sulfur quantities for SO2 + H2O2 and SO2 + O3 + !----------------------------------------------------------------------- + real(r8), parameter :: HENRY298_H2O2 = 7.45e+04_r8 + real(r8), parameter :: H298_H2O2 = -1.45e+04_r8 + real(r8), parameter :: HENRY298_SO2 = 1.23e+00_r8 + real(r8), parameter :: H298_SO2 = -6.25e+03_r8 + real(r8), parameter :: K298_SO2_HSO3 = 1.3e-02_r8 + real(r8), parameter :: H298_SO2_HSO3 = -4.16e+03_r8 + real(r8), parameter :: R_CONC = 82.05e+00_r8 / avo + real(r8), parameter :: R_CAL = rgas * 0.239006e+00_r8 + real(r8), parameter :: K_AQ = 7.57e+07_r8 + real(r8), parameter :: ER_AQ = 4.43e+03_r8 + + real(r8), parameter :: HENRY298_O3 = 1.13e-02_r8 + real(r8), parameter :: H298_O3 = -5.04e+03_r8 + real(r8), parameter :: K298_HSO3_SO3 = 6.6e-08_r8 + real(r8), parameter :: H298_HSO3_SO3 = -2.23e+03_r8 + real(r8), parameter :: K0_AQ = 2.4e+04_r8 + real(r8), parameter :: ER0_AQ = 0.0e+00_r8 + real(r8), parameter :: K1_AQ = 3.7e+05_r8 + real(r8), parameter :: ER1_AQ = 5.53e+03_r8 + real(r8), parameter :: K2_AQ = 1.5e+09_r8 + real(r8), parameter :: ER2_AQ = 5.28e+03_r8 + + real(r8), parameter :: pH = 4.5e+00_r8 + + real(r8), pointer :: sfc(:), dm_aer(:) + integer :: ntot_amode + + real(r8), pointer :: sfc_array(:,:,:), dm_array(:,:,:) + +#ifdef OSLO_AERO + ntot_amode = nmodes_oslo +#else + ! get info about the modal aerosols + ! get ntot_amode + call rad_cnst_get_info(0, nmodes=ntot_amode) +#endif + if (ntot_amode>0) then + allocate(sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) ) + else + allocate(sfc_array(pcols,pver,5), dm_array(pcols,pver,5) ) + endif + + sfc_array(:,:,:) = 0._r8 + dm_array(:,:,:) = 0._r8 + sad_trop(:,:) = 0._r8 + reff_trop(:,:) = 0._r8 + + if( usr_NO2_aer_ndx > 0 .or. usr_NO3_aer_ndx > 0 .or. usr_N2O5_aer_ndx > 0 .or. usr_HO2_aer_ndx > 0 ) then + +! sad_trop should be set outside of usrrxt ?? + if( carma_hetchem_feedback ) then + sad_trop(:ncol,:pver)=strato_sad(:ncol,:pver) + else + + call aero_model_surfarea( & + mmr, rm1, relhum, pmid, temp, strato_sad, sulfate, m, tropchemlev, dlat, & + het1_ndx, pbuf, ncol, sfc_array, dm_array, sad_trop, reff_trop ) + + endif + endif + + level_loop : do k = 1,pver + tinv(:) = 1._r8 / temp(:ncol,k) + tp(:) = 300._r8 * tinv(:) + sqrt_t(:) = sqrt( temp(:ncol,k) ) + sqrt_t_58(:) = sqrt( temp(:ncol,k) / 58.0_r8 ) + +!----------------------------------------------------------------- +! ... o + o2 + m --> o3 + m (JPL15-10) +!----------------------------------------------------------------- + if( usr_O_O2_ndx > 0 ) then + rxt(:,k,usr_O_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 + end if + if( usr_OA_O2_ndx > 0 ) then + rxt(:,k,usr_OA_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 + end if + +!----------------------------------------------------------------- +! ... o + o + m -> o2 + m +!----------------------------------------------------------------- + if ( usr_O_O_ndx > 0 ) then + rxt(:,k,usr_O_O_ndx) = 2.76e-34_r8 * exp( 720.0_r8*tinv(:) ) + end if + +!----------------------------------------------------------------- +! ... cl2o2 + m -> 2*clo + m (JPL15-10) +!----------------------------------------------------------------- + if ( usr_CL2O2_M_ndx > 0 ) then + if ( tag_CLO_CLO_M_ndx > 0 ) then + ko(:) = 2.16e-27_r8 * exp( 8537.0_r8* tinv(:) ) + rxt(:,k,usr_CL2O2_M_ndx) = rxt(:,k,tag_CLO_CLO_M_ndx)/ko(:) + else + rxt(:,k,usr_CL2O2_M_ndx) = 0._r8 + end if + end if + +!----------------------------------------------------------------- +! ... so3 + 2*h2o --> h2so4 + h2o +! Note: this reaction proceeds by the 2 intermediate steps below +! so3 + h2o --> adduct +! adduct + h2o --> h2so4 + h2o +! (Lovejoy et al., JCP, pp. 19911-19916, 1996) +! The first order rate constant used here is recommended by JPL 2011. +! This rate involves the water vapor number density. +!----------------------------------------------------------------- + + if ( usr_SO3_H2O_ndx > 0 ) then + call comp_exp( exp_fac, 6540.0_r8*tinv(:), ncol ) + if( h2o_ndx > 0 ) then + fc(:) = 8.5e-21_r8 * m(:,k) * h2ovmr(:,k) * exp_fac(:) + else + fc(:) = 8.5e-21_r8 * invariants(:,k,inv_h2o_ndx) * exp_fac(:) + end if + rxt(:,k,usr_SO3_H2O_ndx) = 1.0e-20_r8 * fc(:) + end if + +!----------------------------------------------------------------- +! ... n2o5 + m --> no2 + no3 + m (JPL15-10) +!----------------------------------------------------------------- + if( usr_N2O5_M_ndx > 0 ) then + if( tag_NO2_NO3_ndx > 0 ) then + call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) + rxt(:,k,usr_N2O5_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 1.724138e26_r8 * exp_fac(:) + else + rxt(:,k,usr_N2O5_M_ndx) = 0._r8 + end if + end if + if( usr_XNO2NO3_M_ndx > 0 ) then + if( tag_NO2_NO3_ndx > 0 ) then + call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) + rxt(:,k,usr_XNO2NO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) *1.724138e26_r8 * exp_fac(:) + else + rxt(:,k,usr_XNO2NO3_M_ndx) = 0._r8 + end if + end if + if( usr_NO2XNO3_M_ndx > 0 ) then + if( tag_NO2_NO3_ndx > 0 ) then + call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) + rxt(:,k,usr_NO2XNO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 1.734138e26_r8 * exp_fac(:) + else + rxt(:,k,usr_NO2XNO3_M_ndx) = 0._r8 + end if + end if + +!----------------------------------------------------------------- +! set rates for: +! ... hno3 + oh --> no3 + h2o +! ho2no2 + m --> ho2 + no2 + m +!----------------------------------------------------------------- + if( usr_HNO3_OH_ndx > 0 ) then + call comp_exp( exp_fac, 1335._r8*tinv, ncol ) + ko(:) = m(:,k) * 6.5e-34_r8 * exp_fac(:) + call comp_exp( exp_fac, 2199._r8*tinv, ncol ) + ko(:) = ko(:) / (1._r8 + ko(:)/(2.7e-17_r8*exp_fac(:))) + call comp_exp( exp_fac, 460._r8*tinv, ncol ) + rxt(:,k,usr_HNO3_OH_ndx) = ko(:) + 2.4e-14_r8*exp_fac(:) + end if + if( usr_XHNO3_OH_ndx > 0 ) then + call comp_exp( exp_fac, 1335._r8*tinv, ncol ) + ko(:) = m(:,k) * 6.5e-34_r8 * exp_fac(:) + call comp_exp( exp_fac, 2199._r8*tinv, ncol ) + ko(:) = ko(:) / (1._r8 + ko(:)/(2.7e-17_r8*exp_fac(:))) + call comp_exp( exp_fac, 460._r8*tinv, ncol ) + rxt(:,k,usr_XHNO3_OH_ndx) = ko(:) + 2.4e-14_r8*exp_fac(:) + end if + if( usr_HO2NO2_M_ndx > 0 ) then + if( tag_NO2_HO2_ndx > 0 ) then + call comp_exp( exp_fac, -10900._r8*tinv, ncol ) + rxt(:,k,usr_HO2NO2_M_ndx) = rxt(:,k,tag_NO2_HO2_ndx) * exp_fac(:) / 2.1e-27_r8 + else + rxt(:,k,usr_HO2NO2_M_ndx) = 0._r8 + end if + end if + if( usr_XHO2NO2_M_ndx > 0 ) then + if( tag_NO2_HO2_ndx > 0 ) then + call comp_exp( exp_fac, -10900._r8*tinv, ncol ) + rxt(:,k,usr_XHO2NO2_M_ndx) = rxt(:,k,tag_NO2_HO2_ndx) * exp_fac(:) / 2.1e-27_r8 + else + rxt(:,k,usr_XHO2NO2_M_ndx) = 0._r8 + end if + end if +!----------------------------------------------------------------- +! co + oh --> co2 + ho2 (combined branches - do not use with CO_OH_b) +!----------------------------------------------------------------- + if( usr_CO_OH_a_ndx > 0 ) then + rxt(:,k,usr_CO_OH_a_ndx) = 1.5e-13_r8 * & + (1._r8 + 6.e-7_r8*boltz_cgs*m(:,k)*temp(:ncol,k)) + end if +!----------------------------------------------------------------- +! ... co + oh --> co2 + h (second branch JPL15-10, with CO+OH+M) +!----------------------------------------------------------------- + if( usr_CO_OH_b_ndx > 0 ) then + kinf(:) = 2.1e+09_r8 * (temp(:ncol,k)/ t0)**(6.1_r8) + ko (:) = 1.5e-13_r8 + + term1(:) = ko(:) / ( (kinf(:) / m(:,k)) ) + term2(:) = ko(:) / (1._r8 + term1(:)) + + term1(:) = log10( term1(:) ) + term1(:) = 1.0_r8 / (1.0_r8 + term1(:)*term1(:)) + + rxt(:ncol,k,usr_CO_OH_b_ndx) = term2(:) * (0.6_r8)**term1(:) + end if + +!----------------------------------------------------------------- +! ... ho2 + ho2 --> h2o2 +! note: this rate involves the water vapor number density +!----------------------------------------------------------------- + if( usr_HO2_HO2_ndx > 0 ) then + + call comp_exp( exp_fac, 460._r8*tinv, ncol ) + ko(:) = 3.0e-13_r8 * exp_fac(:) + call comp_exp( exp_fac, 920._r8*tinv, ncol ) + kinf(:) = 2.1e-33_r8 * m(:,k) * exp_fac(:) + call comp_exp( exp_fac, 2200._r8*tinv, ncol ) + + if( h2o_ndx > 0 ) then + fc(:) = 1._r8 + 1.4e-21_r8 * m(:,k) * h2ovmr(:,k) * exp_fac(:) + else + fc(:) = 1._r8 + 1.4e-21_r8 * invariants(:,k,inv_h2o_ndx) * exp_fac(:) + end if + rxt(:,k,usr_HO2_HO2_ndx) = (ko(:) + kinf(:)) * fc(:) + + end if + +!----------------------------------------------------------------- +! ... mco3 + no2 -> mpan +!----------------------------------------------------------------- + if( usr_MCO3_NO2_ndx > 0 ) then + rxt(:,k,usr_MCO3_NO2_ndx) = 1.1e-11_r8 * tp(:) / m(:,k) + end if + if( usr_MCO3_XNO2_ndx > 0 ) then + rxt(:,k,usr_MCO3_XNO2_ndx) = 1.1e-11_r8 * tp(:) / m(:,k) + end if + +!----------------------------------------------------------------- +! ... pan + m --> ch3co3 + no2 + m (JPL15-10) +!----------------------------------------------------------------- + call comp_exp( exp_fac, -14000._r8*tinv, ncol ) + if( usr_PAN_M_ndx > 0 ) then + if( tag_CH3CO3_NO2_ndx > 0 ) then + rxt(:,k,usr_PAN_M_ndx) = rxt(:,k,tag_CH3CO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) + else + rxt(:,k,usr_PAN_M_ndx) = 0._r8 + end if + end if + if( usr_XPAN_M_ndx > 0 ) then + if( tag_CH3CO3_NO2_ndx > 0 ) then + rxt(:,k,usr_XPAN_M_ndx) = rxt(:,k,tag_CH3CO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) + else + rxt(:,k,usr_XPAN_M_ndx) = 0._r8 + end if + end if + +!----------------------------------------------------------------- +! ... mpan + m --> mco3 + no2 + m (JPL15-10) +!----------------------------------------------------------------- + if( usr_MPAN_M_ndx > 0 ) then + if( usr_MCO3_NO2_ndx > 0 ) then + rxt(:,k,usr_MPAN_M_ndx) = rxt(:,k,usr_MCO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) + else + rxt(:,k,usr_MPAN_M_ndx) = 0._r8 + end if + end if + if( usr_XMPAN_M_ndx > 0 ) then + if( usr_MCO3_NO2_ndx > 0 ) then + rxt(:,k,usr_XMPAN_M_ndx) = rxt(:,k,usr_MCO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) + else + rxt(:,k,usr_XMPAN_M_ndx) = 0._r8 + end if + end if + +!lke-TS1 +!----------------------------------------------------------------- +! ... pbznit + m --> acbzo2 + no2 + m +!----------------------------------------------------------------- + if( usr_PBZNIT_M_ndx > 0 ) then + if( tag_ACBZO2_NO2_ndx > 0 ) then + rxt(:,k,usr_PBZNIT_M_ndx) = rxt(:,k,tag_ACBZO2_NO2_ndx) * 1.111e28_r8 * exp_fac(:) + else + rxt(:,k,usr_PBZNIT_M_ndx) = 0._r8 + end if + end if + +!----------------------------------------------------------------- +! ... xooh + oh -> h2o + oh +!----------------------------------------------------------------- + if( usr_XOOH_OH_ndx > 0 ) then + call comp_exp( exp_fac, 253._r8*tinv, ncol ) + rxt(:,k,usr_XOOH_OH_ndx) = temp(:ncol,k)**2._r8 * 7.69e-17_r8 * exp_fac(:) + end if + +!----------------------------------------------------------------- +! ... ch3coch3 + oh -> ro2 + h2o +!----------------------------------------------------------------- + if( usr_CH3COCH3_OH_ndx > 0 ) then + call comp_exp( exp_fac, -2000._r8*tinv, ncol ) + rxt(:,k,usr_CH3COCH3_OH_ndx) = 3.82e-11_r8 * exp_fac(:) + 1.33e-13_r8 + end if + +!----------------------------------------------------------------- +! ... DMS + OH --> .5 * SO2 +!----------------------------------------------------------------- + if( usr_DMS_OH_ndx > 0 ) then + call comp_exp( exp_fac, 7460._r8*tinv, ncol ) + ko(:) = 1._r8 + 5.5e-31_r8 * exp_fac * m(:,k) * 0.21_r8 + call comp_exp( exp_fac, 7810._r8*tinv, ncol ) + rxt(:,k,usr_DMS_OH_ndx) = 1.7e-42_r8 * exp_fac * m(:,k) * 0.21_r8 / ko(:) + end if + +!----------------------------------------------------------------- +! ... SO2 + OH --> SO4 (REFERENCE?? - not Liao) +!----------------------------------------------------------------- + if( usr_SO2_OH_ndx > 0 ) then + fc(:) = 3.0e-31_r8 *(300._r8*tinv(:))**3.3_r8 + ko(:) = fc(:)*m(:,k)/(1._r8 + fc(:)*m(:,k)/1.5e-12_r8) + rxt(:,k,usr_SO2_OH_ndx) = ko(:)*.6_r8**(1._r8 + (log10(fc(:)*m(:,k)/1.5e-12_r8))**2._r8)**(-1._r8) + end if +! +! reduced hydrocarbon scheme +! + if ( usr_C2O3_NO2_ndx > 0 ) then + ko(:) = 2.6e-28_r8 * m(:,k) + kinf(:) = 1.2e-11_r8 + rxt(:,k,usr_C2O3_NO2_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log10(ko/kinf))**2)) + end if + if ( usr_C2O3_XNO2_ndx > 0 ) then + ko(:) = 2.6e-28_r8 * m(:,k) + kinf(:) = 1.2e-11_r8 + rxt(:,k,usr_C2O3_XNO2_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log10(ko/kinf))**2)) + end if + if ( usr_C2H4_OH_ndx > 0 ) then + ko(:) = 1.0e-28_r8 * m(:,k) + kinf(:) = 8.8e-12_r8 + rxt(:,k,usr_C2H4_OH_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log(ko/kinf))**2)) + end if + if ( usr_XO2N_HO2_ndx > 0 ) then + rxt(:,k,usr_XO2N_HO2_ndx) = rxt(:,k,tag_XO2N_NO_ndx)*rxt(:,k,tag_XO2_HO2_ndx)/(rxt(:,k,tag_XO2_NO_ndx)+1.e-36_r8) + end if + +! +! hydrolysis reactions on wetted aerosols +! + if( usr_NO2_aer_ndx > 0 .or. usr_NO3_aer_ndx > 0 .or. usr_N2O5_aer_ndx > 0 .or. usr_HO2_aer_ndx > 0 & + .or. usr_GLYOXAL_aer_ndx > 0 ) then + + long_loop : do i = 1,ncol + + sfc => sfc_array(i,k,:) + dm_aer => dm_array(i,k,:) + + c_n2o5 = 1.40e3_r8 * sqrt_t(i) ! mean molecular speed of n2o5 + c_no3 = 1.85e3_r8 * sqrt_t(i) ! mean molecular speed of no3 + c_no2 = 2.15e3_r8 * sqrt_t(i) ! mean molecular speed of no2 + c_ho2 = 2.53e3_r8 * sqrt_t(i) ! mean molecular speed of ho2 + c_glyoxal = 1.455e4_r8 * sqrt_t_58(i) ! mean molecular speed of ho2 + c_isopnita = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of isopnita + c_isopnitb = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of isopnitb + c_onitr = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of onitr + c_honitr = 1.26e3_r8 * sqrt_t(i) ! mean molecular speed of honitr + c_terpnit = 0.992e3_r8 * sqrt_t(i) ! mean molecular speed of terpnit + c_nterpooh = 0.957e3_r8 * sqrt_t(i) ! mean molecular speed of nterpooh + c_nc4cho = 1.21e3_r8 * sqrt_t(i) ! mean molecular speed of nc4cho + c_nc4ch2oh = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of nc4ch2oh + + !------------------------------------------------------------------------- + ! Heterogeneous reaction rates for uptake of a gas on an aerosol: + ! rxt = sfc / ( (rad_aer/Dg_gas) + (4/(c_gas*gamma_gas))) + !------------------------------------------------------------------------- + !------------------------------------------------------------------------- + ! ... n2o5 -> 2 hno3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_N2O5_aer_ndx > 0 ) then + rxt(i,k,usr_N2O5_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) + end if + if( usr_XNO2NO3_aer_ndx > 0 ) then + rxt(i,k,usr_XNO2NO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) + end if + if( usr_NO2XNO3_aer_ndx > 0 ) then + rxt(i,k,usr_NO2XNO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) + end if + !------------------------------------------------------------------------- + ! ... no3 -> hno3 (on sulfate, nh4no3, oc, soa) + !------------------------------------------------------------------------- + if( usr_NO3_aer_ndx > 0 ) then + rxt(i,k,usr_NO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no3, gamma_no3 ) + end if + if( usr_XNO3_aer_ndx > 0 ) then + rxt(i,k,usr_XNO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no3, gamma_no3 ) + end if + !------------------------------------------------------------------------- + ! ... no2 -> 0.5 * (ho+no+hno3) (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_NO2_aer_ndx > 0 ) then + rxt(i,k,usr_NO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no2, gamma_no2 ) + end if + if( usr_XNO2_aer_ndx > 0 ) then + rxt(i,k,usr_XNO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no2, gamma_no2 ) + end if + + !------------------------------------------------------------------------- + ! ... ho2 -> 0.5 * h2o2 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_HO2_aer_ndx > 0 ) then + rxt(i,k,usr_HO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_ho2, gamma_ho2 ) + end if + !------------------------------------------------------------------------- + ! ... glyoxal -> soag1 (on sulfate, nh4no3, oc2, soa) + ! first order uptake, Fuchs and Sutugin, 1971, dCg = 1/4 * gamma * ! A * |v_mol| * Cg * dt + !------------------------------------------------------------------------- + if( usr_GLYOXAL_aer_ndx > 0 ) then + rxt(i,k,usr_GLYOXAL_aer_ndx) = hetrxtrate_gly( sfc, c_glyoxal, gamma_glyoxal ) + end if + !------------------------------------------------------------------------- + ! ... ISOPNITA -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_ISOPNITA_aer_ndx > 0 ) then + rxt(i,k,usr_ISOPNITA_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_isopnita, gamma_isopnita ) + end if + !------------------------------------------------------------------------- + ! ... ISOPNITB -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_ISOPNITB_aer_ndx > 0 ) then + rxt(i,k,usr_ISOPNITB_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_isopnitb, gamma_isopnitb ) + end if + !------------------------------------------------------------------------- + ! ... ONITR -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_ONITR_aer_ndx > 0 ) then + rxt(i,k,usr_ONITR_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_onitr, gamma_onitr ) + end if + !------------------------------------------------------------------------- + ! ... HONITR -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_HONITR_aer_ndx > 0 ) then + rxt(i,k,usr_HONITR_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_honitr, gamma_honitr ) + end if + !------------------------------------------------------------------------- + ! ... TERPNIT -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_TERPNIT_aer_ndx > 0 ) then + rxt(i,k,usr_TERPNIT_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_terpnit, gamma_terpnit ) + end if + !------------------------------------------------------------------------- + ! ... NTERPOOH -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_NTERPOOH_aer_ndx > 0 ) then + rxt(i,k,usr_NTERPOOH_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nterpooh, gamma_nterpooh ) + end if + !------------------------------------------------------------------------- + ! ... NC4CHO -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_NC4CHO_aer_ndx > 0 ) then + rxt(i,k,usr_NC4CHO_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nc4cho, gamma_nc4cho ) + end if + !------------------------------------------------------------------------- + ! ... NC4CH2OH -> HNO3 (on sulfate, nh4no3, oc2, soa) + !------------------------------------------------------------------------- + if( usr_NC4CH2OH_aer_ndx > 0 ) then + rxt(i,k,usr_NC4CH2OH_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nc4ch2oh, gamma_nc4ch2oh ) + end if + + end do long_loop + end if + + ! LLNL super fast chem reaction rates + + !----------------------------------------------------------------------- + ! ... CO + OH --> CO2 + HO2 + !----------------------------------------------------------------------- + if ( usr_oh_co_ndx > 0 ) then + ko(:) = 5.9e-33_r8 * tp(:)**1.4_r8 + kinf(:) = 1.1e-12_r8 * (temp(:ncol,k) / 300._r8)**1.3_r8 + ko_m(:) = ko(:) * m(:,k) + k0(:) = 1.5e-13_r8 * (temp(:ncol,k) / 300._r8)**0.6_r8 + kinf_m(:) = (2.1e+09_r8 * (temp(:ncol,k) / 300._r8)**6.1_r8) / m(:,k) + rxt(:,k,usr_oh_co_ndx) = (ko_m(:)/(1._r8+(ko_m(:)/kinf(:)))) * & + 0.6_r8**(1._r8/(1._r8+(log10(ko_m(:)/kinf(:)))**2._r8)) + & + (k0(:)/(1._r8+(k0(:)/kinf_m(:)))) * & + 0.6_r8**(1._r8/(1._r8+(log10(k0(:)/kinf_m(:)))**2._r8)) + endif + !----------------------------------------------------------------------- + ! ... NO2 + H2O --> 0.5 HONO + 0.5 HNO3 + !----------------------------------------------------------------------- + if ( het_no2_h2o_ndx > 0 ) then + rxt(:,k,het_no2_h2o_ndx) = 4.0e-24_r8 + endif + !----------------------------------------------------------------------- + ! ... DMS + OH --> 0.75 SO2 + 0.25 MSA + !----------------------------------------------------------------------- + if ( usr_oh_dms_ndx > 0 ) then + o2(:ncol) = invariants(:ncol,k,inv_o2_ndx) + rxt(:,k,usr_oh_dms_ndx) = 2.000e-10_r8 * exp(5820.0_r8 * tinv(:)) / & + ((2.000e29_r8 / o2(:)) + exp(6280.0_r8 * tinv(:))) + endif + if ( aq_so2_h2o2_ndx > 0 .or. aq_so2_o3_ndx > 0 ) then + lwc(:) = cwat(:ncol,k) * invariants(:ncol,k,inv_m_ndx) * mbar(:ncol,k) /avo !PJC convert kg/kg to g/cm3 + !----------------------------------------------------------------------- + ! ... SO2 + H2O2 --> S(VI) + !----------------------------------------------------------------------- + if ( aq_so2_h2o2_ndx > 0 ) then + rxt(:,k,aq_so2_h2o2_ndx) = lwc(:) * 1.0e-03_r8 * avo * & + K_AQ * & + + exp(ER_AQ * ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + HENRY298_SO2 * & + K298_SO2_HSO3 * & + HENRY298_H2O2 * & + exp(((H298_SO2 + H298_SO2_HSO3 + H298_H2O2) / R_CAL) * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + (R_CONC * temp(:ncol,k))**2.0e+00_r8 / & + + (1.0e+00_r8 + 13.0e+00_r8 * 10.0e+00_r8**(-pH)) + endif + !----------------------------------------------------------------------- + ! ... SO2 + O3 --> S(VI) + !----------------------------------------------------------------------- + if (aq_so2_o3_ndx >0) then + rxt(:,k,aq_so2_o3_ndx) = lwc(:) * 1.0e-03_r8 * avo * & + HENRY298_SO2 * exp((H298_SO2 / R_CAL) * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + (K0_AQ * exp(ER0_AQ * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) + & + K298_SO2_HSO3 * exp((H298_SO2_HSO3 / R_CAL) * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + (K1_AQ * exp(ER1_AQ * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) / & + 10.0e+00_r8**(-pH) + K2_AQ * exp(ER2_AQ * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + K298_HSO3_SO3 * exp((H298_HSO3_SO3 / R_CAL) * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) / & + (10.0e+00_r8**(-pH))**2.0e+00_r8) ) * & + HENRY298_O3 * exp((H298_O3 / R_CAL) * & + ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & + (R_CONC * temp(:ncol,k))**2.0e+00_r8 + endif + endif + + if ( has_d_chem ) then + + call comp_exp( exp_fac, -600._r8 * tinv, ncol ) + rxt(:,k,ean_ndx(1)) = 1.e-31_r8 * tp(:) * exp_fac(:) + rxt(:,k,ean_ndx(2)) = 9.1e-12_r8 * tp(:)**(-1.46_r8) + call comp_exp( exp_fac, -193._r8 * tinv, ncol ) + rxt(:,k,ean_ndx(3)) = (4.e-30_r8 * exp_fac(:)) * 0.21_r8 + + rxt(:,k,rpe_ndx(1)) = 4.2e-6_r8 * tp(:)**0.5_r8 + rxt(:,k,rpe_ndx(2)) = 6.3e-7_r8 * tp(:)**0.5_r8 + rxt(:,k,rpe_ndx(3)) = 2.5e-6_r8 * tp(:)**0.1_r8 + rxt(:,k,rpe_ndx(4)) = 2.48e-6_r8 * tp(:)**0.76_r8 + rxt(:,k,rpe_ndx(5)) = 1.4e-6_r8 * tp(:)**0.4_r8 + + rxt(:,k,pir_ndx(1)) = 4.e-30_r8 * tp(:)**2.93_r8 + rxt(:,k,pir_ndx(2)) = 4.6e-27_r8 * tp(:)**4._r8 + + call comp_exp( exp_fac, -15900._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(3)) = (2.5e-2_r8 * tp(:)**5._r8) * exp_fac(:) + rxt(:,k,pir_ndx(4)) = 2.3e-27_r8 * tp(:)**7.5_r8 + + call comp_exp( exp_fac, -10272._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(5)) = (2.6e-3_r8 * tp(:)**8.5_r8) * exp_fac(:) + rxt(:,k,pir_ndx(6)) = 3.6e-27_r8 * tp(:)**8.1_r8 + + call comp_exp( exp_fac, -9000._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(7)) = (1.5e-1_r8 * tp(:)**9.1_r8) * exp_fac(:) + rxt(:,k,pir_ndx(8)) = 4.6e-28_r8 * tp(:)**14._r8 + + call comp_exp( exp_fac, -6400._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(9)) = (1.7e-3_r8 * tp(:)**15._r8) * exp_fac(:) + rxt(:,k,pir_ndx(10)) = 1.35e-28_r8 * tp(:)**2.83_r8 + + rxt(:,k,pir_ndx(11)) = 1.e-27_r8 * (308._r8 * tinv(:))**4.7_r8 + rxt(:,k,pir_ndx(12)) = rxt(:,k,pir_ndx(11)) + rxt(:,k,pir_ndx(13)) = 1.4e-29_r8 * tp(:)**4._r8 + + call comp_exp( exp_fac, -3872._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(14)) = (3.4e-7_r8 * tp(:)**5._r8) * exp_fac(:) + + rxt(:,k,pir_ndx(15)) = 3.0e-31_r8 * tp(:)**4.3_r8 + call comp_exp( exp_fac, -2093._r8 * tinv, ncol ) + rxt(:,k,pir_ndx(16)) = (1.5e-8_r8 * tp(:)**4.3_r8) * exp_fac(:) + + rxt(:,k,edn_ndx(1)) = 3.1e-10_r8 * tp(:)**0.83_r8 + call comp_exp( exp_fac, -4990._r8 * tinv, ncol ) + rxt(:,k,edn_ndx(2)) = (1.9e-12_r8 * tp(:)**(-1.5_r8)) * exp_fac(:) + + rxt(:,k,nir_ndx(1)) = 1.05e-12_r8 * tp(:)**2.15_r8 + rxt(:,k,nir_ndx(2)) = 2.5e-11_r8 * tp(:)**0.79_r8 + rxt(:,k,nir_ndx(3)) = 7.5e-11_r8 * tp(:)**0.79_r8 + rxt(:,k,nir_ndx(4)) = rxt(:,k,nir_ndx(1)) + rxt(:,k,nir_ndx(5)) = 1.3e-11_r8 * tp(:)**1.64_r8 + rxt(:,k,nir_ndx(6)) = 3.3e-11_r8 * tp(:)**2.38_r8 + + call comp_exp( exp_fac, -7300_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(7)) = (1.0e-3_r8 * tp(:)) * exp_fac(:) + call comp_exp( exp_fac, -7050_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(8)) = (7.2e-4_r8 * tp(:)) * exp_fac(:) + call comp_exp( exp_fac, -6800_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(9)) = (6.5e-3_r8 * tp(:)) * exp_fac(:) + call comp_exp( exp_fac, -7600_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(10)) = (5.7e-4_r8 * tp(:)) * exp_fac(:) + + call comp_exp( exp_fac, -7150_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(11)) = (1.5e-2_r8 * tp(:)) * exp_fac(:) + + call comp_exp( exp_fac, -13130_r8 * tinv, ncol ) + rxt(:,k,nir_ndx(12)) = (6.0e-3_r8 * tp(:)) * exp_fac(:) + rxt(:,k,nir_ndx(13)) = 5.22e-28_r8 * tp(:)**2.62_r8 + + rxt(:,k,iira_ndx(1)) = 6.0e-8_r8 * tp(:)**.5_r8 + do i = 2,niira + rxt(:,k,iira_ndx(i)) = rxt(:,k,iira_ndx(i-1)) + enddo + + rxt(:,k,iirb_ndx(1)) = 1.25e-25_r8 * tp(:)**4._r8 + do i = 2,niirb + rxt(:,k,iirb_ndx(i)) = rxt(:,k,iirb_ndx(i-1)) + enddo + + call comp_exp( exp_fac, -6600._r8 * tinv, ncol ) + rxt(:,k,usr_clm_h2o_m_ndx) = 2.e-8_r8 * exp_fac(:) + + call comp_exp( exp_fac, -11926._r8 * tinv, ncol ) + rxt(:,k,usr_clm_hcl_m_ndx) = tinv(:) * exp_fac(:) + + endif + end do level_loop + +!----------------------------------------------------------------- +! ... the ionic rates +!----------------------------------------------------------------- + if ( has_ion_rxts ) then + level_loop2 : do k = 1,pver + tp(:ncol) = (2._r8*tempi(:ncol,k) + temp(:ncol,k)) / ( 3._r8 * t0 ) + tp(:) = max( min( tp(:),20._r8 ),1._r8 ) + rxt(:,k,ion1_ndx) = 2.82e-11_r8 + tp(:)*(-7.74e-12_r8 + tp(:)*(1.073e-12_r8 & + + tp(:)*(-5.17e-14_r8 + 9.65e-16_r8*tp(:)))) + tp(:ncol) = (.6363_r8*tempi(:ncol,k) + .3637_r8*temp(:ncol,k)) / t0 + tp(:) = max( min( tp(:),trlim2 ),1._r8 ) + rxt(:,k,ion2_ndx) = 1.533e-12_r8 + tp(:)*(-5.92e-13_r8 + tp(:)*8.6e-14_r8) + tp(:ncol) = 2._r8 * t0 /(tempi(:ncol,k) + temp(:ncol,k)) + where( tp(:ncol) < trlim3 ) + rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 + rxt(:,k,ion11_ndx) = 1.e-11_r8 * tp(:)**.23_r8 + elsewhere + rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 + rxt(:,k,ion11_ndx) = 3.6e-12_r8 / tp(:)**.41_r8 + end where + tp(:ncol) = t0 / tempe(:ncol,k) + rxt(:,k,elec1_ndx) = 4.e-7_r8 * tp(:)**.85_r8 + rxt(:,k,elec3_ndx) = 1.8e-7_r8 * tp(:)**.39_r8 + where( tp(:ncol) < 4._r8 ) + rxt(:,k,elec2_ndx) = 2.7e-7_r8 * tp(:)**.7_r8 + elsewhere + rxt(:,k,elec2_ndx) = 1.6e-7_r8 * tp(:)**.55_r8 + end where + end do level_loop2 + endif + + ! quenching of O+(2P) and O+(2D) by e to produce O+ + ! See TABLE 1 of Roble (1995) + ! drm 2015-07-27 + if (elec4_ndx > 0 .and. elec5_ndx > 0 .and. elec6_ndx > 0) then + do k=1,pver + tp(:ncol) = sqrt(300._r8 / tempe(:ncol,k)) + rxt(:,k,elec4_ndx) = 1.5e-7_r8 * tp(:) + rxt(:,k,elec5_ndx) = 4.0e-8_r8 * tp(:) + rxt(:,k,elec6_ndx) = 6.6e-8_r8 * tp(:) + end do + endif + +!----------------------------------------------------------------- +! ... tropospheric "aerosol" rate constants +!----------------------------------------------------------------- + if ( het1_ndx > 0 .AND. (.NOT. usr_N2O5_aer_ndx > 0) ) then + amas = 4._r8*pi*rm1**3*den/3._r8 ! each mean particle(r=0.1u) mass (g) + do k = 1,pver +!------------------------------------------------------------------------- +! ... estimate humidity effect on aerosols (from Shettle and Fenn, 1979) +! xr is a factor of the increase aerosol radii with hum (hum=0., factor=1) +!------------------------------------------------------------------------- + xr(:) = .999151_r8 + relhum(:ncol,k)*(1.90445_r8 + relhum(:ncol,k)*(-6.35204_r8 + relhum(:ncol,k)*5.32061_r8)) +!------------------------------------------------------------------------- +! ... estimate sulfate particles surface area (cm2/cm3) in each grid +!------------------------------------------------------------------------- + if ( carma_hetchem_feedback ) then + sur(:ncol) = strato_sad(:ncol,k) + else + sur(:) = sulfate(:,k)*m(:,k)/avo*wso4 & ! xform mixing ratio to g/cm3 + / amas & ! xform g/cm3 to num particels/cm3 + * fare & ! xform num particels/cm3 to cm2/cm3 + * xr(:)*xr(:) ! humidity factor + endif +!----------------------------------------------------------------- +! ... compute the "aerosol" reaction rates +!----------------------------------------------------------------- +! k = gam * A * velo/4 +! +! where velo = sqrt[ 8*bk*T/pi/(w/av) ] +! bk = 1.381e-16 +! av = 6.02e23 +! w = 108 (n2o5) HO2(33) CH2O (30) NH3(15) +! +! so that velo = 1.40e3*sqrt(T) (n2o5) gama=0.1 +! so that velo = 2.53e3*sqrt(T) (HO2) gama>0.2 +! so that velo = 2.65e3*sqrt(T) (CH2O) gama>0.022 +! so that velo = 3.75e3*sqrt(T) (NH3) gama=0.4 +!-------------------------------------------------------- +!----------------------------------------------------------------- +! ... use this n2o5 -> 2*hno3 only in tropopause +!----------------------------------------------------------------- + rxt(:,k,het1_ndx) = rxt(:,k,het1_ndx) & + +.25_r8 * gam1 * sur(:) * 1.40e3_r8 * sqrt( temp(:ncol,k) ) + end do + end if + +!lke++ +!----------------------------------------------------------------- +! ... CO tags +!----------------------------------------------------------------- + if( usr_CO_OH_b_ndx > 0 ) then + if( usr_COhc_OH_ndx > 0 ) then + rxt(:ncol,:,usr_COhc_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_COme_OH_ndx > 0 ) then + rxt(:ncol,:,usr_COme_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO01_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO01_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO02_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO02_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO03_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO03_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO04_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO04_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO05_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO05_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO06_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO06_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO07_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO07_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO08_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO08_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO09_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO09_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO10_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO10_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO11_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO11_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO12_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO12_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO13_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO13_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO14_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO14_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO15_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO15_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO16_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO16_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO17_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO17_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO18_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO18_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO19_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO19_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO20_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO20_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO21_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO21_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO22_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO22_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO23_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO23_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO24_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO24_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO25_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO25_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO26_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO26_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO27_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO27_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO28_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO28_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO29_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO29_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO30_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO30_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO31_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO31_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO32_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO32_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO33_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO33_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO34_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO34_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO35_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO35_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO36_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO36_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO37_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO37_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO38_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO38_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO39_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO39_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO40_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO40_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO41_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO41_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + if( usr_CO42_OH_ndx > 0 ) then + rxt(:ncol,:,usr_CO42_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) + end if + end if +!lke-- +! +! jfl : additional BAM removal reactions. Zero out below the tropopause +! + do l=1,num_strat_tau +! + if ( usr_strat_tau_ndx(l) > 0 ) then + do i=1,ncol + rxt(i,tropchemlev(i)+1:pver,usr_strat_tau_ndx(l)) = 0._r8 + end do + end if +! + end do +! + + deallocate( sfc_array, dm_array ) + + end subroutine usrrxt + + subroutine usrrxt_hrates( rxt, tempn, tempi, tempe, & + h2ovmr, m, ncol, kbot ) +!----------------------------------------------------------------- +! ... set the user specified reaction rates for heating +!----------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : rxntot + use ppgrid, only : pver, pcols + + implicit none + +!----------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------- + integer, intent(in) :: ncol ! number columns in chunk + integer, intent(in) :: kbot ! heating levels + real(r8), intent(in) :: tempn(pcols,pver) ! neutral temperature (K) + real(r8), intent(in) :: tempi(pcols,pver) ! ion temperature (K) + real(r8), intent(in) :: tempe(pcols,pver) ! electron temperature (K) + real(r8), intent(in) :: m(ncol,pver) ! total atm density (1/cm^3) + real(r8), intent(in) :: h2ovmr(ncol,pver) ! water vapor (vmr) + real(r8), intent(inout) :: rxt(ncol,pver,rxntot) ! gas phase rates + +!----------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------- + + integer :: k + real(r8), dimension(ncol) :: & + tp, & + tinv, & + ko, & + kinf, & + fc + +!----------------------------------------------------------------- +! ... o + o2 + m --> o3 + m +!----------------------------------------------------------------- + do k = 1,kbot + tinv(:ncol) = 1._r8 / tempn(:ncol,k) + tp(:) = 300._r8 * tinv(:) + rxt(:,k,usr_O_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 + +!----------------------------------------------------------------- +! ... o + o + m -> o2 + m +!----------------------------------------------------------------- + rxt(:,k,usr_O_O_ndx) = 2.76e-34_r8 * exp( 720.0_r8*tinv(:) ) + +!----------------------------------------------------------------- +! ... ho2 + ho2 --> h2o2 +! Note: this rate involves the water vapor number density +!----------------------------------------------------------------- + ko(:) = 3.0e-13_r8 * exp( 460._r8*tinv(:) ) + kinf(:) = 2.1e-33_r8 * m(:,k) * exp( 920._r8*tinv(:) ) + fc(:) = 1._r8 + 1.4e-21_r8 * m(:,k) * h2ovmr(:,k) * exp( 2200._r8*tinv(:) ) + rxt(:,k,usr_HO2_HO2_ndx) = (ko(:) + kinf(:)) * fc(:) + + end do + +!----------------------------------------------------------------- +! ... the ionic rates +!----------------------------------------------------------------- + if ( has_ion_rxts ) then + level_loop2 : do k = 1,kbot + tp(:ncol) = (2._r8*tempi(:ncol,k) + tempn(:ncol,k)) / ( 3._r8 * t0 ) + tp(:) = max( min( tp(:),20._r8 ),1._r8 ) + rxt(:,k,ion1_ndx) = 2.82e-11_r8 + tp(:)*(-7.74e-12_r8 + tp(:)*(1.073e-12_r8 & + + tp(:)*(-5.17e-14_r8 + 9.65e-16_r8*tp(:)))) + tp(:ncol) = (.6363_r8*tempi(:ncol,k) + .3637_r8*tempn(:ncol,k)) / t0 + tp(:) = max( min( tp(:),trlim2 ),1._r8 ) + rxt(:,k,ion2_ndx) = 1.533e-12_r8 + tp(:)*(-5.92e-13_r8 + tp(:)*8.6e-14_r8) + tp(:ncol) = 2._r8 * t0 /(tempi(:ncol,k) + tempn(:ncol,k)) + where( tp(:ncol) < trlim3 ) + rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 + elsewhere + rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 + endwhere + tp(:ncol) = t0 / tempe(:ncol,k) + rxt(:,k,elec1_ndx) = 4.e-7_r8 * tp(:)**.85_r8 + rxt(:,k,elec3_ndx) = 1.8e-7_r8 * tp(:)**.39_r8 + where( tp(:ncol) < 4._r8 ) + rxt(:,k,elec2_ndx) = 2.7e-7_r8 * tp(:)**.7_r8 + elsewhere + rxt(:,k,elec2_ndx) = 1.6e-7_r8 * tp(:)**.55_r8 + endwhere + end do level_loop2 + endif + end subroutine usrrxt_hrates + +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- + subroutine comp_exp( x, y, n ) + + implicit none + + real(r8), intent(out) :: x(:) + real(r8), intent(in) :: y(:) + integer, intent(in) :: n + +#ifdef IBM + call vexp( x, y, n ) +#else + x(:n) = exp( y(:n) ) +#endif + + end subroutine comp_exp + + !------------------------------------------------------------------------- + ! Heterogeneous reaction rates for uptake of a gas on an aerosol: + !------------------------------------------------------------------------- + function hetrxtrate( sfc, dm_aer, dg_gas, c_gas, gamma_gas ) result(rate) + + real(r8), intent(in) :: sfc(:) + real(r8), intent(in) :: dm_aer(:) + real(r8), intent(in) :: dg_gas + real(r8), intent(in) :: c_gas + real(r8), intent(in) :: gamma_gas + real(r8) :: rate + + real(r8),allocatable :: rxt(:) + integer :: n, i + + n = size(sfc) + + allocate(rxt(n)) + do i=1,n + rxt(i) = sfc(i) / (0.5_r8*dm_aer(i)/dg_gas + (4._r8/(c_gas*gamma_gas))) + enddo + + rate = sum(rxt) + + deallocate(rxt) + + endfunction hetrxtrate + + !------------------------------------------------------------------------- + ! Heterogeneous reaction rates for uptake of a glyoxal gas on an aerosol: + !------------------------------------------------------------------------- + function hetrxtrate_gly( sfc, c_gas, gamma_gas ) result(rate) + + real(r8), intent(in) :: sfc(:) + real(r8), intent(in) :: c_gas + real(r8), intent(in) :: gamma_gas + real(r8) :: rate + + real(r8),allocatable :: rxt(:) + integer :: n, i + + n = size(sfc) + + allocate(rxt(n)) + do i=1,n + rxt(i) = 0.25_r8 * c_gas * sfc(i) * gamma_gas + enddo + + rate = sum(rxt) + + deallocate(rxt) + + endfunction hetrxtrate_gly + + +end module mo_usrrxt diff --git a/src/chemistry/oslo_aero/modal_aero_data.F90 b/src/chemistry/oslo_aero/modal_aero_data.F90 new file mode 100644 index 0000000000..e62b884de7 --- /dev/null +++ b/src/chemistry/oslo_aero/modal_aero_data.F90 @@ -0,0 +1,64 @@ + module modal_aero_data + +!-------------------------------------------------------------- +! ... Basic aerosol mode parameters and arrays +!-------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst + use radconstants, only: nswbands, nlwbands + + implicit none + save + + integer, parameter :: ntot_amode = 0 + + integer, private :: qqcw(pcnst)=-1 ! Remaps modal_aero indices into pbuf + + contains + + subroutine qqcw_set_ptr(index, iptr) + use cam_abortutils, only : endrun + + + integer, intent(in) :: index, iptr + + if(index>0 .and. index <= pcnst ) then + qqcw(index)=iptr + else + call endrun('qqcw_set_ptr: attempting to set qqcw pointer already defined') + end if + end subroutine qqcw_set_ptr + +!-------------------------------------------------------------- +!-------------------------------------------------------------- + function qqcw_get_field(pbuf, index, lchnk, errorhandle) + use cam_abortutils, only : endrun + use physics_buffer, only : physics_buffer_desc, pbuf_get_field + + integer, intent(in) :: index, lchnk + real(r8), pointer :: qqcw_get_field(:,:) + logical, optional :: errorhandle + type(physics_buffer_desc), pointer :: pbuf(:) + + logical :: error + + nullify(qqcw_get_field) + error = .false. + if (index>0 .and. index <= pcnst) then + if (qqcw(index)>0) then + call pbuf_get_field(pbuf, qqcw(index), qqcw_get_field) + else + error = .true. + endif + else + error = .true. + end if + + if (error .and. .not. present(errorhandle)) then + call endrun('qqcw_get_field: attempt to access undefined qqcw') + end if + + end function qqcw_get_field + + end module modal_aero_data + diff --git a/src/chemistry/oslo_aero/modal_aero_deposition.F90 b/src/chemistry/oslo_aero/modal_aero_deposition.F90 new file mode 100644 index 0000000000..75b0263cf4 --- /dev/null +++ b/src/chemistry/oslo_aero/modal_aero_deposition.F90 @@ -0,0 +1,215 @@ +module modal_aero_deposition + +!------------------------------------------------------------------------------------------------ +! Purpose: +! +! Partition the contributions from modal components of wet and dry +! deposition at the surface into the fields passed to the coupler. +! +! *** N.B. *** Currently only a simple scheme for the 3-mode version +! of MAM has been implemented. +! +! Revision history: +! Feb 2009 M. Flanner, B. Eaton Original version for trop_mam3. +! Jul 2011 F Vitt -- made avaliable to be used in a prescribed modal aerosol mode (no prognostic MAM) +! Mar 2012 F Vitt -- made changes for to prevent abort when 7-mode aeroslol model is used +! some of the needed consituents do not exist in 7-mode so bin_fluxes will be false +! May 2014 F Vitt -- included contributions from MAM4 aerosols and added soa_a2 to the ocphiwet fluxes +!------------------------------------------------------------------------------------------------ + +use shr_kind_mod, only: r8 => shr_kind_r8 +use camsrfexch, only: cam_out_t +use constituents, only: cnst_get_ind, pcnst +use cam_abortutils, only: endrun +use rad_constituents, only: rad_cnst_get_info +use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac +use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 + +implicit none +private +save + +public :: & + modal_aero_deposition_init, & + set_srf_drydep, & + set_srf_wetdep + +! Private module data + +logical :: initialized = .false. +integer :: bcphi_ndx( pcnst ) = -1 +integer :: bcpho_ndx( pcnst ) = -1 +integer :: ocphi_ndx( pcnst ) = -1 +integer :: ocpho_ndx( pcnst ) = -1 +integer :: crse_dust_ndx( pcnst ) = -1 +integer :: fine_dust_ndx( pcnst ) = -1 +integer :: bcphi_cnt = 0 +integer :: ocphi_cnt = 0 +integer :: bcpho_cnt = 0 +integer :: ocpho_cnt = 0 +integer :: crse_dust_cnt = 0 +integer :: fine_dust_cnt = 0 + +!============================================================================== +contains +!============================================================================== + +subroutine modal_aero_deposition_init( bcphi_indices, bcpho_indices, ocphi_indices, & + ocpho_indices, fine_dust_indices, crse_dust_indices ) + + ! set aerosol indices for re-mapping surface deposition fluxes: + ! *_a1 = accumulation mode + ! *_a2 = aitken mode + ! *_a3 = coarse mode + + ! can be initialized with user specified indices + ! if called from aerodep_flx module (for prescribed modal aerosol fluxes) then these indices are specified + integer, optional, intent(in) :: bcphi_indices(:) ! hydrophilic black carbon + integer, optional, intent(in) :: bcpho_indices(:) ! hydrophobic black carbon + integer, optional, intent(in) :: ocphi_indices(:) ! hydrophilic organic carbon + integer, optional, intent(in) :: ocpho_indices(:) ! hydrophobic organic carbon + integer, optional, intent(in) :: fine_dust_indices(:) ! fine dust + integer, optional, intent(in) :: crse_dust_indices(:) ! coarse dust + + ! local vars + integer :: i, pcnt, scnt + + character(len=16), parameter :: fine_dust_modes(2) = (/ 'accum ', 'fine_dust '/) + character(len=16), parameter :: crse_dust_modes(2) = (/ 'coarse ', 'coarse_dust '/) + character(len=16), parameter :: hydrophilic_carbon_modes(1) = (/'accum '/) + character(len=16), parameter :: hydrophobic_carbon_modes(3) = (/'aitken ', 'coarse ', 'primary_carbon '/) + + ! if already initialized abort the run + if (initialized) then + call endrun('modal_aero_deposition is already initialized') + endif + + + initialized = .true. + +end subroutine modal_aero_deposition_init + +!============================================================================== +subroutine set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) + +! Set surface wet deposition fluxes passed to coupler. + + ! Arguments: + real(r8), intent(in) :: aerdepwetis(:,:) ! aerosol wet deposition (interstitial) + real(r8), intent(in) :: aerdepwetcw(:,:) ! aerosol wet deposition (cloud water) + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i, ispec, idx + integer :: ncol ! number of columns + + real(r8) :: bcphiwet_sum, ocphiwet_sum + !---------------------------------------------------------------------------- + + if (.not.initialized) call endrun('set_srf_wetdep: modal_aero_deposition has not been initialized') + + ncol = cam_out%ncol + + cam_out%bcphiwet(:) = 0._r8 + cam_out%ocphiwet(:) = 0._r8 + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! srf models want positive definite fluxes. + do i = 1, ncol + + ! black carbon fluxes + ! djlo : added bc_n and bc_ax contribution + ! djlo : bc_ax is assumed not to exist in cloud water + cam_out%bcphiwet(i) = -(aerdepwetis(i,l_bc_ni)+aerdepwetcw(i,l_bc_ni)+ & + aerdepwetis(i,l_bc_ai)+aerdepwetcw(i,l_bc_ai)+ & + aerdepwetis(i,l_bc_a )+aerdepwetcw(i,l_bc_a )+ & + aerdepwetis(i,l_bc_ac)+aerdepwetcw(i,l_bc_ac)+ & + aerdepwetis(i,l_bc_n )+aerdepwetcw(i,l_bc_n )+ & + aerdepwetis(i,l_bc_ax)) + + ! organic carbon fluxes + cam_out%ocphiwet(i) = -(aerdepwetis(i,l_om_ni)+aerdepwetcw(i,l_om_ni)+ & + aerdepwetis(i,l_om_ai)+aerdepwetcw(i,l_om_ai)+ & + aerdepwetis(i,l_om_ac)+aerdepwetcw(i,l_om_ac)) + + ! dust fluxes + ! + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: + cam_out%dstwet1(i) = -(aerdepwetis(i,l_dst_a2)+aerdepwetcw(i,l_dst_a2)) + + ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: + cam_out%dstwet2(i) = 0._r8 + cam_out%dstwet3(i) = -(aerdepwetis(i,l_dst_a3)+aerdepwetcw(i,l_dst_a3)) + cam_out%dstwet4(i) = 0._r8 + + enddo + +end subroutine set_srf_wetdep + +!============================================================================== + +subroutine set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) + +! Set surface dry deposition fluxes passed to coupler. + + ! Arguments: + real(r8), intent(in) :: aerdepdryis(:,:) ! aerosol dry deposition (interstitial) + real(r8), intent(in) :: aerdepdrycw(:,:) ! aerosol dry deposition (cloud water) + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i, ispec, idx + integer :: ncol ! number of columns + real(r8):: bcphidry_sum, ocphidry_sum, ocphodry_sum + !---------------------------------------------------------------------------- + + if (.not.initialized) call endrun('set_srf_drydep: modal_aero_deposition has not been initialized') + + ncol = cam_out%ncol + + cam_out%bcphidry(:) = 0._r8 + cam_out%bcphodry(:) = 0._r8 + cam_out%ocphidry(:) = 0._r8 + cam_out%ocphodry(:) = 0._r8 + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! srf models want positive definite fluxes. + do i = 1, ncol + ! black carbon fluxes + cam_out%bcphidry(i) = aerdepdryis(i,l_bc_ni)+aerdepdrycw(i,l_bc_ni)+ & + aerdepdryis(i,l_bc_ai)+aerdepdrycw(i,l_bc_ai)+ & + aerdepdryis(i,l_bc_a )+aerdepdrycw(i,l_bc_a )+ & + aerdepdryis(i,l_bc_ac)+aerdepdrycw(i,l_bc_ac) + cam_out%bcphodry(i) = aerdepdryis(i,l_bc_n )+aerdepdrycw(i,l_bc_n )+ & + aerdepdryis(i,l_bc_ax)+aerdepdrycw(i,l_bc_ax) + + ! organic carbon fluxes + ! djlo : skipped the bc_a contribution (was about om !) + cam_out%ocphidry(i) = aerdepdryis(i,l_om_ni)+aerdepdrycw(i,l_om_ni)+ & + aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & + aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) + cam_out%ocphidry(i) = 0._r8 !aerdepdryis(i,idx_pom1)+aerdepdryis(i,idx_soa1)+aerdepdrycw(i,idx_pom1)+aerdepdrycw(i,idx_soa1) + cam_out%ocphodry(i) = 0._r8 !aerdepdryis(i,idx_soa2)+aerdepdrycw(i,idx_soa2) + + ! dust fluxes + ! + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: + cam_out%dstdry1(i) = aerdepdryis(i,l_dst_a2)+aerdepdrycw(i,l_dst_a2) + + ! Two options for partitioning deposition into bins 2-4: + ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: + cam_out%dstdry2(i) = 0._r8 + cam_out%dstdry3(i) = aerdepdryis(i,l_dst_a3)+aerdepdrycw(i,l_dst_a3) + cam_out%dstdry4(i) = 0._r8 + enddo + +end subroutine set_srf_drydep + + +!============================================================================== + +end module modal_aero_deposition diff --git a/src/chemistry/oslo_aero/modalapp2d.F90 b/src/chemistry/oslo_aero/modalapp2d.F90 new file mode 100644 index 0000000000..31a21aa3e5 --- /dev/null +++ b/src/chemistry/oslo_aero/modalapp2d.F90 @@ -0,0 +1,169 @@ +module modalapp2d + public + save +contains + + subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) + +! Calculation of the apportionment of internally mixed SO4, BC and OC +! mass between the various background mineral and sea-salt modes. Separated +! from pmxsub into a independent subroutine by Alf Kirkevåg on September +! 12'th, 2005, and converted to 2D for use in parmix on September 15'th. +! Modified for new aerosol schemes by Alf Kirkevaag in January 2006: Now +! also Aitken-modes are subject to condensation of H2SO4, and both n and +! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. +!SOA +! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition +! to H2SO4, but as long as SOA is not allowed to condense on more than one +! mode, no changes are necessary here. NB: to allow SOA to condense also on +! the BC(Ait) and/or other modes, change this code accordingly! Without any +! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. +!SOA +! Alf Grini, february 2014 : Added info about units, +! used values calculated at initialization. +! changed in-out variables to components of derived data types (modedefs) +! defined in microphysics_oslo.F90, and corrected for mass balance error +! for SO4 due to lumping of coagulate and condensate. + + + use ppgrid, only : pcols, pver + use shr_kind_mod, only: r8 => shr_kind_r8 + + use commondefinitions + use aerosoldef + use const, only: smallNumber + use koagsub, only: normalizedCoagulationSink + use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + + implicit none +! +! Input arguments +! + integer , intent(in) :: ncol ! number of columns used + real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 + real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC + real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot + real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) + real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 + real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) + real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) + ! + ! Output arguments + ! + real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC + real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot + real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) + real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 + real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) !modal mass fraction (SO4(cond)/SO4(cond+coag)) + real(r8), intent(out) :: fsoam(pcols,pver,nbmodes)! modal mass fraction SOA / (POM+SOA) + + ! + ! Local variables + real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode + real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode + + real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes + real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes + + real(r8) fcondkSO4(pcols,pver,nbmodes) + real(r8) fcondkOA(pcols,pver,nbmodes) + real(r8) fcoagk(pcols,pver,nbmodes) + real(r8) faqk(pcols,pver,nbmodes) + + real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode + real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode + real(r8) csoacondsk(pcols,pver,nbmodes) + real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode + real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + + integer :: i !counter for modes + integer :: k !counter for levels + + !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in koagsub/condtend!!)) + !Should either remove it from there or add something to it here! + do i=1,nbmodes + do k=1,pver + condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) + condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) + coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) + aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode + end do + enddo + + !Sum the sinks + sumCondensationSinkSO4(:,:) = 0.0_r8 + sumCondensationSinkOA(:,:) = 0.0_r8 + sumCoagulationSink(:,:) = 0.0_r8 + sumAquousPhaseSink(:,:) = 0.0_r8 + do i=1,nbmodes + do k=1,pver + sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) + sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) + sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) + sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) + end do + end do + + ! And finally the contribution from each mode relative to the totals are calculated, + ! assuming that the apportionment of mass for the first iteration (in time) is representative + ! for the whole apportionment process (which is ok for small and moderate masses added): + do i=1,nbmodes + do k=1,pver + !Get the fraction of contribution per process per mode + fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode + faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode + + !BC coagulate to this mode [kg/m3] + cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) + + !OC coagulate to this mode [kg/m3] + caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) + + !SOA condensate to this mode [kg/m3] + csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) + + !Aquous phase SO4 to this mode [kg/m3] + caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) + + !so4 condensate + cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) + + !soa coagulate + cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate + end do + enddo + + !The tables take as input the combined coagulate and condensate (both POM and SOA) + !The activation needs them separately for mass balance! + cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) + coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) + + do i=1,nbmodes + do k=1,pver + Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC + + coccondcoagsk(:ncol,k,i) & !OM + + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i + + fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) + fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc + faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase + + !Not needed for tables, but for mass balances in activation + fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag + fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA + end do + enddo + + return +end subroutine modalapp2d_sub + +end module modalapp2d diff --git a/src/chemistry/oslo_aero/ndrop.F90 b/src/chemistry/oslo_aero/ndrop.F90 new file mode 100644 index 0000000000..2a372f946a --- /dev/null +++ b/src/chemistry/oslo_aero/ndrop.F90 @@ -0,0 +1,3143 @@ +module ndrop + +!--------------------------------------------------------------------------------- +! Purpose: +! CAM Interface for droplet activation by modal aerosols +! +! ***N.B.*** This module is currently hardcoded to recognize only the modes that +! affect the climate calculation. This is implemented by using list +! index 0 in all the calls to rad_constituent interfaces. +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp +use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o, & + gravit, latvap, cpair, epsilo, rair +use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class +use physics_types, only: physics_state, physics_ptend, physics_ptend_init +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + +use wv_saturation, only: qsat +use phys_control, only: phys_getopts +use ref_pres, only: top_lev => trop_cloud_top_lev +use shr_spfn_mod, only: erf => shr_spfn_erf +use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & + rad_cnst_get_aer_props, rad_cnst_get_mode_props, & + rad_cnst_get_mam_mmr_idx, rad_cnst_get_mode_num_idx +use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld +use cam_abortutils, only: endrun +use cam_logfile, only: iulog +!++ MH_2015/09/09 +use phys_control, only: use_hetfrz_classnuc +!-- MH_2015/09/09 + +#ifdef OSLO_AERO +!++oslo +use aerosoldef +use parmix_progncdnc +use oslo_utils, only: calculateNumberMedianRadius +!--oslo +#endif + + +implicit none +private +save + +public ndrop_init, dropmixnuc, activate_modal, loadaer + +#ifndef OSLO_AERO +real(r8), allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol +real(r8), allocatable :: exp45logsig(:) +real(r8), allocatable, target :: f1(:) ! abdul-razzak functions of width +real(r8), allocatable, target :: f2(:) ! abdul-razzak functions of width +#endif + +real(r8) :: t0 ! reference temperature +real(r8) :: aten +real(r8) :: surften ! surface tension of water w/respect to air (N/m) +real(r8) :: alog2, alog3, alogaten +real(r8) :: third, twothird, sixth, zero +real(r8) :: sq2, sqpi + +! CCN diagnostic fields +!integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration +!real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration +! (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) +!character(len=8) :: ccn_name(psat)= & +! (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) +!akc6+ +integer, parameter :: psat=7 ! number of supersaturations to calc ccn concentration +real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration + (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) +character(len=8) :: ccn_name(psat)= & + (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) +!akc6- + +! indices in state and pbuf structures +integer :: numliq_idx = -1 +integer :: kvh_idx = -1 + +! description of modal aerosols +integer :: ntot_amode ! number of aerosol modes +integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode +real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode +real(r8), allocatable :: dgnumlo_amode(:) +real(r8), allocatable :: dgnumhi_amode(:) +real(r8), allocatable :: voltonumblo_amode(:) +real(r8), allocatable :: voltonumbhi_amode(:) + +logical :: history_aerosol ! Output the MAM aerosol tendencies +character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields +character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields + +! local indexing for MAM +integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr +integer :: ncnst_tot ! total number of mode number conc + mode species + +! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. +integer, allocatable :: mam_cnst_idx(:,:) + +#ifdef OSLO_AERO +logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies +integer :: n_aerosol_tracers +integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst + !..something like (/ l_so4_a1, l_bc_a, .../)etc +integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the + !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 +#endif + +! ptr2d_t is used to create arrays of pointers to 2D fields +type ptr2d_t + real(r8), pointer :: fld(:,:) +end type ptr2d_t + +! modal aerosols +logical :: prog_modal_aero ! true when modal aerosols are prognostic +logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + ! in the ptend object + +!=============================================================================== +contains +!=============================================================================== + +subroutine ndrop_init + + integer :: ii, l, lptr, m, mm + integer :: nspec_max ! max number of species in a mode + character(len=32) :: tmpname + character(len=32) :: tmpname_cw + character(len=128) :: long_name + character(len=8) :: unit + logical :: history_amwg ! output the variables used by the AMWG diag package +#ifdef OSLO_AERO + character(len=10) :: modeString + character(len=20) :: varname +#endif + + !------------------------------------------------------------------------------- + + ! get indices into state%q and pbuf structures + call cnst_get_ind('NUMLIQ', numliq_idx) + + kvh_idx = pbuf_get_index('kvh') + + zero = 0._r8 + third = 1._r8/3._r8 + twothird = 2._r8*third + sixth = 1._r8/6._r8 + sq2 = sqrt(2._r8) + sqpi = sqrt(pi) + + t0 = 273._r8 + surften = 0.076_r8 + aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) + alogaten = log(aten) + alog2 = log(2._r8) + alog3 = log(3._r8) + + ! get info about the modal aerosols + ! get ntot_amode +#ifdef OSLO_AERO + ntot_amode = nmodes !from opttab +#else + call rad_cnst_get_info(0, nmodes=ntot_amode) +#endif + allocate( & + nspec_amode(ntot_amode), & + sigmag_amode(ntot_amode), & + dgnumlo_amode(ntot_amode), & + dgnumhi_amode(ntot_amode), & +#ifndef OSLO_AERO + alogsig(ntot_amode), & + exp45logsig(ntot_amode), & + f1(ntot_amode), & + f2(ntot_amode), & +#endif + voltonumblo_amode(ntot_amode), & + voltonumbhi_amode(ntot_amode) ) + +#ifdef OSLO_AERO + do m = 1,ntot_amode + nspec_amode(m) = getNumberOfTracersInMode(m) + enddo +#else + do m = 1, ntot_amode + ! use only if width of size distribution is prescribed + + ! get mode info + call rad_cnst_get_info(0, m, nspec=nspec_amode(m)) + + ! get mode properties + call rad_cnst_get_mode_props(0, m, sigmag=sigmag_amode(m), & + dgnumhi=dgnumhi_amode(m), dgnumlo=dgnumlo_amode(m)) + + alogsig(m) = log(sigmag_amode(m)) + exp45logsig(m) = exp(4.5_r8*alogsig(m)*alogsig(m)) + f1(m) = 0.5_r8*exp(2.5_r8*alogsig(m)*alogsig(m)) + f2(m) = 1._r8 + 0.25_r8*alogsig(m) + + voltonumblo_amode(m) = 1._r8 / ( (pi/6._r8)* & + (dgnumlo_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) + voltonumbhi_amode(m) = 1._r8 / ( (pi/6._r8)* & + (dgnumhi_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) + end do +#endif + ! Init the table for local indexing of mam number conc and mmr. + ! This table uses species index 0 for the number conc. + + ! Find max number of species in all the modes, and the total + ! number of mode number concentrations + mode species + nspec_max = nspec_amode(1) + ncnst_tot = nspec_amode(1) + 1 + do m = 2, ntot_amode + nspec_max = max(nspec_max, nspec_amode(m)) + ncnst_tot = ncnst_tot + nspec_amode(m) + 1 + end do + + allocate( & + mam_idx(ntot_amode,0:nspec_max), & + mam_cnst_idx(ntot_amode,0:nspec_max), & + fieldname(ncnst_tot), & + fieldname_cw(ncnst_tot) ) + + ! Local indexing compresses the mode and number/mass indicies into one index. + ! This indexing is used by the pointer arrays used to reference state and pbuf + ! fields. + ii = 0 + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + ii = ii + 1 + mam_idx(m,l) = ii + end do + end do + + ! Add dropmixnuc tendencies for all modal aerosol species + + call phys_getopts(history_amwg_out = history_amwg, & + history_aerosol_out = history_aerosol, & + prog_modal_aero_out=prog_modal_aero) + +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. + n_aerosol_tracers = getNumberOfAerosolTracers() + call fillAerosolTracerList(aerosolTracerList) + call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) + do ii=1,n_aerosol_tracers + print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) + end do +#endif + +#ifdef OSLO_AERO + lq(:)=.FALSE. !Initialize + + !Set up tendencies for tracers (output) + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + + if(.NOT. lq(lptr))then + !add dropmixnuc tendencies + mm=mam_idx(m,l) + fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" + fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" + + long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) + + long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) + + if (history_aerosol) then + call add_default(trim(fieldname(mm)), 1, ' ') + call add_default(trim(fieldname_cw(mm)),1,' ') + endif + + !Do tendencies of this tracer + lq(lptr)=.TRUE. + endif + enddo + enddo + do m=1,ntot_amode + modeString=" " + write(modeString,"(I2)"),m + if(m .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "NCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "VCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "SIGMA"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "HYGRO"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + end do +#else + do m = 1, ntot_amode + do l = 0, nspec_amode(m) ! loop over number + chem constituents + + mm = mam_idx(m,l) + + unit = 'kg/m2/s' + if (l == 0) then ! number + unit = '#/m2/s' + end if + + if (l == 0) then ! number + call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) + else + call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) + end if + + fieldname(mm) = trim(tmpname) // '_mixnuc1' + fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' + + if (prog_modal_aero) then + + ! To set tendencies in the ptend object need to get the constituent indices + ! for the prognostic species + if (l == 0) then ! number + call rad_cnst_get_mode_num_idx(m, lptr) + else + call rad_cnst_get_mam_mmr_idx(m, l, lptr) + end if + mam_cnst_idx(m,l) = lptr + lq(lptr) = .true. + + ! Add tendency fields to the history only when prognostic MAM is enabled. + long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname(mm), horiz_only, 'A', unit, long_name) + + long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name) + + if (history_aerosol) then + call add_default(fieldname(mm), 1, ' ') + call add_default(fieldname_cw(mm), 1, ' ') + end if + + + + end if + + end do + end do + +#endif + +! call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') +! call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') +! call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') +! call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') +! call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') +! call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') +!akc6+ + call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') + call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') + call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') + call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.15%') + call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') + call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') + call addfld('CCN7',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') +!akc6- + +#ifdef OSLO_AERO + if(history_aerosol)then + do l = 1, psat + call add_default(ccn_name(l), 1, ' ') + enddo + end if +#endif + + call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') + call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') + call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') + call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') + call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') + +#ifndef OSLO_AERO + + ! set the add_default fields + if (history_amwg) then + call add_default('CCN3', 1, ' ') + endif + + if (history_aerosol .and. prog_modal_aero) then + do m = 1, ntot_amode + do l = 0, nspec_amode(m) ! loop over number + chem constituents + mm = mam_idx(m,l) + if (l == 0) then ! number + call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) + else + call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) + end if + fieldname(mm) = trim(tmpname) // '_mixnuc1' + fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' + end do + end do + endif + +#endif + +end subroutine ndrop_init + +!=============================================================================== + +subroutine dropmixnuc( & + state, ptend, dtmicro, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + !++ MH_2015/09/07 + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + !-- MH_2015/09/07 + tendnd, & ! Output + !++ MH_2015/04/10 + fn_in, & + from_spcam ) + !-- MH_2015/04/10 + + ! vertical diffusion and nucleation of cloud droplets + ! assume cloud presence controlled by cloud fraction + ! doesn't distinguish between warm, cold clouds + + ! arguments + type(physics_state), target, intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtmicro ! time step for microphysics (s) + + type(physics_buffer_desc), pointer :: pbuf(:) + + ! arguments + real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity + real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction + real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step + real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) + logical, intent(in),optional :: from_spcam ! value insignificant - if variable present, is called from spcam + +!++ MH_2015/09/07 + logical, intent(in) :: hasAerosol(pcols, pver, nmodes) + real(r8), intent(in) :: CProcessModes(pcols,pver) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) + real(r8), intent(in) :: f_c(pcols,pver) + real(r8), intent(in) :: f_aq(pcols,pver) + real(r8), intent(in) :: f_bc(pcols,pver) + real(r8), intent(in) :: f_so4_cond(pcols,pver) + real(r8), intent(in) :: f_soa(pcols,pver) + real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) + real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction + real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity + real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma +!-- MH_2015/09/07 + + ! output arguments + real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) + + !--------------------Local storage------------------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of columns + + real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) + real(r8), pointer :: temp(:,:) ! temperature (K) + real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) + real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) + real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) + real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) + real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) + real(r8), pointer :: zm(:,:) ! geopotential height of level (m) + + real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) + + type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios + type(ptr2d_t), allocatable :: qqcw(:) + real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios + real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios + + + real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 + real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) + real(r8) :: sq2pi + + integer :: i, k, l, m, mm, n + integer :: km1, kp1 + integer :: nnew, nsav, ntemp + integer :: lptr + integer :: nsubmix, nsubmix_bnd + integer, save :: count_submix(100) + integer :: phase ! phase of aerosol + + real(r8) :: arg + real(r8) :: dtinv + real(r8) :: dtmin, tinv, dtt + real(r8) :: lcldn(pcols,pver) + real(r8) :: lcldo(pcols,pver) + + real(r8) :: zs(pver) ! inverse of distance between levels (m) + real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) + real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries + real(r8) :: srcn(pver) ! droplet source rate (/s) + real(r8) :: cs(pcols,pver) ! air density (kg/m3) + real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) + real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) + real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) + + real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) + real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) + real(r8) :: wbar, wmix, wmin, wmax + + real(r8) :: zn(pver) ! g/pdel (m2/g) for layer + real(r8) :: flxconv ! convergence of flux into lowest layer + + real(r8) :: wdiab ! diabatic vertical velocity + real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) + real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) + real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity + real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity + + real(r8) :: dum, dumc + real(r8) :: tmpa + real(r8) :: dact + real(r8) :: fluxntot ! (#/cm2/s) + real(r8) :: dtmix + real(r8) :: alogarg + real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap + + real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) + real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) + real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) + real(r8) :: cldo_tmp, cldn_tmp + real(r8) :: tau_cld_regenerate + real(r8) :: zeroaer(pver) + real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) + + + real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) + real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) + + real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios + real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase +#ifdef OSLO_AERO + !to avoid excessive calls to boundary layer scheme + real(r8), allocatable :: raercol_tracer(:,:,:) + real(r8), allocatable :: raercol_cw_tracer(:,:,:) + real(r8), allocatable :: mact_tracer(:,:) + real(r8), allocatable :: mfullact_tracer(:,:) +#endif + + real(r8) :: na(pcols), va(pcols), hy(pcols) + real(r8), allocatable :: naermod(:) ! (1/m3) + real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) + + real(r8) :: source(pver) + +!++ MH_2015/04/10 + real(r8), allocatable :: fn(:) ! activation fraction for aerosol number + real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) +!-- MH_2015/04/10 + real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass + + real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) + real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) + real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) + ! note: activation fraction fluxes are defined as + ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] + ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] + + + real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output + real(r8), allocatable :: coltend_cw(:,:) ! column tendency + real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat + + !for gas species turbulent mixing + real(r8), pointer :: rgas(:, :, :) + real(r8), allocatable :: rgascol(:, :, :) + real(r8), allocatable :: coltendgas(:) + real(r8) :: zerogas(pver) + character*200 fieldnamegas + + logical :: called_from_spcam + !------------------------------------------------------------------------------- +#ifdef OSLO_AERO + real(r8) :: numberMedianRadius(pcols,pver,nmodes) + real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma + real(r8) :: constituentFraction + !++ MH_2015/04/10 + real(r8) :: volumeCore(pcols,pver,nmodes) + real(r8) :: volumeCoat(pcols,pver,nmodes) + !-- MH_2015/04/10 + integer :: tracerIndex + integer :: cloudTracerIndex + integer :: kcomp + integer :: speciesMap(nmodes) + !++ MH_2015/04/10 +! real(r8) :: fn_tmp(pcols,pver,nmodes) + real(r8), allocatable :: fn_tmp(:), fm_tmp(:) + !-- MH_2015/04/10 + real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) + real(r8) :: componentFraction + real(r8) :: componentFractionOK(pver,nmodes,pcnst) + real(r8) :: sumFraction + logical :: alert + real(r8), dimension(pver, pcnst) :: massBalance + real(r8), dimension(pver, pcnst) :: newMass + real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud + integer :: kCrit, lptr2 + logical :: stopMe + integer :: iDebug=1, lDebug=15 + real(r8) :: mixRatioToMass + real(r8),dimension(pcnst) :: debugSumFraction + real(r8), allocatable :: lnsigman(:) + character(len=2) :: modeString + character(len=20) :: varname +#endif + integer :: numberOfModes +!------------------------------------------------------------------------------- +#undef EXTRATESTS +#undef MASS_BALANCE_CHECK + + sq2pi = sqrt(2._r8*pi) + + lchnk = state%lchnk + ncol = state%ncol + + ncldwtr => state%q(:,:,numliq_idx) + temp => state%t + omega => state%omega + pmid => state%pmid + pint => state%pint + pdel => state%pdel + rpdel => state%rpdel + zm => state%zm + + call pbuf_get_field(pbuf, kvh_idx, kvh) + + ! Create the liquid weighted cloud fractions that were passsed in + ! before. This doesn't seem like the best variable, since the cloud could + ! have liquid condensate, but the part of it that is changing could be the + ! ice portion; however, this is what was done before. + lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) + lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) + + + arg = 1.0_r8 + if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then + write(iulog,*) 'erf(1.0) = ',ERF(arg) + call endrun('dropmixnuc: Error function error') + endif + arg = 0.0_r8 + if (erf(arg) /= 0.0_r8) then + write(iulog,*) 'erf(0.0) = ',erf(arg) + write(iulog,*) 'dropmixnuc: Error function error' + call endrun('dropmixnuc: Error function error') + endif + + dtinv = 1._r8/dtmicro + + allocate( & + nact(pver,ntot_amode), & + mact(pver,ntot_amode), & + raer(ncnst_tot), & + qqcw(ncnst_tot), & + raercol(pver,ncnst_tot,2), & + raercol_cw(pver,ncnst_tot,2), & + coltend(pcols,ncnst_tot), & + coltend_cw(pcols,ncnst_tot), & + naermod(ntot_amode), & + hygro(ntot_amode), & +#ifdef OSLO_AERO + lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) + raercol_tracer(pver,n_aerosol_tracers,2), & + raercol_cw_tracer(pver,n_aerosol_tracers,2), & + mact_tracer(pver,n_aerosol_tracers), & + mfullact_tracer(pver,n_aerosol_tracers), & +#endif + vaerosol(ntot_amode), & + fn(ntot_amode), & + fm(ntot_amode), & + fluxn(ntot_amode), & + fluxm(ntot_amode) ) + + ! Init pointers to mode number and specie mass mixing ratios in + ! intersitial and cloud borne phases. +#ifdef OSLO_AERO + !Need a list of all aerosol species ==> store in raer (mm) + ! or qqcw for cloud-borne aerosols (?) + do m=1,nmodes !All aerosol modes + + !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES + do l = 1, nspec_amode(m) + tracerIndex = getTracerIndex(m,l,.false.) !Index in q + cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer + mm = mam_idx(m,l) !Index in raer/qqcw + raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) + call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) +#ifdef EXTRATESTS +! if(tracerIndex .eq. ldebug)then +! do k=1,pver +! print*,"pointer check",k,m,l,mm,tracerIndex, raer(mm)%fld(idebug,k), state%q(idebug,k,tracerIndex) +! end do +! endf +#endif + enddo + enddo + allocate( & + fn_tmp(ntot_amode), & + fm_tmp(ntot_amode), & + fluxn_tmp(ntot_amode), & + fluxm_tmp(ntot_amode) ) +#else + do m = 1, ntot_amode + mm = mam_idx(m, 0) + call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer(mm)%fld) + call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol + do l = 1, nspec_amode(m) + mm = mam_idx(m, l) + call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer(mm)%fld) + call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol + end do + end do +#endif + + called_from_spcam = (present(from_spcam)) + + if (called_from_spcam) then + rgas => state%q + allocate(rgascol(pver, pcnst, 2)) + allocate(coltendgas(pcols)) + endif + wtke = 0._r8 + + if (prog_modal_aero) then + ! aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) + else + ! no aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop') + end if + +#ifdef OSLO_AERO + !Improve this later by using only cloud points ? + do k = top_lev, pver + do i=1,ncol + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + end do + end do + + !Output this + call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) + do n=1,nmodes + sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) + modeString=" " + write(modeString,"(I2)"),n + if(n .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) + varName = "NCONC"//trim(modeString) + call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) + varName = "VCONC"//trim(modeString) + call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) + varName = "SIGMA"//trim(modeString) + call outfld(varName, sigma(:,:,n), pcols,lchnk) + varName = "HYGRO"//trim(modeString) + call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) + end do + + alert = .FALSE. + do k=top_lev,pver + mm = k - top_lev + 1 + do m=1,nmodes + if(.NOT. alert .and. & + ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then + alert = .TRUE. + lptr = k + print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm + endif + enddo + enddo + + + if(alert)then + print*,"strange stuff here " + stop + + !do m=1,nmodes + ! print*,"numberconc (after alert)", m, modedefs(1)%nnatk(m)*1.e-6_r8, "#/cm3" & + ! ,modedefs(1)%C(m)*1.0e9_r8, "ug/m3" + + ! if(modedefs(1)%nnatk(m) > 1.e-30_r8)then + ! print*, "final weight per particle ",m, modedefs(1)%C(m)/modedefs(1)%nnatk(m) + ! endif + !end do + !stop + endif + +#endif + + ! overall_main_i_loop + do i = 1, ncol + +#ifdef OSLO_AERO + coltend(i,:)=0.0_r8 + coltend_cw(i,:) = 0.0_r8 +#endif + + do k = top_lev, pver-1 + zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) + end do + zs(pver) = zs(pver-1) + + ! load number nucleated into qcld on cloud boundaries + + do k = top_lev, pver + + qcld(k) = ncldwtr(i,k) + qncld(k) = 0._r8 + srcn(k) = 0._r8 + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m + + do m = 1, ntot_amode + nact(k,m) = 0._r8 + mact(k,m) = 0._r8 + end do + + zn(k) = gravit*rpdel(i,k) + + if (k < pver) then + ekd(k) = kvh(i,k+1) + ekd(k) = max(ekd(k), zkmin) + ekd(k) = min(ekd(k), zkmax) + csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) + csbot_cscen(k) = csbot(k)/cs(i,k) + else + ekd(k) = 0._r8 + csbot(k) = cs(i,k) + csbot_cscen(k) = 1.0_r8 + end if + + ! rce-comment - define wtke at layer centers for new-cloud activation + ! and at layer boundaries for old-cloud activation + !++ag + wtke_cen(i,k) = wsub(i,k) + wtke(i,k) = wsub(i,k) + !--ag + wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) + wtke(i,k) = max(wtke(i,k), wmixmin) + + nsource(i,k) = 0._r8 + + end do ! k + + nsav = 1 + nnew = 2 +#ifdef OSLO_AERO + + !get constituent fraction + componentFractionOK(:,:,:) = 0.0_r8 + do k=top_lev, pver + do m = 1,ntot_amode + if(m .le. nbmodes)then + do l = 1, nspec_amode(m) + !calculate fraction of component "l" in mode "m" based on concentrations in clear air + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & + = getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & + ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), getTracerIndex(m,l,.false.) ) + end do + else + do l = 1, nspec_amode(m) + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 + end do + endif + end do + + !Loop over all tracers ==> check that sums to one + !for all tracers which exist in the oslo-modes + do l=1,pcnst + sumFraction = 0.0_r8 + do m=1,ntot_amode + sumFraction = sumFraction + componentFractionOK(k,m,l) + end do + if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% + do m=1,ntot_amode + componentFractionOK(k,m,l) = & + componentFractionOK(k,m,l)/sumFraction + end do + else !negative or zero fraction for this species + !distribute equal fraction to all receiver modes + sumFraction = 0.0_r8 + do m=1,ntot_amode + do lptr=1,getNumberOfTracersInMode(m) + if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then + sumFraction = sumFraction + 1.0_r8 + endif + end do ! tracers in mode + end do ! mode + do m=1,ntot_amode + componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) + end do !modes + endif + end do !tracers + end do !levels + !debug sum fraction for "i" done + + + + debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k + do m = 1, nmodes ! Number of modes + !Get number concentration of this mode + mm =mam_idx(m,0) + do k= top_lev,pver + raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air + !In oslo model, number concentrations are diagnostics, so + !Approximate number concentration in each mode by total + !cloud number concentration scaled by how much is available of + !each mode + raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& + /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) + enddo + + !These are the mass mixing ratios + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !index of tracer (all unique) + raercol(:,mm,nsav) = 0.0_r8 + raercol_cw(:,mm,nsav) = 0.0_r8 + !Several of the fields (raer(mm)%fld point to the same + !field in q. To avoid double counting, we take into + !account the component fraction in the mode + do k=top_lev,pver + if(m .gt. nbmodes) then + componentFraction = 1.0_r8 + else + componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif +#ifdef EXTRATESTS + if(i .eq. iDebug .and. getTracerIndex(m,l,.false.) .eq. lDebug)then + !print*,"componentFraction", i,cnst_name(oslo_cnst_idx(m,l)),componentFraction + print*,"assigning cloud/aerosol", k,m,l,qqcw(mm)%fld(i,k), raer(mm)%fld(i,k) & + ,componentFraction + debugSumFraction(k) = debugSumFraction(k) + componentFraction + endif + if(componentFraction > 1.0_r8)then + print*, "wrong component fraction", componentFraction + stop + call endrun("wrong component fraction") + endif +#endif + !Assign to the components used here i.e. distribute condensate/coagulate to modes + raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction + raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction + enddo ! k (levels) + end do ! l (species) + end do ! m (modes) +#ifdef EXTRATESTS + do k=top_lev,pver + if(i .eq. iDebug .and. (abs(debugSumFraction(k)-1.0_r8).gt.1.e-2_r8) .and. debugSumFraction(k).gt.1.e-6_r8)then + print*, "debugSumFraction", cnst_name(getTracerIndex(m,l,.false.)),i, k, debugSumFraction(k), abs(debugSumFraction(k)-1.0_r8) + componentFraction=0.0_r8 + do m=1,nbmodes + componentFraction = componentFraction + cam(i,k,m) + print*, "MODECONC", m, cam(i,k,m), numberConcentration(i,k,m) + end do + print*, "CS, sumCAM", CProcessModes(i,k), sum(cam(i,k,1:nbmodes)), componentFraction + print*, "q (cond)", state%q(i,k,lDebug)*cs(i,k)!mass in q + print*, "q (aq) " ,state%q(i,k,l_so4_a2)*cs(i,k) + print*, "bulk fractions", f_so4_cond(i,k),f_c(i,k), f_bc(i,k), f_aq(i,k) + !print*, "other levels", debugSumFraction(:) + do m=1,nmodes + do l=1,nspec_amode(m) + if(getTracerIndex(m,l,.false.) == ldebug)then + if(m .gt. nbmodes)then + componentFraction = 1.0_r8 + else + componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif + print*, "nmode, l,k, ", m,l,k , lDebug, componentFraction, cam(i,k,m), f_aqm(i,k,m), f_acm(i,k,m), f_so4_condm(i,k,m) + print*, "fraction2 ", cam(i,k,m), cam(i,k,m)/CProcessModes(i,k)*100.0_r8, " %" + endif + enddo + enddo + call endrun("wrong debugsumfraction") + endif !idebug/ldebug + enddo +#endif + !END OSLO-STUFF, BELOW IS MAM 3 +#else + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol_cw(:,mm,nsav) = 0.0_r8 + raercol(:,mm,nsav) = 0.0_r8 + raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) + raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) + raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) + end do + end do +#endif + + + if (called_from_spcam) then + ! + ! In the MMF model, turbulent mixing for tracer species are turned off. + ! So the turbulent for gas species mixing are added here. + ! (Previously, it had the turbulent mixing for aerosol species) + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) rgascol(:,m,nsav) = rgas(i,:,m) + end do + + endif + + ! droplet nucleation/aerosol activation + + ! tau_cld_regenerate = time scale for regeneration of cloudy air + ! by (horizontal) exchange with clear air + tau_cld_regenerate = 3600.0_r8 * 3.0_r8 + + if (called_from_spcam) then + ! when this is called in the MMF part, no cloud regeneration and decay. + ! set the time scale be very long so that no cloud regeneration. + tau_cld_regenerate = 3600.0_r8 * 24.0_r8 * 365.0_r8 + endif + + + ! k-loop for growing/shrinking cloud calcs ............................. + ! grow_shrink_main_k_loop: & + do k = top_lev, pver + + ! This code was designed for liquid clouds, but the cloudbourne + ! aerosol can be either from liquid or ice clouds. For the ice clouds, + ! we do not do regeneration, but as cloud fraction decreases the + ! aerosols should be returned interstitial. The lack of a liquid cloud + ! should not mean that all of the aerosol is realease. Therefor a + ! section has been added for shrinking ice clouds and checks were added + ! to protect ice cloudbourne aerosols from being released when no + ! liquid cloud is present. + + ! shrinking ice cloud ...................................................... + cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) + cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) + + if (cldn_tmp < cldo_tmp) then + + ! convert activated aerosol to interstitial in decaying cloud + + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + end do + end do + end if + + ! shrinking liquid cloud ...................................................... + ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) + ! and also dissipate the portion of the cloud that will be regenerated + cldo_tmp = lcldo(i,k) + cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) + ! alternate formulation + ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) + + ! fraction is also provided. + if (cldn_tmp < cldo_tmp) then + ! droplet loss in decaying cloud + !++ sungsup + nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv + qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) + !-- sungsup + + ! convert activated aerosol to interstitial in decaying cloud + + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact +#ifdef EXTRATESTS + if(i.eq. iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"decaying cloud", k, dact, cldn_tmp, cldo_tmp + endif +#endif + end do + end do + end if + + ! growing liquid cloud ...................................................... + ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) + ! and also regenerate part of the cloud + cldo_tmp = cldn_tmp + cldn_tmp = lcldn(i,k) + + if (cldn_tmp-cldo_tmp > 0.01_r8) then + + ! rce-comment - use wtke at layer centers for new-cloud activation + wbar = wtke_cen(i,k) + wmix = 0._r8 + wmin = 0._r8 + wmax = 10._r8 + wdiab = 0._r8 + + ! 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) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,k,kcomp) + vaerosol(m) = volumeConcentration(i,k,kcomp) + hygro(m) = hygroscopicity(i,k,kcomp) + lnsigman(m) = lnsigma(i,k,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m +#else + numberOfModes = ntot_amode + phase = 1 ! interstitial + do m = 1, ntot_amode + call loadaer( & + state, pbuf, i, i, k, & + m, cs, phase, na, va, & + hy) + naermod(m) = na(i) + vaerosol(m) = va(i) + hygro(m) = hy(i) + end do +#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 + !-- MH_2015/04/10 + endif + + dumc = (cldn_tmp - cldo_tmp) +#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 + do m = 1, ntot_amode + mm = mam_idx(m,0) +#ifdef OSLO_AERO + if (use_hetfrz_classnuc) then + dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + else + dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + end if +#else + if (use_hetfrz_classnuc) then + dact = dumc*fn_in(i,k,m)*raer(mm)%fld(i,k) ! interstitial only + else + dact = dumc*fn(m)*raer(mm)%fld(i,k) ! interstitial only + end if +#endif + qcld(k) = qcld(k) + dact + nsource(i,k) = nsource(i,k) + dact*dtinv + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + dum = dumc*fm(m) + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) +#ifdef OSLO_AERO + if(m .gt. nbmodes)then + constituentFraction = 1.0_r8 + else + constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) + endif + + dact = dum*raer(mm)%fld(i,k)*constituentFraction +#else + dact = dum*raer(mm)%fld(i,k) ! interstitial only +#endif + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact +#ifdef EXTRATESTS + if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"growing cloud (new/old)", k, raercol_cw(k,mm,nsav), raercol_cw(k,mm,nsav)-dact & + ,raercol(k,mm,nsav),raercol(k,mm,nsav)+dact,dact + endif +#endif + enddo + enddo + endif ! cldn_tmp-cldo_tmp > 0.01_r8 + + enddo ! grow_shrink_main_k_loop + ! end of k-loop for growing/shrinking cloud calcs ...................... + + ! ...................................................................... + ! start of k-loop for calc of old cloud activation tendencies .......... + ! + ! rce-comment + ! changed this part of code to use current cloud fraction (cldn) exclusively + ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 + ! previous code (which used cldo below here) would have no cloud-base activation + ! into layer k. however, activated particles in k mix out to k+1, + ! so they are incorrectly depleted with no replacement + + ! old_cloud_main_k_loop + do k = top_lev, pver + kp1 = min0(k+1, pver) + taumix_internal_pver_inv = 0.0_r8 + + if (lcldn(i,k) > 0.01_r8) then + + wdiab = 0._r8 + wmix = 0._r8 ! single updraft + wbar = wtke(i,k) ! single updraft + if (k == pver) wbar = wtke_cen(i,k) ! single updraft + wmax = 10._r8 + wmin = 0._r8 + + if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then + + ! cloud base + + ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi + ! rce-comments + ! first, should probably have 1/zs(k) here rather than dz(i,k) because + ! the turbulent flux is proportional to ekd(k)*zs(k), + ! while the dz(i,k) is used to get flux divergences + ! and mixing ratio tendency/change + ! second and more importantly, using a single updraft velocity here + ! means having monodisperse turbulent updraft and downdrafts. + ! The sq2pi factor assumes a normal draft spectrum. + ! The fluxn/fluxm from activate must be consistent with the + ! fluxes calculated in explmix. + ekd(k) = wbar/zs(k) + + alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) + wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) + phase = 1 ! interstitial +#ifdef OSLO_AERO + naermod(:) = 0.0_r8 + vaerosol(:) = 0.0_r8 + hygro(:) = 0.0_r8 + lnsigman(:) = log(2.0_r8) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,kp1,kcomp) + vaerosol(m) = volumeConcentration(i,kp1,kcomp) + hygro(m) = hygroscopicity(i,kp1,kcomp) + lnsigman(m) = lnsigma(i,kp1,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m +#else + numberOfModes = ntot_amode + + do m = 1, ntot_amode + ! rce-comment - use kp1 here as old-cloud activation involves + ! aerosol from layer below + call loadaer( & + state, pbuf, i, i, kp1, & + m, cs, phase, na, va, & + hy) + naermod(m) = na(i) + vaerosol(m) = va(i) + hygro(m) = hy(i) + 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 + !-- MH_2015/04/10 + endif + + !Difference in cloud fraction this layer and above! + !we are here because there are more clouds above, and some + !aerosols go into that layer! ==> calculate additional cloud fraction + if (k < pver) then + dumc = lcldn(i,k) - lcldn(i,kp1) + else + dumc = lcldn(i,k) + 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 + + fluxntot = 0.0_r8 + + ! rce-comment 1 + ! flux of activated mass into layer k (in kg/m2/s) + ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) + ! source of activated mass (in kg/kg/s) = flux divergence + ! = actmassflux/(cs(i,k)*dz(i,k)) + ! so need factor of csbot_cscen = csbot(k)/cs(i,k) + ! dum=1./(dz(i,k)) + dum=csbot_cscen(k)/(dz(i,k)) + + ! rce-comment 2 + ! code for k=pver was changed to use the following conceptual model + ! in k=pver, there can be no cloud-base activation unless one considers + ! a scenario such as the layer being partially cloudy, + ! with clear air at bottom and cloudy air at top + ! assume this scenario, and that the clear/cloudy portions mix with + ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) + ! in the absence of other sources/sinks, qact (the activated particle + ! mixratio) attains a steady state value given by + ! qact_ss = fcloud*fact*qtot + ! where fcloud is cloud fraction, fact is activation fraction, + ! qtot=qact+qint, qint is interstitial particle mixratio + ! the activation rate (from mixing within the layer) can now be + ! written as + ! d(qact)/dt = (qact_ss - qact)/taumix_internal + ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) + ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact + ! also, d(qact)/dt can be negative. in the code below + ! it is forced to be >= 0 + ! + ! steve -- + ! you will likely want to change this. i did not really understand + ! what was previously being done in k=pver + ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the + ! droplet deposition velocity which is quite small + ! in the cam3_5_37 version, wtke is done differently and is much + ! larger in k=pver, so the activation is stronger there + ! + if (k == pver) then + taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) + end if + + do m = 1, ntot_amode + mm = mam_idx(m,0) + fluxn(m) = fluxn(m)*dumc + fluxm(m) = fluxm(m)*dumc + nact(k,m) = nact(k,m) + fluxn(m)*dum + mact(k,m) = mact(k,m) + fluxm(m)*dum + if (k < pver) then + ! note that kp1 is used here + fluxntot = fluxntot & + + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) + else + tmpa = raercol(kp1,mm,nsav)*fluxn(m) & + + raercol_cw(kp1,mm,nsav)*(fluxn(m) & + - taumix_internal_pver_inv*dz(i,k)) + fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) + end if + end do + srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) + nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) +#ifdef EXTRATESTS + if(fluxntot/(cs(i,k)*dz(i,k)) > 0.0_r8 )then + print*,"activated/available(from below)",i,k,m,fluxntot/(cs(i,k)*dz(i,k)) + endif +#endif + endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) + + else ! i.e: cldn(i,k) < 0.01_r8 + + ! no liquid cloud + + nsource(i,k) = nsource(i,k) - qcld(k)*dtinv + qcld(k) = 0.0_r8 + + if (cldn(i,k) < 0.01_r8) then + ! no ice cloud either + + ! convert activated aerosol to interstitial in decaying cloud + + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) +#ifdef EXTRATESTS + if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"no cloud", k, raercol(k,mm,nsav) , raercol_cw(k,mm,nsav) + endif +#endif + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + end do + end do + end if + end if + + end do ! old_cloud_main_k_loop + + ! switch nsav, nnew so that nnew is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + + ! load new droplets in layers above, below clouds + + dtmin = dtmicro + ekk(top_lev-1) = 0.0_r8 + ekk(pver) = 0.0_r8 + do k = top_lev, pver-1 + ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface + ! want ekk(k) = ekd(k) * (density at k/k+1 interface) + ! so use pint(i,k+1) as pint is 1:pverp + ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) + ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) + ekk(k) = ekd(k)*csbot(k) + end do + + do k = top_lev, pver + km1 = max0(k-1, top_lev) + ekkp(k) = zn(k)*ekk(k)*zs(k) + ekkm(k) = zn(k)*ekk(k-1)*zs(km1) + tinv = ekkp(k) + ekkm(k) + + ! rce-comment -- tinv is the sum of all first-order-loss-rates + ! for the layer. for most layers, the activation loss rate + ! (for interstitial particles) is accounted for by the loss by + ! turb-transfer to the layer above. + ! k=pver is special, and the loss rate for activation within + ! the layer must be added to tinv. if not, the time step + ! can be too big, and explmix can produce negative values. + ! the negative values are reset to zero, resulting in an + ! artificial source. + if (k == pver) tinv = tinv + taumix_internal_pver_inv + + if (tinv .gt. 1.e-6_r8) then + dtt = 1._r8/tinv + dtmin = min(dtmin, dtt) + end if + end do + + dtmix = 0.9_r8*dtmin + nsubmix = dtmicro/dtmix + 1 + if (nsubmix > 100) then + nsubmix_bnd = 100 + else + nsubmix_bnd = nsubmix + end if + count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 + dtmix = dtmicro/nsubmix + + do k = top_lev, pver + kp1 = min(k+1, pver) + km1 = max(k-1, top_lev) + ! maximum overlap assumption + if (cldn(i,kp1) > 1.e-10_r8) then + overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) + else + overlapp(k) = 1._r8 + end if + if (cldn(i,km1) > 1.e-10_r8) then + overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) + else + overlapm(k) = 1._r8 + end if + end do + + + ! rce-comment + ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) + ! should not exceed the rate of transfer of unactivated particles + ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) + ! however it might if things are not "just right" in subr activate + ! the following is a safety measure to avoid negatives in explmix + do k = top_lev, pver-1 + do m = 1, ntot_amode + nact(k,m) = min( nact(k,m), ekkp(k) ) + mact(k,m) = min( mact(k,m), ekkp(k) ) + end do + end do + +!Don't need the mixing per mode in OSLO_AERO ==> only per tracer +!Note that nsav/nnew is switched above, so operate on nnew here +!nnew is the updated aerosol +#ifdef OSLO_AERO + raercol_tracer(:,:,:) = 0.0_r8 + raercol_cw_tracer(:,:,:) = 0.0_r8 + mact_tracer(:,:) = 0.0_r8 + mfullact_tracer(:,:) = 0.0_r8 + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about + lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers + mm = mam_idx(m,l) + raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & + + raercol(:,mm,nnew) + + raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& + + raercol_cw(:,mm,nnew) + + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) + mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) + +#ifdef EXTRATESTS + if(lptr.eq.lDebug .and. i.eq.iDebug)then + do k=pver,top_lev,-1 + print*, "assigning to tracer space",lptr, raercol(k,mm,nnew) & + , raercol_tracer(k,lptr2,nnew) & + , raercol_cw(k,mm,nnew) & + , raercol_cw_tracer(k,lptr2,nnew) + end do + end if +#endif + end do !l + end do !m + + do lptr2=1,n_aerosol_tracers + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & + /(mfullact_tracer(:,lptr2) + smallNumber) + end do +#endif OSLO_AERO + + ! old_cloud_nsubmix_loop + do n = 1, nsubmix + qncld(:) = qcld(:) + ! switch nsav, nnew so that nsav is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + srcn(:) = 0.0_r8 + + !First mix cloud droplet number concentration + do m = 1, ntot_amode + mm = mam_idx(m,0) + + ! update droplet source + ! rce-comment- activation source in layer k involves particles from k+1 + ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) + srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + + ! rce-comment- new formulation for k=pver + ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) + end do + + !mixing of cloud droplets + call explmix( & + qcld, srcn, ekkp, ekkm, overlapp, & + overlapm, qncld, zero, zero, pver, & + dtmix, .false.) + +#ifdef OSLO_AERO + !Mix number concentrations consistently!! + do m = 1, ntot_amode + mm = mam_idx(m,0) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment - new formulation for k=pver + ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + end do +#endif + +#ifndef OSLO_AERO + ! rce-comment + ! the interstitial particle mixratio is different in clear/cloudy portions + ! of a layer, and generally higher in the clear portion. (we have/had + ! a method for diagnosing the the clear/cloudy mixratios.) the activation + ! source terms involve clear air (from below) moving into cloudy air (above). + ! in theory, the clear-portion mixratio should be used when calculating + ! source terms + do m = 1, ntot_amode + mm = mam_idx(m,0) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment - new formulation for k=pver + ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= mact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = mact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment- new formulation for k=pver + ! source( pver )= mact( pver ,m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*mact(pver,m) & + + raercol_cw(pver,mm,nsav)*(mact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + + end do + end do +#endif + if (called_from_spcam) then + ! + ! turbulent mixing for gas species . + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + flxconv = 0.0_r8 + zerogas(:) = 0.0_r8 + call explmix(rgascol(1,m,nnew),zerogas,ekkp,ekkm,overlapp,overlapm, & + rgascol(1,m,nsav),zero, flxconv, pver,dtmix,& + .true., zerogas) + end if + end do + endif + +#ifdef OSLO_AERO + do lptr2=1,n_aerosol_tracers + source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & + *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) + + tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & + + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) + + source(pver) = max(0.0_r8, tmpa) + flxconv = 0.0_r8 + + call explmix( & + raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) + +#ifdef EXTRATESTS + lptr = aerosolTracerList(lptr2) + if(i.eq.iDebug .and. lptr.eq.lDebug)then + print*, "bugeds for ",trim(cnst_name(lptr)), n, nsubmix + do k=pver,1,-1 + print*, "source (aerosol/cloud) ",k, raercol_cw_tracer(k,lptr2,nnew),raercol_cw_tracer(k,lptr2,nsav) & + , raercol_tracer(k,lptr2,nnew),raercol_tracer(k,lptr2,nsav),source(k) + end do + if(m .le. nbmodes)then + print*, " ", mm, lptr, componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif + endif +#endif + end do !Number of aerosol tracers + end do ! old_cloud_nsubmix_loop + + !Set back to the original framework + !Could probably continue in tracer-space from here + !but return back to mixture for easier use of std. NCAR code + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l=1,nspec_amode(m) + mm=mam_idx(m,l) + lptr = getTracerIndex(m,l,.FALSE.) + lptr2 = inverseAerosolTracerList(lptr) + !All the tracer-space contains sum of all + !modes ==> put in first available component + !and zero in others. + if(.not.tendencyCounted(lptr))then + raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) + raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) + tendencyCounted(lptr) = .TRUE. + else + raercol(:,mm,nnew) = 0.0_r8 + raercol_cw(:,mm,nnew) = 0.0_r8 + end if + end do + end do +#endif + ! evaporate particles again if no cloud + + do k = top_lev, pver + if (cldn(i,k) == 0._r8) then + ! no ice or liquid cloud + qcld(k)=0._r8 + + ! convert activated aerosol to interstitial in decaying cloud + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + end do + end do + end if + end do + + ! droplet number + + ndropcol(i) = 0._r8 + + !Initialize tendnd to zero in all layers since values are set in only top_lev,pver + !Without this the layers above top_lev would be un-initialized + tendnd(i,:) = 0.0_r8 + + do k = top_lev, pver + ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) + tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv + !print*, "tendnd",i,k, "new /old/tend", qcld(k), ncldwtr(i,k), tendnd(i,k) + ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) + end do + ndropcol(i) = ndropcol(i)/gravit + +#ifdef EXTRATESTS + print*, "tendnd (#/kg/sec)", minval(tendnd(i,:)), maxval(tendnd(i,:)) +#endif + + if (prog_modal_aero) then + +#ifdef OSLO_AERO + +#ifdef MASS_BALANCE_CHECK + !test for correct transfer between in-cloud / no-cloud.. + newCloud(:,:) = 0.0_r8 + oldCloud(:,:) = 0.0_r8 + newAerosol(:,:) = 0.0_r8 + oldAerosol(:,:) = 0.0_r8 + deltaCloud(:,:) = 0.0_r8 + !Check mass balances #2 (all new cloud droplet species are taken from aerosols or from layer below + do k=pver,1,-1 + mixRatioToMass = cs(i,k)*dz(i,k) + !First sum up cloud tracer in this layer + tendencyCounted(:)=.FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) !lptr occurs several times + newCloud(k, lptr) = newCloud(k, lptr) + raercol_cw(k, mm, nnew)*mixRatioToMass + newAerosol(k, lptr) = newAerosol(k, lptr) + raercol(k,mm,nnew)*mixRatioToMass + if(.NOT. tendencyCounted(lptr))then + oldAerosol(k, lptr) = raer(mm)%fld(i,k)*mixRatioToMass + oldCloud(k, lptr) = qqcw(mm)%fld(i,k)*mixRatioToMass + tendencyCounted(lptr)=.TRUE. + endif + enddo + enddo + enddo! k + + k = pver + !Check imbalance in bottom layer + + !Any change in cloud species is either from aerosol concentration or from change in layer below + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + + !This is the mass which must go to layer above! + deltaCloud(k,lptr) = (oldAerosol(k,lptr) - newAerosol(k,lptr)) &!used to create cloud species + -(newCloud(k,lptr) - oldCloud(k,lptr)) !created cloud species + enddo + enddo + + !if "deltaCloud" is positive in layer below it means that some aerosol species were sent up + + !Move upwards + do k=pver-1,1,-1 + kp1 = k + 1 + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + deltaCloud(k,lptr) = (oldAerosol(k,lptr)-newAerosol(k,lptr)) & !used to create cloud species + - (newCloud(k,lptr) - oldCloud(k,lptr)) & !created cloud species + - 0.0_r8 ! deltaCloud(kp1,lptr) !species received from below + enddo + enddo + enddo !layers + + stopMe = .FALSE. + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr= getTracerIndex(m,l,.false.) + if(abs(sum(deltaCloud(:,lptr))) > 1.e-8_r8 .and. (.NOT. tendencyCounted(lptr)))then + stopMe = .TRUE. + lptr2 = lptr + print*, "wrong mass budget",i,lptr,cnst_name(lptr), sum(deltaCloud(:,lptr)) + endif + tendencyCounted(lptr) = .TRUE. + enddo + enddo + if(stopMe)then + print*,"error in species : ", cnst_name(lptr2) + do k=pver,1,-1 + print*, "budgets new/old ",k, newCloud(k,lptr2),oldCloud(k,lptr2),newaerosol(k,lptr2),oldAerosol(k,lptr2), deltaCloud(k,lptr2) + enddo + call endrun ("wrong mass budget in column") + endif +#endif +#endif + raertend = 0._r8 + qqcwtend = 0._r8 + + +#ifndef OSLO_AERO + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + + mm = mam_idx(m,l) + lptr = mam_cnst_idx(m,l) + + raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv + qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv + + coltend(i,mm) = sum( pdel(i,:)*raertend )/gravit + coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit + + ptend%q(i,:,lptr) = 0.0_r8 + ptend%q(i,top_lev:pver,lptr) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol + qqcw(mm)%fld(i,:) = 0.0_r8 + qqcw(mm)%fld(i,top_lev:pver) = raercol_cw(top_lev:pver,mm,nnew) ! update cloud-borne aerosol + end do + end do +#else + !OSLO AEROSOLS ... + + coltend_cw(i,:)=0.0_r8 + coltend(i,:) = 0.0_r8 + + !Need to initialize first because process modes arrive several times + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l = 1,getNumberOfTracersInMode(m) + lptr = getTracerIndex(m,l,.false.) + mm = mam_idx(m,l) + + !column tendencies for output + if(.NOT. tendencyCounted(lptr))then + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, + - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total + tendencyCounted(lptr) = .TRUE. + else !Already subtracted total old value, just add new + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted + end if + + ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies + qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones + end do ! Tracers + end do ! Modes + + !First, sum up all the tracer mass concentrations + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays + lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) + + !This is a bit tricky since in our scheme the tracers can arrive several times + !the same tracer can exist in several modes, e.g. condensate!! + !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers + + !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes + + !Tendency at this point is the sum (original value subtracted below) + ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) + !for cloud water concentrations, we don't get tendency , only new concentration + qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) + + end do + end do + + !Need this check due to some tracers (e.g. condensate) several times + tendencyCounted(:) = .FALSE. + + ! Recalculating cloud-borne aerosol number mixing ratios + do m=1,ntot_amode + + !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies + do l= 1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr)) then + ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv + coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency + tendencyCounted(lptr) = .TRUE. + endif + end do !species + end do !modes +#endif + +#ifdef MASS_BALANCE_CHECK + !Check mass balances (all removed should be in tendencies) + massBalance(:,:) = 0.0_r8 + newMass(:,:) = 0.0_r8 + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) !unique index, for example sulfate condendsate in "x mode" or sulf cond in "y mode" + lptr = getTracerIndex(m,l,.false.) + !add up all new values for this tracer + newMass(top_lev:pver,lptr) = newMass(top_lev:pver,lptr) + raercol(top_lev:pver, mm,nnew) + enddo + enddo + tendencyCounted(:)=.FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr))then + massBalance(top_lev:pver, lptr) = newMass(top_lev:pver,lptr) & + - raer(mm)%fld(i,top_lev:pver) & !previous value + - ptend%q(i,top_lev:pver,lptr)/dtinv !added during time step + tendencyCounted(lptr) = .TRUE. + endif + enddo + enddo + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + !Check for large deviation in mass balance for this tracer + if(.NOT. tendencyCounted(lptr) .and. & + (maxval(massBalance(:,lptr)) > 1.e-30_r8 .or. minval(massBalance(:,lptr)) < -1.0e-30_r8))then + tendencyCounted(lptr) = .TRUE. + print*, "massBalance error", i, lptr, maxVal(massBalance(:,lptr)), minVal(massBalance(:,lptr)) + if(maxVal(massBalance(:,lptr)) > 1.e-30_r8)then + kCrit = maxLoc(massBalance(:,lptr),1) + else + kCrit = minLoc(massBalance(:,lptr),1) + endif + print*, "massBalance error loc", massBalance(kCrit, lptr), newMass(kCrit,lptr), raer(mm)%fld(i,kCrit) + !If mass balance error is larger than 1.e-10 times new or original value ==> stop + if(abs(massBalance(kCrit,lptr)) .gt. 1.e-10_r8*raer(mm)%fld(i,kCrit) & + .and. abs(massBalance(kCrit,lptr)).gt.1.e-10_r8*newMass(kCrit,lptr) )then + stop + endif + endif + enddo + enddo +#endif + + + end if !prog_modal_aero + + if (called_from_spcam) then + ! + ! Gas tendency + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + ptend%lq(m) = .true. + ptend%q(i, :, m) = (rgascol(:,m,nnew)-rgas(i,:,m)) * dtinv + end if + end do + endif + + end do ! overall_main_i_loop + +#ifdef EXTRATESTS + !check reasonable values for ncldwtr! + do k=top_lev,pver + if(maxval(ncldwtr(:ncol,k)) .gt. 1.e20_r8)then + print*, "stopping (after dropmixnuc) wrong ncldwtr", maxloc(ncldwtr(:ncol,k)) + do i=1,ncol + print*, "ncldwtr",i,k,ncldwtr(i,k) + enddo + call endrun("wrong ncldwtr (end of dropmixnuc)") + end if + end do !loop on layers +#endif + + ! end of main loop over i/longitude .................................... + + call outfld('NDROPCOL', ndropcol, pcols, lchnk) + call outfld('NDROPSRC', nsource, pcols, lchnk) + call outfld('NDROPMIX', ndropmix, pcols, lchnk) + call outfld('WTKE ', wtke, pcols, lchnk) + +#ifndef OSLO_AERO + !fxm: Make this work with the oslo aerosols also! + call ccncalc(state, pbuf, cs, ccn) +#else + if (history_aerosol) then + call ccncalc_oslo(state & + , pbuf & + , cs & +!+tht + , hasAerosol & +!-tht + , numberConcentration & + , volumeConcentration & + , hygroscopicity & + , lnSigma & + , ccn ) + end if +#endif + if(history_aerosol) then + do l = 1, psat + call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + enddo + end if +#ifndef OSLO_AERO + ! do column tendencies + if (prog_modal_aero) then + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + mm = mam_idx(m,l) + call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) + end do + end do + end if +#endif + + if(called_from_spcam) then + ! + ! output column-integrated Gas tendency (this should be zero) + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + do i=1, ncol + coltendgas(i) = sum( pdel(i,:)*ptend%q(i,:,m) )/gravit + end do + fieldnamegas = trim(cnst_name(m)) // '_mixnuc1sp' + call outfld( trim(fieldnamegas), coltendgas, pcols, lchnk) + end if + end do + deallocate(rgascol, coltendgas) + end if + +#ifdef OSLO_AERO + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr))then + call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) + tendencyCounted(lptr)=.TRUE. + endif + end do + end do +#endif + + deallocate( & + nact, & + mact, & + raer, & + qqcw, & + raercol, & + raercol_cw, & + coltend, & + coltend_cw, & + naermod, & + hygro, & +#ifdef OSLO_AERO + lnsigman, & !Variable std. dev (CAM-Oslo) +#endif + vaerosol, & + fn, & + fm, & + fluxn, & + fluxm ) + +#ifdef OSLO_AERO + deallocate (fluxm_tmp) + deallocate (fluxn_tmp) + deallocate (fm_tmp) + deallocate (fn_tmp) + deallocate(raercol_tracer) + deallocate(raercol_cw_tracer) + deallocate(mact_tracer) + deallocate(mfullact_tracer) +#endif + + +end subroutine dropmixnuc + +!=============================================================================== + +subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & + qold, surfrate, flxconv, pver, dt, is_unact, qactold ) + + ! explicit integration of droplet/aerosol mixing + ! with source due to activation/nucleation + + + integer, intent(in) :: pver ! number of levels + real(r8), intent(out) :: q(pver) ! mixing ratio to be updated + real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step + real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) + real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! below layer k (k,k+1 interface) + real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! above layer k (k,k+1 interface) + real(r8), intent(in) :: overlapp(pver) ! cloud overlap below + real(r8), intent(in) :: overlapm(pver) ! cloud overlap above + real(r8), intent(in) :: surfrate ! surface exchange rate (/s) + real(r8), intent(in) :: flxconv ! convergence of flux from surface + real(r8), intent(in) :: dt ! time step (s) + logical, intent(in) :: is_unact ! true if this is an unactivated species + real(r8), intent(in),optional :: qactold(pver) + ! mixing ratio of ACTIVATED species from previous step + ! *** this should only be present + ! if the current species is unactivated number/sfc/mass + + integer k,kp1,km1 + + if ( is_unact ) then + ! the qactold*(1-overlap) terms are resuspension of activated material + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & + qactold(kp1)*(1.0_r8-overlapp(k))) & + + ekkm(k)*(qold(km1) - qold(k) + & + qactold(km1)*(1.0_r8-overlapm(k))) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do + + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + ! endif + else + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & + ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + + end if + +end subroutine explmix + +!=============================================================================== + +subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + na, nmode, volume, hygro, & + fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) + + ! calculates number, surface, and mass fraction of aerosols activated as CCN + ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud + ! assumes an internal mixture within each of up to nmode multiple aerosol modes + ! a gaussiam spectrum of updrafts can be treated. + + ! mks units + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + + ! input + + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8), intent(in) :: tair ! air temperature (K) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) + integer, intent(in) :: nmode ! number of aerosol modes + real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), intent(in), optional :: lnsigman(:) + + ! output + + real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + ! rce-comment + ! used for consistency check -- this should match (ekd(k)*zs(k)) + ! also, fluxm/flux_fullact gives fraction of aerosol mass flux + ! that is activated + + ! local + + integer, parameter:: nx=200 + integer iquasisect_option, isectional + real(r8) integ,integf + real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) + real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces + real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces + real(r8) tmass ! total aerosol mass concentration (g/cm3) + real(r8) sign(nmode) ! geometric standard deviation of size distribution + real(r8) rm ! number mode radius of aerosol at max supersat (cm) + real(r8) pres ! pressure (Pa) + real(r8) path ! mean free path (m) + real(r8) diff ! diffusivity (m2/s) + real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) + real(r8) diff0,conduct0 + real(r8) es ! saturation vapor pressure + real(r8) qs ! water vapor saturation mixing ratio + real(r8) dqsdt ! change in qs with temperature + real(r8) dqsdp ! change in qs with pressure + real(r8) g ! thermodynamic function (m2/s) + real(r8) zeta(nmode), eta(nmode) + real(r8) lnsmax ! ln(smax) + real(r8) alpha + real(r8) gamma + real(r8) beta + real(r8) sqrtg + real(r8) :: amcube(nmode) ! cube of dry mode radius (m) + !++alfgr (ununsed) real(r8) :: smcrit(nmode) ! critical supersatuation for activation + real(r8) :: lnsm(nmode) ! ln(smcrit) + real(r8) smc(nmode) ! critical supersaturation for number mode radius + real(r8) sumflx_fullact + real(r8) sumflxn(nmode) + real(r8) sumflxm(nmode) + real(r8) sumfn(nmode) + real(r8) sumfm(nmode) + real(r8) fnold(nmode) ! number fraction activated + real(r8) fmold(nmode) ! mass fraction activated + real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) + real(r8), target :: f1_var(nmode), f2_var(nmode) + real(r8) wold,gold + real(r8) alogam + real(r8) rlo,rhi,xint1,xint2,xint3,xint4 + real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb + real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar + real(r8) alw,sqrtalw + real(r8) smax + real(r8) x,arg + real(r8) xmincoeff,xcut,volcut,surfcut + real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf + real(r8) etafactor1,etafactor2(nmode),etafactor2max + real(r8) grow + character(len=*), parameter :: subname='activate_modal' + integer m,n + ! numerical integration parameters + real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 + + real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) + + integer ndist(nx) ! accumulates frequency distribution of integration bins required + data ndist/nx*0/ + save ndist + + fn(:)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact=0._r8 + + if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return + + if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return + + pres=rair*rhoair*tair + diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 + conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + call qsat(tair, pres, es, qs) + dqsdt=latvap/(rh2o*tair*tair)*qs + alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) + gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) + etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. + + grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & + + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) + sqrtg = sqrt(grow) + beta = 2._r8*pi*rhoh2o*grow*gamma + + do m=1,nmode + + if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then + ! number mode radius (m) + ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) +#ifdef OSLO_AERO + if(present(lnsigman))then + 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 + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + else + call endrun("Problem with variable std. dev") + endif +#else + !Std cam + amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig(m)*na(m))) ! only if variable size dist +#endif + ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 + ! should depend on mean radius of mode to account for gas kinetic effects + ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 + ! for approriate size to use for effective diffusivity. + etafactor2(m)=1._r8/(na(m)*beta*sqrtg) + if(hygro(m).gt.1.e-10_r8)then + smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist + else + smc(m)=100._r8 + endif + ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) + else + smc(m)=1._r8 + etafactor2(m)=etafactor2max ! this should make eta big if na is very small. + endif + lnsm(m)=log(smc(m)) ! only if variable size dist + ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & + ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) + enddo + + if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts + + wmax=min(wmaxf,wbar+sds*sigw) + wmin=max(wminf,-wdiab) + wmin=max(wmin,wbar-sds*sigw) + w=wmin + dwmax=eps*sigw + dw=dwmax + dfmax=0.2_r8 + dfmin=0.1_r8 + if (wmax <= w) return + do m=1,nmode + sumflxn(m)=0._r8 + sumfn(m)=0._r8 + fnold(m)=0._r8 + sumflxm(m)=0._r8 + sumfm(m)=0._r8 + fmold(m)=0._r8 + enddo + sumflx_fullact=0._r8 + + fold=0._r8 + wold=0._r8 + gold=0._r8 + + dwmin = min( dwmax, 0.01_r8 ) + do n = 1, nx + +100 wnuc=w+wdiab + ! write(iulog,*)'wnuc=',wnuc + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + enddo + + call maxsat(zeta,eta,nmode,smc,smax & +#ifdef OSLO_AERO + ,f1_var, f2_var & +#endif + ) + ! write(iulog,*)'w,smax=',w,smax + + lnsmax=log(smax) + +#ifdef OSLO_AERO + x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) +#else + x=twothird*(lnsm(nmode)-lnsmax)/(sq2*alogsig(nmode)) +#endif + fnew=0.5_r8*(1._r8-erf(x)) + + + dwnew = dw + if(fnew-fold.gt.dfmax.and.n.gt.1)then + ! reduce updraft increment for greater accuracy in integration + if (dw .gt. 1.01_r8*dwmin) then + dw=0.7_r8*dw + dw=max(dw,dwmin) + w=wold+dw + go to 100 + else + dwnew = dwmin + endif + endif + + if(fnew-fold.lt.dfmin)then + ! increase updraft increment to accelerate integration + dwnew=min(1.5_r8*dw,dwmax) + endif + fold=fnew + + z=(w-wbar)/(sigw*sq2) + g=exp(-z*z) + fnmin=1._r8 + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 + + do m=1,nmode + ! modal +#ifdef OSLO_AERO + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) +#else + x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) +#endif + fn(m)=0.5_r8*(1._r8-erf(x)) + fnmin=min(fn(m),fnmin) + ! integration is second order accurate + ! assumes linear variation of f*g with w + fnbar=(fn(m)*g+fnold(m)*gold) +#ifdef OSLO_AERO + arg=x-1.5_r8*sq2*lnsigman(m) +#else + arg=x-1.5_r8*sq2*alogsig(m) +#endif + fm(m)=0.5_r8*(1._r8-erf(arg)) + fmbar=(fm(m)*g+fmold(m)*gold) + wb=(w+wold) + if(w.gt.0._r8)then + sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & + +(fn(m)*g*w+fnold(m)*gold*wold))*dw + sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & + +(fm(m)*g*w+fmold(m)*gold*wold))*dw + endif + sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw + ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw + fnold(m)=fn(m) + sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw + fmold(m)=fm(m) + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact & + + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw + ! sumg=sumg+0.5_r8*(g+gold)*dw + gold=g + wold=w + dw=dwnew + if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit + w=w+dw + if (n == nx) then + write(iulog,*)'do loop is too short in activate' + write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw + write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab + write(iulog,*)'wnuc=',wnuc + write(iulog,*)'na=',(na(m),m=1,nmode) + write(iulog,*)'fn=',(fn(m),m=1,nmode) + ! dump all subr parameters to allow testing with standalone code + ! (build a driver that will read input and call activate) + write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' + write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode + write(iulog,*)'na=',na + write(iulog,*)'volume=', (volume(m),m=1,nmode) + write(iulog,*)'hydro=' + write(iulog,*) hygro + call endrun(subname) + end if + + enddo + + ndist(n)=ndist(n)+1 + if(w.lt.wmaxf)then + + ! contribution from all updrafts stronger than wmax + ! assuming constant f (close to fmax) + wnuc=w+wdiab + + z1=(w-wbar)/(sigw*sq2) + z2=(wmaxf-wbar)/(sigw*sq2) + g=exp(-z1*z1) + integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) + ! consider only upward flow into cloud base when estimating flux + wf1=max(w,zero) + zf1=(wf1-wbar)/(sigw*sq2) + gf1=exp(-zf1*zf1) + wf2=max(wmaxf,zero) + zf2=(wf2-wbar)/(sigw*sq2) + gf2=exp(-zf2*zf2) + gf=(gf1-gf2) + integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf + + do m=1,nmode + sumflxn(m)=sumflxn(m)+integf*fn(m) + sumfn(m)=sumfn(m)+fn(m)*integ + sumflxm(m)=sumflxm(m)+integf*fm(m) + sumfm(m)=sumfm(m)+fm(m)*integ + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact + integf + ! sumg=sumg+integ + endif + + + do m=1,nmode + fn(m)=sumfn(m)/(sq2*sqpi*sigw) + ! fn(m)=sumfn(m)/(sumg) + if(fn(m).gt.1.01_r8)then + write(iulog,*)'fn=',fn(m),' > 1 in activate' + write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) + write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw + call endrun('activate') + endif + fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) + fm(m)=sumfm(m)/(sq2*sqpi*sigw) + ! fm(m)=sumfm(m)/(sumg) + if(fm(m).gt.1.01_r8)then + write(iulog,*)'fm=',fm(m),' > 1 in activate' + endif + fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) + enddo + ! same form as fluxm + flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) + + else + + ! single updraft + wnuc=wbar+wdiab + + if(wnuc.gt.0._r8)then + + w=wbar + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg +#ifdef OSLO_AERO + if(present(lnsigman))then + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + else + call endrun("Problem with variable std. dev single updraft") + endif +#endif + enddo + + call maxsat(zeta,eta,nmode,smc,smax & +#ifdef OSLO_AERO + ,f1_var, f2_var & +#endif + ) + + lnsmax=log(smax) + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 + + + do m=1,nmode +#ifdef OSLO_AERO + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) +#else + x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) +#endif + fn(m)=0.5_r8*(1._r8-erf(x)) +#ifdef OSLO_AERO + arg=x-1.5_r8*sq2*lnsigman(m) +#else + arg=x-1.5_r8*sq2*alogsig(m) +#endif + fm(m)=0.5_r8*(1._r8-erf(arg)) + if(wbar.gt.0._r8)then + fluxn(m)=fn(m)*w + fluxm(m)=fm(m)*w + endif + enddo + flux_fullact = w + endif + + endif + +end subroutine activate_modal + +!=============================================================================== + +subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) + + ! calculates maximum supersaturation for multiple + ! competing aerosol modes. + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + integer, intent(in) :: nmode ! number of modes + real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + real(r8), intent(in) :: zeta(nmode) + real(r8), intent(in) :: eta(nmode) + real(r8), intent(in), optional, target :: f1_in(:) + real(r8), intent(in), optional, target :: f2_in(:) + + real(r8), intent(out) :: smax ! maximum supersaturation + integer :: m ! mode index + real(r8) :: sum, g1, g2, g1sqrt, g2sqrt + real(r8), pointer :: f1_used(:), f2_used(:) + +#ifdef OSLO_AERO + f1_used => f1_in + f2_used => f2_in +#else + f1_used => f1 + f2_used => f2 +#endif + + + do m=1,nmode + if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then + ! weak forcing. essentially none activated + smax=1.e-20_r8 + else + ! significant activation of this mode. calc activation all modes. + exit + endif + ! No significant activation in any mode. Do nothing. + if (m == nmode) return + + enddo + + sum=0.0_r8 + do m=1,nmode + if(eta(m).gt.1.e-20_r8)then + g1=zeta(m)/eta(m) + g1sqrt=sqrt(g1) + g1=g1sqrt*g1 + g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) + g2sqrt=sqrt(g2) + g2=g2sqrt*g2 + sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) + else + sum=1.e20_r8 + endif + enddo + + smax=1._r8/sqrt(sum) + +end subroutine maxsat + +!=============================================================================== + +#ifndef OSLO_AERO +subroutine ccncalc(state, pbuf, cs, ccn) + + ! calculates number concentration of aerosols activated as CCN at + ! supersaturation supersat. + ! assumes an internal mixture of a multiple externally-mixed aerosol modes + ! cgs units + + ! Ghan et al., Atmos. Res., 1993, 198-221. + + ! arguments + + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + + real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) + real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) + + ! local + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8), pointer :: tair(:,:) ! air temperature (K) + + real(r8) naerosol(pcols) ! interstit+activated aerosol number conc (/m3) + real(r8) vaerosol(pcols) ! interstit+activated aerosol volume conc (m3/m3) + + real(r8) amcube(pcols) + real(r8) super(psat) ! supersaturation + real(r8), allocatable :: amcubecoef(:) + real(r8), allocatable :: argfactor(:) + real(r8) :: surften ! surface tension of water w/respect to air (N/m) + real(r8) surften_coef + real(r8) a(pcols) ! surface tension parameter + real(r8) hygro(pcols) ! aerosol hygroscopicity + real(r8) sm(pcols) ! critical supersaturation at mode radius + real(r8) arg(pcols) + ! mathematical constants + real(r8) twothird,sq2 + integer l,m,n,i,k + real(r8) log,cc + real(r8) smcoefcoef,smcoef(pcols) + integer phase ! phase of aerosol + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + tair => state%t + + allocate( & + amcubecoef(ntot_amode), & + argfactor(ntot_amode) ) + + super(:)=supersat(:)*0.01_r8 + sq2=sqrt(2._r8) + twothird=2._r8/3._r8 + surften=0.076_r8 + surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + smcoefcoef=2._r8/sqrt(27._r8) + + do m=1,ntot_amode + amcubecoef(m)=3._r8/(4._r8*pi*exp45logsig(m)) + argfactor(m)=twothird/(sq2*alogsig(m)) + end do + + ccn = 0._r8 + do k=top_lev,pver + + do i=1,ncol + a(i)=surften_coef/tair(i,k) + smcoef(i)=smcoefcoef*a(i)*sqrt(a(i)) + end do + + do m=1,ntot_amode + + phase=3 ! interstitial+cloudborne + + call loadaer( & + state, pbuf, 1, ncol, k, & + m, cs, phase, naerosol, vaerosol, & + hygro) + + where(naerosol(:ncol)>1.e-3_r8) + amcube(:ncol)=amcubecoef(m)*vaerosol(:ncol)/naerosol(:ncol) + sm(:ncol)=smcoef(:ncol)/sqrt(hygro(:ncol)*amcube(:ncol)) ! critical supersaturation + elsewhere + sm(:ncol)=1._r8 ! value shouldn't matter much since naerosol is small + endwhere + do l=1,psat + do i=1,ncol + arg(i)=argfactor(m)*log(sm(i)/super(l)) + ccn(i,k,l)=ccn(i,k,l)+naerosol(i)*0.5_r8*(1._r8-erf(arg(i))) + enddo + enddo + enddo + enddo + ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + + deallocate( & + amcubecoef, & + argfactor ) + +end subroutine ccncalc + +#else + +subroutine ccncalc_oslo(state & + , pbuf & + , cs & +!+tht + , hasAerosol & +!-tht + , numberConcentration & + , volumeConcentration & + , hygroscopicity & + , lnSigma & + , ccn ) + + ! calculates number concentration of aerosols activated as CCN at + ! supersaturation supersat. + ! assumes an internal mixture of a multiple externally-mixed aerosol modes + ! cgs units + + ! This was used in the BACCHUS-project where it was agreed that + ! CCN would not include cloud-borne aerosols. It is possible to + ! calculate cloud-borne aerosols, but it is complicated, and it was + ! not needed when this code was made. + + ! arguments + + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) + real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) +!+tht + logical, intent(in) :: hasAerosol(pcols, pver, nmodes) +!-tht +!akc6 real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) +!akc6- + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) + real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) + + ! local + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8), pointer :: tair(:,:) ! air temperature (K) + + + real(r8) super(psat) ! supersaturation + real(r8) surften_coef !Coefficient in ARGI / ARGII + real(r8) amcube !number median radius qubed + real(r8) a ! surface tension parameter + real(r8) sm ! critical supersaturation at mode radius + real(r8) arg ! factor in eqn 15 ARGII + real(r8) argfactor !Coefficient in ARGI/ARGII + ! mathematical constants + real(r8), parameter:: twothird=2.0_r8/3.0_r8 + real(r8), parameter:: sq2=sqrt(2.0_r8) + real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) + real(r8) exp45logsig_var + integer lsat,m,i,k + real(r8) smcoefcoef,smcoef + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + tair => state%t + + super(:)=supersat(:)*0.01_r8 + + !This is curvature effect (A) in ARGI + !eqn 5 in ARG1 (missing division by temperature, see below) + surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoefcoef=2._r8/sqrt(27._r8) + + ccn(:,:,:) = 0._r8 + + do m=1,nmodes + do k=top_lev,pver + + do i=1,ncol + +!+tht + if (hasAerosol(i,k,m)) then +!-tht + !Curvature-parameter "A" in ARGI (eqn 5) + a = surften_coef/tair(i,k) + + !standard factor for transforming size distr + !volume ==> number (google psd.pdf by zender) + exp45logsig_var = & + exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) + + !Numbe rmedian radius (power of three) + !By definition of lognormal distribution + amcube =(3._r8*volumeConcentration(i,k,m) & + /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist + + + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoef = smcoefcoef * a * sqrt(a) + + !This is finally solving eqn 9 + !(solve for critical supersat of mode) + sm=smcoef & + / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation + + !Solve eqn 13 in ARGII + do lsat = 1,psat + + !eqn 15 in ARGII + argfactor=twothird/(sq2*lnSigma(i,k,m)) + + !eqn 15 in ARGII + arg=argfactor*log(sm/super(lsat)) + + !eqn 13 i ARGII + ccn(i,k,lsat)=ccn(i,k,lsat) & + +numberConcentration(i,k,m)& + *0.5_r8*(1._r8-erf(arg)) + end do +!+tht + else + do lsat = 1, psat + ccn(i,k,lsat)=0._r8 + enddo + endif +!-tht + end do + end do + end do + + ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + +end subroutine ccncalc_oslo +#endif + +!=============================================================================== + +subroutine loadaer( & + state, pbuf, istart, istop, k, & + m, cs, phase, naerosol, & + vaerosol, hygro) + + ! return aerosol number, volume concentrations, and bulk hygroscopicity + + ! input arguments + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + integer, intent(in) :: istart ! start column index (1 <= istart <= istop <= pcols) + integer, intent(in) :: istop ! stop column index + integer, intent(in) :: m ! mode index + integer, intent(in) :: k ! level index + real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) + integer, intent(in) :: phase ! phase of aerosol: 1 for interstitial, 2 for cloud-borne, 3 for sum + + ! output arguments + real(r8), intent(out) :: naerosol(:) ! number conc (1/m3) + real(r8), intent(out) :: vaerosol(:) ! volume conc (m3/m3) + real(r8), intent(out) :: hygro(:) ! bulk hygroscopicity of mode + + ! internal + integer :: lchnk ! chunk identifier + + real(r8), pointer :: raer(:,:) ! interstitial aerosol mass, number mixing ratios + real(r8), pointer :: qqcw(:,:) ! cloud-borne aerosol mass, number mixing ratios + real(r8) :: specdens, spechygro + + real(r8) :: vol(pcols) ! aerosol volume mixing ratio + integer :: i, l + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + + do i = istart, istop + vaerosol(i) = 0._r8 + hygro(i) = 0._r8 + end do + + do l = 1, nspec_amode(m) + + call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer) + call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw) + call rad_cnst_get_aer_props(0, m, l, density_aer=specdens, hygro_aer=spechygro) + + if (phase == 3) then + do i = istart, istop + vol(i) = max(raer(i,k) + qqcw(i,k), 0._r8)/specdens + end do + else if (phase == 2) then + do i = istart, istop + vol(i) = max(qqcw(i,k), 0._r8)/specdens + end do + else if (phase == 1) then + do i = istart, istop + vol(i) = max(raer(i,k), 0._r8)/specdens + end do + else + write(iulog,*)'phase=',phase,' in loadaer' + call endrun('phase error in loadaer') + end if + + do i = istart, istop + vaerosol(i) = vaerosol(i) + vol(i) + hygro(i) = hygro(i) + vol(i)*spechygro + end do + + end do + + do i = istart, istop + if (vaerosol(i) > 1.0e-30_r8) then ! +++xl add 8/2/2007 + hygro(i) = hygro(i)/(vaerosol(i)) + vaerosol(i) = vaerosol(i)*cs(i,k) + else + hygro(i) = 0.0_r8 + vaerosol(i) = 0.0_r8 + end if + end do + + ! aerosol number + call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer) + call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw) + if (phase == 3) then + do i = istart, istop + naerosol(i) = (raer(i,k) + qqcw(i,k))*cs(i,k) + end do + else if (phase == 2) then + do i = istart, istop + naerosol(i) = qqcw(i,k)*cs(i,k) + end do + else + do i = istart, istop + naerosol(i) = raer(i,k)*cs(i,k) + end do + end if + ! adjust number so that dgnumlo < dgnum < dgnumhi + do i = istart, istop + naerosol(i) = max(naerosol(i), vaerosol(i)*voltonumbhi_amode(m)) + naerosol(i) = min(naerosol(i), vaerosol(i)*voltonumblo_amode(m)) + end do + +end subroutine loadaer + +!=============================================================================== + +end module ndrop + + + + diff --git a/src/chemistry/oslo_aero/ndrop.F90.fpe b/src/chemistry/oslo_aero/ndrop.F90.fpe new file mode 100644 index 0000000000..bd90190fc4 --- /dev/null +++ b/src/chemistry/oslo_aero/ndrop.F90.fpe @@ -0,0 +1,3097 @@ +module ndrop + +!--------------------------------------------------------------------------------- +! Purpose: +! CAM Interface for droplet activation by modal aerosols +! +! ***N.B.*** This module is currently hardcoded to recognize only the modes that +! affect the climate calculation. This is implemented by using list +! index 0 in all the calls to rad_constituent interfaces. +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp +use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o, & + gravit, latvap, cpair, epsilo, rair +use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class +use physics_types, only: physics_state, physics_ptend, physics_ptend_init +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + +use wv_saturation, only: qsat +use phys_control, only: phys_getopts +use ref_pres, only: top_lev => trop_cloud_top_lev +use shr_spfn_mod, only: erf => shr_spfn_erf +use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & + rad_cnst_get_aer_props, rad_cnst_get_mode_props, & + rad_cnst_get_mam_mmr_idx, rad_cnst_get_mode_num_idx +use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld +use cam_abortutils, only: endrun +use cam_logfile, only: iulog +!++ MH_2015/09/09 +use phys_control, only: use_hetfrz_classnuc +!-- MH_2015/09/09 + +#ifdef OSLO_AERO +!++oslo +use aerosoldef +use parmix_progncdnc +use oslo_utils, only: calculateNumberMedianRadius +!--oslo +#endif + + +implicit none +private +save + +public ndrop_init, dropmixnuc, activate_modal, loadaer + +#ifndef OSLO_AERO +real(r8), allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol +real(r8), allocatable :: exp45logsig(:) +real(r8), allocatable, target :: f1(:) ! abdul-razzak functions of width +real(r8), allocatable, target :: f2(:) ! abdul-razzak functions of width +#endif + +real(r8) :: t0 ! reference temperature +real(r8) :: aten +real(r8) :: surften ! surface tension of water w/respect to air (N/m) +real(r8) :: alog2, alog3, alogaten +real(r8) :: third, twothird, sixth, zero +real(r8) :: sq2, sqpi + +! CCN diagnostic fields +integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration +real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration + (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) +character(len=8) :: ccn_name(psat)= & + (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) + +! indices in state and pbuf structures +integer :: numliq_idx = -1 +integer :: kvh_idx = -1 + +! description of modal aerosols +integer :: ntot_amode ! number of aerosol modes +integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode +real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode +real(r8), allocatable :: dgnumlo_amode(:) +real(r8), allocatable :: dgnumhi_amode(:) +real(r8), allocatable :: voltonumblo_amode(:) +real(r8), allocatable :: voltonumbhi_amode(:) + +logical :: history_aerosol ! Output the MAM aerosol tendencies +character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields +character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields + +! local indexing for MAM +integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr +integer :: ncnst_tot ! total number of mode number conc + mode species + +! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. +integer, allocatable :: mam_cnst_idx(:,:) + +#ifdef OSLO_AERO +logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies +integer :: n_aerosol_tracers +integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst + !..something like (/ l_so4_a1, l_bc_a, .../)etc +integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the + !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 +#endif + +! ptr2d_t is used to create arrays of pointers to 2D fields +type ptr2d_t + real(r8), pointer :: fld(:,:) +end type ptr2d_t + +! modal aerosols +logical :: prog_modal_aero ! true when modal aerosols are prognostic +logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + ! in the ptend object + +!=============================================================================== +contains +!=============================================================================== + +subroutine ndrop_init + + integer :: ii, l, lptr, m, mm + integer :: nspec_max ! max number of species in a mode + character(len=32) :: tmpname + character(len=32) :: tmpname_cw + character(len=128) :: long_name + character(len=8) :: unit + logical :: history_amwg ! output the variables used by the AMWG diag package +#ifdef OSLO_AERO + character(len=10) :: modeString + character(len=20) :: varname +#endif + + !------------------------------------------------------------------------------- + + ! get indices into state%q and pbuf structures + call cnst_get_ind('NUMLIQ', numliq_idx) + + kvh_idx = pbuf_get_index('kvh') + + zero = 0._r8 + third = 1._r8/3._r8 + twothird = 2._r8*third + sixth = 1._r8/6._r8 + sq2 = sqrt(2._r8) + sqpi = sqrt(pi) + + t0 = 273._r8 + surften = 0.076_r8 + aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) + alogaten = log(aten) + alog2 = log(2._r8) + alog3 = log(3._r8) + + ! get info about the modal aerosols + ! get ntot_amode +#ifdef OSLO_AERO + ntot_amode = nmodes !from opttab +#else + call rad_cnst_get_info(0, nmodes=ntot_amode) +#endif + allocate( & + nspec_amode(ntot_amode), & + sigmag_amode(ntot_amode), & + dgnumlo_amode(ntot_amode), & + dgnumhi_amode(ntot_amode), & +#ifndef OSLO_AERO + alogsig(ntot_amode), & + exp45logsig(ntot_amode), & + f1(ntot_amode), & + f2(ntot_amode), & +#endif + voltonumblo_amode(ntot_amode), & + voltonumbhi_amode(ntot_amode) ) + +#ifdef OSLO_AERO + do m = 1,ntot_amode + nspec_amode(m) = getNumberOfTracersInMode(m) + enddo +#else + do m = 1, ntot_amode + ! use only if width of size distribution is prescribed + + ! get mode info + call rad_cnst_get_info(0, m, nspec=nspec_amode(m)) + + ! get mode properties + call rad_cnst_get_mode_props(0, m, sigmag=sigmag_amode(m), & + dgnumhi=dgnumhi_amode(m), dgnumlo=dgnumlo_amode(m)) + + alogsig(m) = log(sigmag_amode(m)) + exp45logsig(m) = exp(4.5_r8*alogsig(m)*alogsig(m)) + f1(m) = 0.5_r8*exp(2.5_r8*alogsig(m)*alogsig(m)) + f2(m) = 1._r8 + 0.25_r8*alogsig(m) + + voltonumblo_amode(m) = 1._r8 / ( (pi/6._r8)* & + (dgnumlo_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) + voltonumbhi_amode(m) = 1._r8 / ( (pi/6._r8)* & + (dgnumhi_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) + end do +#endif + ! Init the table for local indexing of mam number conc and mmr. + ! This table uses species index 0 for the number conc. + + ! Find max number of species in all the modes, and the total + ! number of mode number concentrations + mode species + nspec_max = nspec_amode(1) + ncnst_tot = nspec_amode(1) + 1 + do m = 2, ntot_amode + nspec_max = max(nspec_max, nspec_amode(m)) + ncnst_tot = ncnst_tot + nspec_amode(m) + 1 + end do + + allocate( & + mam_idx(ntot_amode,0:nspec_max), & + mam_cnst_idx(ntot_amode,0:nspec_max), & + fieldname(ncnst_tot), & + fieldname_cw(ncnst_tot) ) + + ! Local indexing compresses the mode and number/mass indicies into one index. + ! This indexing is used by the pointer arrays used to reference state and pbuf + ! fields. + ii = 0 + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + ii = ii + 1 + mam_idx(m,l) = ii + end do + end do + + ! Add dropmixnuc tendencies for all modal aerosol species + + call phys_getopts(history_amwg_out = history_amwg, & + history_aerosol_out = history_aerosol, & + prog_modal_aero_out=prog_modal_aero) + +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. + n_aerosol_tracers = getNumberOfAerosolTracers() + call fillAerosolTracerList(aerosolTracerList) + call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) + do ii=1,n_aerosol_tracers + print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) + end do +#endif + +#ifdef OSLO_AERO + lq(:)=.FALSE. !Initialize + + !Set up tendencies for tracers (output) + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + + if(.NOT. lq(lptr))then + !add dropmixnuc tendencies + mm=mam_idx(m,l) + fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" + fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" + + long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) + + long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) + + if (history_aerosol) then + call add_default(trim(fieldname(mm)), 1, ' ') + call add_default(trim(fieldname_cw(mm)),1,' ') + endif + + !Do tendencies of this tracer + lq(lptr)=.TRUE. + endif + enddo + enddo + do m=1,ntot_amode + modeString=" " + write(modeString,"(I2)"),m + if(m .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "NCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "VCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "SIGMA"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "HYGRO"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + end do +#else + do m = 1, ntot_amode + do l = 0, nspec_amode(m) ! loop over number + chem constituents + + mm = mam_idx(m,l) + + unit = 'kg/m2/s' + if (l == 0) then ! number + unit = '#/m2/s' + end if + + if (l == 0) then ! number + call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) + else + call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) + end if + + fieldname(mm) = trim(tmpname) // '_mixnuc1' + fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' + + if (prog_modal_aero) then + + ! To set tendencies in the ptend object need to get the constituent indices + ! for the prognostic species + if (l == 0) then ! number + call rad_cnst_get_mode_num_idx(m, lptr) + else + call rad_cnst_get_mam_mmr_idx(m, l, lptr) + end if + mam_cnst_idx(m,l) = lptr + lq(lptr) = .true. + + ! Add tendency fields to the history only when prognostic MAM is enabled. + long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname(mm), horiz_only, 'A', unit, long_name) + + long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' + call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name) + + if (history_aerosol) then + call add_default(fieldname(mm), 1, ' ') + call add_default(fieldname_cw(mm), 1, ' ') + end if + + + + end if + + end do + end do + +#endif + + call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') + call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') + call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') + call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') + call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') + call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') + +#ifdef OSLO_AERO + if(history_aerosol)then + do l = 1, psat + call add_default(ccn_name(l), 1, ' ') + enddo + end if +#endif + + call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') + call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') + call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') + call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') + call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') + +#ifndef OSLO_AERO + + ! set the add_default fields + if (history_amwg) then + call add_default('CCN3', 1, ' ') + endif + + if (history_aerosol .and. prog_modal_aero) then + do m = 1, ntot_amode + do l = 0, nspec_amode(m) ! loop over number + chem constituents + mm = mam_idx(m,l) + if (l == 0) then ! number + call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) + else + call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) + end if + fieldname(mm) = trim(tmpname) // '_mixnuc1' + fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' + end do + end do + endif + +#endif + +end subroutine ndrop_init + +!=============================================================================== + +subroutine dropmixnuc( & + state, ptend, dtmicro, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + !++ MH_2015/09/07 + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + !-- MH_2015/09/07 + tendnd, & ! Output + !++ MH_2015/04/10 + fn_in, & + from_spcam ) + !-- MH_2015/04/10 + + ! vertical diffusion and nucleation of cloud droplets + ! assume cloud presence controlled by cloud fraction + ! doesn't distinguish between warm, cold clouds + + ! arguments + type(physics_state), target, intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtmicro ! time step for microphysics (s) + + type(physics_buffer_desc), pointer :: pbuf(:) + + ! arguments + real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity + real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction + real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step + real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) + logical, intent(in),optional :: from_spcam ! value insignificant - if variable present, is called from spcam + +!++ MH_2015/09/07 + logical, intent(in) :: hasAerosol(pcols, pver, nmodes) + real(r8), intent(in) :: CProcessModes(pcols,pver) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) + real(r8), intent(in) :: f_c(pcols,pver) + real(r8), intent(in) :: f_aq(pcols,pver) + real(r8), intent(in) :: f_bc(pcols,pver) + real(r8), intent(in) :: f_so4_cond(pcols,pver) + real(r8), intent(in) :: f_soa(pcols,pver) + real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) + real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction + real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity + real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma +!-- MH_2015/09/07 + + ! output arguments + real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) + + !--------------------Local storage------------------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of columns + + real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) + real(r8), pointer :: temp(:,:) ! temperature (K) + real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) + real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) + real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) + real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) + real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) + real(r8), pointer :: zm(:,:) ! geopotential height of level (m) + + real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) + + type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios + type(ptr2d_t), allocatable :: qqcw(:) + real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios + real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios + + + real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 + real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) + real(r8) :: sq2pi + + integer :: i, k, l, m, mm, n + integer :: km1, kp1 + integer :: nnew, nsav, ntemp + integer :: lptr + integer :: nsubmix, nsubmix_bnd + integer, save :: count_submix(100) + integer :: phase ! phase of aerosol + + real(r8) :: arg + real(r8) :: dtinv + real(r8) :: dtmin, tinv, dtt + real(r8) :: lcldn(pcols,pver) + real(r8) :: lcldo(pcols,pver) + + real(r8) :: zs(pver) ! inverse of distance between levels (m) + real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) + real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries + real(r8) :: srcn(pver) ! droplet source rate (/s) + real(r8) :: cs(pcols,pver) ! air density (kg/m3) + real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) + real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) + real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) + + real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) + real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) + real(r8) :: wbar, wmix, wmin, wmax + + real(r8) :: zn(pver) ! g/pdel (m2/g) for layer + real(r8) :: flxconv ! convergence of flux into lowest layer + + real(r8) :: wdiab ! diabatic vertical velocity + real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) + real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) + real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity + real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity + + real(r8) :: dum, dumc + real(r8) :: tmpa + real(r8) :: dact + real(r8) :: fluxntot ! (#/cm2/s) + real(r8) :: dtmix + real(r8) :: alogarg + real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap + + real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) + real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) + real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) + real(r8) :: cldo_tmp, cldn_tmp + real(r8) :: tau_cld_regenerate + real(r8) :: zeroaer(pver) + real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) + + + real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) + real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) + + real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios + real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase +#ifdef OSLO_AERO + !to avoid excessive calls to boundary layer scheme + real(r8), allocatable :: raercol_tracer(:,:,:) + real(r8), allocatable :: raercol_cw_tracer(:,:,:) + real(r8), allocatable :: mact_tracer(:,:) + real(r8), allocatable :: mfullact_tracer(:,:) +#endif + + real(r8) :: na(pcols), va(pcols), hy(pcols) + real(r8), allocatable :: naermod(:) ! (1/m3) + real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) + + real(r8) :: source(pver) + +!++ MH_2015/04/10 + real(r8), allocatable :: fn(:) ! activation fraction for aerosol number + real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) +!-- MH_2015/04/10 + real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass + + real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) + real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) + real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) + ! note: activation fraction fluxes are defined as + ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] + ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] + + + real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output + real(r8), allocatable :: coltend_cw(:,:) ! column tendency + real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat + + !for gas species turbulent mixing + real(r8), pointer :: rgas(:, :, :) + real(r8), allocatable :: rgascol(:, :, :) + real(r8), allocatable :: coltendgas(:) + real(r8) :: zerogas(pver) + character*200 fieldnamegas + + logical :: called_from_spcam + !------------------------------------------------------------------------------- +#ifdef OSLO_AERO + real(r8) :: numberMedianRadius(pcols,pver,nmodes) + real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma + real(r8) :: constituentFraction + !++ MH_2015/04/10 + real(r8) :: volumeCore(pcols,pver,nmodes) + real(r8) :: volumeCoat(pcols,pver,nmodes) + !-- MH_2015/04/10 + integer :: tracerIndex + integer :: cloudTracerIndex + integer :: kcomp + integer :: speciesMap(nmodes) + !++ MH_2015/04/10 +! real(r8) :: fn_tmp(pcols,pver,nmodes) + real(r8), allocatable :: fn_tmp(:), fm_tmp(:) + !-- MH_2015/04/10 + real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) + real(r8) :: componentFraction + real(r8) :: componentFractionOK(pver,nmodes,pcnst) + real(r8) :: sumFraction + logical :: alert + real(r8), dimension(pver, pcnst) :: massBalance + real(r8), dimension(pver, pcnst) :: newMass + real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud + integer :: kCrit, lptr2 + logical :: stopMe + integer :: iDebug=1, lDebug=15 + real(r8) :: mixRatioToMass + real(r8),dimension(pcnst) :: debugSumFraction + real(r8), allocatable :: lnsigman(:) + character(len=2) :: modeString + character(len=20) :: varname +#endif + integer :: numberOfModes +!------------------------------------------------------------------------------- +#undef EXTRATESTS +#undef MASS_BALANCE_CHECK + + sq2pi = sqrt(2._r8*pi) + + lchnk = state%lchnk + ncol = state%ncol + + ncldwtr => state%q(:,:,numliq_idx) + temp => state%t + omega => state%omega + pmid => state%pmid + pint => state%pint + pdel => state%pdel + rpdel => state%rpdel + zm => state%zm + + call pbuf_get_field(pbuf, kvh_idx, kvh) + + ! Create the liquid weighted cloud fractions that were passsed in + ! before. This doesn't seem like the best variable, since the cloud could + ! have liquid condensate, but the part of it that is changing could be the + ! ice portion; however, this is what was done before. + lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) + lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) + + + arg = 1.0_r8 + if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then + write(iulog,*) 'erf(1.0) = ',ERF(arg) + call endrun('dropmixnuc: Error function error') + endif + arg = 0.0_r8 + if (erf(arg) /= 0.0_r8) then + write(iulog,*) 'erf(0.0) = ',erf(arg) + write(iulog,*) 'dropmixnuc: Error function error' + call endrun('dropmixnuc: Error function error') + endif + + dtinv = 1._r8/dtmicro + + allocate( & + nact(pver,ntot_amode), & + mact(pver,ntot_amode), & + raer(ncnst_tot), & + qqcw(ncnst_tot), & + raercol(pver,ncnst_tot,2), & + raercol_cw(pver,ncnst_tot,2), & + coltend(pcols,ncnst_tot), & + coltend_cw(pcols,ncnst_tot), & + naermod(ntot_amode), & + hygro(ntot_amode), & +#ifdef OSLO_AERO + lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) + raercol_tracer(pver,n_aerosol_tracers,2), & + raercol_cw_tracer(pver,n_aerosol_tracers,2), & + mact_tracer(pver,n_aerosol_tracers), & + mfullact_tracer(pver,n_aerosol_tracers), & +#endif + vaerosol(ntot_amode), & + fn(ntot_amode), & + fm(ntot_amode), & + fluxn(ntot_amode), & + fluxm(ntot_amode) ) + + ! Init pointers to mode number and specie mass mixing ratios in + ! intersitial and cloud borne phases. +#ifdef OSLO_AERO + !Need a list of all aerosol species ==> store in raer (mm) + ! or qqcw for cloud-borne aerosols (?) + do m=1,nmodes !All aerosol modes + + !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES + do l = 1, nspec_amode(m) + tracerIndex = getTracerIndex(m,l,.false.) !Index in q + cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer + mm = mam_idx(m,l) !Index in raer/qqcw + raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) + call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) +#ifdef EXTRATESTS +! if(tracerIndex .eq. ldebug)then +! do k=1,pver +! print*,"pointer check",k,m,l,mm,tracerIndex, raer(mm)%fld(idebug,k), state%q(idebug,k,tracerIndex) +! end do +! endf +#endif + enddo + enddo + allocate( & + fn_tmp(ntot_amode), & + fm_tmp(ntot_amode), & + fluxn_tmp(ntot_amode), & + fluxm_tmp(ntot_amode) ) +#else + do m = 1, ntot_amode + mm = mam_idx(m, 0) + call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer(mm)%fld) + call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol + do l = 1, nspec_amode(m) + mm = mam_idx(m, l) + call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer(mm)%fld) + call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol + end do + end do +#endif + + called_from_spcam = (present(from_spcam)) + + if (called_from_spcam) then + rgas => state%q + allocate(rgascol(pver, pcnst, 2)) + allocate(coltendgas(pcols)) + endif + wtke = 0._r8 + + if (prog_modal_aero) then + ! aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) + else + ! no aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop') + end if + +#ifdef OSLO_AERO + !Improve this later by using only cloud points ? + do k = top_lev, pver + do i=1,ncol + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + end do + end do + + !Output this + call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) + do n=1,nmodes + sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) + modeString=" " + write(modeString,"(I2)"),n + if(n .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) + varName = "NCONC"//trim(modeString) + call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) + varName = "VCONC"//trim(modeString) + call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) + varName = "SIGMA"//trim(modeString) + call outfld(varName, sigma(:,:,n), pcols,lchnk) + varName = "HYGRO"//trim(modeString) + call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) + end do + + alert = .FALSE. + do k=top_lev,pver + mm = k - top_lev + 1 + do m=1,nmodes + if(.NOT. alert .and. & +!tht is zero an allowed value for numberConcentration?? + ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then + alert = .TRUE. + lptr = k + print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm + endif + enddo + enddo + + + if(alert)then + print*,"strange stuff here " + stop + + !do m=1,nmodes + ! print*,"numberconc (after alert)", m, modedefs(1)%nnatk(m)*1.e-6_r8, "#/cm3" & + ! ,modedefs(1)%C(m)*1.0e9_r8, "ug/m3" + + ! if(modedefs(1)%nnatk(m) > 1.e-30_r8)then + ! print*, "final weight per particle ",m, modedefs(1)%C(m)/modedefs(1)%nnatk(m) + ! endif + !end do + !stop + endif + +#endif + + ! overall_main_i_loop + do i = 1, ncol + +#ifdef OSLO_AERO + coltend(i,:)=0.0_r8 + coltend_cw(i,:) = 0.0_r8 +#endif + + do k = top_lev, pver-1 + zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) + end do + zs(pver) = zs(pver-1) + + ! load number nucleated into qcld on cloud boundaries + + do k = top_lev, pver + + qcld(k) = ncldwtr(i,k) + qncld(k) = 0._r8 + srcn(k) = 0._r8 + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m + + do m = 1, ntot_amode + nact(k,m) = 0._r8 + mact(k,m) = 0._r8 + end do + + zn(k) = gravit*rpdel(i,k) + + if (k < pver) then + ekd(k) = kvh(i,k+1) + ekd(k) = max(ekd(k), zkmin) + ekd(k) = min(ekd(k), zkmax) + csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) + csbot_cscen(k) = csbot(k)/cs(i,k) + else + ekd(k) = 0._r8 + csbot(k) = cs(i,k) + csbot_cscen(k) = 1.0_r8 + end if + + ! rce-comment - define wtke at layer centers for new-cloud activation + ! and at layer boundaries for old-cloud activation + !++ag + wtke_cen(i,k) = wsub(i,k) + wtke(i,k) = wsub(i,k) + !--ag + wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) + wtke(i,k) = max(wtke(i,k), wmixmin) + + nsource(i,k) = 0._r8 + + end do ! k + + nsav = 1 + nnew = 2 +#ifdef OSLO_AERO + + !get constituent fraction + componentFractionOK(:,:,:) = 0.0_r8 + do k=top_lev, pver + do m = 1,ntot_amode + if(m .le. nbmodes)then + do l = 1, nspec_amode(m) + !calculate fraction of component "l" in mode "m" based on concentrations in clear air + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & + = getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & + ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), getTracerIndex(m,l,.false.) ) + end do + else + do l = 1, nspec_amode(m) + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 + end do + endif + end do + + !Loop over all tracers ==> check that sums to one + !for all tracers which exist in the oslo-modes + do l=1,pcnst + sumFraction = 0.0_r8 + do m=1,ntot_amode + sumFraction = sumFraction + componentFractionOK(k,m,l) + end do + if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% + do m=1,ntot_amode + componentFractionOK(k,m,l) = & + componentFractionOK(k,m,l)/sumFraction + end do + else !negative or zero fraction for this species + !distribute equal fraction to all receiver modes + sumFraction = 0.0_r8 + do m=1,ntot_amode + do lptr=1,getNumberOfTracersInMode(m) + if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then + sumFraction = sumFraction + 1.0_r8 + endif + end do ! tracers in mode + end do ! mode + do m=1,ntot_amode + componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) + end do !modes + endif + end do !tracers + end do !levels + !debug sum fraction for "i" done + + + + debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k + do m = 1, nmodes ! Number of modes + !Get number concentration of this mode + mm =mam_idx(m,0) + do k= top_lev,pver + raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air + !In oslo model, number concentrations are diagnostics, so + !Approximate number concentration in each mode by total + !cloud number concentration scaled by how much is available of + !each mode + raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& + /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) + enddo + + !These are the mass mixing ratios + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !index of tracer (all unique) + raercol(:,mm,nsav) = 0.0_r8 + raercol_cw(:,mm,nsav) = 0.0_r8 + !Several of the fields (raer(mm)%fld point to the same + !field in q. To avoid double counting, we take into + !account the component fraction in the mode + do k=top_lev,pver + if(m .gt. nbmodes) then + componentFraction = 1.0_r8 + else + componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif +#ifdef EXTRATESTS + if(i .eq. iDebug .and. getTracerIndex(m,l,.false.) .eq. lDebug)then + !print*,"componentFraction", i,cnst_name(oslo_cnst_idx(m,l)),componentFraction + print*,"assigning cloud/aerosol", k,m,l,qqcw(mm)%fld(i,k), raer(mm)%fld(i,k) & + ,componentFraction + debugSumFraction(k) = debugSumFraction(k) + componentFraction + endif + if(componentFraction > 1.0_r8)then + print*, "wrong component fraction", componentFraction + stop + call endrun("wrong component fraction") + endif +#endif + !Assign to the components used here i.e. distribute condensate/coagulate to modes + raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction + raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction + enddo ! k (levels) + end do ! l (species) + end do ! m (modes) +#ifdef EXTRATESTS + do k=top_lev,pver + if(i .eq. iDebug .and. (abs(debugSumFraction(k)-1.0_r8).gt.1.e-2_r8) .and. debugSumFraction(k).gt.1.e-6_r8)then + print*, "debugSumFraction", cnst_name(getTracerIndex(m,l,.false.)),i, k, debugSumFraction(k), abs(debugSumFraction(k)-1.0_r8) + componentFraction=0.0_r8 + do m=1,nbmodes + componentFraction = componentFraction + cam(i,k,m) + print*, "MODECONC", m, cam(i,k,m), numberConcentration(i,k,m) + end do + print*, "CS, sumCAM", CProcessModes(i,k), sum(cam(i,k,1:nbmodes)), componentFraction + print*, "q (cond)", state%q(i,k,lDebug)*cs(i,k)!mass in q + print*, "q (aq) " ,state%q(i,k,l_so4_a2)*cs(i,k) + print*, "bulk fractions", f_so4_cond(i,k),f_c(i,k), f_bc(i,k), f_aq(i,k) + !print*, "other levels", debugSumFraction(:) + do m=1,nmodes + do l=1,nspec_amode(m) + if(getTracerIndex(m,l,.false.) == ldebug)then + if(m .gt. nbmodes)then + componentFraction = 1.0_r8 + else + componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif + print*, "nmode, l,k, ", m,l,k , lDebug, componentFraction, cam(i,k,m), f_aqm(i,k,m), f_acm(i,k,m), f_so4_condm(i,k,m) + print*, "fraction2 ", cam(i,k,m), cam(i,k,m)/CProcessModes(i,k)*100.0_r8, " %" + endif + enddo + enddo + call endrun("wrong debugsumfraction") + endif !idebug/ldebug + enddo +#endif + !END OSLO-STUFF, BELOW IS MAM 3 +#else + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol_cw(:,mm,nsav) = 0.0_r8 + raercol(:,mm,nsav) = 0.0_r8 + raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) + raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) + raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) + end do + end do +#endif + + + if (called_from_spcam) then + ! + ! In the MMF model, turbulent mixing for tracer species are turned off. + ! So the turbulent for gas species mixing are added here. + ! (Previously, it had the turbulent mixing for aerosol species) + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) rgascol(:,m,nsav) = rgas(i,:,m) + end do + + endif + + ! droplet nucleation/aerosol activation + + ! tau_cld_regenerate = time scale for regeneration of cloudy air + ! by (horizontal) exchange with clear air + tau_cld_regenerate = 3600.0_r8 * 3.0_r8 + + if (called_from_spcam) then + ! when this is called in the MMF part, no cloud regeneration and decay. + ! set the time scale be very long so that no cloud regeneration. + tau_cld_regenerate = 3600.0_r8 * 24.0_r8 * 365.0_r8 + endif + + + ! k-loop for growing/shrinking cloud calcs ............................. + ! grow_shrink_main_k_loop: & + do k = top_lev, pver + + ! This code was designed for liquid clouds, but the cloudbourne + ! aerosol can be either from liquid or ice clouds. For the ice clouds, + ! we do not do regeneration, but as cloud fraction decreases the + ! aerosols should be returned interstitial. The lack of a liquid cloud + ! should not mean that all of the aerosol is realease. Therefor a + ! section has been added for shrinking ice clouds and checks were added + ! to protect ice cloudbourne aerosols from being released when no + ! liquid cloud is present. + + ! shrinking ice cloud ...................................................... + cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) + cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) + + if (cldn_tmp < cldo_tmp) then + + ! convert activated aerosol to interstitial in decaying cloud + + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + end do + end do + end if + + ! shrinking liquid cloud ...................................................... + ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) + ! and also dissipate the portion of the cloud that will be regenerated + cldo_tmp = lcldo(i,k) + cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) + ! alternate formulation + ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) + + ! fraction is also provided. + if (cldn_tmp < cldo_tmp) then + ! droplet loss in decaying cloud + !++ sungsup + nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv + qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) + !-- sungsup + + ! convert activated aerosol to interstitial in decaying cloud + + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact +#ifdef EXTRATESTS + if(i.eq. iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"decaying cloud", k, dact, cldn_tmp, cldo_tmp + endif +#endif + end do + end do + end if + + ! growing liquid cloud ...................................................... + ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) + ! and also regenerate part of the cloud + cldo_tmp = cldn_tmp + cldn_tmp = lcldn(i,k) + + if (cldn_tmp-cldo_tmp > 0.01_r8) then + + ! rce-comment - use wtke at layer centers for new-cloud activation + wbar = wtke_cen(i,k) + wmix = 0._r8 + wmin = 0._r8 + wmax = 10._r8 + wdiab = 0._r8 + + ! 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) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,k,kcomp) + vaerosol(m) = volumeConcentration(i,k,kcomp) + hygro(m) = hygroscopicity(i,k,kcomp) + lnsigman(m) = lnsigma(i,k,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m +#else + numberOfModes = ntot_amode + phase = 1 ! interstitial + do m = 1, ntot_amode + call loadaer( & + state, pbuf, i, i, k, & + m, cs, phase, na, va, & + hy) + naermod(m) = na(i) + vaerosol(m) = va(i) + hygro(m) = hy(i) + end do +#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 + !-- MH_2015/04/10 + endif + + dumc = (cldn_tmp - cldo_tmp) +#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 + do m = 1, ntot_amode + mm = mam_idx(m,0) +#ifdef OSLO_AERO + if (use_hetfrz_classnuc) then + dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + else + dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + end if +#else + if (use_hetfrz_classnuc) then + dact = dumc*fn_in(i,k,m)*raer(mm)%fld(i,k) ! interstitial only + else + dact = dumc*fn(m)*raer(mm)%fld(i,k) ! interstitial only + end if +#endif + qcld(k) = qcld(k) + dact + nsource(i,k) = nsource(i,k) + dact*dtinv + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + dum = dumc*fm(m) + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) +#ifdef OSLO_AERO + if(m .gt. nbmodes)then + constituentFraction = 1.0_r8 + else + constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) + endif + + dact = dum*raer(mm)%fld(i,k)*constituentFraction +#else + dact = dum*raer(mm)%fld(i,k) ! interstitial only +#endif + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact +#ifdef EXTRATESTS + if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"growing cloud (new/old)", k, raercol_cw(k,mm,nsav), raercol_cw(k,mm,nsav)-dact & + ,raercol(k,mm,nsav),raercol(k,mm,nsav)+dact,dact + endif +#endif + enddo + enddo + endif ! cldn_tmp-cldo_tmp > 0.01_r8 + + enddo ! grow_shrink_main_k_loop + ! end of k-loop for growing/shrinking cloud calcs ...................... + + ! ...................................................................... + ! start of k-loop for calc of old cloud activation tendencies .......... + ! + ! rce-comment + ! changed this part of code to use current cloud fraction (cldn) exclusively + ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 + ! previous code (which used cldo below here) would have no cloud-base activation + ! into layer k. however, activated particles in k mix out to k+1, + ! so they are incorrectly depleted with no replacement + + ! old_cloud_main_k_loop + do k = top_lev, pver + kp1 = min0(k+1, pver) + taumix_internal_pver_inv = 0.0_r8 + + if (lcldn(i,k) > 0.01_r8) then + + wdiab = 0._r8 + wmix = 0._r8 ! single updraft + wbar = wtke(i,k) ! single updraft + if (k == pver) wbar = wtke_cen(i,k) ! single updraft + wmax = 10._r8 + wmin = 0._r8 + + if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then + + ! cloud base + + ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi + ! rce-comments + ! first, should probably have 1/zs(k) here rather than dz(i,k) because + ! the turbulent flux is proportional to ekd(k)*zs(k), + ! while the dz(i,k) is used to get flux divergences + ! and mixing ratio tendency/change + ! second and more importantly, using a single updraft velocity here + ! means having monodisperse turbulent updraft and downdrafts. + ! The sq2pi factor assumes a normal draft spectrum. + ! The fluxn/fluxm from activate must be consistent with the + ! fluxes calculated in explmix. + ekd(k) = wbar/zs(k) + + alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) + wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) + phase = 1 ! interstitial +#ifdef OSLO_AERO + naermod(:) = 0.0_r8 + vaerosol(:) = 0.0_r8 + hygro(:) = 0.0_r8 + lnsigman(:) = log(2.0_r8) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,kp1,kcomp) + vaerosol(m) = volumeConcentration(i,kp1,kcomp) + hygro(m) = hygroscopicity(i,kp1,kcomp) + lnsigman(m) = lnsigma(i,kp1,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m +#else + numberOfModes = ntot_amode + + do m = 1, ntot_amode + ! rce-comment - use kp1 here as old-cloud activation involves + ! aerosol from layer below + call loadaer( & + state, pbuf, i, i, kp1, & + m, cs, phase, na, va, & + hy) + naermod(m) = na(i) + vaerosol(m) = va(i) + hygro(m) = hy(i) + 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 + !-- MH_2015/04/10 + endif + + !Difference in cloud fraction this layer and above! + !we are here because there are more clouds above, and some + !aerosols go into that layer! ==> calculate additional cloud fraction + if (k < pver) then + dumc = lcldn(i,k) - lcldn(i,kp1) + else + dumc = lcldn(i,k) + 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 + + fluxntot = 0.0_r8 + + ! rce-comment 1 + ! flux of activated mass into layer k (in kg/m2/s) + ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) + ! source of activated mass (in kg/kg/s) = flux divergence + ! = actmassflux/(cs(i,k)*dz(i,k)) + ! so need factor of csbot_cscen = csbot(k)/cs(i,k) + ! dum=1./(dz(i,k)) + dum=csbot_cscen(k)/(dz(i,k)) + + ! rce-comment 2 + ! code for k=pver was changed to use the following conceptual model + ! in k=pver, there can be no cloud-base activation unless one considers + ! a scenario such as the layer being partially cloudy, + ! with clear air at bottom and cloudy air at top + ! assume this scenario, and that the clear/cloudy portions mix with + ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) + ! in the absence of other sources/sinks, qact (the activated particle + ! mixratio) attains a steady state value given by + ! qact_ss = fcloud*fact*qtot + ! where fcloud is cloud fraction, fact is activation fraction, + ! qtot=qact+qint, qint is interstitial particle mixratio + ! the activation rate (from mixing within the layer) can now be + ! written as + ! d(qact)/dt = (qact_ss - qact)/taumix_internal + ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) + ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact + ! also, d(qact)/dt can be negative. in the code below + ! it is forced to be >= 0 + ! + ! steve -- + ! you will likely want to change this. i did not really understand + ! what was previously being done in k=pver + ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the + ! droplet deposition velocity which is quite small + ! in the cam3_5_37 version, wtke is done differently and is much + ! larger in k=pver, so the activation is stronger there + ! + if (k == pver) then + taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) + end if + + do m = 1, ntot_amode + mm = mam_idx(m,0) + fluxn(m) = fluxn(m)*dumc + fluxm(m) = fluxm(m)*dumc + nact(k,m) = nact(k,m) + fluxn(m)*dum + mact(k,m) = mact(k,m) + fluxm(m)*dum + if (k < pver) then + ! note that kp1 is used here + fluxntot = fluxntot & + + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) + else + tmpa = raercol(kp1,mm,nsav)*fluxn(m) & + + raercol_cw(kp1,mm,nsav)*(fluxn(m) & + - taumix_internal_pver_inv*dz(i,k)) + fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) + end if + end do + srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) + nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) +#ifdef EXTRATESTS + if(fluxntot/(cs(i,k)*dz(i,k)) > 0.0_r8 )then + print*,"activated/available(from below)",i,k,m,fluxntot/(cs(i,k)*dz(i,k)) + endif +#endif + endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) + + else ! i.e: cldn(i,k) < 0.01_r8 + + ! no liquid cloud + + nsource(i,k) = nsource(i,k) - qcld(k)*dtinv + qcld(k) = 0.0_r8 + + if (cldn(i,k) < 0.01_r8) then + ! no ice cloud either + + ! convert activated aerosol to interstitial in decaying cloud + + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) +#ifdef EXTRATESTS + if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then + print*,"no cloud", k, raercol(k,mm,nsav) , raercol_cw(k,mm,nsav) + endif +#endif + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + end do + end do + end if + end if + + end do ! old_cloud_main_k_loop + + ! switch nsav, nnew so that nnew is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + + ! load new droplets in layers above, below clouds + + dtmin = dtmicro + ekk(top_lev-1) = 0.0_r8 + ekk(pver) = 0.0_r8 + do k = top_lev, pver-1 + ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface + ! want ekk(k) = ekd(k) * (density at k/k+1 interface) + ! so use pint(i,k+1) as pint is 1:pverp + ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) + ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) + ekk(k) = ekd(k)*csbot(k) + end do + + do k = top_lev, pver + km1 = max0(k-1, top_lev) + ekkp(k) = zn(k)*ekk(k)*zs(k) + ekkm(k) = zn(k)*ekk(k-1)*zs(km1) + tinv = ekkp(k) + ekkm(k) + + ! rce-comment -- tinv is the sum of all first-order-loss-rates + ! for the layer. for most layers, the activation loss rate + ! (for interstitial particles) is accounted for by the loss by + ! turb-transfer to the layer above. + ! k=pver is special, and the loss rate for activation within + ! the layer must be added to tinv. if not, the time step + ! can be too big, and explmix can produce negative values. + ! the negative values are reset to zero, resulting in an + ! artificial source. + if (k == pver) tinv = tinv + taumix_internal_pver_inv + + if (tinv .gt. 1.e-6_r8) then + dtt = 1._r8/tinv + dtmin = min(dtmin, dtt) + end if + end do + + dtmix = 0.9_r8*dtmin + nsubmix = dtmicro/dtmix + 1 + if (nsubmix > 100) then + nsubmix_bnd = 100 + else + nsubmix_bnd = nsubmix + end if + count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 + dtmix = dtmicro/nsubmix + + do k = top_lev, pver + kp1 = min(k+1, pver) + km1 = max(k-1, top_lev) + ! maximum overlap assumption + if (cldn(i,kp1) > 1.e-10_r8) then + overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) + else + overlapp(k) = 1._r8 + end if + if (cldn(i,km1) > 1.e-10_r8) then + overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) + else + overlapm(k) = 1._r8 + end if + end do + + + ! rce-comment + ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) + ! should not exceed the rate of transfer of unactivated particles + ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) + ! however it might if things are not "just right" in subr activate + ! the following is a safety measure to avoid negatives in explmix + do k = top_lev, pver-1 + do m = 1, ntot_amode + nact(k,m) = min( nact(k,m), ekkp(k) ) + mact(k,m) = min( mact(k,m), ekkp(k) ) + end do + end do + +!Don't need the mixing per mode in OSLO_AERO ==> only per tracer +!Note that nsav/nnew is switched above, so operate on nnew here +!nnew is the updated aerosol +#ifdef OSLO_AERO + raercol_tracer(:,:,:) = 0.0_r8 + raercol_cw_tracer(:,:,:) = 0.0_r8 + mact_tracer(:,:) = 0.0_r8 + mfullact_tracer(:,:) = 0.0_r8 + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about + lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers + mm = mam_idx(m,l) + raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & + + raercol(:,mm,nnew) + + raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& + + raercol_cw(:,mm,nnew) + + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) + mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) + +#ifdef EXTRATESTS + if(lptr.eq.lDebug .and. i.eq.iDebug)then + do k=pver,top_lev,-1 + print*, "assigning to tracer space",lptr, raercol(k,mm,nnew) & + , raercol_tracer(k,lptr2,nnew) & + , raercol_cw(k,mm,nnew) & + , raercol_cw_tracer(k,lptr2,nnew) + end do + end if +#endif + end do !l + end do !m + + do lptr2=1,n_aerosol_tracers + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & + /(mfullact_tracer(:,lptr2) + smallNumber) + end do +#endif OSLO_AERO + + ! old_cloud_nsubmix_loop + do n = 1, nsubmix + qncld(:) = qcld(:) + ! switch nsav, nnew so that nsav is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + srcn(:) = 0.0_r8 + + !First mix cloud droplet number concentration + do m = 1, ntot_amode + mm = mam_idx(m,0) + + ! update droplet source + ! rce-comment- activation source in layer k involves particles from k+1 + ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) + srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + + ! rce-comment- new formulation for k=pver + ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) + end do + + !mixing of cloud droplets + call explmix( & + qcld, srcn, ekkp, ekkm, overlapp, & + overlapm, qncld, zero, zero, pver, & + dtmix, .false.) + +#ifdef OSLO_AERO + !Mix number concentrations consistently!! + do m = 1, ntot_amode + mm = mam_idx(m,0) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment - new formulation for k=pver + ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + end do +#endif + +#ifndef OSLO_AERO + ! rce-comment + ! the interstitial particle mixratio is different in clear/cloudy portions + ! of a layer, and generally higher in the clear portion. (we have/had + ! a method for diagnosing the the clear/cloudy mixratios.) the activation + ! source terms involve clear air (from below) moving into cloudy air (above). + ! in theory, the clear-portion mixratio should be used when calculating + ! source terms + do m = 1, ntot_amode + mm = mam_idx(m,0) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment - new formulation for k=pver + ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= mact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = mact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment- new formulation for k=pver + ! source( pver )= mact( pver ,m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*mact(pver,m) & + + raercol_cw(pver,mm,nsav)*(mact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & + raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw(:,mm,nsav)) + + end do + end do +#endif + if (called_from_spcam) then + ! + ! turbulent mixing for gas species . + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + flxconv = 0.0_r8 + zerogas(:) = 0.0_r8 + call explmix(rgascol(1,m,nnew),zerogas,ekkp,ekkm,overlapp,overlapm, & + rgascol(1,m,nsav),zero, flxconv, pver,dtmix,& + .true., zerogas) + end if + end do + endif + +#ifdef OSLO_AERO + do lptr2=1,n_aerosol_tracers + source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & + *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) + + tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & + + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) + + source(pver) = max(0.0_r8, tmpa) + flxconv = 0.0_r8 + + call explmix( & + raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) + +#ifdef EXTRATESTS + lptr = aerosolTracerList(lptr2) + if(i.eq.iDebug .and. lptr.eq.lDebug)then + print*, "bugeds for ",trim(cnst_name(lptr)), n, nsubmix + do k=pver,1,-1 + print*, "source (aerosol/cloud) ",k, raercol_cw_tracer(k,lptr2,nnew),raercol_cw_tracer(k,lptr2,nsav) & + , raercol_tracer(k,lptr2,nnew),raercol_tracer(k,lptr2,nsav),source(k) + end do + if(m .le. nbmodes)then + print*, " ", mm, lptr, componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif + endif +#endif + end do !Number of aerosol tracers + end do ! old_cloud_nsubmix_loop + + !Set back to the original framework + !Could probably continue in tracer-space from here + !but return back to mixture for easier use of std. NCAR code + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l=1,nspec_amode(m) + mm=mam_idx(m,l) + lptr = getTracerIndex(m,l,.FALSE.) + lptr2 = inverseAerosolTracerList(lptr) + !All the tracer-space contains sum of all + !modes ==> put in first available component + !and zero in others. + if(.not.tendencyCounted(lptr))then + raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) + raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) + tendencyCounted(lptr) = .TRUE. + else + raercol(:,mm,nnew) = 0.0_r8 + raercol_cw(:,mm,nnew) = 0.0_r8 + end if + end do + end do +#endif + ! evaporate particles again if no cloud + + do k = top_lev, pver + if (cldn(i,k) == 0._r8) then + ! no ice or liquid cloud + qcld(k)=0._r8 + + ! convert activated aerosol to interstitial in decaying cloud + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + end do + end do + end if + end do + + ! droplet number + + ndropcol(i) = 0._r8 + + !Initialize tendnd to zero in all layers since values are set in only top_lev,pver + !Without this the layers above top_lev would be un-initialized + tendnd(i,:) = 0.0_r8 + + do k = top_lev, pver + ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) + tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv + !print*, "tendnd",i,k, "new /old/tend", qcld(k), ncldwtr(i,k), tendnd(i,k) + ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) + end do + ndropcol(i) = ndropcol(i)/gravit + +#ifdef EXTRATESTS + print*, "tendnd (#/kg/sec)", minval(tendnd(i,:)), maxval(tendnd(i,:)) +#endif + + if (prog_modal_aero) then + +#ifdef OSLO_AERO + +#ifdef MASS_BALANCE_CHECK + !test for correct transfer between in-cloud / no-cloud.. + newCloud(:,:) = 0.0_r8 + oldCloud(:,:) = 0.0_r8 + newAerosol(:,:) = 0.0_r8 + oldAerosol(:,:) = 0.0_r8 + deltaCloud(:,:) = 0.0_r8 + !Check mass balances #2 (all new cloud droplet species are taken from aerosols or from layer below + do k=pver,1,-1 + mixRatioToMass = cs(i,k)*dz(i,k) + !First sum up cloud tracer in this layer + tendencyCounted(:)=.FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) !lptr occurs several times + newCloud(k, lptr) = newCloud(k, lptr) + raercol_cw(k, mm, nnew)*mixRatioToMass + newAerosol(k, lptr) = newAerosol(k, lptr) + raercol(k,mm,nnew)*mixRatioToMass + if(.NOT. tendencyCounted(lptr))then + oldAerosol(k, lptr) = raer(mm)%fld(i,k)*mixRatioToMass + oldCloud(k, lptr) = qqcw(mm)%fld(i,k)*mixRatioToMass + tendencyCounted(lptr)=.TRUE. + endif + enddo + enddo + enddo! k + + k = pver + !Check imbalance in bottom layer + + !Any change in cloud species is either from aerosol concentration or from change in layer below + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + + !This is the mass which must go to layer above! + deltaCloud(k,lptr) = (oldAerosol(k,lptr) - newAerosol(k,lptr)) &!used to create cloud species + -(newCloud(k,lptr) - oldCloud(k,lptr)) !created cloud species + enddo + enddo + + !if "deltaCloud" is positive in layer below it means that some aerosol species were sent up + + !Move upwards + do k=pver-1,1,-1 + kp1 = k + 1 + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + deltaCloud(k,lptr) = (oldAerosol(k,lptr)-newAerosol(k,lptr)) & !used to create cloud species + - (newCloud(k,lptr) - oldCloud(k,lptr)) & !created cloud species + - 0.0_r8 ! deltaCloud(kp1,lptr) !species received from below + enddo + enddo + enddo !layers + + stopMe = .FALSE. + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr= getTracerIndex(m,l,.false.) + if(abs(sum(deltaCloud(:,lptr))) > 1.e-8_r8 .and. (.NOT. tendencyCounted(lptr)))then + stopMe = .TRUE. + lptr2 = lptr + print*, "wrong mass budget",i,lptr,cnst_name(lptr), sum(deltaCloud(:,lptr)) + endif + tendencyCounted(lptr) = .TRUE. + enddo + enddo + if(stopMe)then + print*,"error in species : ", cnst_name(lptr2) + do k=pver,1,-1 + print*, "budgets new/old ",k, newCloud(k,lptr2),oldCloud(k,lptr2),newaerosol(k,lptr2),oldAerosol(k,lptr2), deltaCloud(k,lptr2) + enddo + call endrun ("wrong mass budget in column") + endif +#endif +#endif + raertend = 0._r8 + qqcwtend = 0._r8 + + +#ifndef OSLO_AERO + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + + mm = mam_idx(m,l) + lptr = mam_cnst_idx(m,l) + + raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv + qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv + + coltend(i,mm) = sum( pdel(i,:)*raertend )/gravit + coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit + + ptend%q(i,:,lptr) = 0.0_r8 + ptend%q(i,top_lev:pver,lptr) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol + qqcw(mm)%fld(i,:) = 0.0_r8 + qqcw(mm)%fld(i,top_lev:pver) = raercol_cw(top_lev:pver,mm,nnew) ! update cloud-borne aerosol + end do + end do +#else + !OSLO AEROSOLS ... + + coltend_cw(i,:)=0.0_r8 + coltend(i,:) = 0.0_r8 + + !Need to initialize first because process modes arrive several times + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l = 1,getNumberOfTracersInMode(m) + lptr = getTracerIndex(m,l,.false.) + mm = mam_idx(m,l) + + !column tendencies for output + if(.NOT. tendencyCounted(lptr))then + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, + - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total + tendencyCounted(lptr) = .TRUE. + else !Already subtracted total old value, just add new + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted + end if + + ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies + qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones + end do ! Tracers + end do ! Modes + + !First, sum up all the tracer mass concentrations + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays + lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) + + !This is a bit tricky since in our scheme the tracers can arrive several times + !the same tracer can exist in several modes, e.g. condensate!! + !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers + + !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes + + !Tendency at this point is the sum (original value subtracted below) + ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) + !for cloud water concentrations, we don't get tendency , only new concentration + qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) + + end do + end do + + !Need this check due to some tracers (e.g. condensate) several times + tendencyCounted(:) = .FALSE. + + ! Recalculating cloud-borne aerosol number mixing ratios + do m=1,ntot_amode + + !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies + do l= 1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr)) then + ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv + coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency + tendencyCounted(lptr) = .TRUE. + endif + end do !species + end do !modes +#endif + +#ifdef MASS_BALANCE_CHECK + !Check mass balances (all removed should be in tendencies) + massBalance(:,:) = 0.0_r8 + newMass(:,:) = 0.0_r8 + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) !unique index, for example sulfate condendsate in "x mode" or sulf cond in "y mode" + lptr = getTracerIndex(m,l,.false.) + !add up all new values for this tracer + newMass(top_lev:pver,lptr) = newMass(top_lev:pver,lptr) + raercol(top_lev:pver, mm,nnew) + enddo + enddo + tendencyCounted(:)=.FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr))then + massBalance(top_lev:pver, lptr) = newMass(top_lev:pver,lptr) & + - raer(mm)%fld(i,top_lev:pver) & !previous value + - ptend%q(i,top_lev:pver,lptr)/dtinv !added during time step + tendencyCounted(lptr) = .TRUE. + endif + enddo + enddo + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.false.) + !Check for large deviation in mass balance for this tracer + if(.NOT. tendencyCounted(lptr) .and. & + (maxval(massBalance(:,lptr)) > 1.e-30_r8 .or. minval(massBalance(:,lptr)) < -1.0e-30_r8))then + tendencyCounted(lptr) = .TRUE. + print*, "massBalance error", i, lptr, maxVal(massBalance(:,lptr)), minVal(massBalance(:,lptr)) + if(maxVal(massBalance(:,lptr)) > 1.e-30_r8)then + kCrit = maxLoc(massBalance(:,lptr),1) + else + kCrit = minLoc(massBalance(:,lptr),1) + endif + print*, "massBalance error loc", massBalance(kCrit, lptr), newMass(kCrit,lptr), raer(mm)%fld(i,kCrit) + !If mass balance error is larger than 1.e-10 times new or original value ==> stop + if(abs(massBalance(kCrit,lptr)) .gt. 1.e-10_r8*raer(mm)%fld(i,kCrit) & + .and. abs(massBalance(kCrit,lptr)).gt.1.e-10_r8*newMass(kCrit,lptr) )then + stop + endif + endif + enddo + enddo +#endif + + + end if !prog_modal_aero + + if (called_from_spcam) then + ! + ! Gas tendency + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + ptend%lq(m) = .true. + ptend%q(i, :, m) = (rgascol(:,m,nnew)-rgas(i,:,m)) * dtinv + end if + end do + endif + + end do ! overall_main_i_loop + +#ifdef EXTRATESTS + !check reasonable values for ncldwtr! + do k=top_lev,pver + if(maxval(ncldwtr(:ncol,k)) .gt. 1.e20_r8)then + print*, "stopping (after dropmixnuc) wrong ncldwtr", maxloc(ncldwtr(:ncol,k)) + do i=1,ncol + print*, "ncldwtr",i,k,ncldwtr(i,k) + enddo + call endrun("wrong ncldwtr (end of dropmixnuc)") + end if + end do !loop on layers +#endif + + ! end of main loop over i/longitude .................................... + + call outfld('NDROPCOL', ndropcol, pcols, lchnk) + call outfld('NDROPSRC', nsource, pcols, lchnk) + call outfld('NDROPMIX', ndropmix, pcols, lchnk) + call outfld('WTKE ', wtke, pcols, lchnk) + +#ifndef OSLO_AERO + !fxm: Make this work with the oslo aerosols also! + call ccncalc(state, pbuf, cs, ccn) +#else + call ccncalc_oslo(state & + , pbuf & + , cs & + , numberConcentration & + , volumeConcentration & + , hygroscopicity & + , lnSigma & + , ccn ) +#endif + do l = 1, psat + call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + enddo + +#ifndef OSLO_AERO + ! do column tendencies + if (prog_modal_aero) then + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + mm = mam_idx(m,l) + call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) + end do + end do + end if +#endif + + if(called_from_spcam) then + ! + ! output column-integrated Gas tendency (this should be zero) + ! + do m=1, pcnst + if (cnst_species_class(m) == cnst_spec_class_gas) then + do i=1, ncol + coltendgas(i) = sum( pdel(i,:)*ptend%q(i,:,m) )/gravit + end do + fieldnamegas = trim(cnst_name(m)) // '_mixnuc1sp' + call outfld( trim(fieldnamegas), coltendgas, pcols, lchnk) + end if + end do + deallocate(rgascol, coltendgas) + end if + +#ifdef OSLO_AERO + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr))then + call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) + tendencyCounted(lptr)=.TRUE. + endif + end do + end do +#endif + + deallocate( & + nact, & + mact, & + raer, & + qqcw, & + raercol, & + raercol_cw, & + coltend, & + coltend_cw, & + naermod, & + hygro, & +#ifdef OSLO_AERO + lnsigman, & !Variable std. dev (CAM-Oslo) +#endif + vaerosol, & + fn, & + fm, & + fluxn, & + fluxm ) + +#ifdef OSLO_AERO + deallocate (fluxm_tmp) + deallocate (fluxn_tmp) + deallocate (fm_tmp) + deallocate (fn_tmp) + deallocate(raercol_tracer) + deallocate(raercol_cw_tracer) + deallocate(mact_tracer) + deallocate(mfullact_tracer) +#endif + + +end subroutine dropmixnuc + +!=============================================================================== + +subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & + qold, surfrate, flxconv, pver, dt, is_unact, qactold ) + + ! explicit integration of droplet/aerosol mixing + ! with source due to activation/nucleation + + + integer, intent(in) :: pver ! number of levels + real(r8), intent(out) :: q(pver) ! mixing ratio to be updated + real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step + real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) + real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! below layer k (k,k+1 interface) + real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! above layer k (k,k+1 interface) + real(r8), intent(in) :: overlapp(pver) ! cloud overlap below + real(r8), intent(in) :: overlapm(pver) ! cloud overlap above + real(r8), intent(in) :: surfrate ! surface exchange rate (/s) + real(r8), intent(in) :: flxconv ! convergence of flux from surface + real(r8), intent(in) :: dt ! time step (s) + logical, intent(in) :: is_unact ! true if this is an unactivated species + real(r8), intent(in),optional :: qactold(pver) + ! mixing ratio of ACTIVATED species from previous step + ! *** this should only be present + ! if the current species is unactivated number/sfc/mass + + integer k,kp1,km1 + + if ( is_unact ) then + ! the qactold*(1-overlap) terms are resuspension of activated material + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & + qactold(kp1)*(1.0_r8-overlapp(k))) & + + ekkm(k)*(qold(km1) - qold(k) + & + qactold(km1)*(1.0_r8-overlapm(k))) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do + + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + ! endif + else + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & + ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + + end if + +end subroutine explmix + +!=============================================================================== + +subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + na, nmode, volume, hygro, & + fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) + + ! calculates number, surface, and mass fraction of aerosols activated as CCN + ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud + ! assumes an internal mixture within each of up to nmode multiple aerosol modes + ! a gaussiam spectrum of updrafts can be treated. + + ! mks units + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + + ! input + + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8), intent(in) :: tair ! air temperature (K) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) + integer, intent(in) :: nmode ! number of aerosol modes + real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), intent(in), optional :: lnsigman(:) + + ! output + + real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + ! rce-comment + ! used for consistency check -- this should match (ekd(k)*zs(k)) + ! also, fluxm/flux_fullact gives fraction of aerosol mass flux + ! that is activated + + ! local + + integer, parameter:: nx=200 + integer iquasisect_option, isectional + real(r8) integ,integf + real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) + real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces + real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces + real(r8) tmass ! total aerosol mass concentration (g/cm3) + real(r8) sign(nmode) ! geometric standard deviation of size distribution + real(r8) rm ! number mode radius of aerosol at max supersat (cm) + real(r8) pres ! pressure (Pa) + real(r8) path ! mean free path (m) + real(r8) diff ! diffusivity (m2/s) + real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) + real(r8) diff0,conduct0 + real(r8) es ! saturation vapor pressure + real(r8) qs ! water vapor saturation mixing ratio + real(r8) dqsdt ! change in qs with temperature + real(r8) dqsdp ! change in qs with pressure + real(r8) g ! thermodynamic function (m2/s) + real(r8) zeta(nmode), eta(nmode) + real(r8) lnsmax ! ln(smax) + real(r8) alpha + real(r8) gamma + real(r8) beta + real(r8) sqrtg + real(r8) :: amcube(nmode) ! cube of dry mode radius (m) + !++alfgr (ununsed) real(r8) :: smcrit(nmode) ! critical supersatuation for activation + real(r8) :: lnsm(nmode) ! ln(smcrit) + real(r8) smc(nmode) ! critical supersaturation for number mode radius + real(r8) sumflx_fullact + real(r8) sumflxn(nmode) + real(r8) sumflxm(nmode) + real(r8) sumfn(nmode) + real(r8) sumfm(nmode) + real(r8) fnold(nmode) ! number fraction activated + real(r8) fmold(nmode) ! mass fraction activated + real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) + real(r8), target :: f1_var(nmode), f2_var(nmode) + real(r8) wold,gold + real(r8) alogam + real(r8) rlo,rhi,xint1,xint2,xint3,xint4 + real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb + real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar + real(r8) alw,sqrtalw + real(r8) smax + real(r8) x,arg + real(r8) xmincoeff,xcut,volcut,surfcut + real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf + real(r8) etafactor1,etafactor2(nmode),etafactor2max + real(r8) grow + character(len=*), parameter :: subname='activate_modal' + integer m,n + ! numerical integration parameters + real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 + + real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) + + integer ndist(nx) ! accumulates frequency distribution of integration bins required + data ndist/nx*0/ + save ndist + + fn(:)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact=0._r8 + + if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return + + if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return + + pres=rair*rhoair*tair + diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 + conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + call qsat(tair, pres, es, qs) + dqsdt=latvap/(rh2o*tair*tair)*qs + alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) + gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) + etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. + + grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & + + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) + sqrtg = sqrt(grow) + beta = 2._r8*pi*rhoh2o*grow*gamma + + do m=1,nmode + + if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then + ! number mode radius (m) + ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) +#ifdef OSLO_AERO + if(present(lnsigman))then + 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 + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + else + call endrun("Problem with variable std. dev") + endif +#else + !Std cam + amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig(m)*na(m))) ! only if variable size dist +#endif + ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 + ! should depend on mean radius of mode to account for gas kinetic effects + ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 + ! for approriate size to use for effective diffusivity. + etafactor2(m)=1._r8/(na(m)*beta*sqrtg) + if(hygro(m).gt.1.e-10_r8)then + smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist + else + smc(m)=100._r8 + endif + ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) + else + smc(m)=1._r8 + etafactor2(m)=etafactor2max ! this should make eta big if na is very small. + endif + lnsm(m)=log(smc(m)) ! only if variable size dist + ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & + ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) + enddo + + if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts + + wmax=min(wmaxf,wbar+sds*sigw) + wmin=max(wminf,-wdiab) + wmin=max(wmin,wbar-sds*sigw) + w=wmin + dwmax=eps*sigw + dw=dwmax + dfmax=0.2_r8 + dfmin=0.1_r8 + if (wmax <= w) return + do m=1,nmode + sumflxn(m)=0._r8 + sumfn(m)=0._r8 + fnold(m)=0._r8 + sumflxm(m)=0._r8 + sumfm(m)=0._r8 + fmold(m)=0._r8 + enddo + sumflx_fullact=0._r8 + + fold=0._r8 + wold=0._r8 + gold=0._r8 + + dwmin = min( dwmax, 0.01_r8 ) + do n = 1, nx + +100 wnuc=w+wdiab + ! write(iulog,*)'wnuc=',wnuc + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + enddo + + call maxsat(zeta,eta,nmode,smc,smax & +#ifdef OSLO_AERO + ,f1_var, f2_var & +#endif + ) + ! write(iulog,*)'w,smax=',w,smax + + lnsmax=log(smax) + +#ifdef OSLO_AERO + x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) +#else + x=twothird*(lnsm(nmode)-lnsmax)/(sq2*alogsig(nmode)) +#endif + fnew=0.5_r8*(1._r8-erf(x)) + + + dwnew = dw + if(fnew-fold.gt.dfmax.and.n.gt.1)then + ! reduce updraft increment for greater accuracy in integration + if (dw .gt. 1.01_r8*dwmin) then + dw=0.7_r8*dw + dw=max(dw,dwmin) + w=wold+dw + go to 100 + else + dwnew = dwmin + endif + endif + + if(fnew-fold.lt.dfmin)then + ! increase updraft increment to accelerate integration + dwnew=min(1.5_r8*dw,dwmax) + endif + fold=fnew + + z=(w-wbar)/(sigw*sq2) + g=exp(-z*z) + fnmin=1._r8 + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 + + do m=1,nmode + ! modal +#ifdef OSLO_AERO + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) +#else + x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) +#endif + fn(m)=0.5_r8*(1._r8-erf(x)) + fnmin=min(fn(m),fnmin) + ! integration is second order accurate + ! assumes linear variation of f*g with w + fnbar=(fn(m)*g+fnold(m)*gold) +#ifdef OSLO_AERO + arg=x-1.5_r8*sq2*lnsigman(m) +#else + arg=x-1.5_r8*sq2*alogsig(m) +#endif + fm(m)=0.5_r8*(1._r8-erf(arg)) + fmbar=(fm(m)*g+fmold(m)*gold) + wb=(w+wold) + if(w.gt.0._r8)then + sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & + +(fn(m)*g*w+fnold(m)*gold*wold))*dw + sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & + +(fm(m)*g*w+fmold(m)*gold*wold))*dw + endif + sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw + ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw + fnold(m)=fn(m) + sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw + fmold(m)=fm(m) + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact & + + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw + ! sumg=sumg+0.5_r8*(g+gold)*dw + gold=g + wold=w + dw=dwnew + if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit + w=w+dw + if (n == nx) then + write(iulog,*)'do loop is too short in activate' + write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw + write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab + write(iulog,*)'wnuc=',wnuc + write(iulog,*)'na=',(na(m),m=1,nmode) + write(iulog,*)'fn=',(fn(m),m=1,nmode) + ! dump all subr parameters to allow testing with standalone code + ! (build a driver that will read input and call activate) + write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' + write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode + write(iulog,*)'na=',na + write(iulog,*)'volume=', (volume(m),m=1,nmode) + write(iulog,*)'hydro=' + write(iulog,*) hygro + call endrun(subname) + end if + + enddo + + ndist(n)=ndist(n)+1 + if(w.lt.wmaxf)then + + ! contribution from all updrafts stronger than wmax + ! assuming constant f (close to fmax) + wnuc=w+wdiab + + z1=(w-wbar)/(sigw*sq2) + z2=(wmaxf-wbar)/(sigw*sq2) + g=exp(-z1*z1) + integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) + ! consider only upward flow into cloud base when estimating flux + wf1=max(w,zero) + zf1=(wf1-wbar)/(sigw*sq2) + gf1=exp(-zf1*zf1) + wf2=max(wmaxf,zero) + zf2=(wf2-wbar)/(sigw*sq2) + gf2=exp(-zf2*zf2) + gf=(gf1-gf2) + integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf + + do m=1,nmode + sumflxn(m)=sumflxn(m)+integf*fn(m) + sumfn(m)=sumfn(m)+fn(m)*integ + sumflxm(m)=sumflxm(m)+integf*fm(m) + sumfm(m)=sumfm(m)+fm(m)*integ + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact + integf + ! sumg=sumg+integ + endif + + + do m=1,nmode + fn(m)=sumfn(m)/(sq2*sqpi*sigw) + ! fn(m)=sumfn(m)/(sumg) + if(fn(m).gt.1.01_r8)then + write(iulog,*)'fn=',fn(m),' > 1 in activate' + write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) + write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw + call endrun('activate') + endif + fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) + fm(m)=sumfm(m)/(sq2*sqpi*sigw) + ! fm(m)=sumfm(m)/(sumg) + if(fm(m).gt.1.01_r8)then + write(iulog,*)'fm=',fm(m),' > 1 in activate' + endif + fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) + enddo + ! same form as fluxm + flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) + + else + + ! single updraft + wnuc=wbar+wdiab + + if(wnuc.gt.0._r8)then + + w=wbar + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + enddo + + call maxsat(zeta,eta,nmode,smc,smax & +#ifdef OSLO_AERO + ,f1_var, f2_var & +#endif + ) + + lnsmax=log(smax) + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 + + + do m=1,nmode +#ifdef OSLO_AERO + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) +#else + x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) +#endif + fn(m)=0.5_r8*(1._r8-erf(x)) +#ifdef OSLO_AERO + arg=x-1.5_r8*sq2*lnsigman(m) +#else + arg=x-1.5_r8*sq2*alogsig(m) +#endif + fm(m)=0.5_r8*(1._r8-erf(arg)) + if(wbar.gt.0._r8)then + fluxn(m)=fn(m)*w + fluxm(m)=fm(m)*w + endif + enddo + flux_fullact = w + endif + + endif + +end subroutine activate_modal + +!=============================================================================== + +subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) + + ! calculates maximum supersaturation for multiple + ! competing aerosol modes. + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + integer, intent(in) :: nmode ! number of modes + real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + real(r8), intent(in) :: zeta(nmode) + real(r8), intent(in) :: eta(nmode) + real(r8), intent(in), optional, target :: f1_in(:) + real(r8), intent(in), optional, target :: f2_in(:) + + real(r8), intent(out) :: smax ! maximum supersaturation + integer :: m ! mode index + real(r8) :: sum, g1, g2, g1sqrt, g2sqrt + real(r8), pointer :: f1_used(:), f2_used(:) + +#ifdef OSLO_AERO + f1_used => f1_in + f2_used => f2_in +#else + f1_used => f1 + f2_used => f2 +#endif + + + do m=1,nmode + if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then + ! weak forcing. essentially none activated + smax=1.e-20_r8 + else + ! significant activation of this mode. calc activation all modes. + exit + endif + ! No significant activation in any mode. Do nothing. + if (m == nmode) return + + enddo + + sum=0.0_r8 + do m=1,nmode + if(eta(m).gt.1.e-20_r8)then + g1=zeta(m)/eta(m) + g1sqrt=sqrt(g1) + g1=g1sqrt*g1 + g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) + g2sqrt=sqrt(g2) + g2=g2sqrt*g2 + sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) + else + sum=1.e20_r8 + endif + enddo + + smax=1._r8/sqrt(sum) + +end subroutine maxsat + +!=============================================================================== + +#ifndef OSLO_AERO +subroutine ccncalc(state, pbuf, cs, ccn) + + ! calculates number concentration of aerosols activated as CCN at + ! supersaturation supersat. + ! assumes an internal mixture of a multiple externally-mixed aerosol modes + ! cgs units + + ! Ghan et al., Atmos. Res., 1993, 198-221. + + ! arguments + + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + + real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) + real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) + + ! local + + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8), pointer :: tair(:,:) ! air temperature (K) + + real(r8) naerosol(pcols) ! interstit+activated aerosol number conc (/m3) + real(r8) vaerosol(pcols) ! interstit+activated aerosol volume conc (m3/m3) + + real(r8) amcube(pcols) + real(r8) super(psat) ! supersaturation + real(r8), allocatable :: amcubecoef(:) + real(r8), allocatable :: argfactor(:) + real(r8) :: surften ! surface tension of water w/respect to air (N/m) + real(r8) surften_coef + real(r8) a(pcols) ! surface tension parameter + real(r8) hygro(pcols) ! aerosol hygroscopicity + real(r8) sm(pcols) ! critical supersaturation at mode radius + real(r8) arg(pcols) + ! mathematical constants + real(r8) twothird,sq2 + integer l,m,n,i,k + real(r8) log,cc + real(r8) smcoefcoef,smcoef(pcols) + integer phase ! phase of aerosol + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + tair => state%t + + allocate( & + amcubecoef(ntot_amode), & + argfactor(ntot_amode) ) + + super(:)=supersat(:)*0.01_r8 + sq2=sqrt(2._r8) + twothird=2._r8/3._r8 + surften=0.076_r8 + surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + smcoefcoef=2._r8/sqrt(27._r8) + + do m=1,ntot_amode + amcubecoef(m)=3._r8/(4._r8*pi*exp45logsig(m)) + argfactor(m)=twothird/(sq2*alogsig(m)) + end do + + ccn = 0._r8 + do k=top_lev,pver + + do i=1,ncol + a(i)=surften_coef/tair(i,k) + smcoef(i)=smcoefcoef*a(i)*sqrt(a(i)) + end do + + do m=1,ntot_amode + + phase=3 ! interstitial+cloudborne + + call loadaer( & + state, pbuf, 1, ncol, k, & + m, cs, phase, naerosol, vaerosol, & + hygro) + + where(naerosol(:ncol)>1.e-3_r8) + amcube(:ncol)=amcubecoef(m)*vaerosol(:ncol)/naerosol(:ncol) + sm(:ncol)=smcoef(:ncol)/sqrt(hygro(:ncol)*amcube(:ncol)) ! critical supersaturation + elsewhere + sm(:ncol)=1._r8 ! value shouldn't matter much since naerosol is small + endwhere + do l=1,psat + do i=1,ncol + arg(i)=argfactor(m)*log(sm(i)/super(l)) + ccn(i,k,l)=ccn(i,k,l)+naerosol(i)*0.5_r8*(1._r8-erf(arg(i))) + enddo + enddo + enddo + enddo + ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + + deallocate( & + amcubecoef, & + argfactor ) + +end subroutine ccncalc + +#else + +subroutine ccncalc_oslo(state & + , pbuf & + , cs & + , numberConcentration & + , volumeConcentration & + , hygroscopicity & + , lnSigma & + , ccn ) + + ! calculates number concentration of aerosols activated as CCN at + ! supersaturation supersat. + ! assumes an internal mixture of a multiple externally-mixed aerosol modes + ! cgs units + + ! This was used in the BACCHUS-project where it was agreed that + ! CCN would not include cloud-borne aerosols. It is possible to + ! calculate cloud-borne aerosols, but it is complicated, and it was + ! not needed when this code was made. + + ! arguments + + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) + real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) + real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) + real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) + + ! local + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8), pointer :: tair(:,:) ! air temperature (K) + + + real(r8) super(psat) ! supersaturation + real(r8) surften_coef !Coefficient in ARGI / ARGII + real(r8) amcube !number median radius qubed + real(r8) a ! surface tension parameter + real(r8) sm ! critical supersaturation at mode radius + real(r8) arg ! factor in eqn 15 ARGII + real(r8) argfactor !Coefficient in ARGI/ARGII + ! mathematical constants + real(r8), parameter:: twothird=2.0_r8/3.0_r8 + real(r8), parameter:: sq2=sqrt(2.0_r8) + real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) + real(r8) exp45logsig_var + integer lsat,m,i,k + real(r8) smcoefcoef,smcoef + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + tair => state%t + + super(:)=supersat(:)*0.01_r8 + + !This is curvature effect (A) in ARGI + !eqn 5 in ARG1 (missing division by temperature, see below) + surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoefcoef=2._r8/sqrt(27._r8) + + ccn(:,:,:) = 0._r8 + + do m=1,nmodes + do k=top_lev,pver + + do i=1,ncol + + !Curvature-parameter "A" in ARGI (eqn 5) + a = surften_coef/tair(i,k) + + !standard factor for transforming size distr + !volume ==> number (google psd.pdf by zender) + exp45logsig_var = & + exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) + + !Numbe rmedian radius (power of three) + !By definition of lognormal distribution + amcube =(3._r8*volumeConcentration(i,k,m) & +!tht is zero an allowed value for numberConcentration?? + /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist + + + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoef = smcoefcoef * a * sqrt(a) + + !This is finally solving eqn 9 + !(solve for critical supersat of mode) + sm=smcoef & + / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation + + !Solve eqn 13 in ARGII + do lsat = 1,psat + + !eqn 15 in ARGII + argfactor=twothird/(sq2*lnSigma(i,k,m)) + + !eqn 15 in ARGII + arg=argfactor*log(sm/super(lsat)) + + !eqn 13 i ARGII + ccn(i,k,lsat)=ccn(i,k,lsat) & + +numberConcentration(i,k,m)& + *0.5_r8*(1._r8-erf(arg)) + end do + end do + end do + end do + + ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + +end subroutine ccncalc_oslo +#endif + +!=============================================================================== + +subroutine loadaer( & + state, pbuf, istart, istop, k, & + m, cs, phase, naerosol, & + vaerosol, hygro) + + ! return aerosol number, volume concentrations, and bulk hygroscopicity + + ! input arguments + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + integer, intent(in) :: istart ! start column index (1 <= istart <= istop <= pcols) + integer, intent(in) :: istop ! stop column index + integer, intent(in) :: m ! mode index + integer, intent(in) :: k ! level index + real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) + integer, intent(in) :: phase ! phase of aerosol: 1 for interstitial, 2 for cloud-borne, 3 for sum + + ! output arguments + real(r8), intent(out) :: naerosol(:) ! number conc (1/m3) + real(r8), intent(out) :: vaerosol(:) ! volume conc (m3/m3) + real(r8), intent(out) :: hygro(:) ! bulk hygroscopicity of mode + + ! internal + integer :: lchnk ! chunk identifier + + real(r8), pointer :: raer(:,:) ! interstitial aerosol mass, number mixing ratios + real(r8), pointer :: qqcw(:,:) ! cloud-borne aerosol mass, number mixing ratios + real(r8) :: specdens, spechygro + + real(r8) :: vol(pcols) ! aerosol volume mixing ratio + integer :: i, l + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + + do i = istart, istop + vaerosol(i) = 0._r8 + hygro(i) = 0._r8 + end do + + do l = 1, nspec_amode(m) + + call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer) + call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw) + call rad_cnst_get_aer_props(0, m, l, density_aer=specdens, hygro_aer=spechygro) + + if (phase == 3) then + do i = istart, istop + vol(i) = max(raer(i,k) + qqcw(i,k), 0._r8)/specdens + end do + else if (phase == 2) then + do i = istart, istop + vol(i) = max(qqcw(i,k), 0._r8)/specdens + end do + else if (phase == 1) then + do i = istart, istop + vol(i) = max(raer(i,k), 0._r8)/specdens + end do + else + write(iulog,*)'phase=',phase,' in loadaer' + call endrun('phase error in loadaer') + end if + + do i = istart, istop + vaerosol(i) = vaerosol(i) + vol(i) + hygro(i) = hygro(i) + vol(i)*spechygro + end do + + end do + + do i = istart, istop + if (vaerosol(i) > 1.0e-30_r8) then ! +++xl add 8/2/2007 + hygro(i) = hygro(i)/(vaerosol(i)) + vaerosol(i) = vaerosol(i)*cs(i,k) + else + hygro(i) = 0.0_r8 + vaerosol(i) = 0.0_r8 + end if + end do + + ! aerosol number + call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer) + call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw) + if (phase == 3) then + do i = istart, istop + naerosol(i) = (raer(i,k) + qqcw(i,k))*cs(i,k) + end do + else if (phase == 2) then + do i = istart, istop + naerosol(i) = qqcw(i,k)*cs(i,k) + end do + else + do i = istart, istop + naerosol(i) = raer(i,k)*cs(i,k) + end do + end if + ! adjust number so that dgnumlo < dgnum < dgnumhi + do i = istart, istop + naerosol(i) = max(naerosol(i), vaerosol(i)*voltonumbhi_amode(m)) + naerosol(i) = min(naerosol(i), vaerosol(i)*voltonumblo_amode(m)) + end do + +end subroutine loadaer + +!=============================================================================== + +end module ndrop + + + + diff --git a/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 b/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 new file mode 100644 index 0000000000..e6b6696e6d --- /dev/null +++ b/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 @@ -0,0 +1,629 @@ +module nucleate_ice_oslo + +!--------------------------------------------------------------------------------- +! +! CAM Interfaces for nucleate_ice module. +! +! B. Eaton - Sept 2014 +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver +use physconst, only: pi, rair, tmelt +use constituents, only: pcnst, cnst_get_ind +use physics_types, only: physics_state, physics_ptend, physics_ptend_init +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use phys_control, only: use_hetfrz_classnuc +use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & + pbuf_get_index, pbuf_get_field +use cam_history, only: addfld, add_default, outfld + +use ref_pres, only: top_lev => trop_cloud_top_lev +use wv_saturation, only: qsat_water, svp_water, svp_ice +use shr_spfn_mod, only: erf => shr_spfn_erf + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + +use nucleate_ice, only: nucleati_init, nucleati + +use aerosoldef, only: l_dst_a2, l_dst_a3, & + MODE_IDX_DST_A2, MODE_IDX_DST_A3, & + rhopart +use modal_aero_data, only: qqcw_get_field +use const , only: volumeToNumber + +implicit none +private +save + +public :: & + nucleate_ice_oslo_readnl, & + nucleate_ice_oslo_register, & + nucleate_ice_oslo_init, & + nucleate_ice_oslo_calc + + +! Namelist variables +logical, public, protected :: use_preexisting_ice = .false. +logical :: hist_preexisting_ice = .false. +logical :: nucleate_ice_incloud = .false. +logical :: nucleate_ice_use_troplev = .false. +real(r8) :: nucleate_ice_subgrid = -1._r8 +real(r8) :: nucleate_ice_subgrid_strat = -1._r8 +real(r8) :: nucleate_ice_strat = 0.0_r8 + +! Vars set via init method. +real(r8) :: mincld ! minimum allowed cloud fraction +real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + +! constituent indices +integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numice_idx = -1 + +integer :: & + naai_idx, & + naai_hom_idx + +integer :: & + ast_idx = -1, & + dgnum_idx = -1 + +integer :: & + qsatfac_idx +! modal aerosols +logical :: clim_modal_aero = .TRUE. +logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + +!=============================================================================== +contains +!=============================================================================== + +subroutine nucleate_ice_oslo_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, masterprocid, mpi_logical, mpi_real8 + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'nucleate_ice_cam_readnl' + + namelist /nucleate_ice_nl/ use_preexisting_ice, hist_preexisting_ice, & + nucleate_ice_subgrid, nucleate_ice_subgrid_strat, nucleate_ice_strat, & + nucleate_ice_incloud, nucleate_ice_use_troplev + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'nucleate_ice_nl', status=ierr) + if (ierr == 0) then + read(unitn, nucleate_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 + + ! Broadcast namelist variables + call mpi_bcast(use_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(hist_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_subgrid, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_subgrid_strat, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_strat, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_incloud, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_use_troplev, 1, mpi_logical,masterprocid, mpicom, ierr) + +end subroutine nucleate_ice_oslo_readnl + +!================================================================================================ + +subroutine nucleate_ice_oslo_register() + + call pbuf_add_field('NAAI', 'physpkg', dtype_r8, (/pcols,pver/), naai_idx) + call pbuf_add_field('NAAI_HOM', 'physpkg', dtype_r8, (/pcols,pver/), naai_hom_idx) + +end subroutine nucleate_ice_oslo_register + +!================================================================================================ + +subroutine nucleate_ice_oslo_init(mincld_in, bulk_scale_in) + use phys_control, only: phys_getopts + + real(r8), intent(in) :: mincld_in + real(r8), intent(in) :: bulk_scale_in + + ! local variables + integer :: iaer + integer :: ierr + integer :: m, n, nspec + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'nucleate_ice_cam_init' + logical :: history_cesm_forcing + !-------------------------------------------------------------------------------------------- + call phys_getopts(history_cesm_forcing_out = history_cesm_forcing) + + mincld = mincld_in + bulk_scale = bulk_scale_in + + if( masterproc ) then + write(iulog,*) 'nucleate_ice parameters:' + write(iulog,*) ' mincld = ', mincld_in + write(iulog,*) ' bulk_scale = ', bulk_scale_in + write(iulog,*) ' use_preexisiting_ice = ', use_preexisting_ice + write(iulog,*) ' hist_preexisiting_ice = ', hist_preexisting_ice + write(iulog,*) ' nucleate_ice_subgrid = ', nucleate_ice_subgrid + write(iulog,*) ' nucleate_ice_subgrid_strat = ', nucleate_ice_subgrid_strat + write(iulog,*) ' nucleate_ice_strat = ', nucleate_ice_strat + write(iulog,*) ' nucleate_ice_incloud = ', nucleate_ice_incloud + write(iulog,*) ' nucleate_ice_use_troplev = ', nucleate_ice_use_troplev + end if + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMICE', numice_idx) + qsatfac_idx = pbuf_get_index('QSATFAC', ierr) + + if (((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) .and. (qsatfac_idx .eq. -1)) then + call endrun(routine//': ERROR qsatfac is required when subgrid = -1 or subgrid_strat = -1') + end if + + call addfld('NIHF', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to homogenous freezing') + call addfld('NIDEP', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to deposition nucleation') + call addfld('NIIMM', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to immersion freezing') + call addfld('NIMEY', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to meyers deposition') + + call addfld('NIREGM',(/ 'lev' /), 'A', 'C', 'Ice Nucleation Temperature Threshold for Regime') + call addfld('NISUBGRID',(/ 'lev' /), 'A', '', 'Ice Nucleation subgrid saturation factor') + call addfld('NITROP_PD',(/ 'lev' /), 'A', '', 'Chemical Tropopause probability') + if ( history_cesm_forcing ) then + call add_default('NITROP_PD',8,' ') + endif + + if (use_preexisting_ice) then + call addfld('fhom', (/ 'lev' /), 'A','fraction', 'Fraction of cirrus where homogeneous freezing occur' ) + call addfld ('WICE', (/ 'lev' /), 'A','m/s','Vertical velocity Reduction caused by preexisting ice' ) + call addfld ('WEFF', (/ 'lev' /), 'A','m/s','Effective Vertical velocity for ice nucleation' ) + call addfld ('INnso4', (/ 'lev' /), 'A','1/m3','Number Concentation so4 (in) to ice_nucleation') + call addfld ('INnbc', (/ 'lev' /), 'A','1/m3','Number Concentation bc (in) to ice_nucleation') + call addfld ('INndust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (in) ice_nucleation') + call addfld ('INondust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (out) from ice_nucleation') + call addfld ('INhet', (/ 'lev' /), 'A','1/m3', & + 'contribution for in-cloud ice number density increase by het nucleation in ice cloud') + call addfld ('INhom', (/ 'lev' /), 'A','1/m3', & + 'contribution for in-cloud ice number density increase by hom nucleation in ice cloud') + call addfld ('INFrehom', (/ 'lev' /), 'A','frequency','hom IN frequency ice cloud') + call addfld ('INFreIN', (/ 'lev' /), 'A','frequency','frequency of ice nucleation occur') + + if (hist_preexisting_ice) then + call add_default ('WSUBI ', 1, ' ') ! addfld/outfld calls are in microp_aero + + call add_default ('fhom ', 1, ' ') + call add_default ('WICE ', 1, ' ') + call add_default ('WEFF ', 1, ' ') + call add_default ('INnso4 ', 1, ' ') + call add_default ('INnbc ', 1, ' ') + call add_default ('INndust ', 1, ' ') + call add_default ('INhet ', 1, ' ') + call add_default ('INhom ', 1, ' ') + call add_default ('INFrehom', 1, ' ') + call add_default ('INFreIN ', 1, ' ') + end if + end if + + + lq(l_dst_a2) = .TRUE. + lq(l_dst_a3) = .TRUE. + + call nucleati_init(use_preexisting_ice, use_hetfrz_classnuc, nucleate_ice_incloud, iulog, pi, & + mincld) + + ! get indices for fields in the physics buffer + ast_idx = pbuf_get_index('AST') + +end subroutine nucleate_ice_oslo_init + +!================================================================================================ + +subroutine nucleate_ice_oslo_calc( & + state, wsubi, pbuf, dtime, ptend & + , numberConcentration) + + use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3 & + , MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT + use commondefinitions, only: nmodes + + use tropopause, only: tropopause_findChemTrop + + ! arguments + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: wsubi(:,:) + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: dtime + type(physics_ptend), intent(out) :: ptend + + ! local workspace + + ! naai and naai_hom are the outputs shared with the microphysics + real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation + real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) + + integer :: lchnk, ncol + integer :: itim_old + integer :: i, k, m + + real(r8), pointer :: t(:,:) ! input temperature (K) + real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) + real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) + real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) + + real(r8), pointer :: cld_dst_a2(:,:) ! mmr cld dst a2 + real(r8), pointer :: cld_dst_a3(:,:) ! mass m.r. of coarse dust + + real(r8), pointer :: ast(:,:) + real(r8) :: icecldf(pcols,pver) ! ice cloud fraction + real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) + real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) + + real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) + real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) + real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water + integer :: troplev(pcols) ! tropopause level + + real(r8) :: relhum(pcols,pver) ! relative humidity + real(r8) :: icldm(pcols,pver) ! ice cloud fraction + + real(r8) :: so4_num ! so4 aerosol number (#/cm^3) + real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) + real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) + real(r8) :: dst_num ! total dust aerosol number (#/cm^3) + real(r8) :: wght + real(r8) :: dmc + real(r8) :: ssmc + real(r8) :: oso4_num + real(r8) :: odst_num + real(r8) :: osoot_num + real(r8) :: dso4_num ! tuning factor for increased so4 + real(r8) :: ramp ! ---------- " ---------------- + real(r8) :: dust_coarse_fraction ! fraction of dust in coarse (a3) mode + real(r8) :: masslost ! [kg/kg] tmp variable for mass lost + real(r8) :: numberFromSmallDustMode ! [#/cm3] number of dust activated from small mode + + real(r8) :: subgrid(pcols,pver) + real(r8) :: trop_pd(pcols,pver) + + ! For pre-existing ice + real(r8) :: fhom(pcols,pver) ! how much fraction of cloud can reach Shom + real(r8) :: wice(pcols,pver) ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom + real(r8) :: weff(pcols,pver) ! effective Vertical velocity for ice nucleation (m/s); weff=wsubi-wice + real(r8) :: INnso4(pcols,pver) ! #/m3, so4 aerosol number used for ice nucleation + real(r8) :: INnbc(pcols,pver) ! #/m3, bc aerosol number used for ice nucleation + real(r8) :: INndust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation + real(r8) :: INondust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation + real(r8) :: INhet(pcols,pver) ! #/m3, ice number from het freezing + real(r8) :: INhom(pcols,pver) ! #/m3, ice number from hom freezing + real(r8) :: INFrehom(pcols,pver) ! hom freezing occurence frequency. 1 occur, 0 not occur. + real(r8) :: INFreIN(pcols,pver) ! ice nucleation occerence frequency. 1 occur, 0 not occur. + + ! history output for ice nucleation + real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) + real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) + real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) + real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) + real(r8) :: regm(pcols,pver) !output temperature thershold for nucleation regime + + real(r8) :: so4_num_ac + real(r8) :: so4_num_cr + + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + t => state%t + qn => state%q(:,:,1) + qc => state%q(:,:,cldliq_idx) + qi => state%q(:,:,cldice_idx) + ni => state%q(:,:,numice_idx) + pmid => state%pmid + + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + call physics_ptend_init(ptend, state%psetcols, 'nucleatei', lq=lq) + + cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2, lchnk, .true.) + cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2, lchnk, .true.) + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + icecldf(:ncol,:pver) = ast(:ncol,:pver) + + ! naai and naai_hom are the outputs from this parameterization + call pbuf_get_field(pbuf, naai_idx, naai) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) + naai(1:ncol,1:pver) = 0._r8 + naai_hom(1:ncol,1:pver) = 0._r8 + + ! Use the same criteria that is used in chemistry and in CLUBB (for cloud fraction) + ! to determine whether to use tropospheric or stratospheric settings. Include the + ! tropopause level so that the cold point tropopause will use the stratospheric values. + call tropopause_findChemTrop(state, troplev) + + if ((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) then + call pbuf_get_field(pbuf, qsatfac_idx, qsatfac) + end if + + trop_pd(:,:) = 0._r8 + + do k = top_lev, pver + do i = 1, ncol + trop_pd(i, troplev(i)) = 1._r8 + + if (k <= troplev(i)) then + if (nucleate_ice_subgrid_strat .eq. -1._r8) then + subgrid(i, k) = 1._r8 / qsatfac(i, k) + else + subgrid(i, k) = nucleate_ice_subgrid_strat + end if + else + if (nucleate_ice_subgrid .eq. -1._r8) then + subgrid(i, k) = 1._r8 / qsatfac(i, k) + else + subgrid(i, k) = nucleate_ice_subgrid + end if + end if + end do + end do + + + ! initialize history output fields for ice nucleation + nihf(1:ncol,1:pver) = 0._r8 + niimm(1:ncol,1:pver) = 0._r8 + nidep(1:ncol,1:pver) = 0._r8 + nimey(1:ncol,1:pver) = 0._r8 + + if (use_preexisting_ice) then + fhom(:,:) = 0.0_r8 + wice(:,:) = 0.0_r8 + weff(:,:) = 0.0_r8 + INnso4(:,:) = 0.0_r8 + INnbc(:,:) = 0.0_r8 + INndust(:,:) = 0.0_r8 + INondust(:,:) = 0.0_r8 + INhet(:,:) = 0.0_r8 + INhom(:,:) = 0.0_r8 + INFrehom(:,:) = 0.0_r8 + INFreIN(:,:) = 0.0_r8 + endif + + do k = top_lev, pver + + ! Get humidity and saturation vapor pressures + call qsat_water(t(:ncol,k), pmid(:ncol,k), & + es(:ncol), qs(:ncol), gam=gammas(:ncol)) + + do i = 1, ncol + + relhum(i,k) = qn(i,k)/qs(i) + + ! get cloud fraction, check for minimum + icldm(i,k) = max(icecldf(i,k), mincld) + + end do + end do + + + do k = top_lev, pver + do i = 1, ncol + + if (t(i,k) < tmelt - 5._r8) then + + ! compute aerosol number for so4, soot, and dust with units #/cm^3 + so4_num = 0._r8 + soot_num = 0._r8 + dst1_num = 0._r8 + dst2_num = 0._r8 + dst3_num = 0._r8 + dst4_num = 0._r8 + dst_num = 0._r8 + + if (clim_modal_aero) then + !For modal aerosols, assume for the upper troposphere: + ! soot = accumulation mode + ! sulfate = aiken mode + ! dust = coarse mode + ! since modal has internal mixtures. + soot_num = numberConcentration(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT)*1.0e-6_r8 + + dst_num = (numberConcentration(i,k,MODE_IDX_DST_A2) & + + numberConcentration(i,k,MODE_IDX_DST_A3))*1.0e-6_r8 + !Oslo aerosols have two modes.. Need mode-fractions + dust_coarse_fraction = numberConcentration(i,k,MODE_IDX_DST_A3)*1.e-6_r8 / (dst_num+1.e-100_r8) + + + so4_num = (numberConcentration(i,k,MODE_IDX_SO4_AC))*1.0e-6_r8 + + end if !clim modal aero + ! *** Turn off soot nucleation *** + soot_num = 0.0_r8 + + call nucleati( & + wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), & + qc(i,k), qi(i,k), ni(i,k), rho(i,k), & + so4_num, dst_num, soot_num, subgrid(i,k), & + naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & + wice(i,k), weff(i,k), fhom(i,k), regm(i,k), & + oso4_num, odst_num, osoot_num) + + ! Move aerosol used for nucleation from interstial to cloudborne, + ! otherwise the same coarse mode aerosols will be available again + ! in the next timestep and will supress homogeneous freezing. + if (use_preexisting_ice) then + + numberFromSmallDustMode = 0.0_r8 + + !Assume the coarse aerosols were activated first + !so only remove small ones if more than large ones are activated + if(odst_num .gt. dst_num*dust_coarse_fraction)then + + !A2-mode + numberFromSmallDustMode = odst_num - dst_num*dust_coarse_fraction + + masslost = (odst_num & !all removed + - dst_num*dust_coarse_fraction) & !fraction to coarse mode + / volumeToNumber(MODE_IDX_DST_A2) & + * rhopart(l_dst_a2) & + /rho(i,k)*1e6_r8 + + ptend%q(i,k,l_dst_a2) = -masslost*icldm(i,k)/ dtime + cld_dst_a2(i,k) = cld_dst_a2(i,k) + masslost*icldm(i,k) + + end if + + ! Coarse mode (is always lost) + masslost = (odst_num - numberFromSmallDustMode) & + / volumeToNumber(MODE_IDX_DST_A3) & + * rhopart(l_dst_a3) & + / rho(i,k)*1e6_r8 + + ptend%q(i,k,l_dst_a3) = -masslost * icldm(i,k) / dtime + cld_dst_a3(i,k) = cld_dst_a3(i,k) + masslost*icldm(i,k) + + end if + + !Oslo aerosols do not have explicit treatment of coarse sulfate + so4_num_cr = 0.0_r8 + + ! Liu&Penner does not generate enough nucleation in the polar winter + ! stratosphere, which affects surface area density, dehydration and + ! ozone chemistry. Part of this is that there are a larger number of + ! particles in the accumulation mode than in the Aitken mode. In volcanic + ! periods, the coarse mode may also be important. As a short + ! term work around, include the accumulation and coarse mode particles + ! and assume a larger fraction of the sulfates nucleate in the polar + ! stratosphere. + ! + ! Do not include the tropopause level, as stratospheric aerosols + ! only exist above the tropopause level. + ! + ! NOTE: This may still not represent the proper particles that + ! participate in nucleation, because it doesn't include STS and NAT + ! particles. It may not represent the proper saturation threshold for + ! nucleation, and wsubi from CLUBB is probably not representative of + ! wave driven varaibility in the polar stratosphere. + if (nucleate_ice_use_troplev) then + if ((k < troplev(i)) .and. (nucleate_ice_strat > 0._r8)) then + if (oso4_num > 0._r8) then + so4_num_ac = so4_num*rho(i,k)*1.0e-6_r8 !This is maximum sulfate which can activate + !! NCAR/MAM4-version + !!!so4_num_ac = num_accum(i,k)*rho(i,k)*1.0e-6_r8 + !! NCAR/MAM4-version + dso4_num = max(0._r8, (nucleate_ice_strat * (so4_num_cr + so4_num_ac)) - oso4_num) * 1e6_r8 / rho(i,k) + naai(i,k) = naai(i,k) + dso4_num + nihf(i,k) = nihf(i,k) + dso4_num + end if + end if + else + + ! This maintains backwards compatibility with the previous version. + if (pmid(i,k) <= 12500._r8 .and. pmid(i,k) > 100._r8 .and. abs(state%lat(i)) >= 60._r8 * pi / 180._r8) then + ramp = 1._r8 - min(1._r8, max(0._r8, (pmid(i,k) - 10000._r8) / 2500._r8)) + + if (oso4_num > 0._r8) then + dso4_num = (max(oso4_num, ramp * nucleate_ice_strat * so4_num) - oso4_num) * 1e6_r8 / rho(i,k) + naai(i,k) = naai(i,k) + dso4_num + nihf(i,k) = nihf(i,k) + dso4_num + end if + end if + end if + + naai_hom(i,k) = nihf(i,k) + + ! output activated ice (convert from #/kg -> #/m3) + nihf(i,k) = nihf(i,k) *rho(i,k) + niimm(i,k) = niimm(i,k)*rho(i,k) + nidep(i,k) = nidep(i,k)*rho(i,k) + nimey(i,k) = nimey(i,k)*rho(i,k) + + if (use_preexisting_ice) then + INnso4(i,k) =so4_num*1e6_r8 ! (convert from #/cm3 -> #/m3) + INnbc(i,k) =soot_num*1e6_r8 + INndust(i,k)=dst_num*1e6_r8 + INondust(i,k)=odst_num*1e6_r8 + INFreIN(i,k)=1.0_r8 ! 1,ice nucleation occur + INhet(i,k) = (niimm(i,k) + nidep(i,k)) ! #/m3, nimey not in cirrus + INhom(i,k) = nihf(i,k) ! #/m3 + if (INhom(i,k).gt.1e3_r8) then ! > 1/L + INFrehom(i,k)=1.0_r8 ! 1, hom freezing occur + endif + + ! exclude no ice nucleaton + if ((INFrehom(i,k) < 0.5_r8) .and. (INhet(i,k) < 1.0_r8)) then + INnso4(i,k) =0.0_r8 + INnbc(i,k) =0.0_r8 + INndust(i,k)=0.0_r8 + INondust(i,k)=0.0_r8 + INFreIN(i,k)=0.0_r8 + INhet(i,k) = 0.0_r8 + INhom(i,k) = 0.0_r8 + INFrehom(i,k)=0.0_r8 + wice(i,k) = 0.0_r8 + weff(i,k) = 0.0_r8 + fhom(i,k) = 0.0_r8 + endif + end if + + end if + end do + end do + + + call outfld('NIHF', nihf, pcols, lchnk) + call outfld('NIIMM', niimm, pcols, lchnk) + call outfld('NIDEP', nidep, pcols, lchnk) + call outfld('NIMEY', nimey, pcols, lchnk) + call outfld('NIREGM', regm, pcols, lchnk) + call outfld('NISUBGRID', subgrid, pcols, lchnk) + call outfld('NITROP_PD', trop_pd, pcols, lchnk) + + if (use_preexisting_ice) then + call outfld( 'fhom' , fhom, pcols, lchnk) + call outfld( 'WICE' , wice, pcols, lchnk) + call outfld( 'WEFF' , weff, pcols, lchnk) + call outfld('INnso4 ',INnso4 , pcols,lchnk) + call outfld('INnbc ',INnbc , pcols,lchnk) + call outfld('INndust ',INndust, pcols,lchnk) + call outfld('INondust ',INondust, pcols,lchnk) + call outfld('INhet ',INhet , pcols,lchnk) + call outfld('INhom ',INhom , pcols,lchnk) + call outfld('INFrehom',INFrehom,pcols,lchnk) + call outfld('INFreIN ',INFreIN, pcols,lchnk) + end if + +end subroutine nucleate_ice_oslo_calc + +!================================================================================================ + +end module nucleate_ice_oslo diff --git a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 new file mode 100644 index 0000000000..47197dc06c --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 @@ -0,0 +1,1167 @@ +module oslo_aerosols_intr + + use aerosoldef + use commondefinitions + use modal_aero_data, only: qqcw_get_field + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o + use spmd_utils, only: masterproc + use infnan, only: nan, assignment(=) + + use cam_history, only: outfld, fieldname_len + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + + use ref_pres, only: top_lev => clim_modal_aero_top_lev + + use modal_aero_wateruptake, only: modal_strat_sulfate + use mo_setsox, only: setsox, has_sox + + implicit none + + private ! Make default type private to the module + + save + + ! + ! Public interfaces + ! + + public :: oslo_aero_wet_intr ! interface to wet deposition + public :: sol_facti_cloud_borne + public :: oslo_aero_dry_intr ! interface to dry deposition + public :: oslo_aero_initialize + + logical :: inv_o3, inv_oh, inv_no3, inv_ho2 + integer, pointer :: id_so2, id_so4, id_dms, id_o3, id_h2o2, id_oh, id_no3, id_ho2 + integer, target :: spc_ids(8) + + integer :: fracis_idx = 0 + integer :: prain_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 + real(r8) :: sol_facti_cloud_borne + +! variables for table lookup of aerosol impaction/interception scavenging rates + integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 + real(r8) dlndg_nimptblgrow + real(r8) scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, nmodes) + real(r8) scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, nmodes) + + + integer :: ndrydep = 0 + integer,allocatable :: drydep_indices(:) + integer :: nwetdep = 0 + integer,allocatable :: wetdep_indices(:) + logical :: drydep_lq(pcnst) + logical :: wetdep_lq(pcnst) + + logical :: convproc_do_aer = .FALSE. + +contains + + !=============================================================================== + subroutine oslo_aero_initialize(pbuf2d ) + use cam_history, only : addfld, add_default, horiz_only + use mo_chem_utls, only : get_inv_ndx + use gas_wetdep_opts, only : gas_wetdep_list, gas_wetdep_cnt + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk + use ppgrid, only: pcols, pver, begchunk, endchunk + use time_manager, only: is_first_step + use modal_aero_data, only: qqcw_get_field + + implicit none + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + integer :: m + integer :: l + + integer :: i + integer :: lchnk + integer :: tracerIndex + integer :: astat, id + real(r8), pointer :: qqcw(:,:) + + logical :: history_aerosol ! Output the MAM aerosol tendencies + character(len=2) :: unit_basename='kg' ! Units 'kg' or '1' + character(len=100) :: aName ! tracer name + logical :: is_in_output(pcnst) + !----------------------------------------------------------------------- + + fracis_idx = pbuf_get_index('FRACIS') + prain_idx = pbuf_get_index('PRAIN') + rprddp_idx = pbuf_get_index('RPRDDP') + rprdsh_idx = pbuf_get_index('RPRDSH') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + + call phys_getopts( history_aerosol_out = history_aerosol ) + + is_in_output(:)=.false. + drydep_lq(:)=.false. + wetdep_lq(:)=.false. + + !Mode 0 is not subject to wet deposition? (check noresm1 code..) + do m=0,nmodes + do l=1,getNumberOfTracersInMode(m) + + tracerIndex = getTracerIndex(m,l,.false.) + + drydep_lq(tracerIndex)=.true. + wetdep_lq(tracerIndex)=.true. + + if(is_in_output(tracerIndex))then + cycle + endif + + aName = cnst_name(tracerIndex) + + print*, m,l,tracerIndex, trim(aName) + + call addfld (trim(aName)//'SFWET',horiz_only, 'A', unit_basename//'/m2/s', & + 'Wet deposition flux at surface') + call addfld (trim(aName)//'SFSIC',horiz_only, 'A', unit_basename//'/m2/s ', & + 'Wet deposition flux (incloud, convective) at surface') + call addfld (trim(aName)//'SFSIS',horiz_only, 'A', unit_basename//'/m2/s ', & + 'Wet deposition flux (incloud, stratiform) at surface') + call addfld (trim(aName)//'SFSBC',horiz_only, 'A', unit_basename//'/m2/s ', & + 'Wet deposition flux (belowcloud, convective) at surface') + call addfld (trim(aName)//'SFSBS',horiz_only, 'A', unit_basename//'/m2/s ', & + 'Wet deposition flux (belowcloud, stratiform) at surface') + call addfld (trim(aName)//'WET',(/'lev'/), 'A', unit_basename//'/kg/s ','wet deposition tendency') + call addfld (trim(aName)//'SIC',(/'lev'/), 'A', unit_basename//'/kg/s ', & + trim(aName)//' ic wet deposition') + call addfld (trim(aName)//'SIS',(/'lev'/), 'A', unit_basename//'/kg/s ', & + trim(aName)//' is wet deposition') + call addfld (trim(aName)//'SBC',(/'lev'/), 'A', unit_basename//'/kg/s ', & + trim(aName)//' bc wet deposition') + call addfld (trim(aName)//'SBS',(/'lev'/), 'A', unit_basename//'/kg/s ', & + trim(aName)//' bs wet deposition') + + !Extra wd ouptut + if ( history_aerosol ) then + call add_default (trim(aName)//'SFWET', 1, ' ') + call add_default (trim(aName)//'SFSIC', 1, ' ') + call add_default (trim(aName)//'SFSIS', 1, ' ') + call add_default (trim(aName)//'SFSBC', 1, ' ') + call add_default (trim(aName)//'SFSBS', 1, ' ') + endif + + !ddep output + call addfld (trim(aName)//'DDF',horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' dry deposition flux at bottom (grav + turb)') + call addfld (trim(aName)//'TBF',horiz_only, 'A' ,unit_basename//'/m2/s', & + trim(aName)//' turbulent dry deposition flux') + call addfld (trim(aName)//'GVF',horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' gravitational dry deposition flux') + call addfld (trim(aName)//'DTQ',(/'lev'/), 'A', unit_basename//'/kg/s ', & + trim(aName)//' dry deposition') + call addfld (trim(aName)//'DDV',(/'lev'/), 'A', 'm/s', & + trim(aName)//' deposition velocity') + + !extra drydep output + if ( history_aerosol ) then + call add_default (trim(aName)//'DDF', 1, ' ') + call add_default (trim(aName)//'TBF', 1, ' ') + call add_default (trim(aName)//'GVF', 1, ' ') + !call add_default (trim(aName)//'DDV', 1, ' ') + endif + + !some tracers are not in cloud water + if(getCloudTracerIndexDirect(tracerIndex) .lt. 0)then + cycle + endif + + aName = trim(getCloudTracerName(tracerIndex)) + !Cloud water fields (from mo_chm_diags.F90) + call addfld (trim(aName)//'SFWET', horiz_only, 'A', unit_basename//'/m2/s', & + trim(aName)//' wet deposition flux at surface') + call addfld (trim(aName)//'SFSIC', horiz_only, 'A',unit_basename//'/m2/s ', & + trim(aName)//' wet deposition flux (incloud, convective) at surface') + call addfld (trim(aName)//'SFSIS', horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' wet deposition flux (incloud, stratiform) at surface') + call addfld (trim(aName)//'SFSBC', horiz_only, 'A', unit_basename//'/m2/s ' , & + trim(aName)//' wet deposition flux (belowcloud, convective) at surface') + call addfld (trim(aName)//'SFSBS', horiz_only, 'A', unit_basename//'/m2/s ' , & + trim(aName)//' wet deposition flux (belowcloud, stratiform) at surface') + !dry deposition + call addfld (trim(aName)//'DDF', horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' dry deposition flux at bottom (grav + turb)') + call addfld (trim(aName)//'TBF', horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' turbulent dry deposition flux') + call addfld (trim(aName)//'GVF', horiz_only, 'A', unit_basename//'/m2/s ', & + trim(aName)//' gravitational dry deposition flux') + + is_in_output(tracerIndex) = .true. + + end do !tracers + enddo !modes + + !initialize cloud concentrations + + if (is_first_step()) then + ! initialize cloud bourne constituents in physics buffer + + do i = 1, pcnst + do lchnk = begchunk, endchunk + qqcw => qqcw_get_field(pbuf_get_chunk(pbuf2d,lchnk), i, lchnk, .true.) + if (associated(qqcw)) then + qqcw = 1.e-38_r8 + end if + end do + end do + end if + + end subroutine oslo_aero_initialize + + subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend & + , dgncur_awet, wetdens, dgncur_awet_processmode & + , wetdens_processmode, cflx & + ) + + !=============================================================================== + use cam_history, only: outfld + use ppgrid, only: pverp + use physics_types, only: physics_state, physics_ptend + use camsrfexch, only: cam_out_t + use physconst, only: gravit, rair, rhoh2o + use drydep_mod, only: setdvel, d3ddflux, calcram + use dust_sediment_mod, only: dust_sediment_tend, dust_sediment_vel + use modal_aero_deposition, only: set_srf_drydep + use physics_buffer, only : physics_buffer_desc + + !----------------------------------------------------------------------- + implicit none + !----------------------------------------------------------------------- + ! + ! Arguments: + type(physics_state), intent(in) :: state ! Physics state variables + real(r8), intent(in) :: obklen(:) + real(r8), intent(in) :: ustar(:) ! sfc fric vel + type(cam_in_t), target, intent(in) :: cam_in ! import state + real(r8), intent(in) :: dt ! time step + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + ! + real(r8), intent(in) :: dgncur_awet(pcols,pver,0:nmodes) + real(r8), intent(in) :: wetdens(pcols,pver,0:nmodes) + real(r8), intent(in) :: dgncur_awet_processmode(pcols, pver, numberOfProcessModeTracers) + real(r8), intent(in) :: wetdens_processmode(pcols, pver, numberOfProcessModeTracers) + real(r8), intent(in) :: cflx(pcols,pcnst) !Surface fluxes + + ! local vars + real(r8), pointer :: landfrac(:) ! land fraction + real(r8), pointer :: icefrac(:) ! ice fraction + real(r8), pointer :: ocnfrac(:) ! ocean fraction + real(r8), pointer :: fvin(:) ! + real(r8), pointer :: ram1in(:) ! for dry dep velocities from land model for progseasalts + + real(r8) :: fv(pcols) ! for dry dep velocities, from land modified over ocean & ice + real(r8) :: ram1(pcols) ! for dry dep velocities, from land modified over ocean & ice + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: jvlc ! index for last dimension of vlc_xxx arrays + integer :: lphase ! index for interstitial / cloudborne aerosol + integer :: lspec ! index for aerosol number / chem-mass / water-mass + integer :: m ! aerosol mode index + integer :: mm ! tracer index + integer :: i + + real(r8) :: tvs(pcols,pver) + real(r8) :: rho(pcols,pver) ! air density in kg/m3 + real(r8) :: sflx(pcols) ! deposition flux + real(r8):: dep_trb(pcols) !kg/m2/s + real(r8):: dep_grv(pcols) !kg/m2/s (total of grav and trb) + real(r8) :: pvmzaer(pcols,pverp) ! sedimentation velocity in Pa + real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species + + real(r8) :: rad_drop(pcols,pver) + real(r8) :: dens_drop(pcols,pver) + real(r8) :: sg_drop(pcols,pver) + real(r8) :: rad_aer(pcols,pver) + real(r8) :: dens_aer(pcols,pver) + real(r8) :: sg_aer(pcols,pver) + + real(r8) :: vlc_dry(pcols,pver,4) ! dep velocity + real(r8) :: vlc_grv(pcols,pver,4) ! dep velocity + real(r8):: vlc_trb(pcols,4) ! dep velocity + real(r8) :: aerdepdryis(pcols,pcnst) ! aerosol dry deposition (interstitial) + real(r8) :: aerdepdrycw(pcols,pcnst) ! aerosol dry deposition (cloud water) + real(r8), pointer :: fldcw(:,:) + + !++oslo aerosols + real(r8) :: interfaceTendToLowestLayer(pcols) + real(r8) :: deltaH(pcols) + real(r8) :: massLostDD(pcols) + real(r8) :: MMRNew(pcols) + real(r8) :: lossRate(pcols) + real(r8) :: totalProd(pcols) + real(r8) :: fallFromAbove(pcols) + + real(r8) :: logSigma + logical :: is_done(pcnst,2) + !----------------------------------------------------------------------- + + landfrac => cam_in%landfrac(:) + icefrac => cam_in%icefrac(:) + ocnfrac => cam_in%ocnfrac(:) + fvin => cam_in%fv(:) + ram1in => cam_in%ram1(:) + + lchnk = state%lchnk + ncol = state%ncol + aerdepdryis(:,:)=0._r8 + aerdepdrycw(:,:)=0._r8 + ! calc ram and fv over ocean and sea ice ... + call calcram( ncol,landfrac,icefrac,ocnfrac,obklen,& + ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& + state%pdel(:,pver),fvin,fv) + + call outfld( 'airFV', fv(:), pcols, lchnk ) + call outfld( 'RAM1', ram1(:), pcols, lchnk ) + + ! note that tendencies are not only in sfc layer (because of sedimentation) + ! and that ptend is updated within each subroutine for different species + + call physics_ptend_init(ptend, state%psetcols, 'aero_model_drydep', lq=drydep_lq) + + tvs(:ncol,:) = state%t(:ncol,:)!*(1+state%q(:ncol,k) + rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) + + + is_done(:,:) = .false. + +! +! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) +! +! *** mean drop radius should eventually be computed from ndrop and qcldwtr + rad_drop(:,:) = 5.0e-6_r8 + dens_drop(:,:) = rhoh2o + sg_drop(:,:) = 1.46_r8 + !jvlc = 3 + !call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & + ! vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + ! rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, lchnk) + jvlc = 4 + call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) + + + + !At this point we really need to distribute the lifecycle-tracers over + !the actual modes (maybe according to surface available of background tracers?) + + !in mam3, jvlc = 1 means number-concentration + !in oslo_aero, jvlc = 1 means process-modes + !The following logic is based on that process-mode tracers + !always follow AFTER the actual tracers!! + + do m = 0, nmodes ! main loop over aerosol modes + + do lphase = 1, 2 ! loop over interstitial / cloud-borne forms + + if (lphase == 1) then ! interstial aerosol - calc settling/dep velocities of mode + + logSigma = log(lifeCycleSigma(m)) + + ! rad_aer = volume mean wet radius (m) + ! dgncur_awet = geometric mean wet diameter for number distribution (m) + if(top_lev.gt.1) then + rad_aer(1:ncol,:top_lev-1) = 0._r8 + end if + rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet(1:ncol,top_lev:,m) & + *exp(1.5_r8*(logSigma)) + + ! dens_aer(1:ncol,:) = wet density (kg/m3) + if(top_lev.gt.1)then + dens_aer(1:ncol,:top_lev-1) = 0._r8 + end if + dens_aer(1:ncol,top_lev:) = wetdens(1:ncol,top_lev:,m) + sg_aer(1:ncol,:) = lifecycleSigma(m) + + jvlc = 2 + call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) + +! if(m .eq. MODE_IDX_SS_A3)then +! do i=1,ncol +! print*, "rad_aer", rad_aer(i,pver)*1.e6, ' um ', vlc_dry(i,pver,jvlc)*1.e2, " cm/s" +! end do +! end if + end if + + do lspec = 1, getNumberOfTracersInMode(m) ! loop over number + constituents + + mm = getTracerIndex(m,lspec,.false.) + if(is_done(mm,lphase) .eqv. .true. )then + cycle + endif + is_done(mm,lphase)=.true. + + if (lphase == 1) then + jvlc = 2 !mass in clean air tracers + + !Process tracers have their own velocity based on fixed size / density + !Calculate the velocity to use for this specie.. + if ( is_process_mode(mm, .false.) ) then + jvlc = 1 + logSigma = log(processModeSigma(processModeMap(mm))) + if(top_lev.gt.1)then + rad_aer(1:ncol, top_lev-1) = 0.0_r8 + end if + rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet_processmode(1:ncol,top_lev:,processModeMap(mm)) & + *exp(1.5_r8*(logSigma)) + call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) + endif + + else + jvlc = 4 !mass in cloud tracers + endif + + if (mm <= 0) cycle + +! if (lphase == 1) then + if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then + ptend%lq(mm) = .TRUE. + + ! use pvprogseasalts instead (means making the top level 0) + pvmzaer(:ncol,1)=0._r8 + pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) + + call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) + + if(.true.) then ! use phil's method + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + + ! calculate the tendencies and sfc fluxes from the above velocities + call dust_sediment_tend( & + ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & + state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, interfaceTendToLowestLayer ) + else !use charlie's method + call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & + state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) + endif + + !write(iulog,*)"starting ddep proc", mm, pcnst + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !Some tracers have short lifetime with respect to dry dep: + !Solve implicitly for eqn for emission and dry dep in lowest layer + deltaH(:ncol)=state%pdel(:ncol,pver)/rho(:ncol,pver)/gravit ![m] height of layer + !print*, "deltaH", deltaH(:ncol) + lossRate(:ncol) = vlc_dry(:ncol,pver,jvlc)/deltaH(:ncol) ![1/s] loss rate out of layer + !print*, "lossRate", lossRate(:ncol) + !print*, "interfaceFluxesToLowestLayer", interfaceFluxToLowestLayer(:ncol) + + !OBS OBS OBS DIRTY FIX but need approx 2-3 weeks for proper solution + !special treatment of BC_AX because BC_AX is not treated with + !boundary mixing in activation (is by definition not activated!) + !Therefor emissions are already added in "normal" boundary layer + !mixing routine.. + !The proper fix to this is to skip the special treatment of BC_AX + !and skip the index "0" for that mixture alltogether! + if(mm .eq. l_bc_ax) then + totalProd(:ncol) = interfaceTendToLowestLayer(:ncol) + else + totalProd(:ncol) = cflx(:ncol,mm)*gravit/state%pdel(:ncol,pver) + interfaceTendToLowestLayer(:ncol) + end if + + !Do solution + where(lossRate(:ncol)*dt .gt. 1.e-2_r8) + MMRNew(:ncol) = state%q(:ncol,pver,mm)*exp(-lossRate(:ncol)*dt) & + + totalProd(:ncol)/lossRate(:ncol)*(1.0_r8 - exp(-lossRate(:ncol)*dt)) + elsewhere + MMRNew(:ncol) = state%q(:ncol,pver,mm) & + + totalProd(:ncol)*dt & + - state%q(:ncol,pver,mm)*lossRate(:ncol)*dt + end where + + !C0 + Pdt -massLostDD = CNew ==> + massLostDD(:ncol) = state%q(:ncol,pver,mm) - MMRNew(:ncol) + totalProd(:ncol)*dt + !Overwrite tendency in lowest layer to include emissions + !They are then not included in vertical diffusion!! + ptend%q(:ncol,pver,mm) = (MMRNew(:ncol)-state%q(:ncol,pver,mm))/dt + sflx(:ncol) = massLostDD(:ncol)*state%pdel(:ncol,pver) / gravit / dt + !write(iulog,*)"done ddep" + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! apportion dry deposition into turb and gravitational settling for tapes + dep_trb = 0._r8 + dep_grv = 0._r8 + do i=1,ncol + if (vlc_dry(i,pver,jvlc) /= 0._r8) then + dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) + dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) + endif + enddo + + call outfld( trim(cnst_name(mm))//'DDF', sflx, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'TBF', dep_trb, pcols, lchnk ) + call outfld( trim(cnst_name(mm))//'GVF', dep_grv, pcols, lchnk ) + call outfld( trim(cnst_name(mm))//'DTQ', ptend%q(:,:,mm), pcols, lchnk) + aerdepdryis(:ncol,mm) = sflx(:ncol) + + else ! lphase == 2 + + !Pick up the cloud tracers (oslo) + fldcw => qqcw_get_field(pbuf, mm,lchnk,.true.) + if( .not. associated(fldcw))then + cycle + end if + + ! use pvprogseasalts instead (means making the top level 0) + pvmzaer(:ncol,1)=0._r8 + pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) + + + if(.true.) then ! use phil's method + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + + ! calculate the tendencies and sfc fluxes from the above velocities + call dust_sediment_tend( & + ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & + fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) + else !use charlie's method + call d3ddflux( ncol, vlc_dry(:,:,jvlc), fldcw(:,:), state%pmid, & + state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) + endif + + ! apportion dry deposition into turb and gravitational settling for tapes + dep_trb = 0._r8 + dep_grv = 0._r8 + do i=1,ncol + if (vlc_dry(i,pver,jvlc) /= 0._r8) then + dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) + dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) + end if + enddo + + fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + + call outfld( trim(getCloudTracerName(mm))//'DDF', sflx, pcols, lchnk) + call outfld( trim(getCloudTracerName(mm))//'TBF', dep_trb, pcols, lchnk ) + call outfld( trim(getCloudTracerName(mm))//'GVF', dep_grv, pcols, lchnk ) + aerdepdrycw(:ncol,mm) = sflx(:ncol) + + endif + + enddo ! lspec = 0, nspec_amode(m)+1 + enddo ! lphase = 1, 2 + enddo ! m = 1, ntot_amode + + ! if the user has specified prescribed aerosol dep fluxes then + ! do not set cam_out dep fluxes according to the prognostic aerosols + if (.not.aerodep_flx_prescribed()) then + call set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) + endif + + return + end subroutine oslo_aero_dry_intr + !=============================================================================== + subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) + + + !----------------------------------------------------------------------- + !----------------------------------------------------------------------- + use cam_history, only: outfld + use physics_types, only: physics_state, physics_ptend + use camsrfexch, only: cam_out_t + use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t + use physconst, only: gravit + use constituents, only: cnst_mw + use physconst, only: mwdry ! molecular weight dry air ~ kg/kmole + use physconst, only: boltz ! J/K/molecule + use tracer_cnst, only: get_cnst_data + use modal_aero_deposition, only: set_srf_wetdep + use physics_buffer, only : physics_buffer_desc + + type(physics_state), intent(in) :: state ! Physics state variables + real(r8), intent(in) :: dt ! time step + real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + + ! + ! Local variables + ! + integer :: m ! tracer index + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + real(r8) :: iscavt(pcols, pver) + integer :: mm + + real(r8) :: icscavt(pcols, pver) + real(r8) :: isscavt(pcols, pver) + real(r8) :: bcscavt(pcols, pver) + real(r8) :: bsscavt(pcols, pver) + real(r8) :: sol_factb, sol_facti + real(r8) :: sol_factic(pcols,pver) + real(r8) :: sflx(pcols) ! deposition flux + integer :: i,k + real(r8) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1) + integer :: jnv ! index for scavcoefnv 3rd dimension + integer :: lphase ! index for interstitial / cloudborne aerosol + integer :: lspec ! index for aerosol number / chem-mass / water-mass + integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses + real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species + real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 + real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 + real(r8) :: f_act_conv_coarse_dust, f_act_conv_coarse_nacl ! rce 2010/05/02 + real(r8) :: fracis_cw(pcols,pver) + !real(r8) :: hygro_sum_old(pcols,pver) ! before removal [sum of (mass*hydro/dens)] + !real(r8) :: hygro_sum_del(pcols,pver) ! removal change to [sum of (mass*hydro/dens)] + !real(r8) :: hygro_sum_old_ik, hygro_sum_new_ik + real(r8) :: prec(pcols) ! precipitation rate + real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species + real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 + real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for + ! cloud-borne num & vol (0), + ! interstitial num (1), interstitial vol (2) + real(r8) :: tmpa, tmpb + real(r8) :: tmpdust, tmpnacl + real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat + logical :: isprx(pcols,pver) ! true if precipation + real(r8) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) + real(r8) :: aerdepwetcw(pcols,pcnst) ! aerosol wet deposition (cloud water) + + real(r8), pointer :: rprddp(:,:) ! rain production, deep convection + real(r8), pointer :: rprdsh(:,:) ! rain production, shallow convection + real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. + real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. + + real(r8) :: rprddpsum(pcols) + real(r8) :: rprdshsum(pcols) + real(r8) :: evapcdpsum(pcols) + real(r8) :: evapcshsum(pcols) + + real(r8) :: tmp_resudp, tmp_resush + + real(r8) :: sflxec(pcols), sflxecdp(pcols) ! deposition flux + real(r8) :: sflxic(pcols), sflxicdp(pcols) ! deposition flux + real(r8) :: sflxbc(pcols), sflxbcdp(pcols) ! deposition flux + real(r8) :: rcscavt(pcols, pver) + real(r8) :: rsscavt(pcols, pver) + real(r8) :: qqcw_in(pcols,pver), qqcw_sav(pcols,pver,pcnst) ! temporary array to hold qqcw for the current mode + real(r8), pointer :: fldcw(:,:) + + logical :: is_done(pcnst,2) + real(r8),target :: zeroAerosolConcentration(pcols,pver) + + real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble + + type(wetdep_inputs_t) :: dep_inputs + + lchnk = state%lchnk + ncol = state%ncol + + call physics_ptend_init(ptend, state%psetcols, 'aero_model_wetdep', lq=wetdep_lq) + + is_done(:,:) = .false. + + + zeroAerosolConcentration(:,:)=0.0_r8 + + ! Wet deposition of mozart aerosol species. + ptend%name = ptend%name//'+mz_aero_wetdep' + + call wetdep_inputs_set( state, pbuf, dep_inputs ) + call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + + prec(:ncol)=0._r8 + do k=1,pver + where (prec(:ncol) >= 1.e-7_r8) + isprx(:ncol,k) = .true. + elsewhere + isprx(:ncol,k) = .false. + endwhere + prec(:ncol) = prec(:ncol) + (dep_inputs%prain(:ncol,k) + dep_inputs%cmfdqr(:ncol,k) - dep_inputs%evapr(:ncol,k)) & + *state%pdel(:ncol,k)/gravit + end do + + +! calculate the mass-weighted sol_factic for coarse mode species +! sol_factic_coarse(:,:) = 0.30_r8 ! tuned 1/4 + f_act_conv_coarse(:,:) = 0.60_r8 ! rce 2010/05/02 + f_act_conv_coarse_dust = 0.40_r8 ! rce 2010/05/02 + f_act_conv_coarse_nacl = 0.80_r8 ! rce 2010/05/02 + !++ag + f_act_conv_coarse(:,:) = 0.5_r8 + !--ag + + scavcoefnv(:,:,0) = 0.0_r8 ! below-cloud scavcoef = 0.0 for cloud-borne species + + do m = 0, nmodes ! main loop over aerosol modes + + do lphase = 1, 2 ! loop over interstitial (1) and cloud-borne (2) forms + + ! sol_factb and sol_facti values + ! sol_factb - currently this is basically a tuning factor + ! sol_facti & sol_factic - currently has a physical basis, and reflects activation fraction + ! + ! 2008-mar-07 rce - sol_factb (interstitial) changed from 0.3 to 0.1 + ! - sol_factic (interstitial, dust modes) changed from 1.0 to 0.5 + ! - sol_factic (cloud-borne, pcarb modes) no need to set it to 0.0 + ! because the cloud-borne pcarbon == 0 (no activation) + ! + ! rce 2010/05/02 + ! prior to this date, sol_factic was used for convective in-cloud wet removal, + ! and its value reflected a combination of an activation fraction (which varied between modes) + ! and a tuning factor + ! from this date forward, two parameters are used for convective in-cloud wet removal + ! f_act_conv is the activation fraction + ! note that "non-activation" of aerosol in air entrained into updrafts should + ! be included here + ! eventually we might use the activate routine (with w ~= 1 m/s) to calculate + ! this, but there is still the entrainment issue + ! sol_factic is strictly a tuning factor + ! + if (lphase == 1) then ! interstial aerosol + !hygro_sum_old(:,:) = 0.0_r8 + !hygro_sum_del(:,:) = 0.0_r8 + !call modal_aero_bcscavcoef_get( m, ncol, isprx, dgncur_awet, & + ! scavcoefnv(:,:,1), scavcoefnv(:,:,2) ) + + scavcoefnv(:,:,1) = 0.1_r8 !Used by MAM for number concentration + + sol_factb = 0.1_r8 ! all below-cloud scav ON (0.1 "tuning factor") +! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 + + sol_facti = 0.0_r8 ! strat in-cloud scav totally OFF for institial + + sol_factic = 0.4_r8 ! xl 2010/05/20 + + !fxm: simplified relative to MAM + f_act_conv = 0.8 !ag: Introduce tuning per component later + + + else ! cloud-borne aerosol (borne by stratiform cloud drops) + + !++ag + !default 100 % is scavenged by cloud -borne + sol_facti_cloud_borne = 1.0_r8 + !--ag + + sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") + sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor + sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean + ! that conv precip collects strat droplets) + f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean + + end if + if (convproc_do_aer .and. lphase == 1) then + ! if modal aero convproc is turned on for aerosols, then + ! turn off the convective in-cloud removal for interstitial aerosols + ! (but leave the below-cloud on, as convproc only does in-cloud) + ! and turn off the outfld SFWET, SFSIC, SFSID, SFSEC, and SFSED calls + ! for (stratiform)-cloudborne aerosols, convective wet removal + ! (all forms) is zero, so no action is needed + sol_factic = 0.0_r8 + endif + + + do lspec = 1,getNumberOfTracersInMode(m) ! loop over number + chem constituents + water + + + mm = getTracerIndex(m,lspec,.false.) + if(is_done(mm,lphase) .eqv. .true. )then + cycle + endif + is_done(mm,lphase)=.true. + + if (lphase == 1) then + jnv = 2 + !Set correct below cloud scaveing coefficients + !Hard-coded values per mode in NorESM + if(is_process_mode(mm,.FALSE.))then + scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficientProcessModes(processModeMap(mm)) + else + scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficient(m) + end if + else + jnv = 0 !==> below cloud scavenging coefficients are zero (see above) + endif + + + + if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then + ptend%lq(mm) = .TRUE. + dqdt_tmp(:,:) = 0.0_r8 + ! q_tmp reflects changes from modal_aero_calcsize and is the "most current" q + q_tmp(1:ncol,:) = state%q(1:ncol,:,mm) + ptend%q(1:ncol,:,mm)*dt + if(convproc_do_aer) then + !Feed in the saved cloudborne mixing ratios from phase 2 + qqcw_in(:,:) = qqcw_sav(:,:,mm) + !Not implemented for oslo aerosols + else + fldcw => qqcw_get_field(pbuf, mm,lchnk, .TRUE.) + if(.not. associated(fldcw))then + qqcw_in(:,:) = zeroAerosolConcentration(:,:) + else + qqcw_in(:,:) = fldcw(:,:) + end if + endif + + call wetdepa_v2( state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & + dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & + dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & + dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & + dlf, fracis(:,:,mm), sol_factb, ncol, & + scavcoefnv(:,:,jnv), & + is_strat_cloudborne=.false., & + qqcw=qqcw_in(:,:), & + f_act_conv=f_act_conv, & + icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & + convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & + sol_facti_in=sol_facti, sol_factic_in=sol_factic ) + + ptend%q(1:ncol,:,mm) = ptend%q(1:ncol,:,mm) + dqdt_tmp(1:ncol,:) + + call outfld( trim(cnst_name(mm))//'WET', dqdt_tmp(:,:), pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SIC', icscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SIS', isscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SBC', bcscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SBS', bsscavt, pcols, lchnk) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + enddo + enddo + if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFWET', sflx, pcols, lchnk) + aerdepwetis(:ncol,mm) = sflx(:ncol) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFSIC', sflx, pcols, lchnk) + if (convproc_do_aer) sflxic = sflx + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(cnst_name(mm))//'SFSIS', sflx, pcols, lchnk) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(cnst_name(mm))//'SFSBC', sflx, pcols, lchnk) + if (convproc_do_aer)sflxbc = sflx + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(cnst_name(mm))//'SFSBS', sflx, pcols, lchnk) + + + + + else ! lphase == 2 + dqdt_tmp(:,:) = 0.0_r8 + qqcw_tmp(:,:) = 0.0_r8 ! rce 2010/05/01 + + if (convproc_do_aer) then + fldcw => qqcw_get_field(pbuf,mm,lchnk) + qqcw_sav(1:ncol,:,mm) = fldcw(1:ncol,:) + !This option yet not implemented for OSLO_AERO + else + fldcw => qqcw_get_field(pbuf, mm,lchnk, .TRUE.) + if(.not. associated(fldcw))then + cycle + end if + endif + + call wetdepa_v2(state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & + dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & + dep_inputs%evapr, dep_inputs%totcond, fldcw, dt, & + dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & + dlf, fracis_cw, sol_factb, ncol, & + scavcoefnv(:,:,jnv), & + is_strat_cloudborne=.true., & + icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & + convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & + sol_facti_in=sol_facti, sol_factic_in=sol_factic ) + + fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(getCloudTracerName(mm))//'SFWET', sflx, pcols, lchnk) + aerdepwetcw(:ncol,mm) = sflx(:ncol) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(getCloudTracerName(mm))//'SFSIC', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(getCloudTracerName(mm))//'SFSIS', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(getCloudTracerName(mm))//'SFSBC', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + enddo + enddo + call outfld( trim(getCloudTracerName(mm))//'SFSBS', sflx, pcols, lchnk) + + endif + + enddo ! lspec = 0, nspec_amode(m)+1 + enddo ! lphase = 1, 2 + enddo ! m = 1, ntot_amode + + ! if the user has specified prescribed aerosol dep fluxes then + ! do not set cam_out dep fluxes according to the prognostic aerosols + if (.not. aerodep_flx_prescribed()) then + call set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) + endif + + return + + end subroutine oslo_aero_wet_intr + + + + !=============================================================================== + subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & + radius_part, density_part, sig_part, moment, lchnk ) + +! calculates surface deposition velocity of particles +! L. Zhang, S. Gong, J. Padro, and L. Barrie +! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module +! Atmospheric Environment, 35, 549-560, 2001. +! +! Authors: X. Liu + + ! + ! !USES + ! + use physconst, only: pi,boltz, gravit, rair + use mo_drydep, only: n_land_type, fraction_landuse + + ! !ARGUMENTS: + ! + implicit none + ! + real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) + real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) + real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) + real(r8), intent(in) :: ram1(pcols) !aerodynamical resistance (s/m) + real(r8), intent(in) :: radius_part(pcols,pver) ! mean (volume/number) particle radius (m) + real(r8), intent(in) :: density_part(pcols,pver) ! density of particle material (kg/m3) + real(r8), intent(in) :: sig_part(pcols,pver) ! geometric standard deviation of particles + integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) + integer, intent(in) :: ncol + integer, intent(in) :: lchnk + + real(r8), intent(out) :: vlc_trb(pcols) !Turbulent deposn velocity (m/s) + real(r8), intent(out) :: vlc_grv(pcols,pver) !grav deposn velocity (m/s) + real(r8), intent(out) :: vlc_dry(pcols,pver) !dry deposn velocity (m/s) + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! Local Variables + integer :: m,i,k,ix !indices + real(r8) :: rho !atm density (kg/m**3) + real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air + real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere + real(r8) :: shm_nbr ![frc] Schmidt number + real(r8) :: stk_nbr ![frc] Stokes number + real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air + real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle + real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor + real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition + real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance + real(r8) :: brownian ! collection efficiency for Browning diffusion + real(r8) :: impaction ! collection efficiency for impaction + real(r8) :: interception ! collection efficiency for interception + real(r8) :: stickfrac ! fraction of particles sticking to surface + real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment + real(r8) :: lnsig ! ln(sig_part) + real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) + + integer :: lt + real(r8) :: lnd_frc + real(r8) :: wrk1, wrk2, wrk3 + + ! constants + real(r8) gamma(11) ! exponent of schmidt number +! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & +! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & +! 0.50d+00/ + data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & + 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & + 0.54e+00_r8/ + save gamma + + real(r8) alpha(11) ! parameter for impaction +! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & +! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & +! 100.00d+00/ + data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & + 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & + 50.00e+00_r8/ + save alpha + + real(r8) radius_collector(11) ! radius (m) of surface collectors +! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & +! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & +! -1.00d+00/ + data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & + 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & + -1.00e+00_r8/ + save radius_collector + + integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 +! data iwet/1, -1, -1, -1, -1, & +! -1, -1, -1, 1, -1, & +! 1/ + data iwet/-1, -1, -1, -1, -1, & + -1, 1, -1, 1, -1, & + -1/ + save iwet + + + !------------------------------------------------------------------------ + + if(top_lev.gt.1) then + vlc_grv(:ncol,:top_lev-1) = 0._r8 + vlc_dry(:ncol,:top_lev-1) = 0._r8 + endif + + do k=top_lev,pver + do i=1,ncol + + lnsig = log(sig_part(i,k)) +! use a maximum radius of 50 microns when calculating deposition velocity + radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & + exp((float(moment)-1.5_r8)*lnsig*lnsig) + dispersion = exp(2._r8*lnsig*lnsig) + + rho=pmid(i,k)/rair/t(i,k) + + ! Quasi-laminar layer resistance: call rss_lmn_get + ! Size-independent thermokinetic properties + vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & + (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 + mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 + (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) + vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air + + slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & + (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & + radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 + vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & + gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 + vlc_grv(i,k) = vlc_grv(i,k) * dispersion + + vlc_dry(i,k)=vlc_grv(i,k) + enddo + enddo + k=pver ! only look at bottom level for next part + do i=1,ncol + dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] + (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 + shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 + + wrk2 = 0._r8 + wrk3 = 0._r8 + do lt = 1,n_land_type + lnd_frc = fraction_landuse(i,lt,lchnk) + if ( lnd_frc /= 0._r8 ) then + brownian = shm_nbr**(-gamma(lt)) + if (radius_collector(lt) > 0.0_r8) then +! vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) + interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 + else +! non-vegetated surface + stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 + interception = 0.0_r8 + endif + impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 + + if (iwet(lt) > 0) then + stickfrac = 1.0_r8 + else + stickfrac = exp(-sqrt(stk_nbr)) + if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 + endif + rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) + rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) + + wrk1 = 1.0_r8 / rss_trb + wrk2 = wrk2 + lnd_frc*( wrk1 ) + wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) + endif + enddo ! n_land_type + vlc_trb(i) = wrk2 + vlc_dry(i,k) = wrk3 + enddo !ncol + + return + end subroutine modal_aero_depvel_part + + !=============================================================================== + + + +end module oslo_aerosols_intr diff --git a/src/chemistry/oslo_aero/oslo_ocean_intr.F90 b/src/chemistry/oslo_aero/oslo_ocean_intr.F90 new file mode 100644 index 0000000000..c934313700 --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_ocean_intr.F90 @@ -0,0 +1,429 @@ +!------------------------------------------------------------------- +! Marine DMS and POM emissions module +! Documentation: Implementation of interactive DMS and marine organic +! emission schemes in NorESM2, Lewinschal, 2015 +! Manages reading and interpolation of ocean tracer concentrations from file +! and calculates DMS and marine POM emissions. +! Parameterisations available: +! Nightingale et al. Global biogeochemical cycles 2000 (DMS) +! Nilsson, unpublished (POM) +! O'Dowd et al. GRL 2008 (POM) +! Based on prescribed_volcaero created by Francis Vitt and mo_srf_emissions +!------------------------------------------------------------------- +module oslo_ocean_intr + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_abortutils, only : endrun + use spmd_utils, only : masterproc + use tracer_data, only : trfld, trfile + use cam_logfile, only : iulog + use ppgrid, only : pcols, pver,pverp + use camsrfexch, only : cam_in_t !, cam_out_t ? + + implicit none + + + +! new type for ocean species + + type :: oceanspc +! integer :: spc_ndx ! could be added for selective reading + character(len=16) :: species(1) ! Species name +! character(len=8) :: units ! could be added for units check + type(trfld), pointer :: fields(:) ! where the data ends up fields%data + type(trfile) :: file + end type oceanspc + + +!------------------------------------------------------------------------------------- + + + +! List of subroutines that can be accesed from outside module + + public :: oslo_ocean_getnl ! should this be public. Only used locally... + public :: oslo_ocean_init ! initializing, reading file + public :: oslo_ocean_time ! time interpolation + public :: oslo_dms_emis_intr ! calculate dms surface emissions + public :: oslo_dms_inq ! logical function which tells mo_srf_emis what to do + public :: oslo_opom_emis_intr ! calculate opom surface emissions + public :: oslo_opom_inq ! logical function which tells oslo_salt what to do + + + + private + save + + type(oceanspc), allocatable :: oceanspcs(:) + + + + + +! These variables are settable via the namelist (with longer names) +! For reading concentration file + character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var + character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var + character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var + character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var + character(len=256) :: filename = '' !will be collected from NAMELIST + character(len=256) :: filelist = '' !not needed? + character(len=256) :: datapath = '' !will be collected from NAMELIST + character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST + character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST + logical :: rmv_file = .false. !delete file when finished with it + integer :: dms_cycle_yr = 0 !will be collected from NAMELIST + integer :: opom_cycle_yr = 0 !will be collected from NAMELIST + integer :: fixed_ymd = 0 !running one date only? + integer :: fixed_tod = 0 !running one time of day only? + + character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST + character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST + integer :: n_ocean_species !Number of variables read from ocean file + integer :: pndx_fdms !DMS surface flux physics index + +contains +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +subroutine oslo_ocean_getnl() +! Read namelist variables. For oslo namelist variables this is done through oslo_getopts + + use oslo_control, only: oslo_getopts + + implicit none + + ! declaration of variables collected from namelist + character(len=256) :: in_filename + character(len=256) :: in_datapath + character(len=20) :: in_dms_data_source + character(len=32) :: in_dms_data_type + integer :: in_dms_cycle_yr + character(len=20) :: in_opom_data_source + character(len=32) :: in_opom_data_type + integer :: in_opom_cycle_yr + + + ! Initialize namelist variables from local module variables. + in_filename = filename + in_datapath = datapath + in_dms_data_type = dms_data_type + in_dms_cycle_yr = dms_cycle_yr + in_dms_data_source = dms_source + in_opom_data_type = opom_data_type + in_opom_cycle_yr = opom_cycle_yr + in_opom_data_source = opom_source + + ! Read namelist. + call oslo_getopts(dms_source_out = in_dms_data_source, & + dms_source_type_out = in_dms_data_type, & + dms_cycle_year_out = in_dms_cycle_yr, & + opom_source_out = in_opom_data_source, & + opom_source_type_out= in_opom_data_type, & + opom_cycle_year_out = in_opom_cycle_yr, & + ocean_filename_out = in_filename, & + ocean_filepath_out = in_datapath) + + + ! Update module variables with user settings. + filename = in_filename + datapath = in_datapath + dms_data_type = in_dms_data_type + dms_cycle_yr = in_dms_cycle_yr + dms_source = in_dms_data_source + opom_data_type= in_opom_data_type + opom_cycle_yr = in_opom_cycle_yr + opom_source = in_opom_data_source + + ! Write new value set from namelist to log +! write(iulog,*)"test pom namelist 2: " // trim(opom_source) + +endsubroutine oslo_ocean_getnl +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- +subroutine oslo_ocean_init() +! no in parameters all information is local + + use tracer_data, only : trcdata_init + use constituents, only : cnst_get_ind + use cam_history, only : addfld, add_default, horiz_only + + implicit none + + integer :: astat + integer :: m + integer :: cycle_yr(2) + character(len=32) :: data_type(2) + character(len=16) :: emis_species(2) + + ! Collect and save namelist information in module + call oslo_ocean_getnl() + + !get physics index for dms surface flux. Index for cflx + call cnst_get_ind('DMS', pndx_fdms, abort=.true.) + +! write(iulog,*)"test dms p index: " ,pndx_fdms + + if (dms_source=='lana')then + emis_species(1) = dmsl_fld_name + else + emis_species(1) = dmsk_fld_name + endif + if (opom_source=='odowd')then + emis_species(2) = opomo_fld_name + else + emis_species(2) = opomn_fld_name + endif + cycle_yr(1)= dms_cycle_yr + cycle_yr(2)= opom_cycle_yr + data_type(1) = dms_data_type + data_type(2) = opom_data_type + n_ocean_species = 2 + + if (masterproc) write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species + + allocate( oceanspcs(n_ocean_species), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat + call endrun + end if + + + !----------------------------------------------------------------------- + ! ... setup the oceanspcs type array + !----------------------------------------------------------------------- +! Add support for selective reading with saved units etc.? + do m=1,n_ocean_species ! one for now... start with dms +! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index +! oceanspcs(m)%units = 'nmol/L' + oceanspcs(m)%species = emis_species(m) ! nc var name + + enddo + + do m=1,n_ocean_species + + ! Ocean concentrations are not stored in pbuf + allocate(oceanspcs(m)%file%in_pbuf(1)) + oceanspcs(m)%file%in_pbuf(:) = .false. + + call trcdata_init( oceanspcs(m)%species, & + filename, filelist, datapath, & + oceanspcs(m)%fields, & + oceanspcs(m)%file, & + rmv_file, cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) + + enddo +! write(iulog,*) 'oslo_ocean_init: read file ' + + call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) + + call add_default('odms', 1, ' ') + +endsubroutine oslo_ocean_init +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ +subroutine oslo_ocean_time(state, pbuf2d) + + use physics_types, only : physics_state + use ppgrid, only : begchunk, endchunk + use tracer_data, only : advance_trcdata + use physics_buffer, only : physics_buffer_desc + + implicit none + + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: m + + do m = 1,n_ocean_species + + call advance_trcdata( oceanspcs(m)%fields, oceanspcs(m)%file, state, pbuf2d ) + end do + + +endsubroutine oslo_ocean_time + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +subroutine oslo_dms_emis_intr(state, cam_in) + + use physics_types, only: physics_state + use constituents, only: cnst_mw !molecular weight for physics constituents + use cam_history, only: outfld + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + + real(r8), dimension(pcols) :: u10m ![m/s] + real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction + real(r8), pointer :: icefrc(:) ![frc] ice fraction + integer :: ncol ![nbr] number of columns in use + integer :: lchnk ! chunk index + + real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] + real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] + real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file + real(r8) :: open_ocn(pcols) ! Open Ocean + + real(r8), dimension(pcols):: t,scdms,kwdms + + real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean + real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 + + logical, parameter :: method_oslo =.false. + logical, parameter :: method_hamocc=.true. + + !pointers to land model variables + ocnfrc => cam_in%ocnfrac + icefrc => cam_in%icefrac + ncol = state%ncol + lchnk = state%lchnk + + ! IF CONCENTRATION FILE + if (dms_source=='lana' .or. dms_source=='kettle') then + + ! collect dms data from file + flux(:) = 0._r8 + odms(:) = 0._r8 + odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) + + ! open ocean + open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) + !start with midpoint wind speed + u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) + + if (method_oslo) then + ! move the winds to 10m high from the midpoint of the gridbox: + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] + flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] + else if (method_hamocc) then + t(:ncol)=cam_in%sst(:ncol)-273.15_r8 + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) + kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 + flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) + endif + cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) + + call outfld('odms', odms(:ncol), ncol, lchnk) + + ! IF OCEAN FLUX + elseif(dms_source=='ocean_flux') then + cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) + endif + + ! IF EMISSION FILE + ! return without changing cflx + ! return? + +endsubroutine oslo_dms_emis_intr +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +subroutine oslo_opom_emis_intr(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) + + + + integer , intent(in) :: ncol ![nbr] number of columns in use + integer , intent(in) :: lchnk !current chunk + real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 + real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 + real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 + real(r8), intent(in) :: open_ocn(pcols) !open ocean + real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] +! integer :: lchnk ! chunk index + + real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] + + ! Variables for Nilsson parameterisation + real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] +! real(r8), parameter :: c_n = 0.000288657_r8 ! OM tuning constant (NorESM1 value) + real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) + real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode + real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode + real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode + + ! Variables for O'Dowd parameterisation + real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass + real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] + real(r8),parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. + ! Not consistent with the parameterisation of O'Dowd. Set to 1 + ! for original parameterisation. + + + + + ! Nilsson parameterisation + if (opom_source=='nilsson') then + + ! collect POC data from file + flux(:) = 0._r8 + opoc(:) = 0._r8 + + opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + + flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* & + (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) + + opomem_out(:ncol) = flux(:ncol) + + + ! O'Dowd parameterisation + elseif (opom_source=='odowd') then + + ! collect dms data from file + flux(:) = 0._r8 + ochlor(:) = 0._r8 + + ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + ! OM fraction saturates at 90% according to O'Dowd 2008 + omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) + omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) + flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) + opomem_out(:ncol) = flux(:ncol) + endif + + ! return? + +endsubroutine oslo_opom_emis_intr +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +logical function oslo_dms_inq() + implicit none + + if (dms_source=='emission_file') then + oslo_dms_inq = .true. + else + oslo_dms_inq = .false. + endif + return + +end function oslo_dms_inq + + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +logical function oslo_opom_inq() + implicit none + + if (opom_source=='nilsson' .or. opom_source=='odowd') then + oslo_opom_inq = .true. + else + oslo_opom_inq = .false. + endif + return + +end function oslo_opom_inq + +!------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------ + +end module oslo_ocean_intr diff --git a/src/chemistry/oslo_aero/oslo_utils.F90 b/src/chemistry/oslo_aero/oslo_utils.F90 new file mode 100644 index 0000000000..592f0eb6e5 --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_utils.F90 @@ -0,0 +1,179 @@ +module oslo_utils + + use ppgrid, only : pcols, pver + use shr_kind_mod, only: r8 => shr_kind_r8 +! use commondefinitions, only: nmodes, nbmodes + use commondefinitions +! use aerosoldef, only: nmodes, getDryDensity, & +! getNumberOfBackgroundTracersInMode & +! ,getTracerIndex, originalNumberMedianRadius + use aerosoldef, only: getDryDensity, & + getNumberOfBackgroundTracersInMode & + ,getTracerIndex + use const, only : volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab + use physconst, only : pi + use constituents, only: pcnst + +contains + + subroutine calculateNumberConcentration(ncol, q, rho_air, numberConcentration) + implicit none + integer, intent(in) :: ncol !number of columns used + real(r8), intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios + real(r8), intent(in) :: rho_air(pcols,pver) ![kg/m3] air density + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + + integer :: m, l, mm, k + + numberConcentration(:,:,:) = 0.0_r8 + + do m = 0, nmodes + + do l=1,getNumberOfBackgroundTracersInMode(m) + mm = getTracerIndex(m,l,.false.) + + do k=1,pver + numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) & + + ( q(:ncol,k,mm) / getDryDensity(m,l)) !Volume of this tracer + end do + + end do + end do + + !until now, the variable "numberConcentration" actually contained "volume mixing ratio" + !the next couple of lines fixes this! + do m= 0, nmodes + do k=1,pver + numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) * rho_air(:ncol,k) * volumeToNumber(m) + end do + end do + + return + + end subroutine calculateNumberConcentration + + + !Note the "nmodes" here + subroutine calculateNumberMedianRadius(numberConcentration & + , volumeConcentration & + , lnSigma & + , numberMedianRadius & + , ncol ) + + implicit none + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![kg/kg] mass mixing ratios + real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) ![kg/m3] air density + integer, intent(in) :: ncol !number of columns used + + real(r8), intent(out) :: numberMedianRadius(pcols,pver,nmodes) ![m] + + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + + integer :: n,k + + do n=1,nmodes + do k=1,pver + where(volumeConcentration(:ncol,k,n) .gt. 1.e-20_r8) + numberMedianRadius(:ncol, k, n) = 0.5_r8 & !diameter ==> radius + * (volumeConcentration(:ncol,k,n) & !conversion formula + * 6.0_r8/pi/numberConcentration(:ncol,k,n) & + *DEXP(-4.5_r8*lnsigma(:ncol,k,n)*lnsigma(:ncol,k,n)))**aThird + elsewhere + numberMedianRadius(:ncol,k,n) = originalNumberMedianRadius(n) + end where + end do + end do + + end subroutine calculateNumberMedianRadius + + + function calculateEquivalentDensityOfFractalMode( emissionDensity & ![kg/m3] density at point of emission + , emissionRadius & ![kg/m3] radius at point of emission + , fractalDimension & ![kg/m3] fractal dimension of mode + , modeNumberMedianRadius & ![m] number median radius of mode + , modeStandardDeviation & ![m] standard deviation of mode + ) result (equivalentDensityOfFractal) + + !Purpose: output equivalent density of a fractal mode + implicit none + real(r8), intent(in) :: emissionDensity + real(r8), intent(in) :: emissionRadius + real(r8), intent(in) :: fractalDimension + real(r8), intent(in) :: modeNumberMedianRadius + real(r8), intent(in) :: modeStandardDeviation + + real(r8) :: sumVolume + real(r8) :: sumMass + real(r8) :: dN, dNdLogR, dLogR + real(r8) :: densityBin + integer :: i + + !output + real(r8) :: equivalentDensityOfFractal + + sumVolume = 0.0_r8 + sumMass = 0.0_r8 + do i=1, nbinsTab + dLogR = log(rBinEdge(i+1)/rBinEdge(i)) + dNdLogR = calculatedNdLogR(rBinMidPoint(i), modeNumberMedianRadius, modeStandardDeviation) + + !Equivalent density (decreases with size since larger particles are long + !"hair like" threads..) + if(rBinMidPoint(i) < emissionRadius)then + densityBin = emissionDensity + else + densityBin = emissionDensity*(emissionRadius/rBinMidPoint(i))**(3.0 - fractalDimension) + endif + + !number concentration in this bin + dN = dNdLogR * dLogR + + !sum up volume and mass (factor of 4*pi/3 omitted since in both numerator and nominator) + sumVolume = sumVolume + dN * (rBinMidPoint(i)**3) + sumMass = sumMass + dN * densityBin * (rBinMidPoint(i)**3) + + end do + + !Equivalent density is mass by volume + equivalentDensityOfFractal = sumMass / sumVolume + + end function calculateEquivalentDensityOfFractalMode + + + + function calculatedNdLogR(actualRadius, numberMedianRadius, sigma) result (dNdLogR) + implicit none + real(r8), intent(in) :: actualRadius + real(r8), intent(in) :: numberMedianRadius + real(r8), intent(in) :: sigma + + real(r8) :: logSigma + real(r8) :: dNdLogR + + logSigma = log(sigma) + + !This is the formula for the lognormal distribution + dNdLogR = 1.0_r8/(sqrt(2.0_r8*pi)*log(sigma)) & + * DEXP(-0.5_r8*(log(actualRadius/numberMedianRadius))**2/(logSigma**2)) + + return + end function calculatedNdLogR + + !http://en.wikipedia.org/wiki/Log-normal_distribution#Cumulative_distribution_function + function calculateLognormalCDF(actualRadius, numberMedianRadius, sigma) result(CDF) + implicit none + real(r8), intent(in) :: actualRadius + real(r8), intent(in) :: numberMedianRadius + real(r8), intent(in) :: sigma + + real(r8) :: argument + real(r8) :: CDF + + argument = -1.0_r8*(log(actualRadius/numberMedianRadius) / log(sigma) / sqrt(2.0_r8)) + CDF = 0.5_r8 * erfc(argument) + return + end function calculateLognormalCDF + + +end module oslo_utils diff --git a/src/chemistry/oslo_aero/oxi_diurnal_var.F90 b/src/chemistry/oslo_aero/oxi_diurnal_var.F90 new file mode 100644 index 0000000000..3820a8bb2a --- /dev/null +++ b/src/chemistry/oslo_aero/oxi_diurnal_var.F90 @@ -0,0 +1,537 @@ +module oxi_diurnal_var + +use chem_mods, only : nfs +use physconst, only : pi +use mo_chem_utls, only : get_inv_ndx +use ppgrid, only : pcols, pver +use phys_grid, only: get_rlat_all_p, get_rlon_all_p +use shr_kind_mod, only: r8 => shr_kind_r8 +implicit none +private +save + + +public :: & + set_diurnal_invariants + +private :: & + sunrisesetxx , srisesetxx + + + integer, pointer :: id_oh,id_no3,id_ho2 + logical :: inv_oh,inv_ho2,inv_no3 + +contains + + + subroutine set_diurnal_invariants(invariants,dtc,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2, inv_no3, id_no3) !++IH: added ,inv_no3, id_no3 + + use chem_mods, only : nfs + use time_manager, only : get_curr_date + + + real(r8), intent(in) :: dtc ! Time step + integer, intent(in) :: ncol + integer, intent(in) :: lchnk ! chunk id + logical, intent(in) :: inv_oh, inv_ho2, inv_no3 !++IH: added inv_no3 + integer, intent(in) :: id_oh, id_ho2, id_no3 !++IH: added id_no3 + real(r8), intent(inout) :: invariants(ncol,pver,nfs) + + + + + integer :: i ! column index + integer :: k ! height index + integer :: iriseset ! sunrise/set flag + integer :: day, mon, yr, jyr ! date stuff + integer :: j ! working var + integer :: ncsec ! time stuff + + real(r8) :: deglat, deglon ! lat and long (degrees) + real(r8) :: solardec ! solar declination (degrees) + real(r8) :: sum ! working vars + real(r8) :: trise, tset ! sunrise and set times (h then d) + real(r8) :: tlight ! amount of daylight (d) + real(r8) :: trisej, tsetj ! working vars + real(r8) :: t1, t2, ta, tb ! working vars + real(r8) :: rlats(pcols), rlons(pcols) ! latitude & longitude (radians) + real(r8) :: fdiurn_oxid + real(r8) :: fdiurn_no3oxid !++IH + + + + call get_curr_date(yr, mon, day, ncsec) + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + +! jyr = mod( yr, 100 ) + 1900 +! if (jyr < 1950) jyr = jyr + 100 +! if (jyr > 2049) jyr = jyr - 100 + jyr=2000 +! Assume the daily cycle to follow year 2000. The subroutine is +! at any rate only valid between 1950 and 2050, so important years e.g. 1850 +! is out of boundary + + + do i=1,ncol + + fdiurn_oxid=1._r8 + fdiurn_no3oxid=1._r8 !++IH + + deglat = rlats(i)*180._r8/pi + deglat = max( -89.9999_r8, min( +89.9999_r8, deglat ) ) + deglon = rlons(i)*180._r8/pi + +! get sunrise and sunset times in UTC hours + call sunrisesetxx( deglon, deglat, jyr, mon, day, & + iriseset, trise, tset, solardec ) + +! convert rise/set times to days +! compute tlight = amount of daylight +! handle case of all day or night + if (iriseset > 0) then + trise = trise/24._r8 + tset = tset/24._r8 + tlight = tset - trise + if (tlight < 0._r8) then + tset = tset + 1.0_r8 + tlight = tlight + 1._r8 + end if + else + trise = 0._r8 + if (abs(deglat+solardec) .ge. 90._r8) then + tset = 1._r8 + else + tset = 0._r8 + end if + tlight = tset - trise !length of light period in a day + end if + +! if all day or all night (or very close to it), set fdiurn = 1.0 +! Also in periods with all night, we put the mean value for all night steps + if ((tlight .ge. 0.99_r8) .or. (tlight .le. 0.01_r8)) then + fdiurn_oxid = 1._r8 + fdiurn_no3oxid = 1._r8 !++IH +! otherwise determine overlap between current timestep and daylight times +! to account for all overlap possibilities, need to try this +! with rise/set times shifted by +/- 1 day + else !==> There is diurnal cycle + t1 = ncsec/86400._r8 !start of timestep (days) + t2 = t1 + dtc/86400._r8 !end of timestep (days) + sum = 0._r8 + do j = -1, 1 + trisej = trise + dfloat(j) !one day before sunrise, sunrise, one day after runrise + tsetj = trisej + tlight !time of sunset given "j" + ta = max( t1, trisej ) !start or sunrise (if later) + tb = min( t2, tsetj ) !end of step or sunset (if earlier) + sum = sum + max( tb-ta, 0._r8 ) + + end do + + !sum is length of timestep (in days) which has light + !"sum"/(t1-t2) is fraction of timestep which has light + !"tlight is fraction of day which has light + !So if fraction of dt is higher than avg fraction during day ==> increase oxidants + ! if fraction of dt is lower than avg fraction during day ==> decrease oxidants + + !++IH + if (inv_oh .or. inv_ho2) then + !--IH + fdiurn_oxid = max(1.0e-3_r8, sum/(t2-t1)/tlight) + !++IH + end if + if (inv_no3) then + fdiurn_no3oxid = max(1.0e-3_r8, (1._r8 - (sum/(t2-t1))) / (1._r8 - tlight)) + ! (1._r8 - (sum/(t2-t1))) is the fraction of timestep WITHOUT light + ! (1._r8 - tlight) is the fraction of day WITHOUT light + end if + !--IH + end if + + if (inv_oh) then + do k=1,pver + invariants(i,k,id_oh)=invariants(i,k,id_oh)*fdiurn_oxid + end do + end if + + if (inv_ho2) then + do k=1,pver + invariants(i,k,id_ho2)=invariants(i,k,id_ho2)*fdiurn_oxid + end do + end if + + !++IH + if (inv_no3) then + do k=1,pver + invariants(i,k,id_no3)=invariants(i,k,id_no3)*fdiurn_no3oxid + end do + end if + !--IH + + end do ! i= 1,ncol + end subroutine set_diurnal_invariants + + +!-------------------------------------------------------------------- + subroutine sunrisesetxx( xlong, ylat, iyear, imonth, iday, & + iflag, trise, tset, solardec ) +! +! provides interface to subr srisesetxx without use of common blocks +! +! input parameters +! xlong - longitude in degrees (east longitudes are positive) +! ylat - latitude in degrees (north latitudes are positive) +! iyear - year +! imonth - month +! iday - day +! output parameters +! iflag - status flag +! +1 - OK and there is a sunrise and sunset +! 0 - OK but no sunrise or sunset +! -1 = input parameters (date or position) are bad +! trise - time of sunrise in UT hours +! tset - time of sunset in UT hours +! solardec - apparent solar declination in degrees +! +! written 17-aug-93 by r.c.easter +! Rewritten into fortran 90 by Ø Seland + + + + +! arguments + + + real(r8) ,intent(in) :: xlong + real(r8) ,intent(in) :: ylat + integer ,intent(in) :: iyear + integer ,intent(in) :: imonth + integer ,intent(in) :: iday + integer ,intent(out) :: iflag + real(r8) ,intent(out) :: trise + real(r8) ,intent(out) :: tset + real(r8) ,intent(out) :: solardec +! local + real(r8) sunrise, sunset, ap_dec + real(r8) :: xlongb + integer :: iriseset,i + +! need xlong between -180 and +180 + xlongb = xlong +! do 1000 i = 1, 10 + if (xlongb .lt. -180.) then + xlongb = xlongb + 360._r8 + else if (xlongb .gt. 180._r8) then + xlongb = xlongb - 360._r8 +! else +! goto 1050 + end if +!1000 continue +!1050 continue + + call srisesetxx( iyear, imonth, iday, ylat, xlongb, & + iriseset,sunrise, sunset, ap_dec) + + iflag = iriseset + if (iflag .eq. 0) then + iflag = 1 + if (abs(sunrise+100_r8) .le. 0.01_r8) iflag = 0 + end if + trise = sunrise + tset = sunset + solardec = ap_dec + + end subroutine sunrisesetxx + + + +!c*************************************************************************** + subroutine srisesetxx(iyear, month, iday, rlat, rlong, & + iriseset,sunrise, sunset,ap_dec) + + + integer ,intent(in) :: iyear + integer ,intent(in) :: month + integer ,intent(in) :: iday + real(r8) ,intent(in) :: rlat + real(r8) ,intent(in) :: rlong + integer ,intent(out) :: iriseset + real(r8) ,intent(out) :: sunrise + real(r8) ,intent(out) :: sunset + real(r8) ,intent(out) :: ap_dec + + +!local + integer :: jday + + integer ,dimension(12) :: iimonth,iimonthleap + logical :: leapyr + +!c math definitions. +! real(r8),parameter :: twopi = 6.2831853071795864_r8 + real(r8),parameter :: twopi = 2._r8*pi + real(r8), parameter :: deg_rad = 0.017453292519943295_r8 + real(r8), parameter :: rad_deg = 57.295779513082323_r8 +! local variables + + real(r8) :: mean_anomaly, mean_longitude, mean_obliquity + real(r8) :: year + + real(r8) :: delta_years,delta_days,days_j2000 + real(r8) :: cent_j2000,f_mean_anomaly,f_mean_longitude + real(r8) :: ecliptic_long,f_ap_ra, ap_ra,f_gmst0h + real(r8) :: gmst0h,rlat_r,tan_lat,tan_dec,tangterm + real(r8) :: timeterm + + data iimonth /0,31,59,90,120,151,181,212,243,273,304,334/ + data iimonthleap /0,31,60,91,121,152,182,213,244,274,305,335/ + leapyr = .false. + +!! common / sundataxx_cmn / jday, iriseset, +! + sunrise, sunset, rloc_timehrs, ap_dec +!c-------------------------------------------------------------------------- +!c "sunriseset.c" contains the integer function sunriseset() for calculating +!c the rising and setting times of the Sun as seen from a place on Earth on a +!c specific date. +!c +!c Version 1.0 - April 6, 1992. +!c (This code was adapted from "solarpos.c" Version 3.1.) +!c +!c sunriseset() employs the low precision formulas for the Sun's coordinates +!c given in the "Astronomical Almanac" of 1990 to compute the Sun's apparent +!c right ascension, apparent declination, and Greenwich mean sidereal time at +!c 0 hours Universal Time, and then the rising and setting times of the Sun. +!c The "Astronomical Almanac" (A. A.) states a precision of 0.01 degree for the +!c apparent coordinates between the years 1950 and 2050. +!c +!c The following assumptions and simplifications are made: +!c -> diurnal parallax is ignored, resulting in 0 to 9 arc seconds error in +!c apparent position. +!c -> diurnal aberration is also ignored, resulting in 0 to 0.02 second error +!c in right ascension and 0 to 0.3 arc second error in declination. +!c -> geodetic site coordinates are used, without correction for polar motion +!c (maximum amplitude of 0.3 arc second) and local gravity anomalies. +!c -> the formulas ignore atmospheric refraction, semi-diameter, and changes +!c in right ascension and declination over the course of a day; the +!c accuracies of sunrise and sunset are about 2 and 7 minutes for latitude +!c and longitude of 0 degrees, but accuracy degrades significantly for high +!c latitudes. +!c +!c +!c The necessary input parameters are: +!c -> the UT date, specified in one of three ways: +!c 1) year, month, day.fraction +!c 2) year, daynumber.fraction +!c 3) days.fraction elapsed since January 0, 1900. +!c Note: in GChM application, only specification #1 is currently valid +!c -> site geodetic (geographic) latitude and longitude. +!c +!c Refer to the function declaration for the parameter type specifications and +!c formats. +!c +!c sunriseset() returns -1 if an input parameter is out of bounds, or 0 if +!c values were written to the locations specified by the output parameters. +!c Sunrise and sunset times are in UT hours; if there is no sunrise or sunset +!c the values are -1.0. +!c +!c Author: Nels Larson +!c Pacific Northwest Lab. +!c P.O. Box 999 +!c Richland, WA 99352 +!c U.S.A. +!c +!c-------------------------------------------------------------------------- +!c modifications for gchm application by eg chapman +!c 1. translated from c language to fortran +!c 2. input date must be in year, month, day.fraction format; other input +!c code eliminated. +!c 3. added indicator iriseset. when equal to -1, indicates location +!c or date is out of range. +!c +!c--------------------------------------------------------------------------- + +!c------------------------------------------------------------------------- +!c explanation of terms taken from c code +!c int iyear, Four digit year (Gregorian calendar). +!c [1950 through 2049; 0 if using days_1900] +!c month; Month number. +!c [1 through 12; 0 if using daynumber for day] +!c +!c day, /* Calendar day.fraction, or daynumber.fraction. +!c * [If month is NOT 0: +!c +!c * 0 through 32; 31st @ 18:10:00 UT = 31.75694 +!c * If month IS 0: +!c * 0 through 367; 366 @ 18:10:00 UT = 366.75694] */ +!c days_1900, /* Days since 1900 January 0 @ 00:00:00 UT. +!c * [18262.0 (1950/01/00) through 54788.0 (2049/12/32); +!c +!c * 1990/01/01 @ 18:10:00 UT = 32873.75694; +!c * 0.0 o.k. if using {year, month, day} or +!c * {year, daynumber}] */ +!c rlat Observation site geographic latitude. +!c [degrees.fraction, North positive] +!c rlong Observation site geographic longitude. +!c [degrees.fraction, East positive] +!c *ap_ra, /* Apparent solar right ascension. +!c * [hours; 0.0 <= *ap_ra < 24.0] */ +!c *ap_dec, /* Apparent solar declination. +!c * [degrees; -90.0 <= *ap_dec <= 90.0] */ +!c +!c *sunrise, /* Time of sunrise. +!c [UT hours.fraction; -1.0 if no sunrise or sunset] */ +!c *sunset; /* Time of sunset. +!c [UT hours.fraction; -1.0 if no sunset or sunrise] */ +!c int daynum(); /* Computes a sequential daynumber during a year. */ +!c int daynumber, /* Sequential daynumber during a year. */ +!c delta_days, /* Whole days since 2000 January 0. */ +!c delta_years; /* Whole years since 2000. */ +!c double cent_J2000, /* Julian centuries since epoch J2000.0 at 0h UT. */ +!c days_J2000, /* Days since epoch J2000.0. */ +!c ecliptic_long, /* Solar ecliptic longitude. */ +!c +!c gmst0h, /* Greenwich mean sidereal time at 0 hours UT. */ +!c integral, /* Integral portion of double precision number. */ +!c mean_anomaly, /* Earth mean anomaly. */ +!c mean_longitude, /* Solar mean longitude. */ +!c mean_obliquity, /* Mean obliquity of the ecliptic. */ +!c tan_dec, /* Tangent of apparent declination. */ +!c tan_lat, /* Tangent of latitude. */ +!c +!c tangterm, /* Tangent term of Sun rise/set equation. */ +!c timeterm; /* Time term of Sun rise/set equation. */ +!c---------------------------------------------------------------------- + iriseset = 0 +!c check latitude, longitude, dates for proper range before calculating dates. + if (((rlat .lt. -90._r8) .or. (rlat .gt. 90._r8)) .or. & + ((rlong .lt. -180._r8) .or. (rlong .gt. 180._r8))) then + iriseset = -1 + return + end if + +! Year assumed to be betweeen 1950 and 2049. As the model is outside these +! boundary in many cases. year 2000 is assumed for this version of the +! model + + +! if (iyear .lt. 1950 .or. iyear .gt. 2049) then +! iriseset = -1 +! return +! end if +! if (((month .lt. 1) .or. (month .gt. 12)) .or. & +! ((iday .lt. 0) .or. (iday .gt. 32))) then +! iriseset = -1 +! return +! end if +!c determine julian day number + + + +!c there is no year 0 in the Gregorian calendar and the leap year cycle +!c changes for earlier years. +! if (iyear .lt. 1) then +! iriseset = -1 +! return +! end if +!c leap years are divisible by 4, except for centurial years not divisible +!c by 400. + + +! year = real (iyear) +! if ((amod(year,4.) .eq. 0.0) .and. (amod(year,100.) .ne. 0.0)) & +! leapyr = 1 +! if(amod(year,400.) .eq. 0.0) leapyr = 1 + jday = iimonth(month) + iday +! if ((leapyr .eq. 1) .and. (month .gt. 2)) jday = jday + 1 + +! + +!The +!c construct Julian centuries since J2000 at 0 hours UT of date, +!c days.fraction since J2000, and UT hours. + delta_years = iyear - 2000._r8 +!c delta_days is days from 2000/01/00 (1900's are negative). + delta_days = delta_years * 365._r8 + delta_years / 4._r8 + jday + if (iyear .gt. 2000) delta_days = delta_days + 1._r8 +!c J2000 is 2000/01/01.5 + days_j2000 = delta_days - 1.5_r8 + cent_j2000 = days_j2000 / 36525._r8 +!c compute solar position parameters. +!c A. A. 1990, C24. + f_mean_anomaly = (357.528_r8 + 0.9856003_r8 * days_j2000) + f_mean_longitude = (280.460_r8 + 0.9856474_r8 * days_j2000) +!c put mean_anomaly and mean_longitude in the range 0 -> 2 pi. + mean_anomaly = (f_mean_anomaly / 360._r8 - int(f_mean_anomaly & + /360._r8)) * twopi + mean_longitude = (f_mean_longitude /360. - int( & + f_mean_longitude/360._r8)) * twopi + mean_obliquity = (23.439_r8 - 4.0e-7_r8 * days_j2000) * deg_rad + ecliptic_long = ((1.915_r8 * sin(mean_anomaly)) + & + (0.020_r8 * sin(2.0 * mean_anomaly))) * deg_rad + & + mean_longitude +! tangent of ecliptic_long separated into sine and cosine parts for ap_ra. + f_ap_ra = atan2(cos(mean_obliquity) * sin(ecliptic_long), & + cos(ecliptic_long)) +! change range of ap_ra from -pi -> pi to 0 -> 2 pi. + if (f_ap_ra .lt. 0.0) f_ap_ra = f_ap_ra + twopi +! put ap_ra in the range 0 -> 24 hours. + ap_ra = (f_ap_ra / twopi - int(f_ap_ra /twopi)) * 24._r8 + ap_dec = asin(sin(mean_obliquity) * sin(ecliptic_long)) +! calculate local mean sidereal time. +! A. A. 1990, B6-B7. +! horner's method of polynomial exponent expansion used for gmst0h. + f_gmst0h = 24110.54841_r8 + cent_j2000 * (8640184.812866_r8 & + +cent_j2000 * (0.093104_r8 - cent_j2000 * 6.2e-6_r8)) +! convert gmst0h from seconds to hours and put in the range 0 -> 24. +! 24 hours = 86400 seconds + gmst0h = (f_gmst0h / 86400._r8 - int(f_gmst0h / 86400._r8)) * 24._r8 + if (gmst0h .lt. 0._r8) gmst0h = gmst0h + 24._r8 +!c convert latitude to radians. + rlat_r = rlat * deg_rad +!c avoid tangent overflow at +-90 degrees. +!c 1.57079615 radians is equal to 89.99999 degrees. + if (abs(rlat_r) .lt. 1.57079615_r8) then + tan_lat = tan(rlat_r) + else + tan_lat = 6.0e6_r8 + end if + if (abs(ap_dec) .lt. 1.57079615_r8) then + tan_dec = tan(ap_dec) + else + tan_dec = 6.0e6_r8 + end if +!c compute UTs of sunrise and sunset. +!c A. A. 1990, A12. + tangterm = tan_lat * tan_dec + if (abs(tangterm) .gt. 1.0_r8) then + sunrise = -100._r8 + sunset = -100._r8 + else +!c compute angle of tangterm and convert to hours. + tangterm = acos(-tangterm) / twopi * 24._r8 + timeterm = ap_ra - rlong / 15._r8 - gmst0h + sunrise = timeterm - tangterm + sunset = timeterm + tangterm +!c put sunrise and sunset in the range 0 to 24 hours. +!cec inserted following statement since in some latitudes timeterm +!cec minus tangterm is less than -25 + if (sunrise .le. -24._r8) sunrise = sunrise + 48._r8 + if (sunrise .lt. 0._r8) sunrise = sunrise + 24._r8 + if (sunrise .ge. 24._r8) sunrise = sunrise - 24._r8 + if (sunset .lt. 0._r8) sunset = sunset + 24._r8 + if (sunset .ge. 24._r8) sunset = sunset - 24._r8 +!c mean sidereal day is 0.99727 mean solar days. + sunrise = sunrise * 0.99727_r8 + sunset = sunset * 0.99727_r8 + end if +!c convert ap_dec to degrees. + ap_dec = ap_dec * rad_deg + return + end subroutine srisesetxx + + +end module oxi_diurnal_var + + + + diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 new file mode 100644 index 0000000000..aa9296ded0 --- /dev/null +++ b/src/chemistry/oslo_aero/parmix_progncdnc.F90 @@ -0,0 +1,925 @@ +module parmix_progncdnc + + use const, only : volumeToNumber,smallNumber + use modalapp2d + use physconst, only: density_water =>rhoh2o, molecularWeightWater=>mwh2o + use ppgrid, only : pcols, pver + use shr_kind_mod, only: r8 => shr_kind_r8 + use commondefinitions + use aerosoldef + use physconst, only: pi + use constituents, only: pcnst, cnst_name + use intlog1to3, only: intlog1to3_sub + use intlog4, only: intlog4_sub + use intlog5to10, only: intlog5to10_sub + use constituents, only: cnst_name + + implicit none + public + save + + !Size of molecule-layer which defines when particles are coated + real(r8), parameter :: coatingLimit = 2.e-9_r8 ![m] + !The fraction of soluble material required in a components before it + !will add to any coating + real(r8), parameter :: solubleMassFractionCoatingLimit=0.50_r8 + + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + real(r8), parameter :: ln10 = log(10.0_r8) + +contains + + !Calculate concentrations of aerosol modes based on lifecycle species + !Create an array of "mode_definition_t" which holds the aerosol concentrations + subroutine parmix_progncdnc_sub( & + ncol & !I [nbr] number of columns used + ,mmr & !I [kg/kg] mass mixing ratio of tracers + ,rho_air & !I [kg/m3] air density + ,CProcessModes & + ,f_c & + ,f_bc & + ,f_aq & + ,f_so4_cond & + ,f_soa & + ,cam & + ,f_acm & !O [frc] carbon fraction in mode + ,f_bcm & !O [frc] fraction of c being bc + ,f_aqm & !O [frc] fraction of sulfate being aquous + ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate + ,f_soam & + ,numberConcentration & !O [#/m3] number concentration + ,volumeConcentration & !O [m3/m3] volume concentration + ,hygroscopicity & !O [mol/mol] + ,lnsigma & !O [-] log sigma + ,hasAerosol & !I [t/f] do we have this type of aerosol here? +!++ MH_2015/04/10 + ,volumeCore & + ,volumeCoat & +!-- MH_2015/04/10 + ) + + implicit none + + !input + integer, intent(in) :: ncol !Number of columns used in chunk + real(r8), intent(in) :: mmr(pcols,pver,pcnst) + real(r8), intent(in) :: rho_air(pcols,pver) + + !output + logical, intent(out) :: hasAerosol(pcols, pver, nmodes) + real(r8), intent(out) :: f_acm(pcols,pver, nbmodes) + real(r8), intent(out) :: f_bcm(pcols,pver, nbmodes) + real(r8), intent(out) :: f_aqm(pcols, pver, nbmodes) + real(r8), intent(out) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction" + real(r8), intent(out) :: f_soam(pcols, pver, nbmodes) !Needed in "get component fraction" + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton + real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration + real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma + real(r8),intent(out) :: CProcessModes(pcols,pver) + real(r8),intent(out) :: cam(pcols,pver,nbmodes) + real(r8),intent(out) :: f_c(pcols, pver) + real(r8),intent(out) :: f_aq(pcols,pver) + real(r8),intent(out) :: f_bc(pcols,pver) + real(r8),intent(out) :: f_so4_cond(pcols,pver) + real(r8),intent(out) :: f_soa(pcols,pver) +!++ MH_2015/04/10 + real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) + real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) +!-- MH_2015/04/10 + + real(r8) :: f_aitbc(pcols,pver) ! [-] bc fraction in the coated bc-oc mode + real(r8) :: f_nbc(pcols,pver) ! [-] mass fraction of bc in uncoated bc/oc mode + real(r8) :: f_soana(pcols,pver) ! [-] + + !Get mass, number concentration and the total add-ons (previous convaer) + call calculateBulkProperties( & + ncol & !I + , mmr & !I + , rho_air & !I + , numberConcentration & !O + , CProcessModes & !O + , f_c & !O + , f_bc & !O + , f_aq & !O + , f_so4_cond & !O + , f_soa & !O + , f_aitbc & !O + , f_nbc & !O + , f_soana & !O + ) + + !Find the points where we have aerosol (number concentration) + call getAerosolMask(ncol, numberConcentration, hasAerosol) + + !Findn out how much is added per size-mode (modalapp) + call partitionMass( ncol & + ,numberConcentration & + ,CProcessModes & !I [kg/m3] total added mass + ,f_c & !I [frc] fraction of added mass being c + ,f_bc & !I [frc] fraction of c being bc + ,f_aq & !I [frc] fraction of SO4 being aq + ,f_so4_cond & !I [frc] fraction of SO4 coag+cond being cond + ,f_soa & !I [frc] fraction of OM being SOA + ,cam & !O [kg/m3] added mass distributed to modes + ,f_acm & !O [frc] as f_c per mode + ,f_bcm & !O [frc] as f_bc per mode + ,f_aqm & !O [frc] as f_aq per mode + ,f_so4_condm & !O [frc] as f_so4_cond per mode + ,f_soam & !O [frc] + ) + + !Calculate they hygroscopicity (previously in cldwat_par.F90) + call calculateHygroscopicity( ncol & + ,mmr & + ,numberConcentration & + ,rho_air & + ,Cam & + ,f_acm & + ,f_bcm & + ,f_aqm & + ,hasAerosol & + ,hygroscopicity & + ,volumeConcentration & +!++ MH_2015/04/10 + ,volumeCore & + ,volumeCoat & +!-- MH_2015/04/10 + ) + + !Do the interpolation to new modes + call doLognormalInterpolation(ncol & + ,numberConcentration & + ,hasAerosol & + ,cam & + ,volumeConcentration & + ,f_c & + ,f_acm & + ,f_bcm & + ,f_aqm & + ,f_aitbc & !I [frc] bc fraction in int mix bc/oc mode + ,lnSigma & + ) + + end subroutine parmix_progncdnc_sub + + !****************************************************************** + !purpose: Create bulk properties (dependent on tracers, not size modes) + subroutine calculateBulkProperties( & + ncol & + ,qm & !I [kg/kg] transported tracers + ,rho_air & !I [kg/m3] air density + ,numberConcentration & !O [#/m3] aerosol number concentration + ,CProcessModes & !O [kg/m3] total added material + ,f_c & !O [-] fraction of aerosol which is carbon + ,f_bc & !O [-] fraction of carbon which is bc + ,f_aq & !O [-] fraction of sulfate which is aq. + ,f_so4_cond & !O [-] fraction of non-aq so4 which is condensate + ,f_soa & !O [-] fraction of OM which is SOA + ,f_aitbc & !O [-] fraction of bc in the background tracer mode + ,f_nbc & !O [-] fraction of bc in the background tracer mode 14 + ,f_soana & !O [-] fraction of soa in background int-mix mode (1) + ) + + use shr_kind_mod, only: r8 => shr_kind_r8 + use aerosoldef + use oslo_utils, only : calculateNumberConcentration + use const, only : smallNumber + + implicit none + + integer, intent(in) :: ncol ! [nbr] number of columns used + real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density + real(r8), intent(in) :: qm(pcols,pver,pcnst) ! [kg/kg] mmr for transported tracers + + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] + + real(r8), intent(out) :: f_c(pcols,pver) ![-] mass fraction of process mode being c + real(r8), intent(out) :: f_bc(pcols,pver) ![-] mass fraction of c being bc + real(r8), intent(out) :: f_aq(pcols,pver) ![-] mass fraction of s being aq phase + real(r8), intent(out) :: f_so4_cond(pcols,pver) ![-] mass fraction of non-aq s being condensate + real(r8), intent(out) :: f_soa(pcols,pver) ![-] mass fraction of OM being SOA + real(r8), intent(out) :: f_aitbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, coated mode + real(r8), intent(out) :: f_nbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, un-coated mode + real(r8), intent(out) :: f_soana(pcols,pver) ![-] mass fraction of soa in background in int mix ait mode (1) + !Local variables + real(r8) :: totalProcessModes(pcols,pver) ! [kg/kg] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration + real(r8) :: CProcessModes(pcols,pver) ! [kg/m3] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration + + integer :: k !counter for layers + + !Total number concentration per mode + call calculateNumberConcentration(ncol, qm, rho_air, numberConcentration) + + do k=1,pver + + !Total coagulated bc and oc and SO4 (condensate, wet phase and coagulated) (kg/kg) + !internally mixed with background modes + totalProcessModes(:ncol,k) = qm(:ncol,k,l_bc_ac) + qm(:ncol,k,l_om_ac) & + + qm(:ncol,k,l_so4_a1) + qm(:ncol,k,l_so4_a2) + qm(:ncol,k,l_so4_ac) + qm(:ncol,k,l_soa_a1) + + CProcessModes(:ncol,k) = rho_air(:ncol,k)*totalProcessModes(:ncol,k) !==> kg/m3 + + !fraction of process-mode being carbonaceous + f_c(:ncol,k) = min((qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1) )& + /(totalProcessModes(:ncol,k)+smallNumber), 1.0_r8) + + !fraction of "c" being bc (total is oc and bc) + f_bc(:ncol,k) = min(qm(:ncol,k,l_bc_ac)/(qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1)+smallNumber), 1.0_r8) + + !fraction of non-aqeous phase sulphate being condensate + f_so4_cond(:ncol,k) = min(qm(:ncol,k,l_so4_a1)/(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_ac)+smallNumber), 1.0_r8) + + !fraction of sulphate being aquous phase (total is condensate + aqeous phase + coagulate) + f_aq(:ncol,k) = min(qm(:ncol,k,l_so4_a2) & + /(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_a2)+qm(:ncol,k,l_so4_ac)+smallNumber),1.0_r8) + + !fraction of bc in the sulfate-coated bc/oc mode (total background is bc and oc) + f_aitbc(:ncol,k) = min(qm(:ncol,k,l_bc_ai) / (qm(:ncol,k,l_bc_ai) + qm(:ncol,k,l_om_ai) + smallNumber), 1.0_r8) + + !fraction of bc in the un-coated bc/oc (total is bc and oc) + f_nbc(:ncol,k) = min(qm(:ncol,k,l_bc_ni) / (qm(:ncol,k,l_bc_ni) + qm(:ncol,k,l_om_ni) + smallNumber),1.0_r8) + + !fraction of OM process-mode which is SOA + f_soa(:ncol,k) = min(qm(:ncol,k,l_soa_a1) / (qm(:ncol,k,l_om_ac) + qm(:ncol,k,l_soa_a1) + smallNumber), 1.0_r8) + + !fraction of "background" int-mix (mode 1) which is SOA + f_soana(:ncol,k) = min(qm(:ncol,k,l_soa_na) / (qm(:ncol,k,l_soa_na) + qm(:ncol,k,l_so4_na) + smallNumber), 1.0_r8 ) + + end do !k + + return + end subroutine calculateBulkProperties + + !******************************************************************************** + subroutine partitionMass( ncol & !I [nbr] number of columns used + ,Nnatk & !I [#/m3] number concentration + ,CProcessModes & !I [kg/m3] total added mass + ,f_c & !I [frc] fraction of added mass being c + ,f_bc & !I [frc] fraction of c being bc + ,f_aq & !I [frc] fraction of SO4 being aq + ,f_so4_cond & !I [frc] fraction of SO4 coag+cond being cond + ,f_soa & !I [frc] fraction of OM being SOA + ,cam & !O [kg/m3] added mass distributed to modes + ,f_acm & !O [frc] as f_c per mode + ,f_bcm & !O [frc] as f_bc per mode + ,f_aqm & !O [frc] as f_aq per mode + ,f_so4_condm & !O [frc] fraction of non aq sulfate being coagulate + ,f_soam & !O [frc] fraction of OC being SOA + ) + + implicit none + + integer, intent(in) :: ncol + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) + real(r8), intent(in) :: CProcessModes(pcols,pver) + real(r8), intent(in) :: f_c(pcols,pver) + real(r8), intent(in) :: f_bc(pcols,pver) + real(r8), intent(in) :: f_aq(pcols,pver) + real(r8), intent(in) :: f_so4_cond(pcols,pver) + real(r8), intent(in) :: f_soa(pcols,pver) + real(r8), intent(out) :: f_aqm(pcols,pver,nbmodes) + real(r8), intent(out) :: f_acm(pcols,pver,nbmodes) + real(r8), intent(out) :: f_bcm(pcols,pver,nbmodes) + real(r8), intent(out) :: f_so4_condm(pcols,pver,nbmodes) + real(r8), intent(out) :: f_soam(pcols,pver,nbmodes) + real(r8), intent(out) :: cam(pcols, pver, nbmodes) + + !Budget of condensate SO4 + integer :: i + + !++test + integer :: k,l,lptr,m,m1,kcomp + real(r8) :: total + real(r8) :: fraction(pcols,pver,pcnst) !ak: oversized, but only for test use + !--test +#undef EXTRATESTS + + + call modalapp2d_sub(ncol & + ,Nnatk(1,1,1) & !I [#/m3] Total number concentration (skip mode 0) + ,CProcessModes & !I [kg/m3] Total process mode mass concentration + ,f_c & !I [frc] fraction of process mode mass being oc or bc + ,f_bc & !I [frc] fraction of coagulate mass being bc + ,f_aq & !I [frc] fraction of process mode sulfate mass being aq + ,f_so4_cond & + ,f_soa & + ,cam & !O [kg/m3] Process mode mass distributed to each mode + ,f_acm & !O [frc] as f_c, for each mode + ,f_bcm & !O [frc] as f_bc, for each mode + ,f_aqm & !O [frc] as f_aq, for each mode + ,f_so4_condm & !O [frc] + ,f_soam & + ) + +#ifdef EXTRATESTS + !++testing + fraction(:,:,:)=0.0_r8 + do m=1,nbmodes + do l = 1, getNumberOfTracersInMode(m) + lptr = getTracerIndex(m,l,.false.) + do k=1,pver + do i=1,ncol + fraction(i,k,lptr) = fraction(i,k,lptr) & + + getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & + ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m),f_soam(i,k,m), lptr ) + end do + end do + enddo + enddo + + !testing that the mass fractions summed over all modes and species = 1 (or 0 if not present). + do m1=1,pcnst + do k=1, pver + do i=1,ncol + !Check if "fraction" differs from one (accept 0.01 error), only check for concentrations > 1.e-30 kg/m3 + if((abs(fraction(i,k,m1)-1.0_r8) .gt. 1.e-2) .and. (fraction(i,k,m1).gt.0.0_r8) .and. (CProcessModes(i,k) .gt. 1.e-30_r8) )then + if( ( m1 .eq. l_so4_a1 .and. (1.0_r8-f_c(i,k))*(1.0_r8-f_aq(i,k))*f_so4_cond(i,k) .gt. 1.0e-4_r8).or. & + ( m1 .eq. l_so4_a2 .and. (1.0_r8-f_c(i,k))*f_aq(i,k) .gt. 1.0e-4_r8).or. & + ( m1 .eq. l_so4_ac .and. (1.0_r8-f_c(i,k))*(1.0_r8-f_aq(i,k))*(1.0_r8-f_so4_cond(i,k)) .gt. 1.0e-4_r8).or. & + ( m1 .eq. l_bc_ac .and. f_c(i,k)*f_bc(i,k) .gt. 1.0e-4_r8).or. & + ( m1 .eq. l_om_ac .and. f_c(i,k)*(1.0_r8-f_bc(i,k))*(1.0_r8 - f_soa(i,k)) .gt. 1.0e-4_r8) .or. & + ( m1 .eq. l_soa_a1 .and. f_c(i,k)*(1.0_r8-f_bc(i,k))*f_soa(i,k) .gt. 1.0e-4_r8) & + )then + + print*," " + print*,"fraction error ", m1, fraction(i,k,m1), cnst_name(m1) + print*, "Cprocessmodes", CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) + do l=1,nbmodes + print*, "mode, cam", l, cam(i,k,l),nnatk(i,k,l) + enddo + print*,"ca, sum(cam)", CProcessModes(i,k), sum(cam(i,k,:)) + print*,"sulfate fraction", (1.0_r8 - f_c(i,k)) + print*,"carbon fraction", f_c(i,k) + print*,"non aq sulf fraction", (1.0_r8 - f_aq(i,k))*(1.0_r8 - f_c(i,k)) + !There is something wrong with tracer lptr + do m=1,nmodes + do l =1,getNumberOfTracersInMode(m) + lptr = getTracerIndex(m,l,.false.) + if(lptr .eq. m1)then !This is the tracer with problems + print*, "lptr, fraction ", m,l,lptr, & + getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & + ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), lptr,.TRUE. ) & + , NNatk(i,k,m),cam(i,k,m),numberFractionAvailableAqChem(m) + + endif + enddo + enddo + do m=1,nbmodes + print*,"sulfate / c, aq ", m, (1.0_r8-f_acm(i,k,m)), f_acm(i,k,m)& + ,f_aqm(i,k,m), f_so4_condm(i,k,m), f_so4_condm(i,k,m), f_soam(i,k,m) + enddo + + stop !stop on error + endif !if tracer has error + endif !if budget is wrong + enddo + enddo + enddo + + + !Check total carbon + do k=1,pver + do i=1,ncol + total=0.0_r8 + do kcomp=1,nbmodes + total = total + cam(i,k,kcomp)*f_acm(i,k,kcomp) + enddo + if( ABS(total - CProcessModes(i,k)*f_c(i,k)) .gt. 1.e-2_r8*CProcessModes(i,k) )then + if(abs(total) > 1.e-25)then + print*,"CProcessModes", CProcessModes(i,k), total, abs(total - CProcessModes(i,k)*f_c(i,k)) + do kcomp=1,nbmodes + print*,"fcm,cam,fc,ctot", f_acm(i,k,kcomp), cam(i,k,kcomp), f_c(i,k), CProcessModes(i,k) + enddo + stop + endif + endif + end do + end do + + !--testing +#endif + !EXTRATESTS + + end subroutine partitionMass + + !************************************************************* + !Find out where we have aerosols + subroutine getAerosolMask(ncol,numberConcentration, hasAerosol) + implicit none + + integer, intent(in) :: ncol !number of columns used + real(r8), intent(in) :: numberConcentration(pcols, pver, 0:nmodes) + logical, intent(out) :: hasAerosol(pcols, pver, nmodes) + integer :: k !counter for levels + integer :: m !counter for modes + + do m=1,nmodes + do k=1,pver + where(numberConcentration(:ncol,k,m) .gt. smallNumber) + hasAerosol(:ncol,k,m)= .true. + elsewhere + hasAerosol(:ncol,k,m) = .false. + end where + end do !levels + end do !modes + end subroutine + !************************************************************* + + + !************************************************************** + subroutine calculateHygroscopicity( ncol & + ,mmr & + ,numberConcentration & + ,rho_air & + ,Cam & + ,f_acm & + ,f_bcm & + ,f_aqm & + ,hasAerosol & + ,hygroscopicity & + ,volumeConcentration & +!++ MH_2015/04/10 + ,volumeCore & + ,volumeCoat & +!-- MH_2015/04/10 + ) + + !All theory in this subroutine is from + !Abdul-Razzak and S. Ghan: + !A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 + !http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract + implicit none + + !INPUT + integer, intent(in) :: ncol + real(r8), intent(in) :: mmr(pcols,pver,pcnst) !I [kg/kg] mass mixing ratios + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes)!I [#/m3] number concentrations + real(r8), intent(in) :: rho_air(pcols,pver) !I [kg/m3] air density + real(r8), intent(in) :: Cam(pcols, pver, nbmodes) !I [kg/m3] total added mass during microphysics + real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) !I [-] fraction of added mass which is carbon + real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) !I [-] fraction of sulfate which is aq. phase + real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) !I [-] fraction of C which is bc + logical, intent(in) :: hasAerosol(pcols,pver,nmodes) !I [t/f] do we have aerosols + + !OUTPUT + real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) + real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) + + !Local variables + real(r8) :: hygroscopicityAvg(pcols,pver) + real(r8) :: hygroscopicityCoat(pcols,pver) + real(r8) :: massConcentrationTracerInMode(pcols,pver) + !++ MH_2015/04/10 + real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] + real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] + !-- MH_2015/04/10 + real(r8) :: averageRadiusCore(pcols,pver) ![m] + real(r8) :: averageRadiusTotal(pcols,pver) ![m] + integer :: kcomp !counter for modes + integer :: l !counter for components + integer :: tracerIndex + + integer :: k !counter for levels + + integer :: i + + + !initialize + hygroscopicity(:,:,:) = 0.0_r8 + volumeConcentration(:,:,:)=0.0_r8 + + do kcomp=1,nmodes + + !Don't do anything if no tracers in mode + if(getNumberOfBackgroundTracersInMode(kcomp) .lt. 1)then + volumeCore(:,:,kcomp)=smallNumber + volumeCoat(:,:,kcomp)=smallNumber + volumeConcentration(:,:,kcomp)=smallNumber + hygroscopicity(:,:,kcomp) = smallNumber + cycle + end if + + hygroscopicityAvg(:,:) = 0.0_r8 + hygroscopicityCoat(:,:) = 0.0_r8 + volumeCore(:,:,kcomp) = 0.0_r8 + volumeCoat(:,:,kcomp) = 0.0_r8 + + !Loop over tracers in mode + do l=1,getNumberOfBackgroundTracersInMode(kcomp) + + tracerIndex = getTracerIndex(kcomp,l,.false.) !get index in physcis space + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = mmr(:ncol,k,tracerIndex)*rho_air(:ncol,k) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , tracerIndex & + ) + end do !background tracers in mode (l) + + !The background modes can have tracer mass added to them + if(kcomp .le. nbmodes)then + + !added aquous sulfate + if(isTracerInMode(kcomp,l_so4_a2))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*f_aqm(:ncol,k,kcomp) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_so4_a2 & + ) + endif + + !added condensate/coagulate + !All modes which have coagulate have also condensate, so it is + !ok to check for condensate and add the combined mass.. + if(isTracerInMode(kcomp,l_so4_a1))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*(1.0_r8 - f_aqm(:ncol,k,kcomp)) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_so4_a1 & + ) + endif + !Added bc + if(isTracerInMode(kcomp,l_bc_ac))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*f_bcm(:ncol,k,kcomp) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_bc_ac & + ) + endif + + !Added oc (both POM and SOA), then both have the same + !properties, so add combined mass here. + !All modes which have condensate also has coagulate, so OK to check + !for condensate and distribute the sum.. + if(isTracerInMode(kcomp,l_soa_a1))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*(1.0_r8 -f_bcm(:ncol,k,kcomp)) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_om_ac & + ) + endif + end if + + !Note: NCAR definitions of molecular weights are kg/kmol. This is used + !inside "addModeHygroscopicity" and here as in molecularWeightWater. SI units are kg/mol, but + !the error cancels out since eqn 4 has Mw_water/Mw_tracer + + do k=1,pver + + !Finally, when the sums are calculated, Apply finally eqn 4 here!! + + where (hasAerosol(:ncol,k,kcomp)) + where(VolumeCoat(:ncol,k,kcomp) .gt. 1.e-30_r8) + !If there is enough soluble material, a coating will be formed: In that case, the + !volume of the aerosol in question is only the volume of the coating! + hygroscopicityCoat(:ncol,k) = molecularWeightWater*hygroscopicityCoat(:ncol,k) & + & /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here + elsewhere + hygroscopicityCoat(:ncol,k) = 1.e-30_r8 + endwhere + !mode total volume: + volumeConcentration(:ncol,k,kcomp) = volumeCore(:ncol,k,kcomp) + volumeCoat(:ncol,k,kcomp) + + !hygroscopicity of mixture (Note use of total volume to get average hygroscopicity) + hygroscopicityAvg(:ncol,k) = molecularWeightWater*hygroscopicityAvg(:ncol,k) & + & /(density_water * volumeConcentration(:ncol,k,kcomp)) + + + !Average size of insoluble core (average radius) + averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird + + !Average size of total aerosol (average radius) + averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird + + !do i=1,ncol + ! if(numberConcentration(i,k,kcomp) .gt. 1.e6 .and. kcomp.eq.6 )then + ! print*, "hygro_check",kcomp,numberConcentration(i,k,kcomp), averageRadiusTotal(i,k)*1.e6, averageRadiusCore(i,k)*1.e6 & + ! , hygroscopicityCoat(i,k), hygroscopicityAvg(i,k), (averageRadiusTotal(i,k)-averageRadiusCore(i,k))*1.e9 + ! endif + !end do + + !use one or the other hygroscopicity based on coating + where ( averageRadiusTotal(:ncol,k) - averageRadiusCore(:ncol,k) .gt. coatingLimit ) + hygroscopicity(:ncol,k,kcomp) = hygroscopicityCoat(:ncol,k) + elsewhere + hygroscopicity(:ncol,k,kcomp) = hygroscopicityAvg(:ncol,k) + endwhere + elsewhere ! No aerosol + hygroscopicity(:ncol,k,kcomp) = 1.e-10_r8 + end where + + end do !levels + + end do !kcomp /modes + + end subroutine calculateHygroscopicity + + !************************************************************************************** + subroutine addModeHygroscopicity ( ncol & ![nbr] number of columns used + , hasAerosol & ![bool] do we have any aerosol here? + , massConcentrationTracerInMode & ![kg/m3] mass concentration of aerosol in a mode + , volumeCore & ![m3/m3] volume concentration we are adding + , volumeCoat & ![m3/m3] volume concentration we are adding + , hygroscopicityAvg & ![mol_{aerosol}/mol_{tracer} hygroscopicity + , hygroscopicityCoat & ![mol_{aerosol}/mol_{tracer} hygroscopicity coating + , tracerIndex & ![idx] which tracer are we talking about (physics space) + ) + + implicit none + + integer, intent(in) :: ncol + real(r8), intent(in) :: massConcentrationTracerInMode(pcols,pver) ![kg/m3] mass concentration in + logical, intent(in) :: hasAerosol(pcols,pver) ![bool] true if we have any aerosol here + integer, intent(in) :: tracerIndex !in physics space + + real(r8), intent(inout) :: volumeCore(pcols, pver) !O [m3/m3] volume of insoluble core + real(r8), intent(inout) :: volumeCoat(pcols, pver) !O [m3/m3] volume of total aerosol + real(r8), intent(inout) :: hygroscopicityAvg(pcols, pver) !O [-] average hygroscopicity + real(r8), intent(inout) :: hygroscopicityCoat(pcols, pver) !O [-] average hygroscopicity + + real(r8) :: massFractionInCoating + + integer :: k !counter for levels + + !Only tracers more soluble than 20% can add to the coating volume + if(solubleMassFraction(tracerIndex) .gt. solubleMassFractionCoatingLimit)then + massFractionInCoating = 1.0_r8 !all volume goes to coating + else + massFractionInCoating = 0.0_r8 !zero volume goes to coating + endif + + do k=1,pver + + where(hasAerosol(:ncol,k) .eqv. .true.) + + volumeCore(:ncol,k) = volumeCore(:ncol,k) & + + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*(1.0_r8 - massFractionInCoating) + + volumeCoat(:ncol,k) = volumeCoat(:ncol,k) + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*massFractionInCoating + + !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) + !Note that molecular weight is that of the AEROSOL TYPE + !This is because of some conflict with mozart which needs molecular weight of OC tracers to be 12 when reading emissions + !So molecular weight is duplicated, and the molecular weight of the TYPE is used here! + hygroscopicityAvg(:ncol,k) = hygroscopicityAvg(:ncol,k) + & + massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & + *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) + + !Contribution to hygroscopicity of coating (only if goes to coating) + !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) + !Note that molecular weight is that of the AEROSOL TYPE + !This is because of some conflict with mozart which needs molecular weight of OC tracers to be 12 when reading emissions + !So molecular weight is duplicated, and the molecular weight of the TYPE is used here! + hygroscopicityCoat(:ncol,k) = hygroscopicityCoat(:ncol,k) + & + massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & + *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) & + *massFractionInCoating !Only add to this if mass goes to coating + + elsewhere + hygroscopicityAvg(:ncol,k) = 1.0e-10_r8 + hygroscopicityCoat(:ncol,k)= 1.0e-10_r8 + end where + + end do + + end subroutine addModeHygroscopicity + + !**************************************************************** + + subroutine doLognormalInterpolation(ncol & + ,numberConcentration & + ,hasAerosol & + ,cam & + ,volumeConcentration & + ,f_c & + ,f_acm & + ,f_bcm & + ,f_aqm & + ,f_aitbc & + ,lnSigma & + ) + + implicit none + + !input + integer, intent(in) :: ncol + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) + logical, intent(in) :: hasAerosol(pcols,pver,nmodes) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode + real(r8), intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on + real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) + real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode + real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added + real(r8), intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode + + !output + real(r8), intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev + + + !work arrays + real(r8) :: nconccm3(pcols,pver) + real(r8) :: camUg(pcols,pver) + real(r8) :: log10sig(pcols,pver) ![-] logarithm (base 10) of look up tables + real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass + !real(r8), dimension(pcols,pver) :: cxstot ![kg/m3] non allocated mass + integer, dimension(pcols) :: ind ![idx] index in mapping (not really used) + real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables + real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate + integer :: iloop + integer :: kcomp + integer :: i + integer :: k + + + !total mass not allocated to any mode + !this is non-zero if the look-up table can not cope with all the add-on mass + !cxstot(:,:) = 0.0_r8 + + !Remove this later! + do i=1,ncol + ind(i)=i + end do + +! calculate fraction of added mass which is either SOA condensate or OC coagulate, +! which in AeroTab are both treated as condensate for kcomp=1-4 + do kcomp=1,4 + do k=1,pver + do i=1,ncol + f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) + enddo + enddo + enddo + + do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* + + !Go through all "background" size-modes (kcomp=1-10) + do kcomp=1,nbmodes + + camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 + nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) + + !Calculate growth from knowing added process specific internally mixed mass to each background mode + !(level sent but not needed, and kcomp not needed for intlog4_sub) + + if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 + + do k=1,pver + call intlog1to3_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + + end do !loop on levels + + else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 + + do k=1,pver + call intlog4_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do + + else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 + + do k=1,pver + call intlog5to10_sub( & + ncol & !I [nbr] number of points used + , ind & !I [mapping] (not used) + , kcomp & !I [mode index] + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon + , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) + , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do ! k + + endif + + !initialize + lnsigma(:,:,kcomp) = log(2.0_r8) + + !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma + + !This means that in order to conserve the volume (which is known), we have to throw away + !the number concentration. Should create a diagnostic or a warning if number concenration is very different + !from the original number concentration since in principal, the number concentration is + !also conserved! + do k=1,pver + !Don't change number concentration unless "hasAerosol" is true + where(hasAerosol(:ncol,k,kcomp)) + + lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) + + numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & + /(2.0_r8*radius_tmp(:ncol,k))**3 & + *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) + + !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the + !lookup tables told us! If the look up tables were conserving volume we didn't have to do + !the step just above!! + + !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) + !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 + + end where + end do + + end do !kcomp + + !The modes which do not have any added aerosol: + do kcomp=nbmodes+1,nmodes + do k=1,pver + lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) + end do + end do + + !AK (fxm): "unactivated" code below... + !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) + !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) + !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & + ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode + ! *RESHAPE(cxstot,(/pcols,pver/)) & + ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) + + !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & + ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode + ! * RESHAPE(cxstot,(/pcols,pver/)) & + ! * f_c(:,:)/rhopart(l_bc_n)) + + !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! + ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) + ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) + + + enddo ! iloop + + + end subroutine doLognormalInterpolation + +end module parmix_progncdnc diff --git a/src/chemistry/oslo_aero/seasalt_model.F90 b/src/chemistry/oslo_aero/seasalt_model.F90 new file mode 100644 index 0000000000..0bb52f3ec8 --- /dev/null +++ b/src/chemistry/oslo_aero/seasalt_model.F90 @@ -0,0 +1,219 @@ +module seasalt_model + +use constituents, only: cnst_name +use aerosoldef, only: l_ss_a1, l_ss_a2, l_ss_a3,l_om_ni & + , MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 & + , rhopart +use const, only: volumeToNumber +use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl +use spmd_utils, only: masterproc +use camsrfexch, only: cam_in_t, cam_out_t +use ppgrid, only: pcols, pver,pverp +use constituents, only: pcnst, cnst_add, cnst_name, cnst_get_ind +use aerodep_flx, only: aerodep_flx_prescribed +use cam_abortutils, only: endrun +use cam_logfile, only: iulog +use oslo_ocean_intr, only: oslo_opom_emis_intr, oslo_opom_inq + +implicit none +private +save + + !Add Spracklen OC source related to sea salt, Spracklen says about 5.5 sub-micron Tg(C) per year (page 3) + !Total sea salt emissions are about 8000 Tg/year, take into account OM/OC-factor of about 1.4 + !==> scale factor of approx 7.7/8000 + !Note: The emissions are not REALLY related to sea salt, + !but this is as close as we get with the current version + !GRL Volume 35, Issue 12, 28 June 2008, http://onlinelibrary.wiley.com/doi/10.1029/2008GL033359/abstract + real(r8), parameter :: seasaltToSpracklenOM = 7.7_r8/8000_r8 + + !After discussions with Alf K, it is better to scale with only smallest SS-mode since POM is small + !and assume same production mechanism. Nudged 1 degree simulations give 2.52 Tg/yr of SS_A1, so + !to obtain 7.7, we need to scale them by 7.7 / 2.52 ==> 3.03 +!cak real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8 + !updated value for Salter et al. sea-salt treatment, which gives global annual SS_A1 emissions of + !2.663 instead of 0.153 ng m-2 s-1 (i.e. ca 17 times more than the old sea-salt treatment): + real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8*0.153_r8/2.663_r8 +!cak + + integer, parameter :: numberOfSaltModes = 3 + character(len=6), public, dimension(10) :: seasalt_names + integer, parameter, public :: seasalt_nbin = numberOfSaltModes !just because this is needed by mo_photo.F90 + + !Numbers in table below are from KirkevÃ¥g et al (2013) http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html + !Based on Struthers et al 2011 (http://www.atmos-chem-phys.net/11/3459/2011/acp-11-3459-2011.html) + !which are again modified from Maartensson , JGR, vol 108. no D9, 4297, 2003 + ! + !Note that using the numbers from the Kirkevag paper will give 20% too small mass emissions of sea salt globally!! + !The number of significant digits there should have been larger! We are here using the numbers as received from the swedes. + ! + !THESE ARE THE NUMBERS RECEIVED FROM THE SWEDES, THEY ARE UN-DOCUMENTED (SEE EMISSIONS.F90 of NORESM1) + !*************************************************************************************************** +! real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/0.0_r8 , 0.0_r8 , 3.0608e3_r8 /) +! real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/-3.3551e6_r8, 1.1768e5_r8 , -1.6675e6_r8 /) +! real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/1.0554e9_r8 , -1.1369e7_r8, 2.2879e8_r8 /) + + !FOR INFO: THESE ARE THE NUMBERS FROM THE PAPER WHICH GIVE TOO LOW EMISSIONS!! + !******************************************************************************************************* + !real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/0.0_r8, 0.0_r8, 3.06e3_r8 /) + !real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/-3.36e6_r8, 1.18e5_r8, -1.67e6_r8 /) + !real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/1.05e9_r8, -1.14e7_r8, 2.29e8_r8 /) + + !New numbers are based on Salter et al. (2105): www.atmos-chem-phys-discuss.net/15/13783/2015/doi:10.5194/acpd-15-13783-2015 + !Values from Table 1 in Salter et al. (2015): + !******************************************************************************************************* + real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/-5.2168e5_r8, 0.0_r8, 0.0_r8 /) + real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/ 3.31725e7_r8, 7.374e5_r8, 1.4210e4_r8 /) + real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/-6.95275e8_r8,-2.4803e7_r8, 1.4662e7_r8 /) + real(r8), dimension(numberOfSaltModes), parameter :: coeffD = (/ 1.0684e10_r8, 7.7373e8_r8, 1.7075e8_r8 /) + + real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean + + + integer, dimension(numberOfSaltModes) :: modeMap ! [idx] which modes are we modifying + integer, dimension(numberOfSaltModes) :: tracerMap ! [idx] which tracers are we modifying + + real(r8), dimension(pcols), save, public :: OMOceanSource ![kg/m2/s] new OM ocean source + real(r8), dimension(pcols), save, public :: spracklenOMOceanSource ![kg/m2/s] spracklen ocean source + !real(r8), dimension(pcols), save, public :: spracklenOMOceanSource2 ![kg/m2/s] spracklen ocean source + real(r8), dimension(pcols) :: onOMOceanSource ![kg/m2/s] OM source from Nilsson/O'Dowd + logical, parameter, public :: seasalt_active = .TRUE. + +public oslo_salt_emis_intr +public seasalt_init + +!=============================================================================== +contains +!=============================================================================== + + subroutine seasalt_init() + + implicit none + + integer :: i + + modeMap(1) = MODE_IDX_SS_A1 + modeMap(2) = MODE_IDX_SS_A2 + modeMap(3) = MODE_IDX_SS_A3 + + tracerMap(1) = l_ss_a1 + tracerMap(2) = l_ss_a2 + tracerMap(3) = l_ss_a3 + + seasalt_names(:)=" " + do i=1,numberOfSaltModes + seasalt_names(i) = cnst_name(tracerMap(i)) + end do + + spracklenOMOceanSource(:) = 0.0_r8 + end subroutine seasalt_init + +subroutine oslo_salt_emis_intr(state, cam_in) + + !----------------------------------------------------------------------- + ! Purpose: + ! Interface to emission of sea salt + !----------------------------------------------------------------------- + use cam_history, only: outfld + use physics_types, only: physics_state + + ! Arguments: + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + real(r8), dimension(pcols) :: whiteCapAreaFraction ![fraction] + real(r8), dimension(pcols) :: open_ocean ![fraction] + real(r8), dimension(pcols,numberOfSaltModes) :: numberFlux ![#/m2/sec] + real(r8), dimension(pcols) :: u10m ![m/s] + real(r8), dimension(pcols) :: totalSaltEmis ![kg/m2/s] + real(r8), pointer :: sst(:) ![frc] sea surface temperature + real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction + real(r8), pointer :: icefrc(:) ![frc] ice fraction + integer :: n ![] counter for modes + integer :: ncol ![nbr] number of columns in use + integer :: lchnk ! chunk index + + + !number of columns in use + ncol = state%ncol + lchnk = state%lchnk + + !pointers to land model variables + ocnfrc => cam_in%ocnfrac + icefrc => cam_in%icefrac + sst => cam_in%sst + + !start with midpoint wind speed + u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) + + ! move the winds to 10m high from the midpoint of the gridbox: + u10m(:ncol)=u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + +! !whitecap area (eqn 1 in Struthers et al., 2011) +! whitecapAreaFraction(:ncol) = (3.84_r8*10.0_r8**(-6.0_r8))*(u10m(:ncol)**3.41_r8) + + ! New whitecap area fraction / air entrainment flux from eqn. 6 in Salter et al. (2015) + ! JCA & MS Using Hanson & Phillips 99 air entrainment vs. wind speed + ! (Note the uncertainty in the factor 2, written as 2 pluss/minus 1 in Eq. 6 -> possible tuning factor) +!aktst+ whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.41_r8) + whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.74_r8) +!aktst- + + whitecapAreaFraction(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) * whitecapAreaFraction(:ncol) + open_ocean(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) + + do n=1,numberOfSaltModes + +! !eqn 1 in Kirkevag et al. (2013) +! numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & +! ( & +! coeffA(n)*sst(:ncol)*sst(:ncol) & +! + coeffB(n)*sst(:ncol) & +! + coeffC(n) & +! ) + !Eqn. 9 in Salter et al. (2015) + numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & + ( coeffA(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & + + coeffB(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & + + coeffC(n)*(sst(:ncol)-273.15_r8) & + + coeffD(n) ) + end do + + + do n=1,numberOfSaltModes + cam_in%cflx(:ncol, tracerMap(n)) = numberFlux(:ncol,n) & !#/m2/sec + / volumeToNumber(modeMap(n)) & !==> m3/m2/sec + * rhopart(tracerMap(n)) !==> kg/m2/sec + end do + + !totalSaltEmis(:ncol)=0.0_r8 + !do n=1,numberOfSaltModes + ! totalSaltEmis(:ncol) = totalSaltEmis(:ncol) + cam_in%cflx(:ncol,tracerMap(n)) + !end do + !spracklenOMOceanSource(:ncol) = seasaltToSpracklenOM * totalSaltEmis(:ncol) + + !The above code scales to total seasalt emisisons. This scales to mode 1 + !so assuming that submicron OM is proportional to smallest sea salt mode + spracklenOMOceanSource(:ncol) = cam_in%cflx(:ncol, tracerMap(1))*seasaltToSpracklenOM2 + + !do i=1,ncol + ! if(ocnfrc(i).gt.0.999_r8 .and. icefrc(i).lt.0.000001_r8 .and. u10m(i).gt.5 .and. sst(i).gt. 284.0_r8)then + ! print*, "u,sst, s1, s2", u10m(i), sst(i), spracklenOMOceanSource(i), spracklenOMOCeanSource2(i) + ! end if + !end do + + if (oslo_opom_inq())then + call oslo_opom_emis_intr(cam_in%cflx(:ncol, tracerMap(1)), & + cam_in%cflx(:ncol, tracerMap(2)), & + cam_in%cflx(:ncol, tracerMap(3)), & + open_ocean ,ncol,lchnk, onOMOceanSource ) + OMOceanSource(:ncol) = onOMOceanSource(:ncol) + else + OMOceanSource(:ncol) = spracklenOMOceanSource(:ncol) + endif + + return + end subroutine oslo_salt_emis_intr + +end module seasalt_model diff --git a/src/chemistry/oslo_aero/sox_cldaero_mod.F90 b/src/chemistry/oslo_aero/sox_cldaero_mod.F90 new file mode 100644 index 0000000000..d4224ec750 --- /dev/null +++ b/src/chemistry/oslo_aero/sox_cldaero_mod.F90 @@ -0,0 +1,386 @@ +!---------------------------------------------------------------------------------- +! Modal aerosol implementation +!---------------------------------------------------------------------------------- +module sox_cldaero_mod + + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_abortutils, only : endrun + use ppgrid, only : pcols, pver + use mo_chem_utls, only : get_spc_ndx + use aerosoldef, only: l_so4_a2, chemistryIndex + use cldaero_mod, only : cldaero_conc_t, cldaero_allocate, cldaero_deallocate + use chem_mods, only : adv_mass + use physconst, only : gravit + use phys_control, only : phys_getopts + use cldaero_mod, only : cldaero_uptakerate + use chem_mods, only : gas_pcnst + + implicit none + private + + public :: sox_cldaero_init + public :: sox_cldaero_create_obj + public :: sox_cldaero_update + public :: sox_cldaero_destroy_obj + + integer :: id_msa, id_h2so4, id_so2, id_h2o2, id_nh3 + integer :: id_so4_1a + + real(r8), parameter :: small_value = 1.e-20_r8 + +contains + +!---------------------------------------------------------------------------------- +!---------------------------------------------------------------------------------- + + subroutine sox_cldaero_init + + integer :: l, m + logical :: history_aerosol ! Output the MAM aerosol tendencies + + id_msa = get_spc_ndx( 'MSA' ) + id_h2so4 = get_spc_ndx( 'H2SO4' ) + id_so2 = get_spc_ndx( 'SO2' ) + id_h2o2 = get_spc_ndx( 'H2O2' ) + id_nh3 = get_spc_ndx( 'NH3' ) + + id_so4_1a = chemistryIndex(l_so4_a2) + + if (id_h2so4<1 .or. id_so2<1 .or. id_h2o2<1) then + call endrun('sox_cldaero_init:MAM mech does not include necessary species' & + //' -- should not invoke sox_cldaero_mod ') + endif + + call phys_getopts( history_aerosol_out = history_aerosol ) + ! + ! add to history + ! + + end subroutine sox_cldaero_init + +!---------------------------------------------------------------------------------- +!---------------------------------------------------------------------------------- + function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, loffset) result( conc_obj ) + + real(r8), intent(in) :: cldfrc(:,:) + real(r8), intent(in) :: qcw(:,:,:) + real(r8), intent(in) :: lwc(:,:) + real(r8), intent(in) :: cfact(:,:) + integer, intent(in) :: ncol + integer, intent(in) :: loffset + + type(cldaero_conc_t), pointer :: conc_obj + + + integer :: l,n + integer :: i,k + + + conc_obj => cldaero_allocate() + + do k = 1,pver + do i = 1,ncol + if( cldfrc(i,k) >0._r8) then + conc_obj%xlwc(i,k) = lwc(i,k) *cfact(i,k) ! cloud water L(water)/L(air) + conc_obj%xlwc(i,k) = conc_obj%xlwc(i,k) / cldfrc(i,k) ! liquid water in the cloudy fraction of cell + else + conc_obj%xlwc(i,k) = 0._r8 + endif + enddo + enddo + + conc_obj%no3c(:,:) = 0._r8 + + + !Set concenctration of cloud so4 + conc_obj%so4c(:ncol,:) & + = qcw(:ncol,:,id_so4_1a) + + + ! for oslo aerosols, + ! current version does not have nh3/nh4 tracers + ! so so4 is assumed to be nh4hso4 + ! the partial neutralization of so4 is handled by using a + ! -1 charge (instead of -2) in the electro-neutrality equation + conc_obj%nh4c(:ncol,:) = 0._r8 + + ! with 3-mode, assume so4 is nh4hso4, and so half-neutralized + conc_obj%so4_fact = 1._r8 + + + + end function sox_cldaero_create_obj + +!---------------------------------------------------------------------------------- +! Update the mixing ratios +!---------------------------------------------------------------------------------- + subroutine sox_cldaero_update( & + ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & + delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & + aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) + + ! args + + integer, intent(in) :: ncol + integer, intent(in) :: lchnk ! chunk id + integer, intent(in) :: loffset + + real(r8), intent(in) :: dtime ! time step (sec) + + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), intent(in) :: pdel(:,:) + real(r8), intent(in) :: press(:,:) + real(r8), intent(in) :: tfld(:,:) + + real(r8), intent(in) :: cldnum(:,:) + real(r8), intent(in) :: cldfrc(:,:) + real(r8), intent(in) :: cfact(:,:) + real(r8), intent(in) :: xlwc(:,:) + + real(r8), intent(in) :: delso4_hprxn(:,:) + real(r8), intent(in) :: xh2so4(:,:) + real(r8), intent(in) :: xso4(:,:) + real(r8), intent(in) :: xso4_init(:,:) + real(r8), intent(in) :: nh3g(:,:) + real(r8), intent(in) :: hno3g(:,:) + real(r8), intent(in) :: xnh3(:,:) + real(r8), intent(in) :: xhno3(:,:) + real(r8), intent(in) :: xnh4c(:,:) + real(r8), intent(in) :: xmsa(:,:) + real(r8), intent(in) :: xso2(:,:) + real(r8), intent(in) :: xh2o2(:,:) + real(r8), intent(in) :: xno3c(:,:) + + real(r8), intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) + real(r8), intent(inout) :: qin(:,:,:) ! xported species ( vmr ) + + real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + real(r8), intent(out), optional :: aqso4_h2o2_3d(:,:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out), optional :: aqso4_o3_3d(:,:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + + + ! local vars ... + + real(r8) :: dqdt_aqso4(ncol,pver,gas_pcnst), & + dqdt_aqh2so4(ncol,pver,gas_pcnst), & + dqdt_aqhprxn(ncol,pver), dqdt_aqo3rxn(ncol,pver), & + sflx(1:ncol) + + real(r8) :: delso4_o3rxn, & + dso4dt_aqrxn, dso4dt_hprxn, & + dso4dt_gasuptk, dmsadt_gasuptk, & + dmsadt_gasuptk_tomsa, dmsadt_gasuptk_toso4, & + dqdt_aq, dqdt_wr, dqdt + + real(r8) :: fwetrem, sumf, uptkrate + real(r8) :: delnh3, delnh4 + + integer :: l, n, m + integer :: ntot_msa_c + + integer :: i,k + real(r8) :: xl + + ! make sure dqdt is zero initially, for budgets + dqdt_aqso4(:,:,:) = 0.0_r8 + dqdt_aqh2so4(:,:,:) = 0.0_r8 + dqdt_aqhprxn(:,:) = 0.0_r8 + dqdt_aqo3rxn(:,:) = 0.0_r8 + + lev_loop: do k = 1,pver + col_loop: do i = 1,ncol + cloud: if (cldfrc(i,k) >= 1.0e-5_r8) then + xl = xlwc(i,k) ! / cldfrc(i,k) + + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED + + delso4_o3rxn = xso4(i,k) - xso4_init(i,k) + + if (id_nh3>0) then + delnh3 = nh3g(i,k) - xnh3(i,k) + delnh4 = - delnh3 + endif + + !In the case of OSLO-AEROSOLS, + !set no MSA in cloud droplets + ntot_msa_c = 0 + ! average uptake rate over dtime + uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k) ) + ! average uptake rate over dtime + uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime + + ! dso4dt_gasuptk = so4_c tendency from h2so4 gas uptake (mol/mol/s) + ! dmsadt_gasuptk = msa_c tendency from msa gas uptake (mol/mol/s) + dso4dt_gasuptk = xh2so4(i,k) * uptkrate + if (id_msa > 0) then + dmsadt_gasuptk = xmsa(i,k) * uptkrate + else + dmsadt_gasuptk = 0.0_r8 + end if + +! if no modes have msa aerosol, then "rename" scavenged msa gas to so4 + dmsadt_gasuptk_toso4 = 0.0_r8 + dmsadt_gasuptk_tomsa = dmsadt_gasuptk + if (ntot_msa_c == 0) then + dmsadt_gasuptk_tomsa = 0.0_r8 + dmsadt_gasuptk_toso4 = dmsadt_gasuptk + end if + +!----------------------------------------------------------------------- +! now compute TMR tendencies +! this includes the above aqueous so2 chemistry AND +! the uptake of highly soluble aerosol precursor gases (h2so4, msa, ...) +! AND the wetremoval of dissolved, unreacted so2 and h2o2 + + dso4dt_aqrxn = (delso4_o3rxn + delso4_hprxn(i,k)) / dtime + dso4dt_hprxn = delso4_hprxn(i,k) / dtime + +! fwetrem = fraction of in-cloud-water material that is wet removed +! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't have so4 & msa wet removal here + + !Update so4 in cloud water + l = id_so4_1a !We only have one aq-phase tracer in CAM_OSLO + + dqdt_aqso4(i,k,l) = dso4dt_aqrxn*cldfrc(i,k) + dqdt_aqh2so4(i,k,l) = & + (dso4dt_gasuptk + dmsadt_gasuptk_toso4)*cldfrc(i,k) + dqdt_aq = dqdt_aqso4(i,k,l) + dqdt_aqh2so4(i,k,l) + dqdt_wr = -fwetrem*dqdt_aq !wet removal set to zero above + dqdt= dqdt_aq + dqdt_wr + qcw(i,k,l) = qcw(i,k,l) + dqdt*dtime + + !Additional updates for MSA?? +! For gas species, tendency includes +! reactive uptake to cloud water that essentially transforms the gas to +! a different species. Wet removal associated with this is applied +! to the "new" species (e.g., so4_c) rather than to the gas. +! wet removal of the unreacted gas that is dissolved in cloud water. +! Need to multiply both these parts by cldfrc + +! h2so4 (g) & msa (g) + qin(i,k,id_h2so4) = qin(i,k,id_h2so4) - dso4dt_gasuptk * dtime * cldfrc(i,k) + if (id_msa > 0) qin(i,k,id_msa) = qin(i,k,id_msa) - dmsadt_gasuptk * dtime * cldfrc(i,k) + + + ! so2 -- the first order loss rate for so2 is frso2_c*clwlrat(i,k) + ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frso2_c*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't include so2 wet removal here + + dqdt_wr = -fwetrem*xso2(i,k)/dtime*cldfrc(i,k) + dqdt_aq = -dso4dt_aqrxn*cldfrc(i,k) + dqdt = dqdt_aq + dqdt_wr + qin(i,k,id_so2) = qin(i,k,id_so2) + dqdt * dtime + +! h2o2 -- the first order loss rate for h2o2 is frh2o2_c*clwlrat(i,k) +! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frh2o2_c*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't include h2o2 wet removal here + + dqdt_wr = -fwetrem*xh2o2(i,k)/dtime*cldfrc(i,k) + dqdt_aq = -dso4dt_hprxn*cldfrc(i,k) + dqdt = dqdt_aq + dqdt_wr + qin(i,k,id_h2o2) = qin(i,k,id_h2o2) + dqdt * dtime + + ! NH3 + if (id_nh3>0) then + dqdt_aq = delnh3/dtime*cldfrc(i,k) + dqdt = dqdt_aq + qin(i,k,id_nh3) = qin(i,k,id_nh3) + dqdt * dtime + endif + + ! for SO4 from H2O2/O3 budgets + dqdt_aqhprxn(i,k) = dso4dt_hprxn*cldfrc(i,k) + dqdt_aqo3rxn(i,k) = (dso4dt_aqrxn - dso4dt_hprxn)*cldfrc(i,k) + + ENDIF !! WHEN CLOUD IS PRESENTED + + endif cloud + enddo col_loop + enddo lev_loop + + !============================================================== + ! ... Update the mixing ratios + !============================================================== + do k = 1,pver + + qcw(:,k,id_so4_1a) = MAX( qcw(:,k,id_so4_1a), small_value ) + + qin(:,k,id_so2) = MAX( qin(:,k,id_so2), small_value ) + + if ( id_nh3 > 0 ) then + qin(:,k,id_nh3) = MAX( qin(:,k,id_nh3), small_value ) + endif + + end do + + ! diagnostics + + l = id_so4_1a !Index of the a2-tracer in cloud water + n = 1 !Only distribute to one "mode" + aqso4(:,n)=0._r8 + do k=1,pver + do i=1,ncol + aqso4(i,n)=aqso4(i,n)+dqdt_aqso4(i,k,l)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg/m2/s + enddo + enddo + + aqh2so4(:,n)=0._r8 + do k=1,pver + do i=1,ncol + aqh2so4(:,n)=aqh2so4(:,n)+dqdt_aqh2so4(i,k,l)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg/m2/s + enddo + enddo + + aqso4_h2o2(:) = 0._r8 + do k=1,pver + do i=1,ncol + aqso4_h2o2(i)=aqso4_h2o2(i)+dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + + if (present(aqso4_h2o2_3d)) then + aqso4_h2o2_3d(:,:) = 0._r8 + do k=1,pver + do i=1,ncol + aqso4_h2o2_3d(i,k)=dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + end if + + aqso4_o3(:)=0._r8 + do k=1,pver + do i=1,ncol + aqso4_o3(i)=aqso4_o3(i)+dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + + if (present(aqso4_o3_3d)) then + aqso4_o3_3d(:,:)=0._r8 + do k=1,pver + do i=1,ncol + aqso4_o3_3d(i,k)=dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + end if + + end subroutine sox_cldaero_update + + !---------------------------------------------------------------------------------- + !---------------------------------------------------------------------------------- + subroutine sox_cldaero_destroy_obj( conc_obj ) + type(cldaero_conc_t), pointer :: conc_obj + + call cldaero_deallocate( conc_obj ) + + end subroutine sox_cldaero_destroy_obj + +end module sox_cldaero_mod diff --git a/src/chemistry/oslo_aero/vertical_diffusion.F90 b/src/chemistry/oslo_aero/vertical_diffusion.F90 new file mode 100644 index 0000000000..ad433bb680 --- /dev/null +++ b/src/chemistry/oslo_aero/vertical_diffusion.F90 @@ -0,0 +1,1561 @@ +module vertical_diffusion + +!----------------------------------------------------------------------------------------------------- ! +! Module to compute vertical diffusion of momentum, moisture, trace constituents ! +! and static energy. Separate modules compute ! +! 1. stresses associated with turbulent flow over orography ! +! ( turbulent mountain stress ) ! +! 2. eddy diffusivities, including nonlocal tranport terms ! +! 3. molecular diffusivities ! +! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! +! differencing the diffused and initial states. ! +! ! +! Calling sequence: ! +! ! +! vertical_diffusion_init Initializes vertical diffustion constants and modules ! +! init_molec_diff Initializes molecular diffusivity module ! +! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! +! init_tms Initializes turbulent mountain stress module ! +! init_vdiff Initializes diffusion solver module ! +! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! +! vertical_diffusion_tend Computes vertical diffusion tendencies ! +! compute_tms Computes turbulent mountain stresses ! +! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! +! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! +! ! +!----------------------------------------------------------------------------------------------------- ! +! Some notes on refactoring changes made in 2015, which were not quite finished. ! +! ! +! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! +! removing these arguments, and referring to pbuf fields instead, is not complete. ! +! ! +! - compute_vdiff was intended to be split up into three components: ! +! ! +! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! +! ! +! 2. Turbulent diffusion of a single constituent ! +! ! +! 3. Molecular diffusion of a single constituent ! +! ! +! This reorganization would allow the three resulting functions to each use a simpler interface ! +! than the current combined version, and possibly also remove the need to use the fieldlist ! +! object at all. ! +! ! +! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! +! pull out these diagnostic calculations and outfld calls into separate functions. ! +! ! +!---------------------------Code history-------------------------------------------------------------- ! +! J. Rosinski : Jun. 1992 ! +! J. McCaa : Sep. 2004 ! +! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! +!----------------------------------------------------------------------------------------------------- ! + +use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 +use ppgrid, only : pcols, pver, pverp +use constituents, only : pcnst +use diffusion_solver, only : vdiff_selector +use cam_abortutils, only : endrun +use error_messages, only : handle_errmsg +use physconst, only : & + cpair , & ! Specific heat of dry air + gravit , & ! Acceleration due to gravity + rair , & ! Gas constant for dry air + zvir , & ! rh2o/rair - 1 + latvap , & ! Latent heat of vaporization + latice , & ! Latent heat of fusion + karman , & ! von Karman constant + mwdry , & ! Molecular weight of dry air + avogad ! Avogadro's number +use cam_history, only : fieldname_len +use perf_mod +use cam_logfile, only : iulog +use ref_pres, only : do_molec_diff, nbot_molec +use phys_control, only : phys_getopts +use time_manager, only : is_first_step + +#ifdef OSLO_AERO + use aerosoldef, only: getNumberOfAerosolTracers, fillAerosolTracerList +#endif + +implicit none +private +save + +! ----------------- ! +! Public interfaces ! +! ----------------- ! + +public vd_readnl +public vd_register ! Register multi-time-level variables with physics buffer +public vertical_diffusion_init ! Initialization +public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) +public vertical_diffusion_tend ! Full vertical diffusion routine + +! ------------ ! +! Private data ! +! ------------ ! + +character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change +! 'HB' = Holtslag and Boville (default) +! 'HBR' = Holtslag and Boville and Rash +! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) +logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure +! ( when 'diag_TKE' scheme is selected ) +logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion + +character(len=16) :: shallow_scheme ! Shallow convection scheme + +type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion +type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion +type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion +integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer +integer :: kvt_idx ! Index for kinematic molecular conductivity +integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions +integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress + +character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies +integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water +integer :: ixnumice, ixnumliq + +integer :: pblh_idx, tpert_idx, qpert_idx + +! pbuf fields for unicon +integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on +integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on + +! pbuf fields for tms +integer :: ksrftms_idx = -1 +integer :: tautmsx_idx = -1 +integer :: tautmsy_idx = -1 + +! pbuf fields for blj (Beljaars) +integer :: dragblj_idx = -1 +integer :: taubljx_idx = -1 +integer :: taubljy_idx = -1 + +logical :: diff_cnsrv_mass_check ! do mass conservation check +logical :: do_iss ! switch for implicit turbulent surface stress +logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present +integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents +integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols + +logical :: do_pbl_diags = .false. +logical :: waccmx_mode = .false. + +contains + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! +subroutine vd_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom + use shr_log_mod, only: errMsg => shr_log_errMsg + use trb_mtn_stress_cam, only: trb_mtn_stress_readnl + use beljaars_drag_cam, only: beljaars_drag_readnl + use eddy_diff_cam, only: eddy_diff_readnl + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'vd_readnl' + + namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'vert_diff_nl', status=ierr) + if (ierr == 0) then + read(unitn, vert_diff_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + + ! Get eddy_scheme setting from phys_control. + call phys_getopts( eddy_scheme_out = eddy_scheme, & + shallow_scheme_out = shallow_scheme ) + + ! TMS reads its own namelist. + call trb_mtn_stress_readnl(nlfile) + + ! Beljaars reads its own namelist. + call beljaars_drag_readnl(nlfile) + + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) + +end subroutine vd_readnl + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vd_register() + + !------------------------------------------------ ! + ! Register physics buffer fields and constituents ! + !------------------------------------------------ ! + + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + use trb_mtn_stress_cam, only : trb_mtn_stress_register + use beljaars_drag_cam, only : beljaars_drag_register + use eddy_diff_cam, only : eddy_diff_register + + ! Add fields to physics buffer + + ! kvt is used by gw_drag. only needs physpkg scope. + call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) + + + if (eddy_scheme /= 'CLUBB_SGS') then + call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) + end if + + call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) + 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('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) + call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) + + call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) + call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) + + call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) + call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) + call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) + end if + + ! diag_TKE fields + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then + call eddy_diff_register() + end if + + ! TMS fields + call trb_mtn_stress_register() + + ! Beljaars fields + call beljaars_drag_register() + +end subroutine vd_register + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_init(pbuf2d) + + !------------------------------------------------------------------! + ! Initialization of time independent fields for vertical diffusion ! + ! Calls initialization routines for subsidiary modules ! + !----------------------------------------------------------------- ! + + use cam_history, only : addfld, add_default, horiz_only + use cam_history, only : register_vector_field + use eddy_diff_cam, only : eddy_diff_init + use hb_diff, only : init_hb_diff + use molec_diff, only : init_molec_diff + use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select + use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind + use spmd_utils, only : masterproc + use ref_pres, only : press_lim_idx, pref_mid + use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc + use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & + rad_cnst_get_mam_mmr_idx + use trb_mtn_stress_cam,only : trb_mtn_stress_init + use beljaars_drag_cam, only : beljaars_drag_init + use upper_bc, only : ubc_init + use phys_control, only : waccmx_is, fv_am_correction + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + character(128) :: errstring ! Error status for init_vdiff + 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 :: k ! Vertical loop index + + real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) + + integer :: im, l, m, nmodes, nspec + + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_eddy ! output the eddy variables + logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi + integer :: history_budget_histfile_num ! output history file number for budget fields + logical :: history_waccm ! output variables of interest for WACCM runs + + ! ----------------------------------------------------------------- ! + + if (masterproc) then + write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' + end if + + ! Check to see if WACCM-X is on (currently we don't care whether the + ! ionosphere is on or not, since this neutral diffusion code is the + ! same either way). + waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') + + ! ----------------------------------------------------------------- ! + ! Get indices of cloud liquid and ice within the constituents array ! + ! ----------------------------------------------------------------- ! + + call cnst_get_ind( 'CLDLIQ', ixcldliq ) + call cnst_get_ind( 'CLDICE', ixcldice ) + ! These are optional; with the CAM4 microphysics, there are no number + ! constituents. + call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) + call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) + + ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. + call phys_getopts(prog_modal_aero_out=prog_modal_aero) +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. +#endif + if (prog_modal_aero) then + + ! Get the constituent indices of the number and mass mixing ratios of the modal + ! aerosols. + ! + ! N.B. - This implementation assumes that the prognostic modal aerosols are + ! impacting the climate calculation (i.e., can get info from list 0). + ! +#ifndef OSLO_AERO + !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF + !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! + ! First need total number of mam constituents + call rad_cnst_get_info(0, nmodes=nmodes) + do m = 1, nmodes + call rad_cnst_get_info(0, m, nspec=nspec) + pmam_ncnst = pmam_ncnst + 1 + nspec + end do + + allocate(pmam_cnst_idx(pmam_ncnst)) + + ! Get the constituent indicies + im = 1 + do m = 1, nmodes + call rad_cnst_get_mode_num_idx(m, pmam_cnst_idx(im)) + im = im + 1 + call rad_cnst_get_info(0, m, nspec=nspec) + do l = 1, nspec + call rad_cnst_get_mam_mmr_idx(m, l, pmam_cnst_idx(im)) + im = im + 1 + end do + end do +#else if (defined OSLO_AERO) + pmam_ncnst = getNumberOfAerosolTracers() + allocate(pmam_cnst_idx(pmam_ncnst)) + call fillAerosolTracerList(pmam_cnst_idx) +#endif + end if + + ! Initialize upper boundary condition module + + call ubc_init() + + ! ---------------------------------------------------------------------------------------- ! + ! Initialize molecular diffusivity module ! + ! Note that computing molecular diffusivities is a trivial expense, but constituent ! + ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! + ! for each constituent is a needless expense unless the diffusivity is significant. ! + ! ---------------------------------------------------------------------------------------- ! + + !---------------------------------------------------------------------------------------- + ! Initialize molecular diffusion and get top and bottom molecular diffusion limits + !---------------------------------------------------------------------------------------- + + if( do_molec_diff ) then + call init_molec_diff( r8, pcnst, mwdry, avogad, & + errstring) + + call handle_errmsg(errstring, subname="init_molec_diff") + + call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) + if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec + end if + + ! ---------------------------------- ! + ! Initialize eddy diffusivity module ! + ! ---------------------------------- ! + + ! ntop_eddy must be 1 or <= nbot_molec + ! Currently, it is always 1 except for WACCM-X. + if ( waccmx_mode ) then + ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) + else + ntop_eddy = 1 + end if + nbot_eddy = pver + + if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy + + select case ( eddy_scheme ) + case ( 'diag_TKE', 'SPCAM_m2005' ) + if( masterproc ) write(iulog,*) & + 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' + call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) + case ( 'HB', 'HBR', 'SPCAM_sam1mom') + if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' + call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & + karman, eddy_scheme) + call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) + case ( 'CLUBB_SGS' ) + do_pbl_diags = .true. + end select + + ! ------------------------------------------- ! + ! Initialize turbulent mountain stress module ! + ! ------------------------------------------- ! + + call trb_mtn_stress_init() + + ! ----------------------------------- ! + ! Initialize Beljaars SGO drag module ! + ! ----------------------------------- ! + + call beljaars_drag_init() + + ! ---------------------------------- ! + ! Initialize diffusion solver module ! + ! ---------------------------------- ! + + call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) + call handle_errmsg(errstring, subname="init_vdiff") + + ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) + ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. + + fieldlist_wet = new_fieldlist_vdiff( pcnst) + fieldlist_dry = new_fieldlist_vdiff( pcnst) + fieldlist_molec = new_fieldlist_vdiff( pcnst) + + if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) + if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) + if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) + + constit_loop: do k = 1, pcnst + + if (prog_modal_aero) then + ! Do not diffuse droplet number - treated in dropmixnuc + if (k == ixnumliq) cycle constit_loop + ! Don't diffuse modal aerosol - treated in dropmixnuc + do m = 1, pmam_ncnst + if (k == pmam_cnst_idx(m)) cycle constit_loop + enddo + end if + + if( cnst_get_type_byind(k) .eq. 'wet' ) then + if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) + else + if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) + endif + + ! ----------------------------------------------- ! + ! Select constituents for molecular diffusion ! + ! ----------------------------------------------- ! + if ( cnst_get_molec_byind(k) .eq. 'minor' ) then + if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) + endif + + end do constit_loop + + ! ------------------------ ! + ! Diagnostic output fields ! + ! ------------------------ ! + + do k = 1, pcnst + vdiffnam(k) = 'VD'//cnst_name(k) + if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** + call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) + end do + + if (.not. do_pbl_diags) then + call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) + call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) + call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) + call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) + call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) + call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) + call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) + call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) + call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) + + call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) + call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) + call register_vector_field('UFLX', 'VFLX') + end if + + call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) + call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) + call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) + call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') + call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) + call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) + call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) + call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) + call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) + + ! ---------------------------------------------------------------------------- ! + ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! + ! ---------------------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) + call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) + call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) + call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) + call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) + call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) + call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) + call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) + call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) + call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) + + call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) + call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) + call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) + call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) + call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) + call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) + call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) + call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) + call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) + call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) + + call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) + call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) + call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) + call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) + + call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) + call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) + call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) + call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) + + call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) + call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) + call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) + call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) + call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) + call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) + call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) + call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) + call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) + + end if + + call addfld ('ustar',horiz_only, 'A', ' ',' ') + call addfld ('obklen',horiz_only, 'A', ' ',' ') + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + + call phys_getopts( history_amwg_out = history_amwg, & + history_eddy_out = history_eddy, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + if (history_amwg) then + call add_default( vdiffnam(1), 1, ' ' ) + call add_default( 'DTV' , 1, ' ' ) + if (.not. do_pbl_diags) then + call add_default( 'PBLH' , 1, ' ' ) + end if + endif + + if (history_eddy) then + call add_default( 'UFLX ', 1, ' ' ) + call add_default( 'VFLX ', 1, ' ' ) + endif + + if( history_budget ) then + call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) +!AL + call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) +!AL + if( history_budget_histfile_num > 1 ) then + call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) + call add_default( 'DTV' , history_budget_histfile_num, ' ' ) + end if + end if + + if ( history_waccm ) then + if (do_molec_diff) then + call add_default ( 'TTPXMLC', 1, ' ' ) + end if + call add_default( 'DUV' , 1, ' ' ) + call add_default( 'DVV' , 1, ' ' ) + end if + ! ---------------------------- + + + ksrftms_idx = pbuf_get_index('ksrftms') + tautmsx_idx = pbuf_get_index('tautmsx') + tautmsy_idx = pbuf_get_index('tautmsy') + + dragblj_idx = pbuf_get_index('dragblj') + taubljx_idx = pbuf_get_index('taubljx') + taubljy_idx = pbuf_get_index('taubljy') + + if (eddy_scheme == 'CLUBB_SGS') then + kvh_idx = pbuf_get_index('kvh') + end if + + ! Initialization of some pbuf fields + if (is_first_step()) then + ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat + call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) + call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) + end if + end if + +end subroutine vertical_diffusion_init + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_ts_init( pbuf2d, state ) + + !-------------------------------------------------------------- ! + ! Timestep dependent setting, ! + ! At present only invokes upper bc code ! + !-------------------------------------------------------------- ! + use upper_bc, only : ubc_timestep_init + use physics_types , only : physics_state + use ppgrid , only : begchunk, endchunk + + use physics_buffer, only : physics_buffer_desc + + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + call ubc_timestep_init( pbuf2d, state) + +end subroutine vertical_diffusion_ts_init + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_tend( & + ztodt , state , cam_in, & + ustar , obklen , ptend , & + cldn , pbuf) + !---------------------------------------------------- ! + ! This is an interface routine for vertical diffusion ! + !---------------------------------------------------- ! + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field + use physics_types, only : physics_state, physics_ptend, physics_ptend_init + use camsrfexch, only : cam_in_t + use cam_history, only : outfld + + use trb_mtn_stress_cam, only : trb_mtn_stress_tend + use beljaars_drag_cam, only : beljaars_drag_tend + use eddy_diff_cam, only : eddy_diff_tend + use hb_diff, only : compute_hb_diff + use wv_saturation, only : qsat + use molec_diff, only : compute_molec_diff, vd_lu_qdecomp + use constituents, only : qmincg, qmin + use diffusion_solver, only : compute_vdiff, any, operator(.not.) + use physconst, only : cpairv, rairv !Needed for calculation of upward H flux + use time_manager, only : get_nstep + use constituents, only : cnst_get_type_byind, cnst_name, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx + use physconst, only : pi + use pbl_utils, only : virtem, calc_obklen, calc_ustar + use upper_bc, only : ubc_get_vals + use coords_1d, only : Coords1D + + ! --------------- ! + ! Input Arguments ! + ! --------------- ! + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in ! Surface inputs + + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] + + ! ---------------------- ! + ! Input-Output Arguments ! + ! ---------------------- ! + + type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + ! ---------------- ! + ! Output Arguments ! + ! ---------------- ! + + real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] + real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + + character(128) :: errstring ! Error status for compute_vdiff + + integer :: lchnk ! Chunk identifier + integer :: ncol ! Number of atmospheric columns + integer :: i, k, l, m ! column, level, constituent indices + + real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation + real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] + integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] + real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function + ! ( 0<= <=4.964 and 1 at neutral ) + + real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql + real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi + + real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] + real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat + real(r8) :: rztodt ! 1./ztodt [ 1/s ] + real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] + real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] + real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] + real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] + + real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] + real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] + + real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] + real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] + real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] + real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] + real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] + real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] + real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] + real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call + real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] + real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] + real(r8) :: sl(pcols,pver) + real(r8) :: qt(pcols,pver) + real(r8) :: slv(pcols,pver) + real(r8) :: sl_prePBL(pcols,pver) + real(r8) :: qt_prePBL(pcols,pver) + real(r8) :: slv_prePBL(pcols,pver) + real(r8) :: slten(pcols,pver) + real(r8) :: qtten(pcols,pver) + real(r8) :: slflx(pcols,pverp) + real(r8) :: qtflx(pcols,pverp) + real(r8) :: uflx(pcols,pverp) + real(r8) :: vflx(pcols,pverp) + real(r8) :: slflx_cg(pcols,pverp) + real(r8) :: qtflx_cg(pcols,pverp) + real(r8) :: uflx_cg(pcols,pverp) + real(r8) :: vflx_cg(pcols,pverp) + real(r8) :: th(pcols,pver) ! Potential temperature + real(r8) :: topflx(pcols) ! Molecular heat flux at top interface + real(r8) :: rhoair + + real(r8) :: ri(pcols,pver) ! richardson number (HB output) + + ! for obklen calculation outside HB + real(r8) :: thvs(pcols) ! Virtual potential temperature at surface + real(r8) :: rrho(pcols) ! Reciprocal of density at surface + real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] + real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] + real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] + + real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL + real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH + real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion + real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion + real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion + real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion + real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion + real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion + real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion + real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion + real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion + real(r8) :: qv_pro(pcols,pver) + real(r8) :: ql_pro(pcols,pver) + real(r8) :: qi_pro(pcols,pver) + real(r8) :: s_pro(pcols,pver) + real(r8) :: t_pro(pcols,pver) + real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct + real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. + + ! Interpolated interface values. + real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] + real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] + real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] + real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] + + ! Upper boundary conditions + real(r8) :: ubc_t(pcols) ! Temperature [ K ] + real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] + real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) + + ! Pressure coordinates used by the solver. + type(Coords1D) :: p + type(Coords1D) :: p_dry + + real(r8), pointer :: tpert(:) + real(r8), pointer :: qpert(:) + real(r8), pointer :: pblh(:) + + real(r8) :: tmp1(pcols) ! Temporary storage + + integer :: nstep + real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sflx + + ! Copy state so we can pass to intent(inout) routines that return + ! new state instead of a tendency. + real(r8) :: s_tmp(pcols,pver) + real(r8) :: u_tmp(pcols,pver) + real(r8) :: v_tmp(pcols,pver) + real(r8) :: q_tmp(pcols,pver,pcnst) + + ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity + real(r8) :: kq_scal(pcols,pver+1) + ! composition dependent mw_fac on interface level + real(r8) :: mw_fac(pcols,pver+1,pcnst) + + ! Dry static energy top boundary condition. + real(r8) :: dse_top(pcols) + + ! Copies of flux arrays used to zero out any parts that are applied + ! elsewhere (e.g. by CLUBB). + real(r8) :: taux(pcols) + real(r8) :: tauy(pcols) + real(r8) :: shflux(pcols) + real(r8) :: cflux(pcols,pcnst) + + logical :: lq(pcnst) + + ! ----------------------- ! + ! Main Computation Begins ! + ! ----------------------- ! + + rztodt = 1._r8 / ztodt + lchnk = state%lchnk + ncol = state%ncol + + call pbuf_get_field(pbuf, tauresx_idx, tauresx) + call pbuf_get_field(pbuf, tauresy_idx, tauresy) + call pbuf_get_field(pbuf, tpert_idx, tpert) + call pbuf_get_field(pbuf, qpert_idx, qpert) + call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, turbtype_idx, turbtype) + + ! Interpolate temperature to interfaces. + do k = 2, pver + do i = 1, ncol + tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) + end do + end do + tint(:ncol,pver+1) = state%t(:ncol,pver) + + ! Get upper boundary values + call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & + ubc_t, ubc_mmr, ubc_flux ) + + ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? + ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures + if (do_molec_diff) then + if (waccmx_mode) then + tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) + else + tint (:ncol,1) = ubc_t(:ncol) + endif + else + tint(:ncol,1) = state%t(:ncol,1) + end if + + ! Set up pressure coordinates for solver calls. + p = Coords1D(state%pint(:ncol,:)) + p_dry = Coords1D(state%pintdry(:ncol,:)) + + !------------------------------------------------------------------------ + ! Check to see if constituent dependent gas constant needed (WACCM-X) + !------------------------------------------------------------------------ + if (waccmx_mode) then + rairi(:ncol,1) = rairv(:ncol,1,lchnk) + do k = 2, pver + do i = 1, ncol + rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) + end do + end do + rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) + else + rairi(:ncol,:pver+1) = rair + endif + + ! Compute rho at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! Compute rho_dry at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! ---------------------------------------- ! + ! Computation of turbulent mountain stress ! + ! ---------------------------------------- ! + + ! Consistent with the computation of 'normal' drag coefficient, we are using + ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' + ! within the iteration loop of the PBL scheme. + + call trb_mtn_stress_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) + call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) + call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) + + tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) + tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) + + ! ------------------------------------- ! + ! Computation of Beljaars SGO form drag ! + ! ------------------------------------- ! + + call beljaars_drag_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, dragblj_idx, dragblj) + call pbuf_get_field(pbuf, taubljx_idx, taubljx) + call pbuf_get_field(pbuf, taubljy_idx, taubljy) + + ! Add Beljaars integrated drag + + tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) + tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) + + !----------------------------------------------------------------------- ! + ! Computation of eddy diffusivities - Select appropriate PBL scheme ! + !----------------------------------------------------------------------- ! + call pbuf_get_field(pbuf, kvm_idx, kvm_in) + call pbuf_get_field(pbuf, kvh_idx, kvh_in) + call pbuf_get_field(pbuf, smaw_idx, smaw) + call pbuf_get_field(pbuf, tke_idx, tke) + + ! Get potential temperature. + th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) + + select case (eddy_scheme) + case ( 'diag_TKE', 'SPCAM_m2005' ) + + call eddy_diff_tend(state, pbuf, cam_in, & + ztodt, p, tint, rhoi, cldn, wstarent, & + kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & + rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & + tke, sprod, sfi, turbtype, smaw) + + ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. + ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + + case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) + + ! Modification : We may need to use 'taux' instead of 'tautotx' here, for + ! consistency with the previous HB scheme. + + call compute_hb_diff( lchnk , ncol , & + th , state%t , state%q , state%zm , state%zi, & + state%pmid, state%u , state%v , tautotx , tautoty , & + cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & + kvm , kvh , kvq , cgh , cgs , & + tpert , qpert , cldn , cam_in%ocnfrac , tke , & + ri , & + eddy_scheme ) + + call outfld( 'HB_ri', ri, pcols, lchnk ) + + case ( 'CLUBB_SGS' ) + + ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the + ! PBL diffusion will happen before coupling, so vertical_diffusion + ! is only handling other things, e.g. some boundary conditions, tms, + ! and molecular diffusion. + + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + + call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & + cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) + ! Use actual qflux, not lhf/latvap as was done previously + call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + ! These tendencies all applied elsewhere. + kvm = 0._r8 + kvh = 0._r8 + kvq = 0._r8 + + ! Not defined since PBL is not actually running here. + cgh = 0._r8 + cgs = 0._r8 + + end select + + call outfld( 'ustar', ustar(:), pcols, lchnk ) + call outfld( 'obklen', obklen(:), pcols, lchnk ) + + ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff + ! on the next timestep. It is not updated by the compute_vdiff call below. + call pbuf_set_field(pbuf, kvh_idx, kvh) + + ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. + ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below + ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. + call pbuf_set_field(pbuf, kvm_idx, kvm) + + !------------------------------------ ! + ! Application of diffusivities ! + !------------------------------------ ! + + ! Set arrays from input state. + q_tmp(:ncol,:,:) = state%q(:ncol,:,:) + s_tmp(:ncol,:) = state%s(:ncol,:) + u_tmp(:ncol,:) = state%u(:ncol,:) + v_tmp(:ncol,:) = state%v(:ncol,:) + + !------------------------------------------------------ ! + ! Write profile output before applying diffusion scheme ! + !------------------------------------------------------ ! + + if (.not. do_pbl_diags) then + sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) + + call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & + tem2(:ncol,:), ftem(:ncol,:)) + ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + + call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) + call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) + call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) + call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) + call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) + call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) + call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) + + end if + + ! --------------------------------------------------------------------------------- ! + ! Call the diffusivity solver and solve diffusion equation ! + ! The final two arguments are optional function references to ! + ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! + ! --------------------------------------------------------------------------------- ! + + ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and + ! separately print out as diagnostic output, because these are different from + ! the explicit 'tautotx, tautoty' computed above. + ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. + + call pbuf_get_field(pbuf, kvt_idx, kvt) + + if (do_molec_diff .and. .not. waccmx_mode) then + ! Top boundary condition for dry static energy + dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & + gravit * state%zi(:ncol,1) + else + dse_top(:ncol) = 0._r8 + end if + + select case (eddy_scheme) + case ('CLUBB_SGS') + ! CLUBB applies some fluxes itself, but we still want constituent + ! fluxes applied here (except water vapor). + taux = 0._r8 + tauy = 0._r8 + shflux = 0._r8 + cflux(:,1) = 0._r8 + cflux(:,2:) = cam_in%cflx(:,2:) + case default + taux = cam_in%wsx + tauy = cam_in%wsy + shflux = cam_in%shf + cflux = cam_in%cflx + end select + + if( any(fieldlist_wet) ) then + + if (do_molec_diff) then + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p , state%t , rhoi, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_wet , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx , tautmsy , dtk , topflx , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff, waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmid, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_wet call from vertical_diffusion.") + + end if + + if( any( fieldlist_dry ) ) then + + if( do_molec_diff ) then + ! kvm is unused in the output here (since it was assigned + ! above), so we use a temp kvm for the inout argument, and + ! ignore the value output by compute_molec_diff. + kvm_temp = kvm + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p_dry , state%t , rhoi_dry, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_dry , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff , waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmiddry, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_dry call from vertical_diffusion.") + + end if + + if (prog_modal_aero) then + + ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the + ! lowest layer + +!Oslo aero adds emissions together with dry deposition +#ifndef OSLO_AERO + tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) + do m = 1, pmam_ncnst + l = pmam_cnst_idx(m) + q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) + enddo +#endif + end if + + ! -------------------------------------------------------- ! + ! Diagnostics and output writing after applying PBL scheme ! + ! -------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) + + slflx(:ncol,1) = 0._r8 + qtflx(:ncol,1) = 0._r8 + uflx(:ncol,1) = 0._r8 + vflx(:ncol,1) = 0._r8 + + slflx_cg(:ncol,1) = 0._r8 + qtflx_cg(:ncol,1) = 0._r8 + uflx_cg(:ncol,1) = 0._r8 + vflx_cg(:ncol,1) = 0._r8 + + do k = 2, pver + do i = 1, ncol + rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) + slflx(i,k) = kvh(i,k) * & + ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + cgh(i,k) ) + qtflx(i,k) = kvh(i,k) * & + ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) + uflx(i,k) = kvm(i,k) * & + ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + vflx(i,k) = kvm(i,k) * & + ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + slflx_cg(i,k) = kvh(i,k) * cgh(i,k) + qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & + cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) + uflx_cg(i,k) = 0._r8 + vflx_cg(i,k) = 0._r8 + end do + end do + + ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. + ! Note also that 'tautotx' is explicit total stress, different from + ! the ones that have been actually added into the atmosphere. + + slflx(:ncol,pverp) = cam_in%shf(:ncol) + qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) + uflx(:ncol,pverp) = tautotx(:ncol) + vflx(:ncol,pverp) = tautoty(:ncol) + + slflx_cg(:ncol,pverp) = 0._r8 + qtflx_cg(:ncol,pverp) = 0._r8 + uflx_cg(:ncol,pverp) = 0._r8 + vflx_cg(:ncol,pverp) = 0._r8 + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + qtl_flx(:ncol,1) = 0._r8 + qti_flx(:ncol,1) = 0._r8 + do k = 2, pver + do i = 1, ncol + ! For use in the cloud macrophysics + ! Note that density is not added here. Also, only consider local transport term. + qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& + (state%zm(i,k-1)-state%zm(i,k)) + qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& + (state%zm(i,k-1)-state%zm(i,k)) + end do + end do + do i = 1, ncol + rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) + qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + end do + end if + + end if + + ! --------------------------------------------------------------- ! + ! Convert the new profiles into vertical diffusion tendencies. ! + ! Convert KE dissipative heat change into "temperature" tendency. ! + ! --------------------------------------------------------------- ! + + ! All variables are modified by vertical diffusion + + lq(:) = .TRUE. + call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & + ls=.true., lu=.true., lv=.true., lq=lq) + + ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt + ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt + ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt + ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt + if (.not. do_pbl_diags) then + slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt + qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt + end if + + ! ------------------------------------------------------------ ! + ! In order to perform 'pseudo-conservative variable diffusion' ! + ! perform the following two stages: ! + ! ! + ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! + ! (2) 'sten' by 'slten', and ! + ! (3) 'qlten = qiten = 0' ! + ! ! + ! II. Apply 'positive_moisture' ! + ! ! + ! ------------------------------------------------------------ ! + + if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then + + ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) + ptend%s(:ncol,:pver) = slten(:ncol,:pver) + ptend%q(:ncol,:pver,ixcldliq) = 0._r8 + ptend%q(:ncol,:pver,ixcldice) = 0._r8 + if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 + if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 + + do i = 1, ncol + do k = 1, pver + qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt + ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt + qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt + s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt + t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt + end do + end do + + call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & + qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & + ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & + ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) + + end if + + ! ----------------------------------------------------------------- ! + ! Re-calculate diagnostic output variables after vertical diffusion ! + ! ----------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt + ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt + qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt + s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt + t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair + + u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt + v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt + + call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & + tem2(:ncol,:pver), ftem(:ncol,:pver)) + ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 + + tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt + rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt + + end if + + ! -------------------------------------------------------------- ! + ! mass conservation check......... + ! -------------------------------------------------------------- ! + if (diff_cnsrv_mass_check) then + + ! Conservation check + do m = 1, pcnst + fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then + col_loop: do i = 1, ncol + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + do k = 1, pver + if(cnst_get_type_byind(m).eq.'wet') then + pdelx = state%pdel(i,k) + else + pdelx = state%pdeldry(i,k) + endif + sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column + sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied + sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column + enddo + sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) + sflx = (cam_in%cflx(i,m) * ztodt) + if (sum1>1.e-36_r8) then + if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then + nstep = get_nstep() + write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & + 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & + trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & + sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 + call endrun('vertical_diffusion_tend : mass not conserved' ) + endif + endif + enddo col_loop + endif fixed_ubc + enddo + endif + + ! -------------------------------------------------------------- ! + ! Writing state variables after PBL scheme for detailed analysis ! + ! -------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) + call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) + call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) + call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) + call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) + call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) + call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) + call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) + call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) + call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) + call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) + call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) + call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) + call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) + call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) + call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) + call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) + call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) + call outfld( 'slten_PBL' , slten, pcols, lchnk ) + call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'tten_PBL' , tten, pcols, lchnk ) + call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) + + end if + + ! ------------------------------------------- ! + ! Writing the other standard output variables ! + ! ------------------------------------------- ! + + if (.not. do_pbl_diags) then + call outfld( 'QT' , qt, pcols, lchnk ) + call outfld( 'SL' , sl, pcols, lchnk ) + call outfld( 'SLV' , slv, pcols, lchnk ) + call outfld( 'SLFLX' , slflx, pcols, lchnk ) + call outfld( 'QTFLX' , qtflx, pcols, lchnk ) + call outfld( 'UFLX' , uflx, pcols, lchnk ) + call outfld( 'VFLX' , vflx, pcols, lchnk ) + call outfld( 'TKE' , tke, pcols, lchnk ) + + call outfld( 'PBLH' , pblh, pcols, lchnk ) + call outfld( 'TPERT' , tpert, pcols, lchnk ) + call outfld( 'QPERT' , qpert, pcols, lchnk ) + end if + call outfld( 'USTAR' , ustar, pcols, lchnk ) + call outfld( 'KVH' , kvh, pcols, lchnk ) + call outfld( 'KVT' , kvt, pcols, lchnk ) + call outfld( 'KVM' , kvm, pcols, lchnk ) + call outfld( 'CGS' , cgs, pcols, lchnk ) + dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history + call outfld( 'DTVKE' , dtk, pcols, lchnk ) + dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk + call outfld( 'DTV' , dtk, pcols, lchnk ) + call outfld( 'DUV' , ptend%u, pcols, lchnk ) + call outfld( 'DVV' , ptend%v, pcols, lchnk ) + do m = 1, pcnst + call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) + end do + if( do_molec_diff ) then + call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) + end if + + call p%finalize() + call p_dry%finalize() + +end subroutine vertical_diffusion_tend + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & + dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) + ! ------------------------------------------------------------------------------- ! + ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! + ! force them to be larger than minimum value by (1) condensating water vapor ! + ! into liquid or ice, and (2) by transporting water vapor from the very lower ! + ! layer. '2._r8' is multiplied to the minimum values for safety. ! + ! Update final state variables and tendencies associated with this correction. ! + ! If any condensation happens, update (s,t) too. ! + ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! + ! input tendencies. ! + ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! + ! ------------------------------------------------------------------------------- ! + implicit none + integer, intent(in) :: ncol, mkx + real(r8), intent(in) :: cp, xlv, xls + real(r8), intent(in) :: dt, qvmin, qlmin, qimin + real(r8), intent(in) :: dp(ncol,mkx) + real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) + real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) + integer i, k + real(r8) dql, dqi, dqv, sum, aa, dum + + ! Modification : I should check whether this is exactly same as the one used in + ! shallow convection and cloud macrophysics. + + do i = 1, ncol + do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface + dql = max(0._r8,1._r8*qlmin-ql(i,k)) + dqi = max(0._r8,1._r8*qimin-qi(i,k)) + qlten(i,k) = qlten(i,k) + dql/dt + qiten(i,k) = qiten(i,k) + dqi/dt + qvten(i,k) = qvten(i,k) - (dql+dqi)/dt + sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) + ql(i,k) = ql(i,k) + dql + qi(i,k) = qi(i,k) + dqi + qv(i,k) = qv(i,k) - dql - dqi + s(i,k) = s(i,k) + xlv * dql + xls * dqi + t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp + dqv = max(0._r8,1._r8*qvmin-qv(i,k)) + qvten(i,k) = qvten(i,k) + dqv/dt + qv(i,k) = qv(i,k) + dqv + if( k .ne. 1 ) then + qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) + qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt + endif + qv(i,k) = max(qv(i,k),qvmin) + ql(i,k) = max(ql(i,k),qlmin) + qi(i,k) = max(qi(i,k),qimin) + end do + ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv .gt. 1.e-20_r8 ) then + sum = 0._r8 + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) + enddo + aa = dqv*dp(i,1)/max(1.e-20_r8,sum) + if( aa .lt. 0.5_r8 ) then + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) then + dum = aa*qv(i,k) + qv(i,k) = qv(i,k) - dum + qvten(i,k) = qvten(i,k) - dum/dt + endif + enddo + else + write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' + endif + endif + end do + return + +end subroutine positive_moisture + +end module vertical_diffusion diff --git a/src/chemistry/oslo_aero/zm_microphysics.F90 b/src/chemistry/oslo_aero/zm_microphysics.F90 new file mode 100644 index 0000000000..e95caafe7d --- /dev/null +++ b/src/chemistry/oslo_aero/zm_microphysics.F90 @@ -0,0 +1,2445 @@ +module zm_microphysics + +!--------------------------------------------------------------------------------- +! Purpose: +! CAM Interface for cumulus microphysics +! +! Author: Xialiang Song and Guang Jun Zhang, June 2010 +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp +use physconst, only: gravit, rair, tmelt, cpair, rh2o, r_universal, mwh2o, rhoh2o +use physconst, only: latvap, latice +!use activate_drop_mam, only: actdrop_mam_calc +use ndrop, only: activate_modal +use ndrop_bam, only: ndrop_bam_run +use nucleate_ice, only: nucleati +use shr_spfn_mod, only: erf => shr_spfn_erf +use shr_spfn_mod, only: gamma => shr_spfn_gamma +use wv_saturation, only: svp_water, svp_ice +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use micro_mg_utils, only:ice_autoconversion, snow_self_aggregation, accrete_cloud_water_snow, & + secondary_ice_production, accrete_rain_snow, heterogeneous_rain_freezing, & + accrete_cloud_water_rain, self_collection_rain, accrete_cloud_ice_snow + +implicit none +private +save + +public :: & + zm_mphyi, & + zm_mphy, & + zm_conv_t,& + zm_aero_t + +! Private module data + +! constants remaped +real(r8) :: g ! gravity +real(r8) :: mw ! molecular weight of water +real(r8) :: r ! Dry air Gas constant +real(r8) :: rv ! water vapor gas contstant +real(r8) :: rr ! universal gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: rhow ! density of liquid water +real(r8) :: xlf ! latent heat of freezing + +!from 'microconstants' +real(r8) :: rhosn ! bulk density snow +real(r8) :: rhoi ! bulk density ice + +real(r8) :: ac,bc,as,bs,ai,bi,ar,br !fall speed parameters +real(r8) :: ci,di !ice mass-diameter relation parameters +real(r8) :: cs,ds !snow mass-diameter relation parameters +real(r8) :: cr,dr !drop mass-diameter relation parameters +real(r8) :: Eii !collection efficiency aggregation of ice +real(r8) :: Ecc !collection efficiency +real(r8) :: Ecr !collection efficiency cloud droplets/rain +real(r8) :: DCS !autoconversion size threshold +real(r8) :: bimm,aimm !immersion freezing +real(r8) :: rhosu !typical 850mn air density +real(r8) :: mi0 ! new crystal mass +real(r8) :: rin ! radius of contact nuclei +real(r8) :: pi ! pi + +! contact freezing due to dust +! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 +real(r8), parameter :: rn_dst1 = 0.258e-6_r8 +real(r8), parameter :: rn_dst2 = 0.717e-6_r8 +real(r8), parameter :: rn_dst3 = 1.576e-6_r8 +real(r8), parameter :: rn_dst4 = 3.026e-6_r8 + +! smallest mixing ratio considered in microphysics +real(r8), parameter :: qsmall = 1.e-18_r8 + + +type, public :: ptr2d + real(r8), pointer :: val(:,:) +end type ptr2d + +! Aerosols +type :: zm_aero_t + + ! Aerosol treatment + character(len=5) :: scheme ! either 'bulk' or 'modal' + + ! Bulk aerosols + integer :: nbulk = 0 ! number of bulk aerosols affecting climate + integer :: idxsul = -1 ! index in aerosol list for sulfate + integer :: idxdst1 = -1 ! index in aerosol list for dust1 + integer :: idxdst2 = -1 ! index in aerosol list for dust2 + integer :: idxdst3 = -1 ! index in aerosol list for dust3 + integer :: idxdst4 = -1 ! index in aerosol list for dust4 + integer :: idxbcphi = -1 ! index in aerosol list for Soot (BCPHI) + + real(r8), allocatable :: num_to_mass_aer(:) ! conversion of mmr to number conc for bulk aerosols + type(ptr2d), allocatable :: mmr_bulk(:) ! array of pointers to bulk aerosol mmr + real(r8), allocatable :: mmrg_bulk(:,:,:) ! gathered bulk aerosol mmr + + ! Modal aerosols + integer :: nmodes = 0 ! number of modes + integer, allocatable :: nspec(:) ! number of species in each mode + type(ptr2d), allocatable :: num_a(:) ! number mixing ratio of modes (interstitial phase) + type(ptr2d), allocatable :: mmr_a(:,:) ! species mmr in each mode (interstitial phase) + real(r8), allocatable :: numg_a(:,:,:) ! gathered number mixing ratio of modes (interstitial phase) + real(r8), allocatable :: mmrg_a(:,:,:,:) ! gathered species mmr in each mode (interstitial phase) + real(r8), allocatable :: voltonumblo(:) ! volume to number conversion (lower bound) for each mode + real(r8), allocatable :: voltonumbhi(:) ! volume to number conversion (upper bound) for each mode + real(r8), allocatable :: specdens(:,:) ! density of modal species + real(r8), allocatable :: spechygro(:,:) ! hygroscopicity of modal species + + integer :: mode_accum_idx = -1 ! index of accumulation mode + integer :: mode_aitken_idx = -1 ! index of aitken mode + integer :: mode_coarse_idx = -1 ! index of coarse mode + integer :: coarse_dust_idx = -1 ! index of dust in coarse mode + integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode + + type(ptr2d), allocatable :: dgnum(:) ! mode dry radius + real(r8), allocatable :: dgnumg(:,:,:) ! gathered mode dry radius + + real(r8) :: sigmag_aitken + +end type zm_aero_t + +type :: zm_conv_t + + real(r8), allocatable :: qi(:,:) ! wg grid slice of cloud ice. + real(r8), allocatable :: qliq(:,:) ! convective cloud liquid water. + real(r8), allocatable :: qice(:,:) ! convective cloud ice. + real(r8), allocatable :: wu(:,:) ! vertical velocity + real(r8), allocatable :: sprd(:,:) ! rate of production of snow at that layer + real(r8), allocatable :: qrain(:,:) ! convective rain water. + real(r8), allocatable :: qsnow(:,:) ! convective snow. + real(r8), allocatable :: qnl(:,:) ! convective cloud liquid water num concen. + real(r8), allocatable :: qni(:,:) ! convective cloud ice num concen. + real(r8), allocatable :: qnr(:,:) ! convective rain water num concen. + real(r8), allocatable :: qns(:,:) ! convective snow num concen. + real(r8), allocatable :: frz(:,:) ! heating rate due to freezing + real(r8), allocatable :: autolm(:,:) !mass tendency due to autoconversion of droplets to rain + real(r8), allocatable :: accrlm(:,:) !mass tendency due to accretion of droplets by rain + real(r8), allocatable :: bergnm(:,:) !mass tendency due to Bergeron process + real(r8), allocatable :: fhtimm(:,:) !mass tendency due to immersion freezing + real(r8), allocatable :: fhtctm(:,:) !mass tendency due to contact freezing + real(r8), allocatable :: fhmlm (:,:) !mass tendency due to homogeneous freezing + real(r8), allocatable :: hmpim (:,:) !mass tendency due to HM process + real(r8), allocatable :: accslm(:,:) !mass tendency due to accretion of droplets by snow + real(r8), allocatable :: dlfm (:,:) !mass tendency due to detrainment of droplet + real(r8), allocatable :: autoln(:,:) !num tendency due to autoconversion of droplets to rain + real(r8), allocatable :: accrln(:,:) !num tendency due to accretion of droplets by rain + real(r8), allocatable :: bergnn(:,:) !num tendency due to Bergeron process + real(r8), allocatable :: fhtimn(:,:) !num tendency due to immersion freezing + real(r8), allocatable :: fhtctn(:,:) !num tendency due to contact freezing + real(r8), allocatable :: fhmln (:,:) !num tendency due to homogeneous freezing + real(r8), allocatable :: accsln(:,:) !num tendency due to accretion of droplets by snow + real(r8), allocatable :: activn(:,:) !num tendency due to droplets activation + real(r8), allocatable :: dlfn (:,:) !num tendency due to detrainment of droplet + real(r8), allocatable :: autoim(:,:) !mass tendency due to autoconversion of cloud ice to snow + real(r8), allocatable :: accsim(:,:) !mass tendency due to accretion of cloud ice by snow + real(r8), allocatable :: difm (:,:) !mass tendency due to detrainment of cloud ice + real(r8), allocatable :: nuclin(:,:) !num tendency due to ice nucleation + real(r8), allocatable :: autoin(:,:) !num tendency due to autoconversion of cloud ice to snow + real(r8), allocatable :: accsin(:,:) !num tendency due to accretion of cloud ice by snow + real(r8), allocatable :: hmpin (:,:) !num tendency due to HM process + real(r8), allocatable :: difn (:,:) !num tendency due to detrainment of cloud ice + real(r8), allocatable :: cmel (:,:) !mass tendency due to condensation + real(r8), allocatable :: cmei (:,:) !mass tendency due to deposition + real(r8), allocatable :: trspcm(:,:) !LWC tendency due to convective transport + real(r8), allocatable :: trspcn(:,:) !droplet num tendency due to convective transport + real(r8), allocatable :: trspim(:,:) !IWC tendency due to convective transport + real(r8), allocatable :: trspin(:,:) !ice crystal num tendency due to convective transport + real(r8), allocatable :: dcape(:) ! CAPE change due to freezing heating + real(r8), allocatable :: lambdadpcu(:,:)! slope of cloud liquid size distr + real(r8), allocatable :: mudpcu(:,:) ! width parameter of droplet size distr + real(r8), allocatable :: di(:,:) + real(r8), allocatable :: dnl(:,:) + real(r8), allocatable :: dni(:,:) + real(r8), allocatable :: qide(:,:) ! cloud ice mixing ratio for detrainment (kg/kg) + real(r8), allocatable :: qncde(:,:) ! cloud water number concentration for detrainment (1/kg) + real(r8), allocatable :: qnide(:,:) ! cloud ice number concentration for detrainment (1/kg) + + +end type zm_conv_t + +real(r8), parameter :: dcon = 25.e-6_r8 +real(r8), parameter :: mucon = 5.3_r8 +real(r8), parameter :: lambdadpcu = (mucon + 1._r8)/dcon + +!=============================================================================== +contains +!=============================================================================== + +subroutine zm_mphyi + +!----------------------------------------------------------------------- +! +! Purpose: +! initialize constants for the cumulus microphysics +! called from zm_conv_init() in zm_conv_intr.F90 +! +! Author: Xialiang Song, June 2010 +! +!----------------------------------------------------------------------- + +!NOTE: +! latent heats should probably be fixed with temperature +! for energy conservation with the rest of the model +! (this looks like a +/- 3 or 4% effect, but will mess up energy balance) + + xlf = latice ! latent heat freezing + +! from microconstants + +! parameters below from Reisner et al. (1998) +! density parameters (kg/m3) + + rhosn = 100._r8 ! bulk density snow + rhoi = 500._r8 ! bulk density ice + rhow = 1000._r8 ! bulk density liquid + +! fall speed parameters, V = aD^b +! V is in m/s + +! droplets + ac = 3.e7_r8 + bc = 2._r8 + +! snow + as = 11.72_r8 + bs = 0.41_r8 + +! cloud ice + ai = 700._r8 + bi = 1._r8 + +! rain + ar = 841.99667_r8 + br = 0.8_r8 + +! particle mass-diameter relationship +! currently we assume spherical particles for cloud ice/snow +! m = cD^d + + pi= 3.14159265358979323846_r8 + +! cloud ice mass-diameter relationship + + ci = rhoi*pi/6._r8 + di = 3._r8 + +! snow mass-diameter relationship + + cs = rhosn*pi/6._r8 + ds = 3._r8 + +! drop mass-diameter relationship + + cr = rhow*pi/6._r8 + dr = 3._r8 + +! collection efficiency, aggregation of cloud ice and snow + + Eii = 0.1_r8 + +! collection efficiency, accretion of cloud water by rain + + Ecr = 1.0_r8 + +! autoconversion size threshold for cloud ice to snow (m) + + Dcs = 150.e-6_r8 +! immersion freezing parameters, bigg 1953 + + bimm = 100._r8 + aimm = 0.66_r8 + +! typical air density at 850 mb + + rhosu = 85000._r8/(rair * tmelt) + +! mass of new crystal due to aerosol freezing and growth (kg) + + mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) + +! radius of contact nuclei aerosol (m) + + rin = 0.1e-6_r8 + +end subroutine zm_mphyi + +!=============================================================================== + +subroutine zm_mphy(su, qu, mu, du, eu, cmel, cmei, zf, pm, te, qe, & + eps0, jb, jt, jlcl, msg, il2g, grav, cp, rd, aero, gamhat, & + qc, qi, nc, ni, qcde, qide, ncde, nide, rprd, sprd, frz, & + wu, qr, qni, nr, ns, autolm, accrlm, bergnm, fhtimm, fhtctm, & + fhmlm, hmpim, accslm, dlfm, autoln, accrln, bergnn, fhtimn, fhtctn, & + fhmln, accsln, activn, dlfn, autoim, accsim, difm, nuclin, autoin, & + accsin, hmpin, difn, trspcm, trspcn, trspim, trspin, lamc, pgam ) + + +! Purpose: +! microphysic parameterization for Zhang-McFarlane convection scheme +! called from cldprp() in zm_conv.F90 +! +! Author: Xialiang Song, June 2010 + + use time_manager, only: get_step_size + +! variable declarations + + implicit none + +! input variables + real(r8), intent(in) :: su(pcols,pver) ! normalized dry stat energy of updraft + real(r8), intent(in) :: qu(pcols,pver) ! spec hum of updraft + real(r8), intent(in) :: mu(pcols,pver) ! updraft mass flux + real(r8), intent(in) :: du(pcols,pver) ! detrainement rate of updraft + real(r8), intent(in) :: eu(pcols,pver) ! entrainment rate of updraft + real(r8), intent(in) :: cmel(pcols,pver) ! condensation rate of updraft + real(r8), intent(in) :: cmei(pcols,pver) ! condensation rate of updraft + real(r8), intent(in) :: zf(pcols,pverp) ! height of interfaces + real(r8), intent(in) :: pm(pcols,pver) ! pressure of env + real(r8), intent(in) :: te(pcols,pver) ! temp of env + real(r8), intent(in) :: qe(pcols,pver) ! spec. humidity of env + real(r8), intent(in) :: eps0(pcols) + real(r8), intent(in) :: gamhat(pcols,pver) ! gamma=L/cp(dq*/dT) at interface + + integer, intent(in) :: jb(pcols) ! updraft base level + integer, intent(in) :: jt(pcols) ! updraft plume top + integer, intent(in) :: jlcl(pcols) ! updraft lifting cond level + integer, intent(in) :: msg ! missing moisture vals + integer, intent(in) :: il2g ! number of columns in gathered arrays + + type(zm_aero_t), intent(in) :: aero ! aerosol object + + real(r8) grav ! gravity + real(r8) cp ! heat capacity of dry air + real(r8) rd ! gas constant for dry air + +! output variables + real(r8), intent(out) :: qc(pcols,pver) ! cloud water mixing ratio (kg/kg) + real(r8), intent(out) :: qi(pcols,pver) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(out) :: nc(pcols,pver) ! cloud water number conc (1/kg) + real(r8), intent(out) :: ni(pcols,pver) ! cloud ice number conc (1/kg) + real(r8), intent(out) :: qcde(pcols,pver) ! cloud water mixing ratio for detrainment(kg/kg) + real(r8), intent(out) :: qide(pcols,pver) ! cloud ice mixing ratio for detrainment (kg/kg) + real(r8), intent(out) :: ncde(pcols,pver) ! cloud water number conc for detrainment (1/kg) + real(r8), intent(out) :: nide(pcols,pver) ! cloud ice number conc for detrainment (1/kg) + real(r8), intent(out) :: wu(pcols,pver) + real(r8), intent(out) :: qni(pcols,pver) ! snow mixing ratio + real(r8), intent(out) :: qr(pcols,pver) ! rain mixing ratio + real(r8), intent(out) :: ns(pcols,pver) ! snow number conc + real(r8), intent(out) :: nr(pcols,pver) ! rain number conc + real(r8), intent(out) :: rprd(pcols,pver) ! rate of production of precip at that layer + real(r8), intent(out) :: sprd(pcols,pver) ! rate of production of snow at that layer + real(r8), intent(out) :: frz(pcols,pver) ! rate of freezing + + + real(r8), intent(inout) :: lamc(pcols,pver) ! slope of cloud liquid size distr + real(r8), intent(inout) :: pgam(pcols,pver) ! spectral width parameter of droplet size distr + +! tendency for output + real(r8),intent(out) :: autolm(pcols,pver) !mass tendency due to autoconversion of droplets to rain + real(r8),intent(out) :: accrlm(pcols,pver) !mass tendency due to accretion of droplets by rain + real(r8),intent(out) :: bergnm(pcols,pver) !mass tendency due to Bergeron process + real(r8),intent(out) :: fhtimm(pcols,pver) !mass tendency due to immersion freezing + real(r8),intent(out) :: fhtctm(pcols,pver) !mass tendency due to contact freezing + real(r8),intent(out) :: fhmlm (pcols,pver) !mass tendency due to homogeneous freezing + real(r8),intent(out) :: hmpim (pcols,pver) !mass tendency due to HM process + real(r8),intent(out) :: accslm(pcols,pver) !mass tendency due to accretion of droplets by snow + real(r8),intent(out) :: dlfm (pcols,pver) !mass tendency due to detrainment of droplet + real(r8),intent(out) :: trspcm(pcols,pver) !mass tendency of droplets due to convective transport + + real(r8),intent(out) :: autoln(pcols,pver) !num tendency due to autoconversion of droplets to rain + real(r8),intent(out) :: accrln(pcols,pver) !num tendency due to accretion of droplets by rain + real(r8),intent(out) :: bergnn(pcols,pver) !num tendency due to Bergeron process + real(r8),intent(out) :: fhtimn(pcols,pver) !num tendency due to immersion freezing + real(r8),intent(out) :: fhtctn(pcols,pver) !num tendency due to contact freezing + real(r8),intent(out) :: fhmln (pcols,pver) !num tendency due to homogeneous freezing + real(r8),intent(out) :: accsln(pcols,pver) !num tendency due to accretion of droplets by snow + real(r8),intent(out) :: activn(pcols,pver) !num tendency due to droplets activation + real(r8),intent(out) :: dlfn (pcols,pver) !num tendency due to detrainment of droplet + real(r8),intent(out) :: trspcn(pcols,pver) !num tendency of droplets due to convective transport + + real(r8),intent(out) :: autoim(pcols,pver) !mass tendency due to autoconversion of cloud ice to snow + real(r8),intent(out) :: accsim(pcols,pver) !mass tendency due to accretion of cloud ice by snow + real(r8),intent(out) :: difm (pcols,pver) !mass tendency due to detrainment of cloud ice + real(r8),intent(out) :: trspim(pcols,pver) !mass tendency of ice crystal due to convective transport + + real(r8),intent(out) :: nuclin(pcols,pver) !num tendency due to ice nucleation + real(r8),intent(out) :: autoin(pcols,pver) !num tendency due to autoconversion of cloud ice to snow + real(r8),intent(out) :: accsin(pcols,pver) !num tendency due to accretion of cloud ice by snow + real(r8),intent(out) :: hmpin (pcols,pver) !num tendency due to HM process + real(r8),intent(out) :: difn (pcols,pver) !num tendency due to detrainment of cloud ice + real(r8),intent(out) :: trspin(pcols,pver) !num tendency of ice crystal due to convective transport + +!................................................................................ +! local workspace +! all units mks unless otherwise stated + real(r8) :: deltat ! time step (s) + real(r8) :: omsm ! number near unity for round-off issues + real(r8) :: dum ! temporary dummy variable + real(r8) :: dum1 ! temporary dummy variable + real(r8) :: dum2 ! temporary dummy variable + + real(r8) :: q(pcols,pver) ! water vapor mixing ratio (kg/kg) + real(r8) :: t(pcols,pver) ! temperature (K) + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + real(r8) :: dz(pcols,pver) ! height difference across model vertical level + + real(r8) :: qcic(pcols,pver) ! in-cloud cloud liquid mixing ratio + real(r8) :: qiic(pcols,pver) ! in-cloud cloud ice mixing ratio + real(r8) :: qniic(pcols,pver) ! in-precip snow mixing ratio + real(r8) :: qric(pcols,pver) ! in-precip rain mixing ratio + real(r8) :: ncic(pcols,pver) ! in-cloud droplet number conc + real(r8) :: niic(pcols,pver) ! in-cloud cloud ice number conc + real(r8) :: nsic(pcols,pver) ! in-precip snow number conc + real(r8) :: nric(pcols,pver) ! in-precip rain number conc + + real(r8) :: lami(pver) ! slope of cloud ice size distr + real(r8) :: n0i(pver) ! intercept of cloud ice size distr + real(r8) :: n0c(pver) ! intercept of cloud liquid size distr + real(r8) :: lams(pver) ! slope of snow size distr + real(r8) :: n0s(pver) ! intercept of snow size distr + real(r8) :: lamr(pver) ! slope of rain size distr + real(r8) :: n0r(pver) ! intercept of rain size distr + real(r8) :: cdist1(pver) ! size distr parameter to calculate droplet freezing + real(r8) :: lammax ! maximum allowed slope of size distr + real(r8) :: lammin ! minimum allowed slope of size distr + + real(r8) :: mnuccc(pver) ! mixing ratio tendency due to freezing of cloud water + real(r8) :: nnuccc(pver) ! number conc tendency due to freezing of cloud water + real(r8) :: mnucct(pver) ! mixing ratio tendency due to contact freezing of cloud water + real(r8) :: nnucct(pver) ! number conc tendency due to contact freezing of cloud water + real(r8) :: msacwi(pver) ! mixing ratio tendency due to HM ice multiplication + real(r8) :: nsacwi(pver) ! number conc tendency due to HM ice multiplication + real(r8) :: prf(pver) ! mixing ratio tendency due to fallout of rain + real(r8) :: psf(pver) ! mixing ratio tendency due to fallout of snow + real(r8) :: pnrf(pver) ! number conc tendency due to fallout of rain + real(r8) :: pnsf(pver) ! number conc tendency due to fallout of snow + real(r8) :: prc(pver) ! mixing ratio tendency due to autoconversion of cloud droplets + real(r8) :: nprc(pver) ! number conc tendency due to autoconversion of cloud droplets + real(r8) :: nprc1(pver) ! qr tendency due to autoconversion of cloud droplets + real(r8) :: nsagg(pver) ! ns tendency due to self-aggregation of snow + real(r8) :: dc0 ! mean size droplet size distr + real(r8) :: ds0 ! mean size snow size distr (area weighted) + real(r8) :: eci ! collection efficiency for riming of snow by droplets + real(r8) :: dv(pcols,pver) ! diffusivity of water vapor in air + real(r8) :: mua(pcols,pver) ! viscocity of air + real(r8) :: psacws(pver) ! mixing rat tendency due to collection of droplets by snow + real(r8) :: npsacws(pver) ! number conc tendency due to collection of droplets by snow + real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow + real(r8) :: npracs(pver) ! number conc tendency due to collection of rain by snow + real(r8) :: mnuccr(pver) ! mixing rat tendency due to freezing of rain + real(r8) :: nnuccr(pver) ! number conc tendency due to freezing of rain + real(r8) :: pra(pver) ! mixing rat tendnency due to accretion of droplets by rain + real(r8) :: npra(pver) ! nc tendnency due to accretion of droplets by rain + real(r8) :: nragg(pver) ! nr tendency due to self-collection of rain + real(r8) :: prci(pver) ! mixing rat tendency due to autoconversion of cloud ice to snow + real(r8) :: nprci(pver) ! number conc tendency due to autoconversion of cloud ice to snow + real(r8) :: prai(pver) ! mixing rat tendency due to accretion of cloud ice by snow + real(r8) :: nprai(pver) ! number conc tendency due to accretion of cloud ice by snow + real(r8) :: prb(pver) ! rain mixing rat tendency due to Bergeron process + real(r8) :: nprb(pver) ! number conc tendency due to Bergeron process + real(r8) :: fhmrm (pcols,pver) !mass tendency due to homogeneous freezing of rain + +! fall speed + real(r8) :: arn(pcols,pver) ! air density corrected rain fallspeed parameter + real(r8) :: asn(pcols,pver) ! air density corrected snow fallspeed parameter + real(r8) :: acn(pcols,pver) ! air density corrected cloud droplet fallspeed parameter + real(r8) :: ain(pcols,pver) ! air density corrected cloud ice fallspeed parameter + real(r8) :: uns(pver) ! number-weighted snow fallspeed + real(r8) :: ums(pver) ! mass-weighted snow fallspeed + real(r8) :: unr(pver) ! number-weighted rain fallspeed + real(r8) :: umr(pver) ! mass-weighted rain fallspeed + +! conservation check + real(r8) :: qce ! dummy qc for conservation check + real(r8) :: qie ! dummy qi for conservation check + real(r8) :: nce ! dummy nc for conservation check + real(r8) :: nie ! dummy ni for conservation check + real(r8) :: qre ! dummy qr for conservation check + real(r8) :: nre ! dummy nr for conservation check + real(r8) :: qnie ! dummy qni for conservation check + real(r8) :: nse ! dummy ns for conservation check + real(r8) :: ratio ! parameter for conservation check + +! sum of source/sink terms for cloud hydrometeor + real(r8) :: qctend(pcols,pver) ! microphysical tendency qc (1/s) + real(r8) :: qitend(pcols,pver) ! microphysical tendency qi (1/s) + real(r8) :: nctend(pcols,pver) ! microphysical tendency nc (1/(kg*s)) + real(r8) :: nitend(pcols,pver) ! microphysical tendency ni (1/(kg*s)) + real(r8) :: qnitend(pcols,pver) ! snow mixing ratio source/sink term + real(r8) :: nstend(pcols,pver) ! snow number concentration source/sink term + real(r8) :: qrtend(pcols,pver) ! rain mixing ratio source/sink term + real(r8) :: nrtend(pcols,pver) ! rain number concentration source/sink term + +! terms for Bergeron process + real(r8) :: bergtsf !bergeron timescale to remove all liquid + real(r8) :: plevap ! cloud liquid water evaporation rate + +! variables for droplet activation by modal aerosols + real(r8) :: wmix, wmin, wmax, wdiab + real(r8) :: vol, nlsrc + real(r8), allocatable :: vaerosol(:), hygro(:), naermod(:) + real(r8), allocatable :: fn(:) ! number fraction of aerosols activated + real(r8), allocatable :: fm(:) ! mass fraction of aerosols activated + real(r8), allocatable :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), allocatable :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + real(r8) :: dmc + real(r8) :: ssmc + real(r8) :: dgnum_aitken + +! bulk aerosol variables + real(r8), allocatable :: naer2(:,:,:) ! new aerosol number concentration (/m3) + real(r8), allocatable :: naer2h(:,:,:) ! new aerosol number concentration (/m3) + real(r8), allocatable :: maerosol(:) ! aerosol mass conc (kg/m3) + real(r8) :: so4_num + real(r8) :: soot_num + real(r8) :: dst1_num + real(r8) :: dst2_num + real(r8) :: dst3_num + real(r8) :: dst4_num + real(r8) :: dst_num + +! droplet activation + logical :: in_cloud ! true when above cloud base layer (k > jb) + real(r8) :: smax_f ! droplet and rain size distr factor used in the + ! in-cloud smax calculation + real(r8) :: dum2l(pcols,pver) ! number conc of CCN (1/kg) + real(r8) :: npccn(pver) ! droplet activation rate + real(r8) :: ncmax + real(r8) :: mtimec ! factor to account for droplet activation timescale + +! ice nucleation + real(r8) :: dum2i(pcols,pver) ! number conc of ice nuclei available (1/kg) + real(r8) :: qs(pcols,pver) ! liquid-ice weighted sat mixing rat (kg/kg) + real(r8) :: es(pcols,pver) ! sat vapor press (pa) over water + real(r8) :: relhum(pcols,pver) ! relative humidity + real(r8) :: esi(pcols,pver) ! sat vapor press (pa) over ice + real(r8) :: nnuccd(pver) ! ice nucleation rate from deposition/cond.-freezing + real(r8) :: mnuccd(pver) ! mass tendency from ice nucleation + real(r8) :: mtime ! factor to account for ice nucleation timescale + +! output for ice nucleation + real(r8) :: nimey(pcols,pver) !number conc of ice nuclei due to meyers deposition (1/m3) + real(r8) :: nihf(pcols,pver) !number conc of ice nuclei due to heterogenous freezing (1/m3) + real(r8) :: nidep(pcols,pver) !number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) + real(r8) :: niimm(pcols,pver) !number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) + + real(r8) :: wpice, weff, fhom ! unused dummies + +! loop array variables + integer i,k, n, l + integer ii,kk, m + +! loop variables for iteration solution + integer iter,it,ltrue(pcols) + +! used in contact freezing via dust particles + real(r8) tcnt, viscosity, mfp + real(r8) slip1, slip2, slip3, slip4 + real(r8) dfaer1, dfaer2, dfaer3, dfaer4 + real(r8) nacon1,nacon2,nacon3,nacon4 + +! used in immersion freezing via soot + real(r8) ttend(pver) + real(r8) naimm + real(r8) :: ntaer(pcols,pver) + real(r8) :: ntaerh(pcols,pver) + +! used in homogeneous freezing + real(r8) :: fholm (pcols,pver) !mass tendency due to homogeneous freezing + real(r8) :: fholn (pcols,pver) !number conc tendency due to homogeneous freezing + +! used in secondary ice production + real(r8) ni_secp + +! used in vertical velocity calculation + real(r8) th(pcols,pver) + real(r8) qh(pcols,pver) + real(r8) zkine(pcols,pver) + real(r8) zbuo(pcols,pver) + real(r8) zfacbuo, cwdrag, cwifrac, retv, zbuoc + real(r8) zbc, zbe, zdkbuo, zdken + real(r8) arcf(pcols,pver) + real(r8) p(pcols,pver) + real(r8) ph(pcols,pver) + +! used in vertical integreation + logical qcimp(pver) ! true to solve qc with implicit formula + logical ncimp(pver) ! true to solve nc with implicit formula + logical qiimp(pver) ! true to solve qi with implicit formula + logical niimp(pver) ! true to solve ni with implicit formula + +! tendency due to adjustment + real(r8) :: ncadj(pcols,pver) !droplet num tendency due to adjustment + real(r8) :: niadj(pcols,pver) !ice crystal num tendency due to adjustment + real(r8) :: ncorg, niorg, total + + real(r8) :: rhoh(pcols,pver) ! air density (kg m-3) at interface + real(r8) :: rhom(pcols,pver) ! air density (kg m-3) at mid-level + real(r8) :: tu(pcols,pver) ! temperature in updraft (K) + + integer kqi(pcols),kqc(pcols) + logical lcbase(pcols), libase(pcols) + + real(r8) :: nai_bcphi, nai_dst1, nai_dst2, nai_dst3, nai_dst4 + + real(r8) flxrm, mvtrm, flxrn, mvtrn, flxsm, mvtsm, flxsn, mvtsn + integer nlr, nls + + real(r8) rmean, beta6, beta66, r6, r6c + real(r8) temp1, temp2, temp3, temp4 ! variable to store output which is not required by this routine + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! initialization +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + if (aero%scheme == 'modal') then + + allocate(vaerosol(aero%nmodes), hygro(aero%nmodes), naermod(aero%nmodes), & + fn(aero%nmodes), fm(aero%nmodes), fluxn(aero%nmodes), fluxm(aero%nmodes)) + + else if (aero%scheme == 'bulk') then + + allocate( & + naer2(pcols,pver,aero%nbulk), & + naer2h(pcols,pver,aero%nbulk), & + maerosol(aero%nbulk)) + + end if + + deltat= get_step_size() !for FV dynamical core + + ! parameters for scheme + omsm=0.99999_r8 + zfacbuo = 0.5_r8/(1._r8+0.5_r8) + cwdrag = 1.875_r8*0.506_r8 + cwifrac = 0.5_r8 + retv = 0.608_r8 + bergtsf = 1800._r8 + + ! initialize multi-level fields + do i=1,il2g + do k=1,pver + q(i,k) = qu(i,k) + tu(i,k)= su(i,k) - grav/cp*zf(i,k) + t(i,k) = su(i,k) - grav/cp*zf(i,k) + p(i,k) = 100._r8*pm(i,k) + wu(i,k) = 0._r8 + zkine(i,k)= 0._r8 + arcf(i,k) = 0._r8 + zbuo(i,k) = 0._r8 + nc(i,k) = 0._r8 + ni(i,k) = 0._r8 + qc(i,k) = 0._r8 + qi(i,k) = 0._r8 + ncde(i,k) = 0._r8 + nide(i,k) = 0._r8 + qcde(i,k) = 0._r8 + qide(i,k) = 0._r8 + rprd(i,k) = 0._r8 + sprd(i,k) = 0._r8 + frz(i,k) = 0._r8 + qcic(i,k) = 0._r8 + qiic(i,k) = 0._r8 + ncic(i,k) = 0._r8 + niic(i,k) = 0._r8 + qr(i,k) = 0._r8 + qni(i,k) = 0._r8 + nr(i,k) = 0._r8 + ns(i,k) = 0._r8 + qric(i,k) = 0._r8 + qniic(i,k) = 0._r8 + nric(i,k) = 0._r8 + nsic(i,k) = 0._r8 + nimey(i,k) = 0._r8 + nihf(i,k) = 0._r8 + nidep(i,k) = 0._r8 + niimm(i,k) = 0._r8 + fhmrm(i,k) = 0._r8 + + autolm(i,k) = 0._r8 + accrlm(i,k) = 0._r8 + bergnm(i,k) = 0._r8 + fhtimm(i,k) = 0._r8 + fhtctm(i,k) = 0._r8 + fhmlm (i,k) = 0._r8 + fholm (i,k) = 0._r8 + hmpim (i,k) = 0._r8 + accslm(i,k) = 0._r8 + dlfm (i,k) = 0._r8 + + autoln(i,k) = 0._r8 + accrln(i,k) = 0._r8 + bergnn(i,k) = 0._r8 + fhtimn(i,k) = 0._r8 + fhtctn(i,k) = 0._r8 + fhmln (i,k) = 0._r8 + fholn (i,k) = 0._r8 + accsln(i,k) = 0._r8 + activn(i,k) = 0._r8 + dlfn (i,k) = 0._r8 + + autoim(i,k) = 0._r8 + accsim(i,k) = 0._r8 + difm (i,k) = 0._r8 + + nuclin(i,k) = 0._r8 + autoin(i,k) = 0._r8 + accsin(i,k) = 0._r8 + hmpin (i,k) = 0._r8 + difn (i,k) = 0._r8 + + trspcm(i,k) = 0._r8 + trspcn(i,k) = 0._r8 + trspim(i,k) = 0._r8 + trspin(i,k) = 0._r8 + + ncadj (i,k) = 0._r8 + niadj (i,k) = 0._r8 + end do + end do + + ! initialize time-varying parameters + do k=1,pver + do i=1,il2g + if (k .eq.1) then + rhoh(i,k) = p(i,k)/(t(i,k)*rd) + rhom(i,k) = p(i,k)/(t(i,k)*rd) + th (i,k) = te(i,k) + qh (i,k) = qe(i,k) + dz (i,k) = zf(i,k) - zf(i,k+1) + ph(i,k) = p(i,k) + else + rhoh(i,k) = 0.5_r8*(p(i,k)+p(i,k-1))/(t(i,k)*rd) + if (k .eq. pver) then + rhom(i,k) = p(i,k)/(rd*t(i,k)) + else + rhom(i,k) = 2.0_r8*p(i,k)/(rd*(t(i,k)+t(i,k+1))) + end if + th (i,k) = 0.5_r8*(te(i,k)+te(i,k-1)) + qh (i,k) = 0.5_r8*(qe(i,k)+qe(i,k-1)) + dz(i,k) = zf(i,k-1) - zf(i,k) + ph(i,k) = 0.5_r8*(p(i,k) + p(i,k-1)) + end if + dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/ph(i,k) + mua(i,k) = 1.496E-6_r8*t(i,k)**1.5_r8/ & + (t(i,k)+120._r8) + + rho(i,k) = rhoh(i,k) + + ! air density adjustment for fallspeed parameters + ! add air density correction factor to the power of + ! 0.54 following Heymsfield and Bansemer 2006 + + arn(i,k)=ar*(rhosu/rho(i,k))**0.54_r8 + asn(i,k)=as*(rhosu/rho(i,k))**0.54_r8 + acn(i,k)=ac*(rhosu/rho(i,k))**0.54_r8 + ain(i,k)=ai*(rhosu/rho(i,k))**0.54_r8 + + end do + end do + + if (aero%scheme == 'modal') then + + wmix = 0._r8 + wmin = 0._r8 + wmax = 10._r8 + wdiab = 0._r8 + + do k=1,pver + do i=1,il2g + dum2l(i,k)=0._r8 + dum2i(i,k)=0._r8 + ntaer(i,k) = 0.0_r8 + ntaerh(i,k) = 0.0_r8 + do m = 1, aero%nmodes + ntaer(i,k) = ntaer(i,k) + aero%numg_a(i,k,m)*rhom(i,k) + enddo + end do + end do + + else if (aero%scheme == 'bulk') then + + ! initialize aerosol number + do k=1,pver + do i=1,il2g + naer2(i,k,:)=0._r8 + naer2h(i,k,:)=0._r8 + dum2l(i,k)=0._r8 + dum2i(i,k)=0._r8 + end do + end do + + do k=1,pver + do i=1,il2g + ntaer(i,k) = 0.0_r8 + ntaerh(i,k) = 0.0_r8 + do m = 1, aero%nbulk + maerosol(m) = aero%mmrg_bulk(i,k,m)*rhom(i,k) + + ! set number nucleated for sulfate based on Lohmann et al. 2000 (JGR) Eq.2 + ! Na=340.*(massSO4)^0.58 where Na=cm-3 and massSO4=ug/m3 + ! convert units to Na [m-3] and SO4 [kgm-3] + ! Na(m-3)= 1.e6 cm3 m-3 Na(cm-3)=340. *(massSO4[kg/m3]*1.e9ug/kg)^0.58 + ! or Na(m-3)= 1.e6* 340.*(1.e9ug/kg)^0.58 * (massSO4[kg/m3])^0.58 + + if (m .eq. aero%idxsul) then + naer2(i,k,m)= 5.64259e13_r8 * maerosol(m)**0.58_r8 + else + naer2(i,k,m)=maerosol(m)*aero%num_to_mass_aer(m) + end if + ntaer(i,k) = ntaer(i,k) + naer2(i,k,m) + end do + end do + end do + + end if + + do i=1,il2g + ltrue(i)=0 + do k=1,pver + if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall.or.cmel(i,k).ge.qsmall.or.cmei(i,k).ge.qsmall) ltrue(i)=1 + end do + end do + + ! skip microphysical calculations if no cloud water + do i=1,il2g + if (ltrue(i).eq.0) then + do k=1,pver + qctend(i,k)=0._r8 + qitend(i,k)=0._r8 + qnitend(i,k)=0._r8 + qrtend(i,k)=0._r8 + nctend(i,k)=0._r8 + nitend(i,k)=0._r8 + nrtend(i,k)=0._r8 + nstend(i,k)=0._r8 + qniic(i,k)=0._r8 + qric(i,k)=0._r8 + nsic(i,k)=0._r8 + nric(i,k)=0._r8 + qni(i,k)=0._r8 + qr(i,k)=0._r8 + ns(i,k)=0._r8 + nr(i,k)=0._r8 + qc(i,k) = 0._r8 + qi(i,k) = 0._r8 + nc(i,k) = 0._r8 + ni(i,k) = 0._r8 + qcde(i,k) = 0._r8 + qide(i,k) = 0._r8 + ncde(i,k) = 0._r8 + nide(i,k) = 0._r8 + rprd(i,k) = 0._r8 + sprd(i,k) = 0._r8 + frz(i,k) = 0._r8 + end do + goto 300 + end if + + kqc(i) = 1 + kqi(i) = 1 + lcbase(i) = .true. + libase(i) = .true. + + ! assign number of steps for iteration + ! use 2 steps following Song and Zhang, 2011, J. Clim. + iter = 2 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! iteration + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + do it=1,iter + + ! initialize sub-step microphysical tendencies + do k=1,pver + qctend(i,k)=0._r8 + qitend(i,k)=0._r8 + qnitend(i,k)=0._r8 + qrtend(i,k)=0._r8 + nctend(i,k)=0._r8 + nitend(i,k)=0._r8 + nrtend(i,k)=0._r8 + nstend(i,k)=0._r8 + rprd(i,k) = 0._r8 + sprd(i,k) = 0._r8 + frz(i,k) = 0._r8 + qniic(i,k)=0._r8 + qric(i,k)=0._r8 + nsic(i,k)=0._r8 + nric(i,k)=0._r8 + qiic(i,k)=0._r8 + qcic(i,k)=0._r8 + niic(i,k)=0._r8 + ncic(i,k)=0._r8 + qcimp(k) = .false. + ncimp(k) = .false. + qiimp(k) = .false. + niimp(k) = .false. + dum2l(i,k)=0._r8 + dum2i(i,k)=0._r8 + autolm(i,k) = 0._r8 + accrlm(i,k) = 0._r8 + bergnm(i,k) = 0._r8 + fhtimm(i,k) = 0._r8 + fhtctm(i,k) = 0._r8 + fhmlm (i,k) = 0._r8 + fholm (i,k) = 0._r8 + hmpim (i,k) = 0._r8 + accslm(i,k) = 0._r8 + dlfm (i,k) = 0._r8 + + autoln(i,k) = 0._r8 + accrln(i,k) = 0._r8 + bergnn(i,k) = 0._r8 + fhtimn(i,k) = 0._r8 + fhtctn(i,k) = 0._r8 + fhmln (i,k) = 0._r8 + fholn (i,k) = 0._r8 + accsln(i,k) = 0._r8 + activn(i,k) = 0._r8 + dlfn (i,k) = 0._r8 + ncadj (i,k) = 0._r8 + + autoim(i,k) = 0._r8 + accsim(i,k) = 0._r8 + difm (i,k) = 0._r8 + + nuclin(i,k) = 0._r8 + autoin(i,k) = 0._r8 + accsin(i,k) = 0._r8 + hmpin (i,k) = 0._r8 + difn (i,k) = 0._r8 + niadj (i,k) = 0._r8 + + trspcm(i,k) = 0._r8 + trspcn(i,k) = 0._r8 + trspim(i,k) = 0._r8 + trspin(i,k) = 0._r8 + + fhmrm (i,k) = 0._r8 + end do + + do k = pver,msg+2,-1 + + if (k > jt(i) .and. k <= jb(i) .and. eps0(i) > 0._r8 & + .and.mu(i,k).gt.0._r8 .and. mu(i,k-1).gt.0._r8) then + + ! initialize precip fallspeeds to zero + if (it.eq.1) then + ums(k)=0._r8 + uns(k)=0._r8 + umr(k)=0._r8 + unr(k)=0._r8 + prf(k)=0._r8 + pnrf(k)=0._r8 + psf(k) =0._r8 + pnsf(k) = 0._r8 + end if + ttend(k)=0._r8 + nnuccd(k)=0._r8 + npccn(k)=0._r8 + + !************************************************************************************ + ! obtain values of cloud water/ice mixing ratios and number concentrations in updraft + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + !************************************************************************************ + + + if (it.eq.1) then + qcic(i,k) = qc(i,k) + qiic(i,k) = qi(i,k) + ncic(i,k) = nc(i,k) + niic(i,k) = ni(i,k) + qniic(i,k)= qni(i,k) + qric(i,k) = qr(i,k) + nsic(i,k) = ns(i,k) + nric(i,k) = nr(i,k) + else + if (k.le.kqc(i)) then + qcic(i,k) = qc(i,k) + ncic(i,k) = nc(i,k) + + ! consider rain falling from above + flxrm = 0._r8 + mvtrm = 0._r8 + flxrn = 0._r8 + mvtrn = 0._r8 + nlr = 0 + + do kk= k,jt(i)+3,-1 + if (qr(i,kk-1) .gt. 0._r8) then + nlr = nlr + 1 + flxrm = flxrm + umr(kk-1)*qr(i,kk-1)*arcf(i,kk-1) + flxrn = flxrn + unr(kk-1)*nr(i,kk-1)*arcf(i,kk-1) + mvtrm = mvtrm + umr(kk-1)*arcf(i,kk-1) + mvtrn = mvtrn + unr(kk-1)*arcf(i,kk-1) + end if + end do + if (mvtrm.gt.0) then + qric(i,k) = (qr(i,k)*mu(i,k)+flxrm)/(mu(i,k)+mvtrm) + else + qric(i,k) = qr(i,k) + end if + if (mvtrn.gt.0) then + nric(i,k) = (nr(i,k)*mu(i,k)+flxrn)/(mu(i,k)+mvtrn) + else + nric(i,k) = nr(i,k) + end if + + end if + if (k.eq.kqc(i)) then + qcic(i,k) = qc(i,k-1) + ncic(i,k) = nc(i,k-1) + end if + if(k.le.kqi(i)) then + qiic(i,k) = qi(i,k) + niic(i,k) = ni(i,k) +! consider snow falling from above + flxsm = 0._r8 + mvtsm = 0._r8 + flxsn = 0._r8 + mvtsn = 0._r8 + nls = 0 + + do kk= k,jt(i)+3,-1 + if (qni(i,kk-1) .gt. 0._r8) then + nls = nls + 1 + flxsm = flxsm + ums(kk-1)*qni(i,kk-1)*arcf(i,kk-1) + mvtsm = mvtsm + ums(kk-1)*arcf(i,kk-1) + flxsn = flxsn + uns(kk-1)*ns(i,kk-1)*arcf(i,kk-1) + mvtsn = mvtsn + uns(kk-1)*arcf(i,kk-1) + end if + end do + + if (mvtsm.gt.0) then + qniic(i,k) = (qni(i,k)*mu(i,k)+flxsm)/(mu(i,k)+mvtsm) + else + qniic(i,k) = qni(i,k) + end if + if (mvtsn.gt.0) then + nsic(i,k) = (ns(i,k)*mu(i,k)+flxsn)/(mu(i,k)+mvtsn) + else + nsic(i,k) = ns(i,k) + end if + end if + if(k.eq.kqi(i)) then + qiic(i,k) = qi(i,k-1) + niic(i,k) = ni(i,k-1) + end if + end if + + !********************************************************************** + ! boundary condition for cloud liquid water and cloud ice + !*********************************************************************** + + ! boundary condition for provisional cloud water + if (cmel(i,k-1).gt.qsmall .and. lcbase(i) .and. it.eq.1 ) then + kqc(i) = k + lcbase(i) = .false. + qcic(i,k) = dz(i,k)*cmel(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) + ncic(i,k) = qcic(i,k)/(4._r8/3._r8*pi*10.e-6_r8**3*rhow) + end if + + ! boundary condition for provisional cloud ice + if (qiic(i,k).gt.qsmall .and. libase(i) .and. it.eq.1 ) then + kqi(i) = k + libase(i) = .false. + else if ( cmei(i,k-1).gt.qsmall .and. & + cmei(i,k).lt.qsmall .and. k.le.jb(i) .and. libase(i) .and. it.eq.1 ) then + kqi(i)=k + libase(i) = .false. + qiic(i,k) = dz(i,k)*cmei(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) + niic(i,k) = qiic(i,k)/(4._r8/3._r8*pi*25.e-6_r8**3*rhoi) + end if + + !*************************************************************************** + ! get size distribution parameters based on in-cloud cloud water/ice + ! these calculations also ensure consistency between number and mixing ratio + !*************************************************************************** + ! cloud ice + if (qiic(i,k).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + niic(i,k)=min(niic(i,k),qiic(i,k)*1.e20_r8) + lami(k) = (gamma(1._r8+di)*ci* & + niic(i,k)/qiic(i,k))**(1._r8/di) + n0i(k) = niic(i,k)*lami(k) + + ! check for slope + lammax = 1._r8/10.e-6_r8 + lammin = 1._r8/(2._r8*dcs) + + ! adjust vars + if (lami(k).lt.lammin) then + lami(k) = lammin + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) + niic(i,k) = n0i(k)/lami(k) + else if (lami(k).gt.lammax) then + lami(k) = lammax + n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) + niic(i,k) = n0i(k)/lami(k) + end if + else + lami(k) = 0._r8 + n0i(k) = 0._r8 + end if + + ! cloud water + if (qcic(i,k).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + ncic(i,k)=min(ncic(i,k),qcic(i,k)*1.e20_r8) + + ! get pgam from fit to observations of martin et al. 1994 + + pgam(i,k)=0.0005714_r8*(ncic(i,k)/1.e6_r8/rho(i,k))+0.2714_r8 + pgam(i,k)=1._r8/(pgam(i,k)**2)-1._r8 + pgam(i,k)=max(pgam(i,k),2._r8) + pgam(i,k)=min(pgam(i,k),15._r8) + + ! calculate lamc + lamc(i,k) = (pi/6._r8*rhow*ncic(i,k)*gamma(pgam(i,k)+4._r8)/ & + (qcic(i,k)*gamma(pgam(i,k)+1._r8)))**(1._r8/3._r8) + + ! lammin, 50 micron diameter max mean size + lammin = (pgam(i,k)+1._r8)/40.e-6_r8 + lammax = (pgam(i,k)+1._r8)/1.e-6_r8 + + if (lamc(i,k).lt.lammin) then + lamc(i,k) = lammin + ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & + gamma(pgam(i,k)+1._r8)/ & + (pi*rhow*gamma(pgam(i,k)+4._r8)) + else if (lamc(i,k).gt.lammax) then + lamc(i,k) = lammax + ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & + gamma(pgam(i,k)+1._r8)/ & + (pi*rhow*gamma(pgam(i,k)+4._r8)) + end if + + ! parameter to calculate droplet freezing + + cdist1(k) = ncic(i,k)/gamma(pgam(i,k)+1._r8) + else + lamc(i,k) = 0._r8 + cdist1(k) = 0._r8 + end if + + ! boundary condition for cloud liquid water + if ( kqc(i) .eq. k ) then + qc(i,k) = 0._r8 + nc(i,k) = 0._r8 + end if + + ! boundary condition for cloud ice + if (kqi(i).eq.k ) then + qi(i,k) = 0._r8 + ni(i,k) = 0._r8 + end if + + !************************************************************************** + ! begin micropysical process calculations + !************************************************************************** + + !................................................................. + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000) + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (qcic(i,k).ge.1.e-8_r8) then + + ! nprc is increase in rain number conc due to autoconversion + ! nprc1 is decrease in cloud droplet conc due to autoconversion + ! Khrouditnov and Kogan (2000) +! prc(k) = 1350._r8*qcic(i,k)**2.47_r8* & +! (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8) + + ! Liu and Daum(2004)(modified), Wood(2005) + rmean = 1.e6_r8*((qcic(i,k)/ncic(i,k))/(4._r8/3._r8*pi*rhow))**(1._r8/3._r8) + + if (rmean .ge. 15._r8) then + + beta6 = (1._r8+3._r8/rmean)**(1._r8/3._r8) + beta66 = (1._r8+3._r8/rmean)**2._r8 + r6 = beta6*rmean + r6c = 7.5_r8/(r6**0.5_r8*(qcic(i,k)*rho(i,k))**(1._r8/6._r8)) + prc(k) = 1.3e9_r8*beta66*(qcic(i,k)*rho(i,k))**3._r8/ & + (ncic(i,k)*rho(i,k))*max(0._r8,r6-r6c)/rho(i,k) + + nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k)) + nprc(k) = nprc1(k)*0.5_r8 + else + prc(k)=0._r8 + nprc(k)=0._r8 + nprc1(k)=0._r8 + end if + else + prc(k)=0._r8 + nprc(k)=0._r8 + nprc1(k)=0._r8 + end if + + ! provisional rain mixing ratio and number concentration (qric and nric) + ! at boundary are estimated via autoconversion + + if (k.eq.kqc(i) .and. it.eq.1) then + qric(i,k) = prc(k)*dz(i,k)/0.55_r8 + nric(i,k) = nprc(k)*dz(i,k)/0.55_r8 + qr(i,k) = 0.0_r8 + nr(i,k) = 0.0_r8 + end if + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + call ice_autoconversion(t(i,k), qiic(i,k), lami(k), n0i(k), dcs, prci(k), nprci(k), 1) + + ! provisional snow mixing ratio and number concentration (qniic and nsic) + ! at boundary are estimated via autoconversion + + if (k.eq.kqi(i) .and. it.eq.1) then + qniic(i,k)= prci(k)*dz(i,k)*0.25_r8 + nsic(i,k)= nprci(k)*dz(i,k)*0.25_r8 + qni(i,k)= 0.0_r8 + ns(i,k)= 0.0_r8 + end if + + ! if precip mix ratio is zero so should number concentration + if (qniic(i,k).lt.qsmall) then + qniic(i,k)=0._r8 + nsic(i,k)=0._r8 + end if + if (qric(i,k).lt.qsmall) then + qric(i,k)=0._r8 + nric(i,k)=0._r8 + end if + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + nric(i,k)=max(nric(i,k),0._r8) + nsic(i,k)=max(nsic(i,k),0._r8) + + !********************************************************************** + ! get size distribution parameters for precip + !********************************************************************** + ! rain + + if (qric(i,k).ge.qsmall) then + lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8) + n0r(k) = nric(i,k)*lamr(k) + + ! check for slope + lammax = 1._r8/150.e-6_r8 + lammin = 1._r8/3000.e-6_r8 + + ! adjust vars + if (lamr(k).lt.lammin) then + lamr(k) = lammin + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k).gt.lammax) then + lamr(k) = lammax + n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) + nric(i,k) = n0r(k)/lamr(k) + end if + + ! provisional rain number and mass weighted mean fallspeed (m/s) + ! Eq.18 of Morrison and Gettelman, 2008, J. Climate + unr(k) = min(arn(i,k)*gamma(1._r8+br)/lamr(k)**br,10._r8) + umr(k) = min(arn(i,k)*gamma(4._r8+br)/(6._r8*lamr(k)**br),10._r8) + else + lamr(k) = 0._r8 + n0r(k) = 0._r8 + umr(k) = 0._r8 + unr(k) = 0._r8 + end if + + !...................................................................... + ! snow + if (qniic(i,k).ge.qsmall) then + lams(k) = (gamma(1._r8+ds)*cs*nsic(i,k)/ & + qniic(i,k))**(1._r8/ds) + n0s(k) = nsic(i,k)*lams(k) + + ! check for slope + lammax = 1._r8/10.e-6_r8 + lammin = 1._r8/2000.e-6_r8 + + ! adjust vars + if (lams(k).lt.lammin) then + lams(k) = lammin + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) + nsic(i,k) = n0s(k)/lams(k) + else if (lams(k).gt.lammax) then + lams(k) = lammax + n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) + nsic(i,k) = n0s(k)/lams(k) + end if + + ! provisional snow number and mass weighted mean fallspeed (m/s) + ums(k) = min(asn(i,k)*gamma(4._r8+bs)/(6._r8*lams(k)**bs),3.6_r8) + uns(k) = min(asn(i,k)*gamma(1._r8+bs)/lams(k)**bs,3.6_r8) + else + lams(k) = 0._r8 + n0s(k) = 0._r8 + ums(k) = 0._r8 + uns(k) = 0._r8 + end if + + !....................................................................... + ! snow self-aggregation from passarelli, 1978, used by Reisner(1998,Eq.A.35) + ! this is hard-wired for bs = 0.4 for now + ! ignore self-collection of cloud ice + + call snow_self_aggregation(t(i,k), rho(i,k), asn(i,k), rhosn, qniic(i,k), nsic(i,k), nsagg(k), 1) + + !....................................................................... + ! accretion of cloud droplets onto snow/graupel + ! here use continuous collection equation with + ! simple gravitational collection kernel + ! ignore collisions between droplets/cloud ice + + ! ignore collision of snow with droplets above freezing + + call accrete_cloud_water_snow(t(i,k), rho(i,k), asn(i,k), uns(k), mua(i,k), & + qcic(i,k), ncic(i,k), qniic(i,k), pgam(i,k), lamc(i,k), lams(k), n0s(k), & + psacws(k), npsacws(k), 1) + + ! secondary ice production due to accretion of droplets by snow + ! (Hallet-Mossop process) (from Cotton et al., 1986) + + call secondary_ice_production(t(i,k), psacws(k), msacwi(k), nsacwi(k), 1) + + !....................................................................... + ! accretion of rain water by snow + ! formula from ikawa and saito, 1991, used by reisner et al., 1998 + + call accrete_rain_snow(t(i,k), rho(i,k), umr(k), ums(k), unr(k), uns(k), qric(i,k), & + qniic(i,k), lamr(k), n0r(k), lams(k), n0s(k), pracs(k), npracs(k), 1 ) + + !....................................................................... + ! heterogeneous freezing of rain drops + ! follows from Bigg (1953) + + call heterogeneous_rain_freezing(t(i,k), qric(i,k), nric(i,k), lamr(k), mnuccr(k), nnuccr(k), 1) + + !....................................................................... + ! accretion of cloud liquid water by rain + ! formula from Khrouditnov and Kogan (2000) + ! gravitational collection kernel, droplet fall speed neglected + + call accrete_cloud_water_rain(.true., qric(i,k), qcic(i,k), ncic(i,k), [1._r8], [0._r8], pra(k), npra(k), 1) + + !....................................................................... + ! Self-collection of rain drops + ! from Beheng(1994) + + call self_collection_rain(rho(i,k), qric(i,k), nric(i,k), nragg(k), 1) + + !....................................................................... + ! Accretion of cloud ice by snow + ! For this calculation, it is assumed that the Vs >> Vi + ! and Ds >> Di for continuous collection + + call accrete_cloud_ice_snow(t(i,k), rho(i,k), asn(i,k), qiic(i,k), niic(i,k), & + qniic(i,k), lams(k), n0s(k), prai(k), nprai(k), 1) + + !....................................................................... + ! fallout term + prf(k) = -umr(k)*qric(i,k)/dz(i,k) + pnrf(k) = -unr(k)*nric(i,k)/dz(i,k) + psf(k) = -ums(k)*qniic(i,k)/dz(i,k) + pnsf(k) = -uns(k)*nsic(i,k)/dz(i,k) + + !........................................................................ + ! calculate vertical velocity in cumulus updraft + + if (k.eq.jb(i)) then + zkine(i,jb(i)) = 0.5_r8 + wu (i,jb(i)) = 1._r8 + zbuo (i,jb(i)) = (tu(i,jb(i))*(1._r8+retv*qu(i,jb(i)))- & + th(i,jb(i))*(1._r8+retv*qh(i,jb(i))))/ & + (th(i,jb(i))*(1._r8+retv*qh(i,jb(i)))) + else + if (.true.) then + ! ECMWF formula + zbc = tu(i,k)*(1._r8+retv*qu(i,k)-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k)) + zbe = th(i,k)*(1._r8+retv*qh(i,k)) + zbuo(i,k) = (zbc-zbe)/zbe + zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 + zdkbuo = dz(i,k+1)*grav*zfacbuo*zbuoc + zdken = min(.99_r8,(1._r8+cwdrag)*max(du(i,k),eu(i,k))*dz(i,k+1)/ & + max(1.e-10_r8,mu(i,k+1))) + zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & + (1._r8+zdken) + else + ! Gregory formula + zbc = tu(i,k)*(1._r8+retv*qu(i,k)) + zbe = th(i,k)*(1._r8+retv*qh(i,k)) + zbuo(i,k) = (zbc-zbe)/zbe-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k) + zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 + zdkbuo = dz(i,k+1)*grav*zbuoc*(1.0_r8-0.25_r8)/6._r8 + zdken = du(i,k)*dz(i,k+1)/max(1.e-10_r8,mu(i,k+1)) + zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & + (1._r8+zdken) + end if + wu(i,k) = min(15._r8,sqrt(2._r8*max(0.1_r8,zkine(i,k) ))) + end if + + arcf(i,k)= mu(i,k)/wu(i,k) + + !............................................................................ + ! droplet activation + ! calculate potential for droplet activation if cloud water is present + ! formulation from Abdul-Razzak and Ghan (2000) and Abdul-Razzak et al. (1998), AR98 + + if (aero%scheme == 'bulk') then + naer2h(i,k,:) = 0.5_r8*(naer2(i,k,:) + naer2(i,k-1,:)) + end if + + ntaerh(i,k) = 0.5_r8*(ntaer(i,k) + ntaer(i,k-1)) + + if (qcic(i,k).ge.qsmall ) then + + if (aero%scheme == 'modal') then + + nlsrc = 0._r8 + + do m = 1, aero%nmodes + vaerosol(m) = 0._r8 + hygro(m) = 0._r8 + do l = 1, aero%nspec(m) + vol = max(0.5_r8*(aero%mmrg_a(i,k,l,m)+aero%mmrg_a(i,k-1,l,m)) , 0._r8)/aero%specdens(l,m) + vaerosol(m) = vaerosol(m) + vol + hygro(m) = hygro(m) + vol*aero%spechygro(l,m) + end do + if (vaerosol(m) > 1.0e-30_r8) then + hygro(m) = hygro(m)/(vaerosol(m)) + vaerosol(m) = vaerosol(m)*rho(i,k) + else + hygro(m) = 0.0_r8 + vaerosol(m) = 0.0_r8 + endif + naermod(m) = 0.5_r8*(aero%numg_a(i,k,m)+aero%numg_a(i,k-1,m))*rho(i,k) + naermod(m) = max(naermod(m), vaerosol(m)*aero%voltonumbhi(m)) + naermod(m) = min(naermod(m), vaerosol(m)*aero%voltonumblo(m)) + end do + + in_cloud = (k < jb(i)) + smax_f = 0.0_r8 + if (in_cloud) then + if ( qcic(i,k).ge.qsmall ) & + smax_f = ncic(i,k)/lamc(i,k) * gamma(2.0_r8 + pgam(i,k))/gamma(1.0_r8 + pgam(i,k)) + if ( qric(i,k).ge.qsmall) smax_f = smax_f + nric(i,k)/lamr(k) + + end if + +! call activate_modal( & +! wu(i,k), wmix, wdiab, wmin, wmax, & +! t(i,k), rho(i,k), naermod, aero%nmodes, vaerosol, & +! hygro, fn, fm, & +! fluxn, fluxm, flux_fullact, in_cloud_in=in_cloud, smax_f=smax_f) + + do m = 1, aero%nmodes + nlsrc = nlsrc + fn(m)*naermod(m) ! number nucleated + end do + + if (nlsrc .ne. nlsrc) then + write(iulog,*) "nlsrc=",nlsrc,"wu(i,k)=",wu(i,k) + write(iulog,*) "fn(m)=",fn,"naermod(m)=",naermod,"aero%specdens(l,m)=",aero%specdens + write(iulog,*) "vaerosol(m)=",vaerosol,"aero%voltonumbhi(m)=",aero%voltonumbhi + write(iulog,*) "aero%voltonumblo(m)=",aero%voltonumblo,"k=",k,"i=",i + write(iulog,*) "aero%numg_a(i,k,m)=",aero%numg_a(i,k,:),"rho(i,k)=",rho(i,k) + write(iulog,*) "aero%mmrg_a(i,k,l,m)=",aero%mmrg_a(i,k,:,:) + end if + + dum2l(i,k) = nlsrc + + else if (aero%scheme == 'bulk') then + + call ndrop_bam_run( & + wu(i,k), t(i,k), rho(i,k), naer2h(i,k,:), aero%nbulk, & + aero%nbulk, maerosol, dum2) + + dum2l(i,k) = dum2 + + end if + + else + dum2l(i,k) = 0._r8 + end if + + ! get droplet activation rate + if (qcic(i,k).ge.qsmall .and. t(i,k).gt.238.15_r8 .and. k.gt.jt(i)+2 ) then + + ! assume aerosols already activated are equal number of existing droplets for simplicity + if (k.eq.kqc(i)) then + npccn(k) = dum2l(i,k)/deltat + else + npccn(k) = (dum2l(i,k)-ncic(i,k))/deltat + end if + + ! make sure number activated > 0 + npccn(k) = max(0._r8,npccn(k)) + ncmax = dum2l(i,k) + else + npccn(k)=0._r8 + ncmax = 0._r8 + end if + + !.............................................................................. + !ice nucleation + es(i,k) = svp_water(t(i,k)) ! over water in mixed clouds + esi(i,k) = svp_ice(t(i,k)) ! over ice + qs(i,k) = 0.622_r8*es(i,k)/(ph(i,k) - (1.0_r8-0.622_r8)*es(i,k)) + qs(i,k) = min(1.0_r8,qs(i,k)) + if (qs(i,k) < 0.0_r8) qs(i,k) = 1.0_r8 + + relhum(i,k)= 1.0_r8 + + if (t(i,k).lt.tmelt ) then + + ! compute aerosol number for so4, soot, and dust with units #/cm^3 + so4_num = 0._r8 + soot_num = 0._r8 + dst1_num = 0._r8 + dst2_num = 0._r8 + dst3_num = 0._r8 + dst4_num = 0._r8 + + if (aero%scheme == 'modal') then + + !For modal aerosols, assume for the upper troposphere: + ! soot = accumulation mode + ! sulfate = aiken mode + ! dust = coarse mode + ! since modal has internal mixtures. + soot_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_accum_idx) & + +aero%numg_a(i,k,aero%mode_accum_idx))*rho(i,k)*1.0e-6_r8 + dmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx) & + +aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx)) + ssmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx) & + +aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx)) + if (dmc > 0._r8) then + dst_num = dmc/(ssmc + dmc) *(aero%numg_a(i,k-1,aero%mode_coarse_idx) & + + aero%numg_a(i,k,aero%mode_coarse_idx))*0.5_r8*rho(i,k)*1.0e-6_r8 + else + dst_num = 0.0_r8 + end if + dgnum_aitken = 0.5_r8*(aero%dgnumg(i,k,aero%mode_aitken_idx)+ & + aero%dgnumg(i,k-1,aero%mode_aitken_idx)) + if (dgnum_aitken > 0._r8) then + ! only allow so4 with D>0.1 um in ice nucleation + so4_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_aitken_idx)+ & + aero%numg_a(i,k,aero%mode_aitken_idx))*rho(i,k)*1.0e-6_r8 & + * (0.5_r8 - 0.5_r8*erf(log(0.1e-6_r8/dgnum_aitken)/ & + (2._r8**0.5_r8*log(aero%sigmag_aitken)))) + else + so4_num = 0.0_r8 + end if + so4_num = max(0.0_r8, so4_num) + + else if (aero%scheme == 'bulk') then + + if (aero%idxsul > 0) then + so4_num = naer2h(i,k,aero%idxsul)/25._r8 *1.0e-6_r8 + end if + if (aero%idxbcphi > 0) then + soot_num = naer2h(i,k,aero%idxbcphi)/25._r8 *1.0e-6_r8 + end if + if (aero%idxdst1 > 0) then + dst1_num = naer2h(i,k,aero%idxdst1)/25._r8 *1.0e-6_r8 + end if + if (aero%idxdst2 > 0) then + dst2_num = naer2h(i,k,aero%idxdst2)/25._r8 *1.0e-6_r8 + end if + if (aero%idxdst3 > 0) then + dst3_num = naer2h(i,k,aero%idxdst3)/25._r8 *1.0e-6_r8 + end if + if (aero%idxdst4 > 0) then + dst4_num = naer2h(i,k,aero%idxdst4)/25._r8 *1.0e-6_r8 + end if + dst_num = dst1_num + dst2_num + dst3_num + dst4_num + + end if + + ! *** Turn off soot nucleation *** + soot_num = 0.0_r8 + + ! Liu et al.,J. climate, 2007 + if ( wu(i,k) .lt. 4.0_r8) then + call nucleati( & + wu(i,k), t(i,k), ph(i,k), relhum(i,k), 1.0_r8, qcic(i,k), & + 1.0e-20_r8, 0.0_r8, rho(i,k), so4_num, dst_num, soot_num, 1.0_r8, & + dum2i(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & + wpice, weff, fhom, temp1, temp2, temp3, temp4, .true. ) + end if + nihf(i,k)=nihf(i,k)*rho(i,k) ! convert from #/kg -> #/m3) + niimm(i,k)=niimm(i,k)*rho(i,k) + nidep(i,k)=nidep(i,k)*rho(i,k) + nimey(i,k)=nimey(i,k)*rho(i,k) + + if (.false.) then + ! cooper curve (factor of 1000 is to convert from L-1 to m-3) + !dum2i(i,k)=0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k)))*1000._r8 + + ! put limit on number of nucleated crystals, set to number at T=-30 C + ! cooper (limit to value at -35 C) + !dum2i(i,k)=min(dum2i(i,k),208.9e3_r8)/rho(i,k) ! convert from m-3 to kg-1 + end if + + else + dum2i(i,k)=0._r8 + end if + + ! ice nucleation if activated nuclei exist at t<0C + + if (dum2i(i,k).gt.0._r8.and.t(i,k).lt.tmelt.and. & + relhum(i,k)*es(i,k)/esi(i,k).gt. 1.05_r8 .and. k.gt.jt(i)+1) then + + if (k.eq.kqi(i)) then + nnuccd(k)=dum2i(i,k)/deltat + else + nnuccd(k)=(dum2i(i,k)-niic(i,k))/deltat + end if + nnuccd(k)=max(nnuccd(k),0._r8) + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd(k) = nnuccd(k) * mi0 + else + nnuccd(k)=0._r8 + mnuccd(k) = 0._r8 + end if + + !................................................................................ + ! Bergeron process + ! If 0C< T <-40C and both ice and liquid exist + + if (t(i,k).le.273.15_r8 .and. t(i,k).gt.233.15_r8 .and. & + qiic(i,k).gt.0.5e-6_r8 .and. qcic(i,k).gt. qsmall) then + plevap = qcic(i,k)/bergtsf + prb(k) = max(0._r8,plevap) + nprb(k) = prb(k)/(qcic(i,k)/ncic(i,k)) + else + prb(k)=0._r8 + nprb(k)=0._r8 + end if + + !................................................................................ + ! heterogeneous freezing of cloud water (-5C < T < -35C) + + if (qcic(i,k).ge.qsmall .and.ncic(i,k).gt.0._r8 .and. ntaerh(i,k).gt.0._r8 .and. & + t(i,k).le.268.15_r8 .and. t(i,k).gt.238.15_r8 ) then + + if (aero%scheme == 'bulk') then + ! immersion freezing (Diehl and Wurzler, 2004) + ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) + + nai_bcphi = 0.0_r8 + nai_dst1 = 0.0_r8 + nai_dst2 = 0.0_r8 + nai_dst3 = 0.0_r8 + nai_dst4 = 0.0_r8 + + if (aero%idxbcphi > 0) nai_bcphi = naer2h(i,k,aero%idxbcphi) + if (aero%idxdst1 > 0) nai_dst1 = naer2h(i,k,aero%idxdst1) + if (aero%idxdst2 > 0) nai_dst2 = naer2h(i,k,aero%idxdst2) + if (aero%idxdst3 > 0) nai_dst3 = naer2h(i,k,aero%idxdst3) + if (aero%idxdst4 > 0) nai_dst4 = naer2h(i,k,aero%idxdst4) + + naimm = (0.00291_r8*nai_bcphi + 32.3_r8*(nai_dst1 + nai_dst2 + & + nai_dst3 + nai_dst4))/ntaerh(i,k) !m-3 + if (ttend(k) .lt. 0._r8) then + nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 + mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) + end if + else + if (.false.) then + ! immersion freezing (Diehl and Wurzler, 2004) + ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) + naimm = (0.00291_r8*soot_num + 32.3_r8*dst_num )*1.0e6_r8/ntaerh(i,k) !m-3 + if (ttend(k) .lt. 0._r8) then + nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 + mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) + end if + else + ! immersion freezing (Bigg, 1953) + mnuccc(k) = pi*pi/36._r8*rhow* & + cdist1(k)*gamma(7._r8+pgam(i,k))* & + bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & + lamc(i,k)**3/lamc(i,k)**3 + + nnuccc(k) = pi/6._r8*cdist1(k)*gamma(pgam(i,k)+4._r8) & + *bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(i,k)**3 + end if + end if + + ! contact freezing (Young, 1974) with hooks into simulated dust + + tcnt=(270.16_r8-t(i,k))**1.3_r8 + viscosity=1.8e-5_r8*(t(i,k)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) + mfp=2.0_r8*viscosity/(ph(i,k) & ! Mean free path (m) + *sqrt(8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i,k)))) + + slip1=1.0_r8+(mfp/rn_dst1)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst1/mfp))))! Slip correction factor + slip2=1.0_r8+(mfp/rn_dst2)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst2/mfp)))) + slip3=1.0_r8+(mfp/rn_dst3)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst3/mfp)))) + slip4=1.0_r8+(mfp/rn_dst4)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst4/mfp)))) + + dfaer1=1.381e-23_r8*t(i,k)*slip1/(6._r8*pi*viscosity*rn_dst1) ! aerosol diffusivity (m2/s) + dfaer2=1.381e-23_r8*t(i,k)*slip2/(6._r8*pi*viscosity*rn_dst2) + dfaer3=1.381e-23_r8*t(i,k)*slip3/(6._r8*pi*viscosity*rn_dst3) + dfaer4=1.381e-23_r8*t(i,k)*slip4/(6._r8*pi*viscosity*rn_dst4) + + nacon1=0.0_r8 + nacon2=0.0_r8 + nacon3=0.0_r8 + nacon4=0.0_r8 + + if (aero%scheme == 'modal') then + + ! For modal aerosols: + ! use size '3' for dust coarse mode... + ! scale by dust fraction in coarse mode + + dmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx) & + +aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx)) + ssmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx) & + +aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx)) + if (dmc > 0.0_r8) then + nacon3 = dmc/(ssmc + dmc) * (aero%numg_a(i,k,aero%mode_coarse_idx) & + + aero%numg_a(i,k-1,aero%mode_coarse_idx))*0.5_r8*rho(i,k) + end if + + else if (aero%scheme == 'bulk') then + + if (aero%idxdst1.gt.0) then + nacon1=naer2h(i,k,aero%idxdst1)*tcnt *0.0_r8 + endif + if (aero%idxdst2.gt.0) then + nacon2=naer2h(i,k,aero%idxdst2)*tcnt ! 1/m3 + endif + if (aero%idxdst3.gt.0) then + nacon3=naer2h(i,k,aero%idxdst3)*tcnt + endif + if (aero%idxdst4.gt.0) then + nacon4=naer2h(i,k,aero%idxdst4)*tcnt + endif + end if + + mnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*pi*pi/3._r8*rhow* & + cdist1(k)*gamma(pgam(i,k)+5._r8)/lamc(i,k)**4 + + nnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*2._r8*pi* & + cdist1(k)*gamma(pgam(i,k)+2._r8)/lamc(i,k) + + ! if (nnuccc(k).gt.nnuccd(k)) then + ! dum=nnuccd(k)/nnuccc(k) + ! scale mixing ratio of droplet freezing with limit + ! mnuccc(k)=mnuccc(k)*dum + ! nnuccc(k)=nnuccd(k) + ! end if + + else + mnuccc(k) = 0._r8 + nnuccc(k) = 0._r8 + mnucct(k) = 0._r8 + nnucct(k) = 0._r8 + end if + + ! freeze cloud liquid water homogeneously at -40 C + if (t(i,k) < 233.15_r8 .and. qc(i,k) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above + ! threshold + dum = xlf/cp*qc(i,k) + if (t(i,k)+dum.gt.233.15_r8) then + dum = -(t(i,k)-233.15_r8)*cp/xlf + dum = dum/qc(i,k) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + fholm(i,k) = mu(i,k)*dum*qc(i,k) + fholn(i,k) = mu(i,k)*dum*nc(i,k) + end if + + + !**************************************************************************************** + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! since activation/nucleation processes are fast, need to take into account + ! factor mtime = mixing timescale in cloud / model time step + ! for now mixing timescale is assumed to be 15 min + !***************************************************************************************** + + mtime=deltat/900._r8 + mtimec=deltat/900._r8 + + ! conservation of qc + ! ice mass production from ice nucleation(deposition/cond.-freezing), mnuccd, + ! is considered as a part of cmei. + + qce = mu(i,k)*qc(i,k)-fholm(i,k) +dz(i,k)*cmel(i,k-1) + dum = arcf(i,k)*(pra(k)+prc(k)+prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & + psacws(k))*dz(i,k) + if( qce.lt.0._r8) then + qcimp(k) = .true. + prc(k) = 0._r8 + pra(k) = 0._r8 + prb(k) = 0._r8 + mnuccc(k) = 0._r8 + mnucct(k) = 0._r8 + msacwi(k) = 0._r8 + psacws(k) = 0._r8 + else if (dum.gt.qce) then + ratio = qce/dum*omsm + prc(k) = prc(k)*ratio + pra(k) = pra(k)*ratio + prb(k) = prb(k)*ratio + mnuccc(k) = mnuccc(k)*ratio + mnucct(k) = mnucct(k)*ratio + msacwi(k) = msacwi(k)*ratio + psacws(k) = psacws(k)*ratio + end if + + ! conservation of nc + nce = mu(i,k)*nc(i,k)-fholn(i,k) + (arcf(i,k)*npccn(k)*mtimec)*dz(i,k) + dum = arcf(i,k)*dz(i,k)*(nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+ & + npsacws(k)+ nprb(k) ) + if (nce.lt.0._r8) then + ncimp(k) = .true. + nprc1(k) = 0._r8 + npra(k) = 0._r8 + nnuccc(k) = 0._r8 + nnucct(k) = 0._r8 + npsacws(k) = 0._r8 + nprb(k) = 0._r8 + else if (dum.gt.nce) then + ratio = nce/dum*omsm + nprc1(k) = nprc1(k)*ratio + npra(k) = npra(k)*ratio + nnuccc(k) = nnuccc(k)*ratio + nnucct(k) = nnucct(k)*ratio + npsacws(k) = npsacws(k)*ratio + nprb(k) = nprb(k)*ratio + end if + + ! conservation of qi + qie = mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*(cmei(i,k-1) + & + ( mnuccc(k)+mnucct(k)+msacwi(k)+prb(k))*arcf(i,k) ) + dum = arcf(i,k)*(prci(k)+ prai(k))*dz(i,k) + if (qie.lt.0._r8) then + qiimp(k) = .true. + prci(k) = 0._r8 + prai(k) = 0._r8 + else if (dum.gt.qie) then + ratio = qie/dum*omsm + prci(k) = prci(k)*ratio + prai(k) = prai(k)*ratio + end if + + ! conservation of ni + nie = mu(i,k)*ni(i,k)+fholn(i,k) +dz(i,k)*(nnuccd(k)*mtime*arcf(i,k) & + +(nnuccc(k)+ nnucct(k))*arcf(i,k) ) + dum = arcf(i,k)*dz(i,k)*(-nsacwi(k)+nprci(k)+ nprai(k)) + if( nie.lt.0._r8) then + niimp(k) = .true. + nsacwi(k)= 0._r8 + nprci(k) = 0._r8 + nprai(k) = 0._r8 + else if (dum.gt.nie) then + ratio = nie/dum*omsm + nsacwi(k)= nsacwi(k)*ratio + nprci(k) = nprci(k)*ratio + nprai(k) = nprai(k)*ratio + end if + + ! conservation of qr + + qre = mu(i,k)*qr(i,k)+dz(i,k)*(pra(k)+prc(k))*arcf(i,k) + dum = arcf(i,k)*dz(i,k)*(pracs(k)+ mnuccr(k)-prf(k)) + if (qre.lt.0._r8) then + prf(k) = 0._r8 + pracs(k) = 0._r8 + mnuccr(k) = 0._r8 + else if (dum.gt.qre) then + ratio = qre/dum*omsm + prf(k) = prf(k)*ratio + pracs(k) = pracs(k)*ratio + mnuccr(k) = mnuccr(k)*ratio + end if + + ! conservation of nr + nre = mu(i,k)*nr(i,k) + nprc(k)*arcf(i,k)*dz(i,k) + dum = arcf(i,k)*dz(i,k)*(npracs(k)+nnuccr(k) & + -nragg(k)-pnrf(k)) + if(nre.lt.0._r8) then + npracs(k)= 0._r8 + nnuccr(k)= 0._r8 + nragg(k) = 0._r8 + pnrf(k) = 0._r8 + else if (dum.gt.nre) then + ratio = nre/dum*omsm + npracs(k)= npracs(k)*ratio + nnuccr(k)= nnuccr(k)*ratio + nragg(k) = nragg(k)*ratio + pnrf(k) = pnrf(k)*ratio + end if + + ! conservation of qni + + qnie = mu(i,k)*qni(i,k)+dz(i,k)*( (prai(k)+psacws(k)+prci(k)+ & + pracs(k)+mnuccr(k))*arcf(i,k) ) + dum = arcf(i,k)*dz(i,k)*(-psf(k)) + + if(qnie.lt.0._r8) then + psf(k) = 0._r8 + else if (dum.gt.qnie) then + ratio = qnie/dum*omsm + psf(k) = psf(k)*ratio + end if + + ! conservation of ns + nse = mu(i,k)*ns(i,k)+dz(i,k)*(nprci(k)+nnuccr(k))*arcf(i,k) + dum = arcf(i,k)*dz(i,k)*(-nsagg(k)-pnsf(k)) + if (nse.lt.0._r8) then + nsagg(k) = 0._r8 + pnsf(k) = 0._r8 + else if (dum.gt.nse) then + ratio = nse/dum*omsm + nsagg(k) = nsagg(k)*ratio + pnsf(k) = pnsf(k)*ratio + end if + + !***************************************************************************** + ! get tendencies due to microphysical conversion processes + !***************************************************************************** + + if (k.le.kqc(i)) then + qctend(i,k) = (-pra(k)-prc(k)-prb(k)-mnuccc(k)-mnucct(k)-msacwi(k)- & + psacws(k)) + + qitend(i,k) = (prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)-prci(k)- prai(k)) + + qrtend(i,k) = (pra(k)+prc(k))+(-pracs(k)- mnuccr(k)) + + qnitend(i,k) = (prai(k)+psacws(k)+prci(k))+(pracs(k)+mnuccr(k)) + + ! multiply activation/nucleation by mtime to account for fast timescale + + nctend(i,k) = npccn(k)*mtimec+(-nnuccc(k)-nnucct(k)-npsacws(k) & + -npra(k)-nprc1(k)-nprb(k)) + + nitend(i,k) = nnuccd(k)*mtime+(nnuccc(k)+ nnucct(k)+nsacwi(k)-nprci(k)- & + nprai(k)) + + nstend(i,k) = nsagg(k)+nnuccr(k) + nprci(k) + + nrtend(i,k) = nprc(k)+(-npracs(k)-nnuccr(k) +nragg(k)) + + ! for output + ! cloud liquid water------------- + + autolm(i,k-1) = -prc(k)*arcf(i,k) + accrlm(i,k-1) = -pra(k)*arcf(i,k) + bergnm(i,k-1) = -prb(k)*arcf(i,k) + fhtimm(i,k-1) = -mnuccc(k)*arcf(i,k) + fhtctm(i,k-1) = -mnucct(k)*arcf(i,k) + hmpim (i,k-1) = -msacwi(k)*arcf(i,k) + accslm(i,k-1) = -psacws(k)*arcf(i,k) + fhmlm(i,k-1) = -fholm(i,k)/dz(i,k) + + autoln(i,k-1) = -nprc1(k)*arcf(i,k) + accrln(i,k-1) = -npra(k)*arcf(i,k) + bergnn(i,k-1) = -nprb(k)*arcf(i,k) + fhtimn(i,k-1) = -nnuccc(k)*arcf(i,k) + fhtctn(i,k-1) = -nnucct(k)*arcf(i,k) + accsln(i,k-1) = -npsacws(k)*arcf(i,k) + activn(i,k-1) = npccn(k)*mtimec*arcf(i,k) + fhmln(i,k-1) = -fholn(i,k)/dz(i,k) + + !cloud ice------------------------ + + autoim(i,k-1) = -prci(k)*arcf(i,k) + accsim(i,k-1) = -prai(k)*arcf(i,k) + + nuclin(i,k-1) = nnuccd(k)*mtime*arcf(i,k) + autoin(i,k-1) = -nprci(k)*arcf(i,k) + accsin(i,k-1) = -nprai(k)*arcf(i,k) + hmpin (i,k-1) = nsacwi(k)*arcf(i,k) + + else + qctend(i,k) = 0._r8 + qitend(i,k) = 0._r8 + qrtend(i,k) = 0._r8 + qnitend(i,k) = 0._r8 + nctend(i,k) = 0._r8 + nitend(i,k) = 0._r8 + nstend(i,k) = 0._r8 + nrtend(i,k) = 0._r8 + end if + + !******************************************************************************** + ! vertical integration + !******************************************************************************** + ! snow + if ( k.le.kqi(i) ) then + qni(i,k-1) = 1._r8/mu(i,k-1)* & + (mu(i,k)*qni(i,k)+dz(i,k)*(qnitend(i,k)+psf(k))*arcf(i,k) ) + + ns(i,k-1) = 1._r8/mu(i,k-1)* & + (mu(i,k)*ns(i,k)+dz(i,k)*(nstend(i,k)+pnsf(k))*arcf(i,k) ) + + else + qni(i,k-1)=0._r8 + ns(i,k-1)=0._r8 + end if + + if (qni(i,k-1).le.0._r8) then + qni(i,k-1)=0._r8 + ns(i,k-1)=0._r8 + end if + + ! rain + if (k.le.kqc(i) ) then + qr(i,k-1) = 1._r8/mu(i,k-1)* & + (mu(i,k)*qr(i,k)+dz(i,k)*(qrtend(i,k)+prf(k))*arcf(i,k) ) + + nr(i,k-1) = 1._r8/mu(i,k-1)* & + (mu(i,k)*nr(i,k)+dz(i,k)*(nrtend(i,k)+pnrf(k))*arcf(i,k) ) + + else + qr(i,k-1)=0._r8 + nr(i,k-1)=0._r8 + end if + + if( qr(i,k-1) .le. 0._r8) then + qr(i,k-1)=0._r8 + nr(i,k-1)=0._r8 + end if + + ! freeze rain homogeneously at -40 C + + if (t(i,k-1) < 233.15_r8 .and. qr(i,k-1) > 0._r8) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cp*qr(i,k-1) + if (t(i,k-1)+dum.gt.233.15_r8) then + dum = -(t(i,k-1)-233.15_r8)*cp/xlf + dum = dum/qr(i,k-1) + dum = max(0._r8,dum) + dum = min(1._r8,dum) + else + dum = 1._r8 + end if + qni(i,k-1)=qni(i,k-1)+dum*qr(i,k-1) + ns(i,k-1)=ns(i,k-1)+dum*nr(i,k-1) + qr(i,k-1)=(1._r8-dum)*qr(i,k-1) + nr(i,k-1)=(1._r8-dum)*nr(i,k-1) + fhmrm(i,k-1) = -mu(i,k-1)*dum*qr(i,k-1)/dz(i,k) + end if + + + ! cloud water + if ( k.le.kqc(i) ) then + qc(i,k-1) = (mu(i,k)*qc(i,k)-fholm(i,k)+dz(i,k)*qctend(i,k)*arcf(i,k) & + +dz(i,k)*cmel(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) + + qcde(i,k) = qc(i,k-1) + + nc(i,k-1) = (mu(i,k)*nc(i,k) -fholn(i,k) +dz(i,k)*nctend(i,k)*arcf(i,k) ) & + /(mu(i,k-1)+dz(i,k)*du(i,k-1)) + + ncde(i,k) = nc(i,k-1) + else + qc(i,k-1)=0._r8 + nc(i,k-1)=0._r8 + end if + + if (qc(i,k-1).lt.0._r8) write(iulog,*) "negative qc(i,k-1)=",qc(i,k-1) + dlfm(i,k-1) = -du(i,k-1)*qcde(i,k) + dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) + + if (qc(i,k-1).le. 0._r8) then + qc(i,k-1)=0._r8 + nc(i,k-1)=0._r8 + end if + + if (nc(i,k-1).lt. 0._r8) then + write(iulog,*) "nc(i,k-1)=",nc(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) + write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"nc(i,k)=",ni(i,k) + write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nctend(i,k)=",nctend(i,k) + write(iulog,*) "eu(i,k-1)=",eu(i,k-1) + end if + + ! cloud ice + if( k.le.kqi(i)) then + qi(i,k-1) = (mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*qitend(i,k)*arcf(i,k) & + +dz(i,k)*cmei(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) + + qide(i,k) = qi(i,k-1) + + ni(i,k-1) = (mu(i,k)*ni(i,k)+fholn(i,k)+dz(i,k)*nitend(i,k)*arcf(i,k) ) & + /(mu(i,k-1)+dz(i,k)*du(i,k-1)) + + nide(i,k) = ni(i,k-1) + else + qi(i,k-1)=0._r8 + ni(i,k-1)=0._r8 + end if + + if (qi(i,k-1).lt.0._r8) write(iulog,*) "negative qi(i,k-1)=",qi(i,k-1) + difm(i,k-1) = -du(i,k-1)*qide(i,k) + difn(i,k-1) = -du(i,k-1)*nide(i,k) + + if (qi(i,k-1).le. 0._r8) then + qi(i,k-1)=0._r8 + ni(i,k-1)=0._r8 + end if + + + if (ni(i,k-1).lt. 0._r8) then + write(iulog,*) "ni(i,k-1)=",ni(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) + write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"ni(i,k)=",ni(i,k) + write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nitend(i,k)=",nitend(i,k) + write(iulog,*) "eu(i,k-1)=",eu(i,k-1) + end if + + + frz(i,k-1) = cmei(i,k-1) + arcf(i,k)*(prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & + pracs(k)+mnuccr(k)+psacws(k) )-fhmlm(i,k-1)-fhmrm(i,k-1) + + + !****************************************************************************** + ! get size distribution parameters based on in-cloud cloud water/ice + ! these calculations also ensure consistency between number and mixing ratio + + ! following equation(2,3,4) of Morrison and Gettelman, 2008, J. Climate. + ! Gamma(n)= (n-1)! + ! lamc <-> lambda for cloud liquid water + ! pgam <-> meu for cloud liquid water + ! meu=0 for ice,rain and snow + !******************************************************************************* + + ! cloud ice + niorg = ni(i,k-1) + if (qi(i,k-1).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + ni(i,k-1)=min(ni(i,k-1),qi(i,k-1)*1.e20_r8) + ! ni should be non-negative + ! ni(i,k-1) = max(ni(i,k-1), 0._r8) + if (ni(i,k-1).lt. 0._r8) write(iulog,*) "ni(i,k-1)=",ni(i,k-1) + + lami(k-1) = (gamma(1._r8+di)*ci* & + ni(i,k-1)/qi(i,k-1))**(1._r8/di) + n0i(k-1) = ni(i,k-1)*lami(k-1) + + ! check for slope + lammax = 1._r8/10.e-6_r8 + lammin = 1._r8/(2._r8*dcs) + + ! adjust vars + if (lami(k-1).lt.lammin) then + lami(k-1) = lammin + n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) + ni(i,k-1) = n0i(k-1)/lami(k-1) + else if (lami(k-1).gt.lammax) then + lami(k-1) = lammax + n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) + ni(i,k-1) = n0i(k-1)/lami(k-1) + end if + else + lami(k-1) = 0._r8 + n0i(k-1) = 0._r8 + end if + + nide(i,k) = ni(i,k-1) + difn(i,k-1) = -du(i,k-1)*nide(i,k) + + niadj(i,k-1)= (ni(i,k-1)- niorg)*mu(i,k-1)/dz(i,k) + + if (niadj(i,k-1) .lt. 0._r8) then + total = nuclin(i,k-1)-fhtimn(i,k-1)-fhtctn(i,k-1)-fhmln(i,k-1)+ hmpin (i,k-1) + if (total .ne. 0._r8) then + nuclin(i,k-1) = nuclin(i,k-1) + nuclin(i,k-1)*niadj(i,k-1)/total + fhtimn(i,k-1) = fhtimn(i,k-1) + fhtimn(i,k-1)*niadj(i,k-1)/total + fhtctn(i,k-1) = fhtctn(i,k-1) + fhtctn(i,k-1)*niadj(i,k-1)/total + fhmln (i,k-1) = fhmln (i,k-1) + fhmln (i,k-1)*niadj(i,k-1)/total + hmpin (i,k-1) = hmpin (i,k-1) + hmpin (i,k-1)*niadj(i,k-1)/total + else + total = 5._r8 + nuclin(i,k-1) = nuclin(i,k-1) + niadj(i,k-1)/total + fhtimn(i,k-1) = fhtimn(i,k-1) + niadj(i,k-1)/total + fhtctn(i,k-1) = fhtctn(i,k-1) + niadj(i,k-1)/total + fhmln (i,k-1) = fhmln (i,k-1) + niadj(i,k-1)/total + hmpin (i,k-1) = hmpin (i,k-1) + niadj(i,k-1)/total + end if + else if (niadj(i,k-1) .gt. 0._r8) then + total = autoin(i,k-1)+accsin(i,k-1) + if (total .ne. 0._r8) then + autoin(i,k-1) = autoin(i,k-1) + autoin(i,k-1)*niadj(i,k-1)/total + accsin(i,k-1) = accsin(i,k-1) + accsin(i,k-1)*niadj(i,k-1)/total + else + total = 2._r8 + autoin(i,k-1) = autoin(i,k-1) + niadj(i,k-1)/total + accsin(i,k-1) = accsin(i,k-1) + niadj(i,k-1)/total + end if + end if + + !................................................................................ + !cloud water + ncorg = nc(i,k-1) + if (qc(i,k-1).ge.qsmall) then + + ! add upper limit to in-cloud number concentration to prevent numerical error + nc(i,k-1)=min(nc(i,k-1),qc(i,k-1)*1.e20_r8) + ! and make sure it's non-negative + ! nc(i,k-1) = max(nc(i,k-1), 0._r8) + if (nc(i,k-1).lt. 0._r8) write(iulog,*) "nc(i,k-1)=",nc(i,k-1) + + ! get pgam from fit to observations of martin et al. 1994 + + pgam(i,k-1)=0.0005714_r8*(nc(i,k-1)/1.e6_r8/rho(i,k-1))+0.2714_r8 + pgam(i,k-1)=1._r8/(pgam(i,k-1)**2)-1._r8 + pgam(i,k-1)=max(pgam(i,k-1),2._r8) + pgam(i,k-1)=min(pgam(i,k-1),15._r8) + ! calculate lamc + + lamc(i,k-1) = (pi/6._r8*rhow*nc(i,k-1)*gamma(pgam(i,k-1)+4._r8)/ & + (qc(i,k-1)*gamma(pgam(i,k-1)+1._r8)))**(1._r8/3._r8) + + ! lammin, 50 micron diameter max mean size + lammin = (pgam(i,k-1)+1._r8)/40.e-6_r8 + lammax = (pgam(i,k-1)+1._r8)/1.e-6_r8 + + if (lamc(i,k-1).lt.lammin) then + lamc(i,k-1) = lammin + nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & + gamma(pgam(i,k-1)+1._r8)/ & + (pi*rhow*gamma(pgam(i,k-1)+4._r8)) + else if (lamc(i,k-1).gt.lammax) then + lamc(i,k-1) = lammax + nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & + gamma(pgam(i,k-1)+1._r8)/ & + (pi*rhow*gamma(pgam(i,k-1)+4._r8)) + end if + + ! parameter to calculate droplet freezing + + cdist1(k-1) = nc(i,k-1)/gamma(pgam(i,k-1)+1._r8) + else + lamc(i,k-1) = 0._r8 + cdist1(k-1) = 0._r8 + end if + + ncde(i,k) = nc(i,k-1) + dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) + + ncadj(i,k-1) = (nc(i,k-1)- ncorg)*mu(i,k-1)/dz(i,k) + if (ncadj(i,k-1) .lt. 0._r8) then + activn(i,k-1) = activn(i,k-1) + ncadj(i,k-1) + else if (ncadj(i,k-1) .gt. 0._r8) then + total = autoln(i,k-1)+accrln(i,k-1)+bergnn(i,k-1)+accsln(i,k-1) + if (total .ne. 0._r8) then + autoln(i,k-1) = autoln(i,k-1) + autoln(i,k-1)*ncadj(i,k-1)/total + accrln(i,k-1) = accrln(i,k-1) + accrln(i,k-1)*ncadj(i,k-1)/total + bergnn(i,k-1) = bergnn(i,k-1) + bergnn(i,k-1)*ncadj(i,k-1)/total + accsln(i,k-1) = accsln(i,k-1) + accsln(i,k-1)*ncadj(i,k-1)/total + else + total = 4._r8 + autoln(i,k-1) = autoln(i,k-1) + ncadj(i,k-1)/total + accrln(i,k-1) = accrln(i,k-1) + ncadj(i,k-1)/total + bergnn(i,k-1) = bergnn(i,k-1) + ncadj(i,k-1)/total + accsln(i,k-1) = accsln(i,k-1) + ncadj(i,k-1)/total + end if + end if + + trspcm(i,k-1) = (mu(i,k)*qc(i,k) - mu(i,k-1)*qc(i,k-1))/dz(i,k) + trspcn(i,k-1) = (mu(i,k)*nc(i,k) - mu(i,k-1)*nc(i,k-1))/dz(i,k) + trspim(i,k-1) = (mu(i,k)*qi(i,k) - mu(i,k-1)*qi(i,k-1))/dz(i,k) + trspin(i,k-1) = (mu(i,k)*ni(i,k) - mu(i,k-1)*ni(i,k-1))/dz(i,k) + + if (k-1 .eq. jt(i)+1) then + trspcm(i,k-2) = mu(i,k-1)*qc(i,k-1)/dz(i,k-1) + trspcn(i,k-2) = mu(i,k-1)*nc(i,k-1)/dz(i,k-1) + trspim(i,k-2) = mu(i,k-1)*qi(i,k-1)/dz(i,k-1) + trspin(i,k-2) = mu(i,k-1)*ni(i,k-1)/dz(i,k-1) + qcde(i,k-1) = qc(i,k-1) + ncde(i,k-1) = nc(i,k-1) + qide(i,k-1) = qi(i,k-1) + nide(i,k-1) = ni(i,k-1) + dlfm (i,k-2) = -du(i,k-2)*qcde(i,k-1) + dlfn (i,k-2) = -du(i,k-2)*ncde(i,k-1) + difm (i,k-2) = -du(i,k-2)*qide(i,k-1) + difn (i,k-2) = -du(i,k-2)*nide(i,k-1) + end if + + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + if (qr(i,k-1).ge.qsmall) then + + lamr(k-1) = (pi*rhow*nr(i,k-1)/qr(i,k-1))**(1._r8/3._r8) + n0r(k-1) = nr(i,k-1)*lamr(k-1) + + ! check for slope + lammax = 1._r8/150.e-6_r8 + lammin = 1._r8/3000.e-6_r8 + ! adjust vars + if (lamr(k-1).lt.lammin) then + lamr(k-1) = lammin + n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) + nr(i,k-1) = n0r(k-1)/lamr(k-1) + else if (lamr(k-1).gt.lammax) then + lamr(k-1) = lammax + n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) + nr(i,k-1) = n0r(k-1)/lamr(k-1) + end if + + unr(k-1) = min(arn(i,k-1)*gamma(1._r8+br)/lamr(k-1)**br,10._r8) + umr(k-1) = min(arn(i,k-1)*gamma(4._r8+br)/(6._r8*lamr(k-1)**br),10._r8) + else + lamr(k-1) = 0._r8 + n0r(k-1) = 0._r8 + umr(k-1) = 0._r8 + unr(k-1) = 0._r8 + end if + + !...................................................................... + ! snow + if (qni(i,k-1).ge.qsmall) then + lams(k-1) = (gamma(1._r8+ds)*cs*ns(i,k-1)/ & + qni(i,k-1))**(1._r8/ds) + n0s(k-1) = ns(i,k-1)*lams(k-1) + + ! check for slope + lammax = 1._r8/10.e-6_r8 + lammin = 1._r8/2000.e-6_r8 + + ! adjust vars + if (lams(k-1).lt.lammin) then + lams(k-1) = lammin + n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) + ns(i,k-1) = n0s(k-1)/lams(k-1) + else if (lams(k-1).gt.lammax) then + lams(k-1) = lammax + n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) + ns(i,k-1) = n0s(k-1)/lams(k-1) + end if + ums(k-1) = min(asn(i,k-1)*gamma(4._r8+bs)/(6._r8*lams(k-1)**bs),3.6_r8) + uns(k-1) = min(asn(i,k-1)*gamma(1._r8+bs)/lams(k-1)**bs,3.6_r8) + else + lams(k-1) = 0._r8 + n0s(k-1) = 0._r8 + ums(k-1) = 0._r8 + uns(k-1) = 0._r8 + end if + + rprd(i,k-1)= (qnitend(i,k) + qrtend(i,k))*arcf(i,k) + sprd(i,k-1)= qnitend(i,k) *arcf(i,k) -fhmrm(i,k-1) + + end if ! k (No products) rate = ** User defined ** ( 1) + + Reactions + usr_HO2_HO2 ( 1) HO2 + HO2 -> H2O2 rate = ** User defined ** ( 2) + ( 2) H2O2 + OH -> H2O + HO2 rate = 2.90E-12*exp( -160./t) ( 3) + ( 3) DMS + OH -> SO2 rate = 9.60E-12*exp( -234./t) ( 4) + ( 4) DMS + NO3 -> SO2 + {HNO3} rate = 1.90E-13*exp( 520./t) ( 5) + ( 5) SO2 + OH + M -> H2SO4 + M troe : ko=3.00E-31*(300/t)**3.30 ( 6) + ki=1.50E-12 + f=0.60 + usr_DMS_OH ( 6) DMS + OH -> .75*SO2 + .5*HO2 + 0.029*SOA_LV + 0.114*SOA_SV rate = ** User defined ** ( 7) + ( 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) + +Heterogeneous loss species + +Extraneous prod/loss species + ( 1) SO2 (dataset) + ( 2) BC_NI (dataset) + ( 3) BC_AX (dataset) + ( 4) BC_N (dataset) + ( 5) OM_NI (dataset) + ( 6) SO4_PR (dataset) + ( 7) H2O (dataset) + + + Equation Report + + d(SO2)/dt = r3*OH*DMS + r4*NO3*DMS + .75*r6*OH*DMS + - r5*OH*M*SO2 + d(H2SO4)/dt = r5*OH*M*SO2 + d(DMS)/dt = - r3*OH*DMS - r4*NO3*DMS - r6*OH*DMS + d(H2O2)/dt = r1 + - j1*H2O2 - r2*OH*H2O2 + d(SO4_NA)/dt = 0 + d(SO4_A1)/dt = 0 + d(SO4_A2)/dt = 0 + d(SO4_AC)/dt = 0 + d(SO4_PR)/dt = 0 + d(BC_N)/dt = 0 + d(BC_AX)/dt = 0 + d(BC_NI)/dt = 0 + d(BC_A)/dt = 0 + d(BC_AI)/dt = 0 + d(BC_AC)/dt = 0 + d(OM_NI)/dt = 0 + d(OM_AI)/dt = 0 + d(OM_AC)/dt = 0 + d(DST_A2)/dt = 0 + d(DST_A3)/dt = 0 + d(SS_A1)/dt = 0 + d(SS_A2)/dt = 0 + d(SS_A3)/dt = 0 + 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(monoterp)/dt = - r7*O3*monoterp - r8*OH*monoterp - r9*NO3*monoterp + d(isoprene)/dt = - r10*O3*isoprene - r11*OH*isoprene - r12*NO3*isoprene + d(H2O)/dt = r2*OH*H2O2 diff --git a/src/chemistry/pp_trop_mam_oslo/chem_mech.in b/src/chemistry/pp_trop_mam_oslo/chem_mech.in new file mode 100644 index 0000000000..5897d33683 --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/chem_mech.in @@ -0,0 +1,109 @@ +BEGSIM + SPECIES + + Solution + SO2, H2SO4 + DMS -> CH3SCH3, H2O2 + SO4_NA->H2SO4, SO4_A1->H2SO4, SO4_A2->NH4HSO4 + SO4_AC->H2SO4, SO4_PR->H2SO4, BC_N->C + BC_AX->C, BC_NI->C, BC_A->C, BC_AI->C + BC_AC->C, OM_NI->C, OM_AI->C, OM_AC->C + DST_A2->AlSiO5, DST_A3->AlSiO5 + SS_A1->NaCl, SS_A2->NaCl, SS_A3->NaCl +* Approximate soa species with those of monoterpene oxidation products +* based on Paasonen et al. (2010); Taipale et al. (2008). + SOA_NA->C10H16O2, SOA_A1->C10H16O2 + SOA_LV ->C10H16O2, SOA_SV->C10H16O2 + monoterp -> C10H16, isoprene -> C5H8 + H2O + End Solution + + Fixed + M, N2, O2, O3, OH, NO3, HO2 + End Fixed + + Col-int + O3 = 0. + O2 = 0. + End Col-int + + End SPECIES + + Solution Classes + Explicit + End Explicit + Implicit + DMS, SO2, H2O2 + SO4_NA, SO4_A1, SO4_A2 + SO4_AC, SO4_PR, BC_N + BC_AX, BC_NI, BC_A, BC_AI + BC_AC, OM_NI, OM_AI, OM_AC + DST_A2, DST_A3 + SS_A1, SS_A2, SS_A3 , H2SO4 + SOA_NA, SOA_A1 + SOA_LV,SOA_SV, monoterp, isoprene + H2O + End Implicit + End Solution Classes + + CHEMISTRY + Photolysis + [jh2o2] H2O2 + hv -> + End Photolysis + + Reactions + [usr_HO2_HO2] HO2 + HO2 -> H2O2 + H2O2 + OH -> H2O + HO2 ; 2.9e-12, -160 + DMS + OH -> SO2 ; 9.6e-12, -234. + DMS + NO3 -> SO2 + HNO3 ; 1.9e-13, 520. + SO2 + OH + M -> H2SO4 + M ; 3.0e-31, 3.3, 1.5e-12, 0.0, 0.6 +* SOA has MW=168, and MSA=96, so to get correct MSA mass ==> factor of 96/168 = 0.57 +* Then account for 0.25 which is 0.25 MSA molec per DMS molec (the other 0.75 goes to SO2) +* Then 0.2 assumed yield for SOA_LV and 0.8 assumed yield for SOA_SV gives the coefficients below +* reaction rate from Chin et al 1996, JGR, vol 101, no D13 +* + [usr_DMS_OH] DMS + OH -> .75 * SO2 + .5 * HO2 + 0.029*SOA_LV + 0.114*SOA_SV +* +*cka: added organic vapor oxidation with constants from IUPAC below +* Assume a yield of 15% for SOA LV production from these reactions +* Assume a yield of 15 % for monoterpene and 5% for isoprene SOA SV production reactions +* SOA_LV: very low volatility, can nucleate or grow small particles (oxidation products from O3+monoterp) +* SOA_SV: rest of SOA formed + 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. + End Reactions + + Heterogeneous + H2O2, SO2 + End Heterogeneous + + Ext Forcing + SO2 <- dataset + BC_NI <-dataset + BC_AX <-dataset + BC_N <-dataset + OM_NI <-dataset + SO4_PR <-dataset + H2O <- dataset + End Ext Forcing + + END CHEMISTRY + + SIMULATION PARAMETERS + + Version Options + model = cam + machine = intel + architecture = hybrid + vec_ftns = on + multitask = on + namemod = on + modules = on + End Version Options + + END SIMULATION PARAMETERS +ENDSIM diff --git a/src/chemistry/pp_trop_mam_oslo/chem_mods.F90 b/src/chemistry/pp_trop_mam_oslo/chem_mods.F90 new file mode 100644 index 0000000000..bcd985192b --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/chem_mods.F90 @@ -0,0 +1,50 @@ + module chem_mods +!-------------------------------------------------------------- +! ... Basic chemistry parameters and arrays +!-------------------------------------------------------------- + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none + save + integer, parameter :: phtcnt = 1, & ! number of photolysis reactions + rxntot = 13, & ! number of total reactions + gascnt = 12, & ! number of gas phase reactions + nabscol = 2, & ! number of absorbing column densities + gas_pcnst = 30, & ! number of "gas phase" species + nfs = 7, & ! number of "fixed" species + relcnt = 0, & ! number of relationship species + grpcnt = 0, & ! number of group members + nzcnt = 38, & ! number of non-zero matrix entries + extcnt = 7, & ! number of species with external forcing + clscnt1 = 0, & ! number of species in explicit class + clscnt2 = 0, & ! number of species in hov class + clscnt3 = 0, & ! number of species in ebi class + clscnt4 = 30, & ! number of species in implicit class + clscnt5 = 0, & ! number of species in rodas class + indexm = 1, & ! index of total atm density in invariant array + indexh2o = 0, & ! index of water vapor density + clsze = 1, & ! loop length for implicit chemistry + rxt_tag_cnt = 3, & + enthalpy_cnt = 0, & + nslvd = 0 + integer :: clscnt(5) = 0 + integer :: cls_rxt_cnt(4,5) = 0 + integer :: clsmap(gas_pcnst,5) = 0 + integer :: permute(gas_pcnst,5) = 0 + integer :: diag_map(clscnt4) = 0 + real(r8) :: adv_mass(gas_pcnst) = 0._r8 + real(r8) :: crb_mass(gas_pcnst) = 0._r8 + real(r8) :: fix_mass(max(1,nfs)) + real(r8), allocatable :: cph_enthalpy(:) + integer, allocatable :: cph_rid(:) + integer, allocatable :: num_rnts(:) + integer, allocatable :: rxt_tag_map(:) + real(r8), allocatable :: pht_alias_mult(:,:) + character(len=32), allocatable :: rxt_tag_lst(:) + character(len=16), allocatable :: pht_alias_lst(:,:) + character(len=16) :: inv_lst(max(1,nfs)) + character(len=16) :: extfrc_lst(max(1,extcnt)) + logical :: frc_from_dataset(max(1,extcnt)) + logical :: is_vector + logical :: is_scalar + character(len=16) :: slvd_lst(max(1,nslvd)) + end module chem_mods diff --git a/src/chemistry/pp_trop_mam_oslo/m_rxt_id.F90 b/src/chemistry/pp_trop_mam_oslo/m_rxt_id.F90 new file mode 100644 index 0000000000..278910603d --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/m_rxt_id.F90 @@ -0,0 +1,16 @@ + module m_rxt_id + implicit none + integer, parameter :: rid_jh2o2 = 1 + integer, parameter :: rid_usr_HO2_HO2 = 2 + integer, parameter :: rid_usr_DMS_OH = 7 + integer, parameter :: rid_r0003 = 3 + integer, parameter :: rid_r0004 = 4 + integer, parameter :: rid_r0005 = 5 + integer, parameter :: rid_r0006 = 6 + integer, parameter :: rid_r0008 = 8 + integer, parameter :: rid_r0009 = 9 + integer, parameter :: rid_r0010 = 10 + integer, parameter :: rid_r0011 = 11 + integer, parameter :: rid_r0012 = 12 + integer, parameter :: rid_r0013 = 13 + end module m_rxt_id diff --git a/src/chemistry/pp_trop_mam_oslo/m_spc_id.F90 b/src/chemistry/pp_trop_mam_oslo/m_spc_id.F90 new file mode 100644 index 0000000000..f288d118fa --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/m_spc_id.F90 @@ -0,0 +1,33 @@ + module m_spc_id + implicit none + integer, parameter :: id_SO2 = 1 + integer, parameter :: id_H2SO4 = 2 + integer, parameter :: id_DMS = 3 + integer, parameter :: id_H2O2 = 4 + integer, parameter :: id_SO4_NA = 5 + integer, parameter :: id_SO4_A1 = 6 + integer, parameter :: id_SO4_A2 = 7 + integer, parameter :: id_SO4_AC = 8 + integer, parameter :: id_SO4_PR = 9 + integer, parameter :: id_BC_N = 10 + integer, parameter :: id_BC_AX = 11 + integer, parameter :: id_BC_NI = 12 + integer, parameter :: id_BC_A = 13 + integer, parameter :: id_BC_AI = 14 + integer, parameter :: id_BC_AC = 15 + integer, parameter :: id_OM_NI = 16 + integer, parameter :: id_OM_AI = 17 + integer, parameter :: id_OM_AC = 18 + integer, parameter :: id_DST_A2 = 19 + integer, parameter :: id_DST_A3 = 20 + integer, parameter :: id_SS_A1 = 21 + integer, parameter :: id_SS_A2 = 22 + integer, parameter :: id_SS_A3 = 23 + integer, parameter :: id_SOA_NA = 24 + integer, parameter :: id_SOA_A1 = 25 + integer, parameter :: id_SOA_LV = 26 + integer, parameter :: id_SOA_SV = 27 + integer, parameter :: id_monoterp = 28 + integer, parameter :: id_isoprene = 29 + integer, parameter :: id_H2O = 30 + end module m_spc_id diff --git a/src/chemistry/pp_trop_mam_oslo/mo_adjrxt.F90 b/src/chemistry/pp_trop_mam_oslo/mo_adjrxt.F90 new file mode 100644 index 0000000000..fe6931f11d --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_adjrxt.F90 @@ -0,0 +1,34 @@ + module mo_adjrxt + private + public :: adjrxt + contains + subroutine adjrxt( rate, inv, m, ncol, nlev ) + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : nfs, rxntot + implicit none +!-------------------------------------------------------------------- +! ... dummy arguments +!-------------------------------------------------------------------- + integer, intent(in) :: ncol, nlev + real(r8), intent(in) :: inv(ncol,nlev,nfs) + real(r8), intent(in) :: m(ncol,nlev) + real(r8), intent(inout) :: rate(ncol,nlev,rxntot) +!-------------------------------------------------------------------- +! ... local variables +!-------------------------------------------------------------------- + real(r8) :: im(ncol,nlev) + im(:,:) = 1._r8 / m(:,:) + rate(:,:, 3) = rate(:,:, 3) * inv(:,:, 5) + rate(:,:, 4) = rate(:,:, 4) * inv(:,:, 5) + rate(:,:, 5) = rate(:,:, 5) * inv(:,:, 6) + rate(:,:, 7) = rate(:,:, 7) * inv(:,:, 5) + rate(:,:, 8) = rate(:,:, 8) * inv(:,:, 4) + rate(:,:, 9) = rate(:,:, 9) * inv(:,:, 5) + rate(:,:, 10) = rate(:,:, 10) * inv(:,:, 6) + rate(:,:, 11) = rate(:,:, 11) * inv(:,:, 4) + rate(:,:, 12) = rate(:,:, 12) * inv(:,:, 5) + rate(:,:, 13) = rate(:,:, 13) * inv(:,:, 6) + rate(:,:, 2) = rate(:,:, 2) * inv(:,:, 7) * inv(:,:, 7) * im(:,:) + rate(:,:, 6) = rate(:,:, 6) * inv(:,:, 5) * inv(:,:, 1) + end subroutine adjrxt + end module mo_adjrxt diff --git a/src/chemistry/pp_trop_mam_oslo/mo_exp_sol.F90 b/src/chemistry/pp_trop_mam_oslo/mo_exp_sol.F90 new file mode 100644 index 0000000000..cfde22391a --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_exp_sol.F90 @@ -0,0 +1,79 @@ +module mo_exp_sol + private + public :: exp_sol + public :: exp_sol_inti +contains + subroutine exp_sol_inti + use mo_tracname, only : solsym + use chem_mods, only : clscnt1, clsmap + use ppgrid, only : pver + use cam_history, only : addfld + implicit none + integer :: i,j + do i = 1,clscnt1 + j = clsmap(i,1) + call addfld( trim(solsym(j))//'_CHMP', (/ 'lev' /), 'I', '/cm3/s', 'chemical production rate' ) + call addfld( trim(solsym(j))//'_CHML', (/ 'lev' /), 'I', '/cm3/s', 'chemical loss rate' ) + enddo + end subroutine exp_sol_inti + subroutine exp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, xhnm, ncol, lchnk, ltrop ) + !----------------------------------------------------------------------- + ! ... Exp_sol advances the volumetric mixing ratio + ! forward one time step via the fully explicit + ! Euler scheme + !----------------------------------------------------------------------- + use chem_mods, only : clscnt1, extcnt, gas_pcnst, clsmap, rxntot + use ppgrid, only : pcols, pver + use mo_prod_loss, only : exp_prod_loss + use mo_indprd, only : indprd + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_history, only : outfld + use mo_tracname, only : solsym + implicit none + !----------------------------------------------------------------------- + ! ... Dummy arguments + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! het rates (1/cm^3/s) + real(r8), intent(in) :: reaction_rates(ncol,pver,rxntot) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol,pver,extcnt) ! "external insitu forcing" (1/cm^3/s) + real(r8), intent(in) :: xhnm(ncol,pver) + integer, intent(in) :: ltrop(pcols) ! chemistry troposphere boundary (index) + real(r8), intent(inout) :: base_sol(ncol,pver,gas_pcnst) ! working mixing ratios (vmr) + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: i, k, l, m + real(r8), dimension(ncol,pver,clscnt1) :: & + prod, & + loss, & + ind_prd + real(r8), dimension(ncol,pver) :: wrk + !----------------------------------------------------------------------- + ! ... Put "independent" production in the forcing + !----------------------------------------------------------------------- + call indprd( 1, ind_prd, clscnt1, base_sol, extfrc, & + reaction_rates, ncol ) + !----------------------------------------------------------------------- + ! ... Form F(y) + !----------------------------------------------------------------------- + call exp_prod_loss( prod, loss, base_sol, reaction_rates, het_rates ) + !----------------------------------------------------------------------- + ! ... Solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + do m = 1,clscnt1 + l = clsmap(m,1) + do i = 1,ncol + do k = ltrop(i)+1,pver + base_sol(i,k,l) = base_sol(i,k,l) + delt * (prod(i,k,m) + ind_prd(i,k,m) - loss(i,k,m)) + end do + end do + wrk(:,:) = (prod(:,:,m) + ind_prd(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHMP', wrk(:,:), ncol, lchnk ) + wrk(:,:) = (loss(:,:,m))*xhnm + call outfld( trim(solsym(l))//'_CHML', wrk(:,:), ncol, lchnk ) + end do + end subroutine exp_sol +end module mo_exp_sol diff --git a/src/chemistry/pp_trop_mam_oslo/mo_imp_sol.F90 b/src/chemistry/pp_trop_mam_oslo/mo_imp_sol.F90 new file mode 100644 index 0000000000..d885728ba4 --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_imp_sol.F90 @@ -0,0 +1,392 @@ +module mo_imp_sol + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, gas_pcnst, clsmap + use cam_logfile, only : iulog + implicit none + private + public :: imp_slv_inti, imp_sol + save + real(r8), parameter :: rel_err = 1.e-3_r8 + real(r8), parameter :: high_rel_err = 1.e-4_r8 + !----------------------------------------------------------------------- + ! Newton-Raphson iteration limits + !----------------------------------------------------------------------- + integer, parameter :: itermax = 11 + integer, parameter :: cut_limit = 5 + real(r8), parameter :: small = 1.e-40_r8 + real(r8) :: epsilon(clscnt4) + logical :: factor(itermax) +contains + subroutine imp_slv_inti + !----------------------------------------------------------------------- + ! ... Initialize the implict solver + !----------------------------------------------------------------------- + use mo_chem_utls, only : get_spc_ndx + implicit none + !----------------------------------------------------------------------- + ! ... Local variables + !----------------------------------------------------------------------- + integer :: m, ox_ndx, o3a_ndx + real(r8) :: eps(gas_pcnst) + factor(:) = .true. + eps(:) = rel_err + ox_ndx = get_spc_ndx( 'OX' ) + if( ox_ndx < 1 ) then + ox_ndx = get_spc_ndx( 'O3' ) + end if + if( ox_ndx > 0 ) then + eps(ox_ndx) = high_rel_err + end if + m = get_spc_ndx( 'NO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'N2O5' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'OH' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'HO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + o3a_ndx = get_spc_ndx( 'O3A' ) + if( o3a_ndx > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XHO2NO2' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'XNO2NO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + m = get_spc_ndx( 'NO2XNO3' ) + if( m > 0 ) then + eps(m) = high_rel_err + end if + do m = 1,clscnt4 + epsilon(m) = eps(clsmap(m,4)) + end do + end subroutine imp_slv_inti + subroutine imp_sol( base_sol, reaction_rates, het_rates, extfrc, delt, & + ncol,nlev, lchnk, prod_out, loss_out ) + !----------------------------------------------------------------------- + ! ... imp_sol advances the volumetric mixing ratio + ! forward one time step via the fully implicit euler scheme. + ! this source is meant for small l1 cache machines such as + ! the intel pentium and itanium cpus + !----------------------------------------------------------------------- + use chem_mods, only : rxntot, extcnt, nzcnt, permute, cls_rxt_cnt + use mo_tracname, only : solsym + use mo_lin_matrix, only : linmat + use mo_nln_matrix, only : nlnmat + use mo_lu_factor, only : lu_fac + use mo_lu_solve, only : lu_slv + use mo_prod_loss, only : imp_prod_loss + use mo_indprd, only : indprd + use time_manager, only : get_nstep + use perf_mod, only : t_startf, t_stopf + implicit none + !----------------------------------------------------------------------- + ! ... dummy args + !----------------------------------------------------------------------- + integer, intent(in) :: ncol ! columns in chunck + integer, intent(in) :: nlev + integer, intent(in) :: lchnk ! chunk id + real(r8), intent(in) :: delt ! time step (s) + real(r8), intent(in) :: reaction_rates(ncol,nlev,max(1,rxntot)) ! rxt rates (1/cm^3/s) + real(r8), intent(in) :: extfrc(ncol,nlev,max(1,extcnt)) ! external in-situ forcing (1/cm^3/s) + real(r8), intent(in) :: het_rates(ncol,nlev,max(1,gas_pcnst)) ! washout rates (1/s) + real(r8), intent(inout) :: base_sol(ncol,nlev,gas_pcnst) ! species mixing ratios (vmr) + real(r8), intent(out) :: prod_out(ncol,nlev,max(1,clscnt4)) + real(r8), intent(out) :: loss_out(ncol,nlev,max(1,clscnt4)) + !----------------------------------------------------------------------- + ! ... local variables + !----------------------------------------------------------------------- + integer :: nr_iter, & + lev, & + i, & + j, & + k, l, & + m + integer :: fail_cnt, cut_cnt, stp_con_cnt + integer :: nstep + real(r8) :: interval_done, dt, dti + real(r8) :: max_delta(max(1,clscnt4)) + real(r8) :: sys_jac(max(1,nzcnt)) + real(r8) :: lin_jac(max(1,nzcnt)) + real(r8), dimension(max(1,clscnt4)) :: & + solution, & + forcing, & + iter_invariant, & + prod, & + loss + real(r8) :: lrxt(max(1,rxntot)) + real(r8) :: lsol(max(1,gas_pcnst)) + real(r8) :: lhet(max(1,gas_pcnst)) + real(r8), dimension(ncol,nlev,max(1,clscnt4)) :: & + ind_prd + logical :: convergence + logical :: frc_mask, iter_conv + logical :: converged(max(1,clscnt4)) + solution(:) = 0._r8 + !----------------------------------------------------------------------- + ! ... class independent forcing + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + call indprd( 4, ind_prd, clscnt4, base_sol, extfrc, & + reaction_rates, ncol ) + else + do m = 1,max(1,clscnt4) + ind_prd(:,:,m) = 0._r8 + end do + end if + level_loop : do lev = 1,nlev + column_loop : do i = 1,ncol + !----------------------------------------------------------------------- + ! ... transfer from base to local work arrays + !----------------------------------------------------------------------- + do m = 1,rxntot + lrxt(m) = reaction_rates(i,lev,m) + end do + if( gas_pcnst > 0 ) then + do m = 1,gas_pcnst + lhet(m) = het_rates(i,lev,m) + end do + end if + !----------------------------------------------------------------------- + ! ... time step loop + !----------------------------------------------------------------------- + dt = delt + cut_cnt = 0 + fail_cnt = 0 + stp_con_cnt = 0 + interval_done = 0._r8 + time_step_loop : do + dti = 1._r8 / dt + !----------------------------------------------------------------------- + ! ... transfer from base to local work arrays + !----------------------------------------------------------------------- + do m = 1,gas_pcnst + lsol(m) = base_sol(i,lev,m) + end do + !----------------------------------------------------------------------- + ! ... transfer from base to class array + !----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + solution(m) = lsol(j) + end do + !----------------------------------------------------------------------- + ! ... set the iteration invariant part of the function f(y) + !----------------------------------------------------------------------- + if( cls_rxt_cnt(1,4) > 0 .or. extcnt > 0 ) then + do m = 1,clscnt4 + iter_invariant(m) = dti * solution(m) + ind_prd(i,lev,m) + end do + else + do m = 1,clscnt4 + iter_invariant(m) = dti * solution(m) + end do + end if + !----------------------------------------------------------------------- + ! ... the linear component + !----------------------------------------------------------------------- + if( cls_rxt_cnt(2,4) > 0 ) then + call t_startf( 'lin_mat' ) + call linmat( lin_jac, lsol, lrxt, lhet ) + call t_stopf( 'lin_mat' ) + end if + !======================================================================= + ! the newton-raphson iteration for f(y) = 0 + !======================================================================= + iter_loop : do nr_iter = 1,itermax + !----------------------------------------------------------------------- + ! ... the non-linear component + !----------------------------------------------------------------------- + if( factor(nr_iter) ) then + call t_startf( 'nln_mat' ) + call nlnmat( sys_jac, lsol, lrxt, lin_jac, dti ) + call t_stopf( 'nln_mat' ) + !----------------------------------------------------------------------- + ! ... factor the "system" matrix + !----------------------------------------------------------------------- + call t_startf( 'lu_fac' ) + call lu_fac( sys_jac ) + call t_stopf( 'lu_fac' ) + end if + !----------------------------------------------------------------------- + ! ... form f(y) + !----------------------------------------------------------------------- + call t_startf( 'prod_loss' ) + call imp_prod_loss( prod, loss, lsol, lrxt, lhet ) + call t_stopf( 'prod_loss' ) + do m = 1,clscnt4 + forcing(m) = solution(m)*dti - (iter_invariant(m) + prod(m) - loss(m)) + end do + !----------------------------------------------------------------------- + ! ... solve for the mixing ratio at t(n+1) + !----------------------------------------------------------------------- + call t_startf( 'lu_slv' ) + call lu_slv( sys_jac, forcing ) + call t_stopf( 'lu_slv' ) + do m = 1,clscnt4 + solution(m) = solution(m) + forcing(m) + end do + !----------------------------------------------------------------------- + ! ... convergence measures + !----------------------------------------------------------------------- + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + if( abs(solution(m)) > 1.e-20_r8 ) then + max_delta(k) = abs( forcing(m)/solution(m) ) + else + max_delta(k) = 0._r8 + end if + end do + end if + !----------------------------------------------------------------------- + ! ... limit iterate + !----------------------------------------------------------------------- + where( solution(:) < 0._r8 ) + solution(:) = 0._r8 + endwhere + !----------------------------------------------------------------------- + ! ... transfer latest solution back to work array + !----------------------------------------------------------------------- + do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + lsol(j) = solution(m) + end do + !----------------------------------------------------------------------- + ! ... check for convergence + !----------------------------------------------------------------------- + converged(:) = .true. + if( nr_iter > 1 ) then + do k = 1,clscnt4 + m = permute(k,4) + frc_mask = abs( forcing(m) ) > small + if( frc_mask ) then + converged(k) = abs(forcing(m)) <= epsilon(k)*abs(solution(m)) + else + converged(k) = .true. + end if + end do + convergence = all( converged(:) ) + if( convergence ) then + exit + end if + end if + end do iter_loop + !----------------------------------------------------------------------- + ! ... check for newton-raphson convergence + !----------------------------------------------------------------------- + if( .not. convergence ) then + !----------------------------------------------------------------------- + ! ... non-convergence + !----------------------------------------------------------------------- + fail_cnt = fail_cnt + 1 + nstep = get_nstep() + write(iulog,'('' imp_sol: Time step '',1p,e21.13,'' failed to converge @ (lchnk,lev,col,nstep) = '',4i6)') & + dt,lchnk,lev,i,nstep + stp_con_cnt = 0 + if( cut_cnt < cut_limit ) then + cut_cnt = cut_cnt + 1 + if( cut_cnt < cut_limit ) then + dt = .5_r8 * dt + else + dt = .1_r8 * dt + end if + cycle time_step_loop + else + write(iulog,'('' imp_sol: Failed to converge @ (lchnk,lev,col,nstep,dt,time) = '',4i6,1p,2e21.13)') & + lchnk,lev,i,nstep,dt,interval_done+dt + do m = 1,clscnt4 + if( .not. converged(m) ) then + write(iulog,'(1x,a8,1x,1pe10.3)') solsym(clsmap(m,4)), max_delta(m) + end if + end do + end if + end if + !----------------------------------------------------------------------- + ! ... check for interval done + !----------------------------------------------------------------------- + interval_done = interval_done + dt + if( abs( delt - interval_done ) <= .0001_r8 ) then + if( fail_cnt > 0 ) then + write(iulog,*) 'imp_sol : @ (lchnk,lev,col) = ',lchnk,lev,i,' failed ',fail_cnt,' times' + end if + exit time_step_loop + else + !----------------------------------------------------------------------- + ! ... transfer latest solution back to base array + !----------------------------------------------------------------------- + if( convergence ) then + stp_con_cnt = stp_con_cnt + 1 + end if + do m = 1,gas_pcnst + base_sol(i,lev,m) = lsol(m) + end do + if( stp_con_cnt >= 2 ) then + dt = 2._r8*dt + stp_con_cnt = 0 + end if + dt = min( dt,delt-interval_done ) + ! write(iulog,'('' imp_sol: New time step '',1p,e21.13)') dt + end if + end do time_step_loop + !----------------------------------------------------------------------- + ! ... Transfer latest solution back to base array + !----------------------------------------------------------------------- + cls_loop: do k = 1,clscnt4 + j = clsmap(k,4) + m = permute(k,4) + base_sol(i,lev,j) = solution(m) + ! output diagnostics + prod_out(i,lev,k) = prod(k) + ind_prd(i,lev,k) + loss_out(i,lev,k) = loss(k) + end do cls_loop + end do column_loop + end do level_loop + end subroutine imp_sol +end module mo_imp_sol diff --git a/src/chemistry/pp_trop_mam_oslo/mo_indprd.F90 b/src/chemistry/pp_trop_mam_oslo/mo_indprd.F90 new file mode 100644 index 0000000000..f9ec6830fb --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_indprd.F90 @@ -0,0 +1,56 @@ + module mo_indprd + use shr_kind_mod, only : r8 => shr_kind_r8 + private + public :: indprd + contains + subroutine indprd( class, prod, nprod, y, extfrc, rxt, ncol ) + use chem_mods, only : gas_pcnst, extcnt, rxntot + use ppgrid, only : pver + implicit none +!-------------------------------------------------------------------- +! ... dummy arguments +!-------------------------------------------------------------------- + integer, intent(in) :: class + integer, intent(in) :: ncol + integer, intent(in) :: nprod + real(r8), intent(in) :: y(ncol,pver,gas_pcnst) + real(r8), intent(in) :: rxt(ncol,pver,rxntot) + real(r8), intent(in) :: extfrc(ncol,pver,extcnt) + real(r8), intent(inout) :: prod(ncol,pver,nprod) +!-------------------------------------------------------------------- +! ... "independent" production for Implicit species +!-------------------------------------------------------------------- + if( class == 4 ) then + prod(:,:,1) = 0._r8 + prod(:,:,2) = + extfrc(:,:,1) + prod(:,:,3) =rxt(:,:,2) + prod(:,:,4) = 0._r8 + prod(:,:,5) = 0._r8 + prod(:,:,6) = 0._r8 + prod(:,:,7) = 0._r8 + prod(:,:,8) = + extfrc(:,:,6) + prod(:,:,9) = + extfrc(:,:,4) + prod(:,:,10) = + extfrc(:,:,3) + prod(:,:,11) = + extfrc(:,:,2) + prod(:,:,12) = 0._r8 + prod(:,:,13) = 0._r8 + prod(:,:,14) = 0._r8 + prod(:,:,15) = + extfrc(:,:,5) + prod(:,:,16) = 0._r8 + prod(:,:,17) = 0._r8 + prod(:,:,18) = 0._r8 + prod(:,:,19) = 0._r8 + prod(:,:,20) = 0._r8 + prod(:,:,21) = 0._r8 + prod(:,:,22) = 0._r8 + prod(:,:,23) = 0._r8 + prod(:,:,24) = 0._r8 + prod(:,:,25) = 0._r8 + prod(:,:,26) = 0._r8 + prod(:,:,27) = 0._r8 + prod(:,:,28) = 0._r8 + prod(:,:,29) = 0._r8 + prod(:,:,30) = + extfrc(:,:,7) + end if + end subroutine indprd + end module mo_indprd diff --git a/src/chemistry/pp_trop_mam_oslo/mo_lin_matrix.F90 b/src/chemistry/pp_trop_mam_oslo/mo_lin_matrix.F90 new file mode 100644 index 0000000000..e4c7687ebb --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_lin_matrix.F90 @@ -0,0 +1,74 @@ + module mo_lin_matrix + private + public :: linmat + contains + subroutine linmat01( mat, y, rxt, het_rates ) +!---------------------------------------------- +! ... linear matrix entries for implicit species +!---------------------------------------------- + use chem_mods, only : gas_pcnst, rxntot, nzcnt + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none +!---------------------------------------------- +! ... dummy arguments +!---------------------------------------------- + real(r8), intent(in) :: y(gas_pcnst) + real(r8), intent(in) :: rxt(rxntot) + real(r8), intent(in) :: het_rates(max(1,gas_pcnst)) + real(r8), intent(inout) :: mat(nzcnt) + mat(1) = -( rxt(4) + rxt(5) + rxt(7) + het_rates(3) ) + mat(5) = -( rxt(6) + het_rates(1) ) + mat(2) = rxt(4) + rxt(5) + .750_r8*rxt(7) + mat(7) = -( rxt(1) + rxt(3) + het_rates(4) ) + mat(9) = -( het_rates(5) ) + mat(10) = -( het_rates(6) ) + mat(11) = -( het_rates(7) ) + mat(12) = -( het_rates(8) ) + mat(13) = -( het_rates(9) ) + mat(14) = -( het_rates(10) ) + mat(15) = -( het_rates(11) ) + mat(16) = -( het_rates(12) ) + mat(17) = -( het_rates(13) ) + mat(18) = -( het_rates(14) ) + mat(19) = -( het_rates(15) ) + mat(20) = -( het_rates(16) ) + mat(21) = -( het_rates(17) ) + mat(22) = -( het_rates(18) ) + mat(23) = -( het_rates(19) ) + mat(24) = -( het_rates(20) ) + mat(25) = -( het_rates(21) ) + mat(26) = -( het_rates(22) ) + mat(27) = -( het_rates(23) ) + mat(28) = -( het_rates(2) ) + mat(6) = rxt(6) + mat(29) = -( het_rates(24) ) + mat(30) = -( het_rates(25) ) + mat(31) = -( het_rates(26) ) + mat(3) = .029_r8*rxt(7) + mat(33) = .150_r8*rxt(8) + 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(35) = -( rxt(8) + rxt(9) + rxt(10) + het_rates(28) ) + mat(37) = -( rxt(11) + rxt(12) + rxt(13) + het_rates(29) ) + mat(38) = -( het_rates(30) ) + mat(8) = rxt(3) + end subroutine linmat01 + subroutine linmat( mat, y, rxt, het_rates ) +!---------------------------------------------- +! ... linear matrix entries for implicit species +!---------------------------------------------- + use chem_mods, only : gas_pcnst, rxntot, nzcnt + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none +!---------------------------------------------- +! ... dummy arguments +!---------------------------------------------- + real(r8), intent(in) :: y(gas_pcnst) + real(r8), intent(in) :: rxt(rxntot) + real(r8), intent(in) :: het_rates(max(1,gas_pcnst)) + real(r8), intent(inout) :: mat(nzcnt) + call linmat01( mat, y, rxt, het_rates ) + end subroutine linmat + end module mo_lin_matrix diff --git a/src/chemistry/pp_trop_mam_oslo/mo_lu_factor.F90 b/src/chemistry/pp_trop_mam_oslo/mo_lu_factor.F90 new file mode 100644 index 0000000000..703de44018 --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_lu_factor.F90 @@ -0,0 +1,57 @@ + module mo_lu_factor + private + public :: lu_fac + contains + subroutine lu_fac01( lu ) + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none +!----------------------------------------------------------------------- +! ... dummy args +!----------------------------------------------------------------------- + real(r8), intent(inout) :: lu(:) + lu(1) = 1._r8 / lu(1) + lu(2) = lu(2) * lu(1) + lu(3) = lu(3) * lu(1) + lu(4) = lu(4) * lu(1) + lu(5) = 1._r8 / lu(5) + lu(6) = lu(6) * lu(5) + lu(7) = 1._r8 / lu(7) + lu(8) = lu(8) * lu(7) + lu(9) = 1._r8 / lu(9) + lu(10) = 1._r8 / lu(10) + lu(11) = 1._r8 / lu(11) + lu(12) = 1._r8 / lu(12) + lu(13) = 1._r8 / lu(13) + lu(14) = 1._r8 / lu(14) + lu(15) = 1._r8 / lu(15) + lu(16) = 1._r8 / lu(16) + lu(17) = 1._r8 / lu(17) + lu(18) = 1._r8 / lu(18) + lu(19) = 1._r8 / lu(19) + lu(20) = 1._r8 / lu(20) + lu(21) = 1._r8 / lu(21) + lu(22) = 1._r8 / lu(22) + lu(23) = 1._r8 / lu(23) + lu(24) = 1._r8 / lu(24) + lu(25) = 1._r8 / lu(25) + lu(26) = 1._r8 / lu(26) + lu(27) = 1._r8 / lu(27) + lu(28) = 1._r8 / lu(28) + lu(29) = 1._r8 / lu(29) + lu(30) = 1._r8 / lu(30) + lu(31) = 1._r8 / lu(31) + lu(32) = 1._r8 / lu(32) + lu(35) = 1._r8 / lu(35) + lu(37) = 1._r8 / lu(37) + lu(38) = 1._r8 / lu(38) + end subroutine lu_fac01 + subroutine lu_fac( lu ) + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none +!----------------------------------------------------------------------- +! ... dummy args +!----------------------------------------------------------------------- + real(r8), intent(inout) :: lu(:) + call lu_fac01( lu ) + end subroutine lu_fac + end module mo_lu_factor diff --git a/src/chemistry/pp_trop_mam_oslo/mo_lu_solve.F90 b/src/chemistry/pp_trop_mam_oslo/mo_lu_solve.F90 new file mode 100644 index 0000000000..862191c56b --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_lu_solve.F90 @@ -0,0 +1,90 @@ + module mo_lu_solve + private + public :: lu_slv + contains + subroutine lu_slv01( lu, b ) + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, nzcnt + implicit none +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real(r8), intent(in) :: lu(:) + real(r8), intent(inout) :: b(:) +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... solve L * y = b +!----------------------------------------------------------------------- + b(2) = b(2) - lu(2) * b(1) + b(26) = b(26) - lu(3) * b(1) + b(27) = b(27) - lu(4) * b(1) + b(23) = b(23) - lu(6) * b(2) + b(30) = b(30) - lu(8) * b(3) + end subroutine lu_slv01 + subroutine lu_slv02( lu, b ) + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, nzcnt + implicit none +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real(r8), intent(in) :: lu(:) + real(r8), intent(inout) :: b(:) +!----------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... solve L * y = b +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! ... Solve U * x = y +!----------------------------------------------------------------------- + b(30) = b(30) * lu(38) + b(29) = b(29) * lu(37) + b(27) = b(27) - lu(36) * b(29) + b(28) = b(28) * lu(35) + b(27) = b(27) - lu(34) * b(28) + b(26) = b(26) - lu(33) * b(28) + b(27) = b(27) * lu(32) + b(26) = b(26) * lu(31) + b(25) = b(25) * lu(30) + b(24) = b(24) * lu(29) + b(23) = b(23) * lu(28) + b(22) = b(22) * lu(27) + b(21) = b(21) * lu(26) + b(20) = b(20) * lu(25) + b(19) = b(19) * lu(24) + b(18) = b(18) * lu(23) + b(17) = b(17) * lu(22) + b(16) = b(16) * lu(21) + b(15) = b(15) * lu(20) + b(14) = b(14) * lu(19) + b(13) = b(13) * lu(18) + b(12) = b(12) * lu(17) + b(11) = b(11) * lu(16) + b(10) = b(10) * lu(15) + b(9) = b(9) * lu(14) + b(8) = b(8) * lu(13) + b(7) = b(7) * lu(12) + b(6) = b(6) * lu(11) + b(5) = b(5) * lu(10) + b(4) = b(4) * lu(9) + b(3) = b(3) * lu(7) + b(2) = b(2) * lu(5) + b(1) = b(1) * lu(1) + end subroutine lu_slv02 + subroutine lu_slv( lu, b ) + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : clscnt4, nzcnt + implicit none +!----------------------------------------------------------------------- +! ... Dummy args +!----------------------------------------------------------------------- + real(r8), intent(in) :: lu(:) + real(r8), intent(inout) :: b(:) + call lu_slv01( lu, b ) + call lu_slv02( lu, b ) + end subroutine lu_slv + end module mo_lu_solve diff --git a/src/chemistry/pp_trop_mam_oslo/mo_nln_matrix.F90 b/src/chemistry/pp_trop_mam_oslo/mo_nln_matrix.F90 new file mode 100644 index 0000000000..3aa3cd3972 --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_nln_matrix.F90 @@ -0,0 +1,103 @@ + module mo_nln_matrix + use shr_kind_mod, only : r8 => shr_kind_r8 + private + public :: nlnmat + contains + subroutine nlnmat( mat, y, rxt, lmat, dti ) + use chem_mods, only : gas_pcnst, rxntot, nzcnt + implicit none +!---------------------------------------------- +! ... dummy arguments +!---------------------------------------------- + real(r8), intent(in) :: dti + real(r8), intent(in) :: lmat(nzcnt) + real(r8), intent(in) :: y(gas_pcnst) + real(r8), intent(in) :: rxt(rxntot) + real(r8), intent(inout) :: mat(nzcnt) + call nlnmat_finit( mat, lmat, dti ) + end subroutine nlnmat + subroutine nlnmat_finit( mat, lmat, dti ) + use chem_mods, only : gas_pcnst, rxntot, nzcnt + implicit none +!---------------------------------------------- +! ... dummy arguments +!---------------------------------------------- + real(r8), intent(in) :: dti + real(r8), intent(in) :: lmat(nzcnt) + real(r8), intent(inout) :: mat(nzcnt) +!---------------------------------------------- +! ... local variables +!---------------------------------------------- +!---------------------------------------------- +! ... complete matrix entries implicit species +!---------------------------------------------- + mat( 1) = lmat( 1) + mat( 2) = lmat( 2) + mat( 3) = lmat( 3) + mat( 4) = lmat( 4) + mat( 5) = lmat( 5) + mat( 6) = lmat( 6) + mat( 7) = lmat( 7) + mat( 8) = lmat( 8) + mat( 9) = lmat( 9) + mat( 10) = lmat( 10) + mat( 11) = lmat( 11) + mat( 12) = lmat( 12) + mat( 13) = lmat( 13) + mat( 14) = lmat( 14) + mat( 15) = lmat( 15) + mat( 16) = lmat( 16) + mat( 17) = lmat( 17) + mat( 18) = lmat( 18) + mat( 19) = lmat( 19) + mat( 20) = lmat( 20) + mat( 21) = lmat( 21) + mat( 22) = lmat( 22) + mat( 23) = lmat( 23) + mat( 24) = lmat( 24) + mat( 25) = lmat( 25) + mat( 26) = lmat( 26) + mat( 27) = lmat( 27) + mat( 28) = lmat( 28) + mat( 29) = lmat( 29) + mat( 30) = lmat( 30) + mat( 31) = lmat( 31) + mat( 32) = lmat( 32) + mat( 33) = lmat( 33) + mat( 34) = lmat( 34) + mat( 35) = lmat( 35) + mat( 36) = lmat( 36) + mat( 37) = lmat( 37) + mat( 38) = lmat( 38) + mat( 1) = mat( 1) - dti + mat( 5) = mat( 5) - dti + mat( 7) = mat( 7) - dti + mat( 9) = mat( 9) - dti + mat( 10) = mat( 10) - dti + mat( 11) = mat( 11) - dti + mat( 12) = mat( 12) - dti + mat( 13) = mat( 13) - dti + mat( 14) = mat( 14) - dti + mat( 15) = mat( 15) - dti + mat( 16) = mat( 16) - dti + mat( 17) = mat( 17) - dti + mat( 18) = mat( 18) - dti + mat( 19) = mat( 19) - dti + mat( 20) = mat( 20) - dti + mat( 21) = mat( 21) - dti + mat( 22) = mat( 22) - dti + mat( 23) = mat( 23) - dti + mat( 24) = mat( 24) - dti + mat( 25) = mat( 25) - dti + mat( 26) = mat( 26) - dti + mat( 27) = mat( 27) - dti + mat( 28) = mat( 28) - dti + mat( 29) = mat( 29) - dti + mat( 30) = mat( 30) - dti + mat( 31) = mat( 31) - dti + mat( 32) = mat( 32) - dti + mat( 35) = mat( 35) - dti + mat( 37) = mat( 37) - dti + mat( 38) = mat( 38) - dti + end subroutine nlnmat_finit + end module mo_nln_matrix diff --git a/src/chemistry/pp_trop_mam_oslo/mo_phtadj.F90 b/src/chemistry/pp_trop_mam_oslo/mo_phtadj.F90 new file mode 100644 index 0000000000..aaa43829fe --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_phtadj.F90 @@ -0,0 +1,24 @@ + module mo_phtadj + private + public :: phtadj + contains + subroutine phtadj( p_rate, inv, m, ncol, nlev ) + use chem_mods, only : nfs, phtcnt + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none +!-------------------------------------------------------------------- +! ... dummy arguments +!-------------------------------------------------------------------- + integer, intent(in) :: ncol, nlev + real(r8), intent(in) :: inv(ncol,nlev,max(1,nfs)) + real(r8), intent(in) :: m(ncol,nlev) + real(r8), intent(inout) :: p_rate(ncol,nlev,max(1,phtcnt)) +!-------------------------------------------------------------------- +! ... local variables +!-------------------------------------------------------------------- + integer :: k + real(r8) :: im(ncol,nlev) + do k = 1,nlev + end do + end subroutine phtadj + end module mo_phtadj diff --git a/src/chemistry/pp_trop_mam_oslo/mo_prod_loss.F90 b/src/chemistry/pp_trop_mam_oslo/mo_prod_loss.F90 new file mode 100644 index 0000000000..0cbb77be48 --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_prod_loss.F90 @@ -0,0 +1,97 @@ + module mo_prod_loss + use shr_kind_mod, only : r8 => shr_kind_r8 + private + public :: exp_prod_loss + public :: imp_prod_loss + contains + subroutine exp_prod_loss( prod, loss, y, rxt, het_rates ) + use ppgrid, only : pver + implicit none +!-------------------------------------------------------------------- +! ... dummy args +!-------------------------------------------------------------------- + real(r8), dimension(:,:,:), intent(out) :: & + prod, & + loss + real(r8), intent(in) :: y(:,:,:) + real(r8), intent(in) :: rxt(:,:,:) + real(r8), intent(in) :: het_rates(:,:,:) + end subroutine exp_prod_loss + subroutine imp_prod_loss( prod, loss, y, rxt, het_rates ) + use ppgrid, only : pver + implicit none +!-------------------------------------------------------------------- +! ... dummy args +!-------------------------------------------------------------------- + real(r8), dimension(:), intent(out) :: & + prod, & + loss + real(r8), intent(in) :: y(:) + real(r8), intent(in) :: rxt(:) + real(r8), intent(in) :: het_rates(:) +!-------------------------------------------------------------------- +! ... loss and production for Implicit method +!-------------------------------------------------------------------- + loss(1) = ( + rxt(4) + rxt(5) + rxt(7) + het_rates(3))* y(3) + prod(1) = 0._r8 + loss(2) = ( + rxt(6) + het_rates(1))* y(1) + prod(2) = (rxt(4) +rxt(5) +.750_r8*rxt(7))*y(3) + loss(3) = ( + rxt(1) + rxt(3) + het_rates(4))* y(4) + prod(3) = 0._r8 + loss(4) = ( + het_rates(5))* y(5) + prod(4) = 0._r8 + loss(5) = ( + het_rates(6))* y(6) + prod(5) = 0._r8 + loss(6) = ( + het_rates(7))* y(7) + prod(6) = 0._r8 + loss(7) = ( + het_rates(8))* y(8) + prod(7) = 0._r8 + loss(8) = ( + het_rates(9))* y(9) + prod(8) = 0._r8 + loss(9) = ( + het_rates(10))* y(10) + prod(9) = 0._r8 + loss(10) = ( + het_rates(11))* y(11) + prod(10) = 0._r8 + loss(11) = ( + het_rates(12))* y(12) + prod(11) = 0._r8 + loss(12) = ( + het_rates(13))* y(13) + prod(12) = 0._r8 + loss(13) = ( + het_rates(14))* y(14) + prod(13) = 0._r8 + loss(14) = ( + het_rates(15))* y(15) + prod(14) = 0._r8 + loss(15) = ( + het_rates(16))* y(16) + prod(15) = 0._r8 + loss(16) = ( + het_rates(17))* y(17) + prod(16) = 0._r8 + loss(17) = ( + het_rates(18))* y(18) + prod(17) = 0._r8 + loss(18) = ( + het_rates(19))* y(19) + prod(18) = 0._r8 + loss(19) = ( + het_rates(20))* y(20) + prod(19) = 0._r8 + loss(20) = ( + het_rates(21))* y(21) + prod(20) = 0._r8 + loss(21) = ( + het_rates(22))* y(22) + prod(21) = 0._r8 + loss(22) = ( + het_rates(23))* y(23) + prod(22) = 0._r8 + loss(23) = ( + het_rates(2))* y(2) + prod(23) =rxt(6)*y(1) + loss(24) = ( + het_rates(24))* y(24) + prod(24) = 0._r8 + loss(25) = ( + het_rates(25))* y(25) + prod(25) = 0._r8 + loss(26) = ( + het_rates(26))* y(26) + prod(26) =.029_r8*rxt(7)*y(3) +.150_r8*rxt(8)*y(28) + loss(27) = ( + het_rates(27))* y(27) + prod(27) = (.050_r8*rxt(11) +.050_r8*rxt(12) +.050_r8*rxt(13))*y(29) & + + (.150_r8*rxt(9) +.150_r8*rxt(10))*y(28) +.114_r8*rxt(7)*y(3) + loss(28) = ( + rxt(8) + rxt(9) + rxt(10) + het_rates(28))* y(28) + prod(28) = 0._r8 + loss(29) = ( + rxt(11) + rxt(12) + rxt(13) + het_rates(29))* y(29) + prod(29) = 0._r8 + loss(30) = ( + het_rates(30))* y(30) + prod(30) =rxt(3)*y(4) + end subroutine imp_prod_loss + end module mo_prod_loss diff --git a/src/chemistry/pp_trop_mam_oslo/mo_rxt_rates_conv.F90 b/src/chemistry/pp_trop_mam_oslo/mo_rxt_rates_conv.F90 new file mode 100644 index 0000000000..7f9000e78e --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_rxt_rates_conv.F90 @@ -0,0 +1,25 @@ +module mo_rxt_rates_conv + use shr_kind_mod, only : r8 => shr_kind_r8 + implicit none + private + public :: set_rates +contains + subroutine set_rates( rxt_rates, sol, ncol ) + real(r8), intent(inout) :: rxt_rates(:,:,:) + real(r8), intent(in) :: sol(:,:,:) + integer, intent(in) :: ncol + rxt_rates(:ncol,:, 1) = rxt_rates(:ncol,:, 1)*sol(:ncol,:, 4) ! rate_const*H2O2 + ! rate_const + rxt_rates(:ncol,:, 3) = rxt_rates(:ncol,:, 3)*sol(:ncol,:, 4) ! rate_const*OH*H2O2 + rxt_rates(:ncol,:, 4) = rxt_rates(:ncol,:, 4)*sol(:ncol,:, 3) ! rate_const*OH*DMS + rxt_rates(:ncol,:, 5) = rxt_rates(:ncol,:, 5)*sol(:ncol,:, 3) ! rate_const*NO3*DMS + rxt_rates(:ncol,:, 6) = rxt_rates(:ncol,:, 6)*sol(:ncol,:, 1) ! rate_const*OH*M*SO2 + rxt_rates(:ncol,:, 7) = rxt_rates(:ncol,:, 7)*sol(:ncol,:, 3) ! rate_const*OH*DMS + rxt_rates(:ncol,:, 8) = rxt_rates(:ncol,:, 8)*sol(:ncol,:, 28) ! rate_const*O3*monoterp + rxt_rates(:ncol,:, 9) = rxt_rates(:ncol,:, 9)*sol(:ncol,:, 28) ! rate_const*OH*monoterp + rxt_rates(:ncol,:, 10) = rxt_rates(:ncol,:, 10)*sol(:ncol,:, 28) ! rate_const*NO3*monoterp + rxt_rates(:ncol,:, 11) = rxt_rates(:ncol,:, 11)*sol(:ncol,:, 29) ! rate_const*O3*isoprene + rxt_rates(:ncol,:, 12) = rxt_rates(:ncol,:, 12)*sol(:ncol,:, 29) ! rate_const*OH*isoprene + rxt_rates(:ncol,:, 13) = rxt_rates(:ncol,:, 13)*sol(:ncol,:, 29) ! rate_const*NO3*isoprene + end subroutine set_rates +end module mo_rxt_rates_conv diff --git a/src/chemistry/pp_trop_mam_oslo/mo_setrxt.F90 b/src/chemistry/pp_trop_mam_oslo/mo_setrxt.F90 new file mode 100644 index 0000000000..b9909e2e6b --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_setrxt.F90 @@ -0,0 +1,90 @@ + + module mo_setrxt + + use shr_kind_mod, only : r8 => shr_kind_r8 + + private + public :: setrxt + public :: setrxt_hrates + + contains + + subroutine setrxt( rate, temp, m, ncol ) + + use ppgrid, only : pver, pcols + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : rxntot + use mo_jpl, only : jpl + + implicit none + +!------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------- + integer, intent(in) :: ncol + real(r8), intent(in) :: temp(pcols,pver) + real(r8), intent(in) :: m(ncol,pver) + real(r8), intent(inout) :: rate(ncol,pver,rxntot) + +!------------------------------------------------------- +! ... local variables +!------------------------------------------------------- + integer :: n + real(r8) :: itemp(ncol,pver) + real(r8) :: exp_fac(ncol,pver) + real(r8) :: ko(ncol,pver) + real(r8) :: kinf(ncol,pver) + + itemp(:ncol,:) = 1._r8 / temp(:ncol,:) + n = ncol*pver + rate(:,:,3) = 2.9e-12_r8 * exp( -160._r8 * itemp(:,:) ) + rate(:,:,4) = 9.6e-12_r8 * exp( -234._r8 * itemp(:,:) ) + rate(:,:,5) = 1.9e-13_r8 * exp( 520._r8 * itemp(:,:) ) + rate(:,:,8) = 8.05e-16_r8 * exp( -640._r8 * itemp(:,:) ) + rate(:,:,9) = 1.2e-11_r8 * exp( 440._r8 * itemp(:,:) ) + rate(:,:,10) = 1.2e-12_r8 * exp( 490._r8 * itemp(:,:) ) + rate(:,:,11) = 1.03e-14_r8 * exp( -1995._r8 * itemp(:,:) ) + rate(:,:,12) = 2.7e-11_r8 * exp( 390._r8 * itemp(:,:) ) + rate(:,:,13) = 3.15e-12_r8 * exp( -450._r8 * itemp(:,:) ) + + itemp(:,:) = 300._r8 * itemp(:,:) + + ko(:,:) = 3.0e-31_r8 * itemp(:,:)**3.3_r8 + kinf(:,:) = 1.5e-12_r8 + call jpl( rate(1,1,6), m, 0.6_r8, ko, kinf, n ) + + end subroutine setrxt + + + subroutine setrxt_hrates( rate, temp, m, ncol, kbot ) + + use ppgrid, only : pver, pcols + use shr_kind_mod, only : r8 => shr_kind_r8 + use chem_mods, only : rxntot + use mo_jpl, only : jpl + + implicit none + +!------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: kbot + real(r8), intent(in) :: temp(pcols,pver) + real(r8), intent(in) :: m(ncol,pver) + real(r8), intent(inout) :: rate(ncol,pver,rxntot) + +!------------------------------------------------------- +! ... local variables +!------------------------------------------------------- + integer :: n + real(r8) :: itemp(ncol,kbot) + real(r8) :: exp_fac(ncol,kbot) + real(r8) :: ko(ncol,kbot) + real(r8) :: kinf(ncol,kbot) + real(r8) :: wrk(ncol,kbot) + + + end subroutine setrxt_hrates + + end module mo_setrxt diff --git a/src/chemistry/pp_trop_mam_oslo/mo_sim_dat.F90 b/src/chemistry/pp_trop_mam_oslo/mo_sim_dat.F90 new file mode 100644 index 0000000000..ff81ecfc5d --- /dev/null +++ b/src/chemistry/pp_trop_mam_oslo/mo_sim_dat.F90 @@ -0,0 +1,132 @@ + + module mo_sim_dat + + private + public :: set_sim_dat + + contains + + subroutine set_sim_dat + + use chem_mods, only : clscnt, cls_rxt_cnt, clsmap, permute, adv_mass, fix_mass, crb_mass + use chem_mods, only : diag_map + use chem_mods, only : phtcnt, rxt_tag_cnt, rxt_tag_lst, rxt_tag_map + use chem_mods, only : pht_alias_lst, pht_alias_mult + use chem_mods, only : extfrc_lst, inv_lst, slvd_lst + use chem_mods, only : enthalpy_cnt, cph_enthalpy, cph_rid, num_rnts, rxntot + use cam_abortutils,only : endrun + use mo_tracname, only : solsym + use chem_mods, only : frc_from_dataset + use chem_mods, only : is_scalar, is_vector + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_logfile, only : iulog + + implicit none + +!-------------------------------------------------------------- +! ... local variables +!-------------------------------------------------------------- + integer :: ios + + is_scalar = .true. + is_vector = .false. + + clscnt(:) = (/ 0, 0, 0, 30, 0 /) + + cls_rxt_cnt(:,4) = (/ 1, 12, 0, 30 /) + + solsym(: 30) = (/ 'SO2 ','H2SO4 ','DMS ','H2O2 ','SO4_NA ', & + 'SO4_A1 ','SO4_A2 ','SO4_AC ','SO4_PR ','BC_N ', & + 'BC_AX ','BC_NI ','BC_A ','BC_AI ','BC_AC ', & + 'OM_NI ','OM_AI ','OM_AC ','DST_A2 ','DST_A3 ', & + 'SS_A1 ','SS_A2 ','SS_A3 ','SOA_NA ','SOA_A1 ', & + 'SOA_LV ','SOA_SV ','monoterp ','isoprene ','H2O ' /) + + adv_mass(: 30) = (/ 64.064800_r8, 98.078400_r8, 62.132400_r8, 34.013600_r8, 98.078400_r8, & + 98.078400_r8, 115.107340_r8, 98.078400_r8, 98.078400_r8, 12.011000_r8, & + 12.011000_r8, 12.011000_r8, 12.011000_r8, 12.011000_r8, 12.011000_r8, & + 12.011000_r8, 12.011000_r8, 12.011000_r8, 135.064039_r8, 135.064039_r8, & + 58.442468_r8, 58.442468_r8, 58.442468_r8, 168.227200_r8, 168.227200_r8, & + 168.227200_r8, 168.227200_r8, 136.228400_r8, 68.114200_r8, 18.014200_r8 /) + + crb_mass(: 30) = (/ 0.000000_r8, 0.000000_r8, 24.022000_r8, 0.000000_r8, 0.000000_r8, & + 0.000000_r8, 0.000000_r8, 0.000000_r8, 0.000000_r8, 12.011000_r8, & + 12.011000_r8, 12.011000_r8, 12.011000_r8, 12.011000_r8, 12.011000_r8, & + 12.011000_r8, 12.011000_r8, 12.011000_r8, 0.000000_r8, 0.000000_r8, & + 0.000000_r8, 0.000000_r8, 0.000000_r8, 120.110000_r8, 120.110000_r8, & + 120.110000_r8, 120.110000_r8, 120.110000_r8, 60.055000_r8, 0.000000_r8 /) + + fix_mass(: 7) = (/ 0.00000000_r8, 28.0134800_r8, 31.9988000_r8, 47.9982000_r8, 17.0068000_r8, & + 62.0049400_r8, 33.0062000_r8 /) + + clsmap(: 30,4) = (/ 3, 1, 4, 5, 6, 7, 8, 9, 10, 11, & + 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, & + 22, 23, 2, 24, 25, 26, 27, 28, 29, 30 /) + + permute(: 30,4) = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30 /) + + diag_map(: 30) = (/ 1, 5, 7, 9, 10, 11, 12, 13, 14, 15, & + 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, & + 26, 27, 28, 29, 30, 31, 32, 35, 37, 38 /) + + extfrc_lst(: 7) = (/ 'SO2 ','BC_NI ','BC_AX ','BC_N ','OM_NI ', & + 'SO4_PR ','H2O ' /) + + frc_from_dataset(: 7) = (/ .true., .true., .true., .true., .true., & + .true., .true. /) + + inv_lst(: 7) = (/ 'M ', 'N2 ', 'O2 ', 'O3 ', 'OH ', & + 'NO3 ', 'HO2 ' /) + + if( allocated( rxt_tag_lst ) ) then + deallocate( rxt_tag_lst ) + end if + allocate( rxt_tag_lst(rxt_tag_cnt),stat=ios ) + if( ios /= 0 ) then + write(iulog,*) 'set_sim_dat: failed to allocate rxt_tag_lst; error = ',ios + call endrun + end if + if( allocated( rxt_tag_map ) ) then + deallocate( rxt_tag_map ) + end if + allocate( rxt_tag_map(rxt_tag_cnt),stat=ios ) + if( ios /= 0 ) then + write(iulog,*) 'set_sim_dat: failed to allocate rxt_tag_map; error = ',ios + call endrun + end if + rxt_tag_lst( 1: 3) = (/ 'jh2o2 ', 'usr_HO2_HO2 ', & + 'usr_DMS_OH ' /) + rxt_tag_map(:rxt_tag_cnt) = (/ 1, 2, 7 /) + if( allocated( pht_alias_lst ) ) then + deallocate( pht_alias_lst ) + end if + allocate( pht_alias_lst(phtcnt,2),stat=ios ) + if( ios /= 0 ) then + write(iulog,*) 'set_sim_dat: failed to allocate pht_alias_lst; error = ',ios + call endrun + end if + if( allocated( pht_alias_mult ) ) then + deallocate( pht_alias_mult ) + end if + allocate( pht_alias_mult(phtcnt,2),stat=ios ) + if( ios /= 0 ) then + write(iulog,*) 'set_sim_dat: failed to allocate pht_alias_mult; error = ',ios + call endrun + end if + pht_alias_lst(:,1) = (/ ' ' /) + pht_alias_lst(:,2) = (/ ' ' /) + pht_alias_mult(:,1) = (/ 1._r8 /) + pht_alias_mult(:,2) = (/ 1._r8 /) + allocate( num_rnts(rxntot-phtcnt),stat=ios ) + if( ios /= 0 ) then + write(iulog,*) 'set_sim_dat: failed to allocate num_rnts; error = ',ios + call endrun + end if + num_rnts(:) = (/ 2, 2, 2, 2, 3, 2, 2, 2, 2, 2, & + 2, 2 /) + + end subroutine set_sim_dat + + end module mo_sim_dat diff --git a/src/chemistry/utils/prescribed_volcaero.F90 b/src/chemistry/utils/prescribed_volcaero.F90 index 092310a7b9..a8792c7a4d 100644 --- a/src/chemistry/utils/prescribed_volcaero.F90 +++ b/src/chemistry/utils/prescribed_volcaero.F90 @@ -24,6 +24,7 @@ module prescribed_volcaero public :: write_prescribed_volcaero_restart public :: read_prescribed_volcaero_restart public :: has_prescribed_volcaero + public :: has_prescribed_volcaero_cmip6,solar_bands,terrestrial_bands public :: init_prescribed_volcaero_restart @@ -45,6 +46,11 @@ module prescribed_volcaero integer :: fixed_tod = 0 integer :: radius_ndx + ! CMIP6 extension + logical, save :: has_prescribed_volcaero_cmip6 = .false. + integer, parameter :: solar_bands=14, terrestrial_bands=16 + character(len=256) :: locfn + contains !------------------------------------------------------------------- @@ -54,6 +60,10 @@ subroutine prescribed_volcaero_readnl(nlfile) use namelist_utils, only: find_group_name use units, only: getunit, freeunit use mpishorthand + ! CMIP6 + use cam_pio_utils, only : cam_pio_openfile, init_pio_subsystem + use pio, only : pio_inquire, file_desc_t, pio_inq_dimname + use pio, only : pio_nowrite, pio_closefile, pio_noerr character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -61,6 +71,11 @@ subroutine prescribed_volcaero_readnl(nlfile) integer :: unitn, ierr character(len=*), parameter :: subname = 'prescribed_volcaero_readnl' + ! CMIP6 + integer :: dimid,ndims + type(file_desc_t) :: ncid + character(len=80) :: dimname + character(len=16) :: prescribed_volcaero_name character(len=256) :: prescribed_volcaero_file character(len=256) :: prescribed_volcaero_filelist @@ -136,6 +151,28 @@ subroutine prescribed_volcaero_readnl(nlfile) ! Turn on prescribed volcanics if user has specified an input dataset. if (len_trim(filename) > 0 .and. filename.ne.'NONE') has_prescribed_volcaero = .true. + ! Check if input file contains CMIP6 forcing + if (has_prescribed_volcaero) then + if (len_trim(datapath) > 0 ) then + locfn=trim(datapath)//'/'//trim(filename) + else + locfn=trim(filename) + endif + call init_pio_subsystem + call cam_pio_openfile(ncid,locfn,PIO_NOWRITE) + ierr = pio_inquire(ncid,ndimensions=ndims) + do dimid=1,ndims + ierr = pio_inq_dimname(ncid,dimid,dimname) + ! assume CMIP6 if vertical coordinate is altitude + if ( trim(dimname) == 'altitude' ) then + has_prescribed_volcaero = .false. + has_prescribed_volcaero_cmip6 = .true. + endif + enddo + call pio_closefile(ncid) + endif + + end subroutine prescribed_volcaero_readnl !------------------------------------------------------------------- @@ -146,12 +183,32 @@ subroutine prescribed_volcaero_register() integer :: idx + ! CMIP6 + integer :: band + character(len=3) :: c3 + if (has_prescribed_volcaero) then call pbuf_add_field(volcaero_name,'physpkg',dtype_r8,(/pcols,pver/),idx) call pbuf_add_field(volcrad_name, 'physpkg',dtype_r8,(/pcols,pver/),idx) endif + ! CMIP6 + if (has_prescribed_volcaero_cmip6) then + do band=1,solar_bands + write(c3,'(i3)') band + call pbuf_add_field('ext_sun'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + call pbuf_add_field('omega_sun'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + call pbuf_add_field('g_sun'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + enddo + do band=1,terrestrial_bands + write(c3,'(i3)') band + call pbuf_add_field('ext_earth'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + call pbuf_add_field('omega_earth'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + call pbuf_add_field('g_earth'//trim(adjustl(c3)),'physpkg',dtype_r8,(/pcols,pver/),idx) + enddo + endif + endsubroutine prescribed_volcaero_register !------------------------------------------------------------------- @@ -160,15 +217,24 @@ subroutine prescribed_volcaero_init() use tracer_data, only : trcdata_init use cam_history, only : addfld, horiz_only - use physics_buffer, only : pbuf_get_index + use ppgrid, only : pver + use error_messages, only: handle_err + use ppgrid, only: pcols, pver, begchunk, endchunk + + use physics_buffer, only : physics_buffer_desc, pbuf_get_index implicit none integer :: ndx, istat integer :: errcode character(len=32) :: specifier(1) + + ! CMIP6 + integer :: band + character(len=3) :: c3 + character(len=32) :: specifier_cmip6(3*(solar_bands+terrestrial_bands)) - if ( has_prescribed_volcaero ) then + if ( has_prescribed_volcaero .or. has_prescribed_volcaero_cmip6 ) then if ( masterproc ) then write(iulog,*) 'volcanic aerosol is prescribed in :'//trim(filename) endif @@ -176,6 +242,9 @@ subroutine prescribed_volcaero_init() return endif + ! not CMIP6 + if ( has_prescribed_volcaero ) then + specifier(1) = trim(volcaero_name)//':'//trim(fld_name) @@ -192,6 +261,35 @@ subroutine prescribed_volcaero_init() radius_ndx = pbuf_get_index(volcrad_name, errcode) + ! CMIP6 + else + + do band=1,solar_bands + write(c3,'(i3)') band + specifier_cmip6(band*3-2) = 'ext_sun'//trim(adjustl(c3))//':'//'ext_sun'//trim(adjustl(c3)) + specifier_cmip6(band*3-1) = 'omega_sun'//trim(adjustl(c3))//':'//'omega_sun'//trim(adjustl(c3)) + specifier_cmip6(band*3-0) = 'g_sun'//trim(adjustl(c3))//':'//'g_sun'//trim(adjustl(c3)) + call addfld('ext_sun'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1/km', 'Extinction coefficient of solar bands' ) + call addfld('omega_sun'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1', 'Single scattering albedo of solar bands' ) + call addfld('g_sun'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1', 'Asymmetry factor of solar bands' ) + enddo + do band=1,terrestrial_bands + write(c3,'(i3)') band + specifier_cmip6((solar_bands+band)*3-2) = 'ext_earth'//trim(adjustl(c3))//':'//'ext_earth'//trim(adjustl(c3)) + specifier_cmip6((solar_bands+band)*3-1) = 'omega_earth'//trim(adjustl(c3))//':'//'omega_earth'//trim(adjustl(c3)) + specifier_cmip6((solar_bands+band)*3-0) = 'g_earth'//trim(adjustl(c3))//':'//'g_earth'//trim(adjustl(c3)) + call addfld('ext_earth'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1/km', 'Extinction coefficient of terrestrial bands' ) + call addfld('omega_earth'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1', 'Single scattering albedo of terrestrial bands' ) + call addfld('g_earth'//trim(adjustl(c3)),(/ 'lev' /), 'I', '1', 'Asymmetry factor of terrestrial bands' ) + enddo + + allocate(file%in_pbuf(size(specifier_cmip6))) + file%in_pbuf(:) = .true. + call trcdata_init( specifier_cmip6, filename, filelist, datapath, fields, file, & + rmv_file, cycle_yr, fixed_ymd, fixed_tod, data_type) + + endif + end subroutine prescribed_volcaero_init !------------------------------------------------------------------- @@ -235,10 +333,17 @@ subroutine prescribed_volcaero_adv( state, pbuf2d) !WACCM-derived relation between mass concentration and wet aerosol radius in meters real(r8),parameter :: radius_conversion = 1.9e-4_r8 - if( .not. has_prescribed_volcaero ) return + ! CMIP6 + integer :: band + character(len=3) :: c3 + + if ( .not. (has_prescribed_volcaero .or. has_prescribed_volcaero_cmip6) ) return call advance_trcdata( fields, file, state, pbuf2d ) + ! not CMIP6 + if ( has_prescribed_volcaero ) then + ! copy prescribed tracer fields into state svariable with the correct units do c = begchunk,endchunk pbuf_chnk => pbuf_get_chunk(pbuf2d, c) @@ -285,6 +390,65 @@ subroutine prescribed_volcaero_adv( state, pbuf2d) enddo + ! CMIP6 + else + + do c = begchunk,endchunk + pbuf_chnk => pbuf_get_chunk(pbuf2d, c) + call tropopause_find(state(c), tropLev, primary=TROP_ALG_TWMO, backup=TROP_ALG_CLIMATE) + ncol = state(c)%ncol + do band=1,solar_bands + write(c3,'(i3)') band + call pbuf_get_field(pbuf_chnk, fields(band*3-2)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0._r8 + enddo + enddo + call outfld('ext_sun'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + call pbuf_get_field(pbuf_chnk, fields(band*3-1)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0.999_r8 + enddo + enddo + call outfld('omega_sun'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + call pbuf_get_field(pbuf_chnk, fields(band*3-0)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0.5_r8 + enddo + enddo + call outfld('g_sun'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + enddo + do band=1,terrestrial_bands + write(c3,'(i3)') band + call pbuf_get_field(pbuf_chnk, fields((solar_bands+band)*3-2)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0._r8 + enddo + enddo + call outfld('ext_earth'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + call pbuf_get_field(pbuf_chnk, fields((solar_bands+band)*3-1)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0.999_r8 + enddo + enddo + call outfld('omega_earth'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + call pbuf_get_field(pbuf_chnk, fields((solar_bands+band)*3-0)%pbuf_ndx, data) + do i = 1,ncol + do k = 1,pver + if ( k >= tropLev(i) ) data(i,k) = 0.5_r8 + enddo + enddo + call outfld('g_earth'//trim(adjustl(c3)),data(:,:), pcols, state(c)%lchnk) + enddo + enddo + + endif + end subroutine prescribed_volcaero_adv !------------------------------------------------------------------- diff --git a/src/control/cam_history.F90 b/src/control/cam_history.F90 index 0f08e35904..465d51e1d3 100644 --- a/src/control/cam_history.F90 +++ b/src/control/cam_history.F90 @@ -2215,6 +2215,8 @@ subroutine fldlst () ! on that grid. integer, allocatable :: gridsontape(:,:) + logical, parameter :: i_am_a_nazi_arse=.false. !+tht if T exit on error + ! ! First ensure contents of fincl, fexcl, and fwrtpr are all valid names ! @@ -2232,9 +2234,12 @@ subroutine fldlst () write(iulog,*) trim(errormsg) call shr_sys_flush(iulog) end if + fincl(f:pflds-1,t)=fincl(f+1:pflds,t) + fincl(pflds,t)=' ' errors_found = errors_found + 1 + else + f = f + 1 end if - f = f + 1 end do f = 1 @@ -2242,16 +2247,18 @@ subroutine fldlst () mastername='' listentry => get_entry_by_name(masterlinkedlist, fexcl(f,t)) if(associated(listentry)) mastername = listentry%field%name - if (fexcl(f,t) /= mastername) then write(errormsg,'(3a,2(i0,a))')'FLDLST: ', trim(fexcl(f,t)), ' in fexcl(', f,', ',t, ') not found' if (masterproc) then write(iulog,*) trim(errormsg) call shr_sys_flush(iulog) end if + fexcl(f:pflds-1,t)=fexcl(f+1:pflds,t) + fexcl(pflds,t)=' ' errors_found = errors_found + 1 + else + f = f + 1 end if - f = f + 1 end do f = 1 @@ -2286,7 +2293,7 @@ subroutine fldlst () ! Give masterproc a chance to write all the log messages call mpi_barrier(mpicom, t) write(errormsg, '(a,i0,a)') 'FLDLST: ',errors_found,' errors found, see log' - call endrun(trim(errormsg)) + if (i_am_a_nazi_arse) call endrun(trim(errormsg)) end if nflds(:) = 0 diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90 index 7f1e3364c4..619d9b5b61 100644 --- a/src/control/ncdio_atm.F90 +++ b/src/control/ncdio_atm.F90 @@ -207,6 +207,7 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & else call pio_setframe(ncid, varid, int(1,kind=pio_offset_kind)) end if + ndims = ndims - 1 end if ! NB: strt and cnt were initialized to 1 @@ -625,6 +626,7 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & else call pio_setframe(ncid, varid, int(1,kind=pio_offset_kind)) end if + ndims = ndims - 1 end if field_dnames(1) = dimname1 diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index f390d45744..53b36d061f 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -38,6 +38,9 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use physconst, only: physconst_readnl use physics_buffer, only: pbuf_readnl use phys_control, only: phys_ctl_readnl +#ifdef OSLO_AERO + use oslo_control, only: oslo_ctl_readnl +#endif use wv_saturation, only: wv_sat_readnl use ref_pres, only: ref_pres_readnl use cam3_aero_data, only: cam3_aero_data_readnl @@ -179,6 +182,9 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call rayleigh_friction_readnl(nlfilename) #if ( defined OFFLINE_DYN ) call metdata_readnl(nlfilename) +#endif +#if (defined OSLO_AERO) + call oslo_ctl_readnl(nlfilename) #endif call offline_driver_readnl(nlfilename) call analytic_ic_readnl(nlfilename) diff --git a/src/dynamics/fv/cd_core.F90 b/src/dynamics/fv/cd_core.F90 index e679a1d144..de71ae6450 100644 --- a/src/dynamics/fv/cd_core.F90 +++ b/src/dynamics/fv/cd_core.F90 @@ -12,7 +12,7 @@ subroutine cd_core(grid, nx, u, v, pt, & mlt, ncx, ncy, nmfx, nmfy, iremote, & cxtag, cytag, mfxtag, mfytag, & cxreqs, cyreqs, mfxreqs, mfyreqs, & - kmtp, am_correction, am_fixer, dod, don ,high_order_top) + kmtp, am_correction, am_geom_crrct, am_fixer, dod, don ,high_order_top) ! Dynamical core for both C- and D-grid Lagrangian dynamics ! @@ -82,6 +82,7 @@ subroutine cd_core(grid, nx, u, v, pt, & real(r8), intent(in) :: del2coef integer, intent(in) :: kmtp ! range of levels (1:kmtp) where order is reduced logical, intent(in) :: am_correction ! logical switch for correction (applied here) + logical, intent(in) :: am_geom_crrct ! logical switch for correction (applied here) logical, intent(in) :: am_fixer ! logical switch for fixer (generate out args) logical, intent(in) :: high_order_top ! use uniform 4th order everywhere (incl. model top) @@ -168,6 +169,11 @@ subroutine cd_core(grid, nx, u, v, pt, & real(r8), intent(out) :: & ptk(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) +!+diag 3/7/2017 local array + real(r8) :: & + ucc(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d,grid%kfirst:grid%klast) ! u-Winds correction +!-diag + ! C.-C. Chen, omega calculation real(r8), intent(out) :: & cx_om(grid%im,grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ! Courant in X @@ -229,7 +235,7 @@ subroutine cd_core(grid, nx, u, v, pt, & integer :: npes_yz integer i, j, k, ml - integer js1g1, js2g0, js2g1, jn2g1 ,js4g0,jn3g0 + integer js1g1, js2g0, js2g1, jn2g1 ,js4g0 ,jn3g0 integer jn2g0, jn1g1 integer iord , jord @@ -290,6 +296,12 @@ subroutine cd_core(grid, nx, u, v, pt, & real(r8) :: ptr(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast+1) logical :: sw_am_corr + logical :: am_press_crrct !+tht 11.05.2019 + real(r8):: wg_hiord !+tht 11.05.2019 + +!+tht 12.10.2017 + real(r8) tpr, acap +!-tht 12.10.2017 !****************************************************************** !****************************************************************** @@ -371,6 +383,15 @@ subroutine cd_core(grid, nx, u, v, pt, & endif #endif +!+tht 11.05.2019 + am_press_crrct = am_geom_crrct.and.am_correction + if (am_press_crrct) then + wg_hiord =-D1_0 + else + wg_hiord = D0_0 + endif +!-tht 11.05.2019 + npes_yz = grid%npes_yz im = grid%im @@ -399,14 +420,25 @@ subroutine cd_core(grid, nx, u, v, pt, & kelp(grid%im,grid%jfirst-1:grid%jlast ,grid%kfirst:grid%klast ), & dpn(grid%im,grid%jfirst :grid%jlast ,grid%kfirst:grid%klast ), & dpo(grid%im,grid%jfirst :grid%jlast ,grid%kfirst:grid%klast ) ) +!+tht 12/04/2019 +! define polar cap contributions correctly + acap=1._r8/4._r8 ! effective AM/MoI contribution from polar caps +!-tht 12/04/2019 + endif + if (am_press_crrct) then + allocate( & + dpr(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast ) ) + xakap = 1._r8/cap3vc(1,jfirst,kfirst) endif if (am_correction) then allocate( & - dpr(grid%im,grid%jfirst-1:grid%jlast+1,grid%kfirst:grid%klast ), & ddpu(grid%im,grid%jfirst :grid%jlast ,grid%kfirst:grid%klast ), & dpns(grid%jfirst:grid%jlast,grid%kfirst:grid%klast), & ddus(grid%jfirst:grid%jlast,grid%kfirst:grid%klast) ) - xakap = 1._r8/cap3vc(1,jfirst,kfirst) +!+tht 04.07.2017 + ddus = 0._r8 + ucc = 0._r8 +!-tht 04.07.2017 else xakap = 1._r8 endif @@ -454,6 +486,7 @@ subroutine cd_core(grid, nx, u, v, pt, & jn2g0 = min(jm-1,jlast) jn1g1 = min(jm,jlast+1) jn2g1 = min(jm-1,jlast+1) + js4g0 = max(4,jfirst) jn3g0 = min(jm-2,jlast) @@ -732,7 +765,7 @@ subroutine cd_core(grid, nx, u, v, pt, & ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & u_cen(1,jfirst-ng_d,k), v_cen(1,jfirst-ng_s,k), & - reset_winds, met_rlx(k), am_correction) + reset_winds, met_rlx(k), am_geom_crrct) ! Optionally filter advecting C-grid winds if (filtcw .gt. 0) then @@ -780,7 +813,7 @@ subroutine cd_core(grid, nx, u, v, pt, & ua(1,jfirst-ng_d,k), va(1,jfirst-ng_s,k), & uc(1,jfirst-ng_d,k), vc(1,jfirst-2,k), & ptc(1,jfirst,k), delpf(1,jfirst-ng_d,k), & - ptk(1,jfirst,k), tiny, iord, jord, am_correction) + ptk(1,jfirst,k), tiny, iord, jord, am_geom_crrct) end do call FVstopclock(grid,'---C_CORE') @@ -1044,7 +1077,7 @@ subroutine cd_core(grid, nx, u, v, pt, & do k = kfirst, klast do j = js2g0, jn2g0 - if (am_correction) then + if (am_press_crrct) then do i = 1, im ! AM fix: ensure interior pressure torque vanishes @@ -1125,7 +1158,7 @@ subroutine cd_core(grid, nx, u, v, pt, & call FVstartclock(grid,'---C_V_PGRAD') - if (am_correction) then + if (am_press_crrct) then !$omp parallel do private(i, j, k) ! AM correction (pressure, advective winds): pxc -> ptr do k = kfirst, klast+1 @@ -1308,8 +1341,20 @@ subroutine cd_core(grid, nx, u, v, pt, & dpo(i,j,k)=(kelp(i,j,k)*cosp(j)+kelp(i,j-1,k)*cosp(j-1))/(cosp(j)+cosp(j-1)) ! A->D end do end do + if (jfirst.eq.1) then + do i = 1, im + dpn(i, 2,k)=(help(i, 2 ,k)*cosp( 2 )+acap*help(i, 1,k)*cose( 2))/cosp( 2 ) + dpo(i, 2,k)=(kelp(i, 2 ,k)*cosp( 2 )+acap*kelp(i, 1,k)*cose( 2))/cosp( 2 ) + end do + endif + if (jlast.eq.jm) then + do i = 1, im + dpn(i,jm,k)=(help(i,jm-1,k)*cosp(jm-1)+acap*help(i,jm,k)*cose(jm))/cosp(jm-1) + dpo(i,jm,k)=(kelp(i,jm-1,k)*cosp(jm-1)+acap*kelp(i,jm,k)*cose(jm))/cosp(jm-1) + end do + endif end do - + if (am_correction) then !$omp parallel do private(i, j, k) do k = kfirst, klast @@ -1324,7 +1369,7 @@ subroutine cd_core(grid, nx, u, v, pt, & do k = kfirst, klast do j = js2g0, jlast do i = 1, im - ddu(i,j,k)=ddu(i,j,k)* D0_5*(dpo(i,j,k)+dpn(i,j,k)*3._r8)*D0_5 + ddu(i,j,k)=ddu(i,j,k)* D0_5*(dpo(i,j,k)+dpn(i,j,k) ) ! new 05/03/2019 end do end do end do @@ -1332,15 +1377,23 @@ subroutine cd_core(grid, nx, u, v, pt, & !$omp parallel do private(i, j, k) do k = kfirst, klast do j = js2g0, jlast - ddus(j,k) = ddu(1,j,k) + (u(1,j,k) + uc(1,j,k)/D4_0)*ddpu(1,j,k) - & - vf(1,j,k)*(dpn(1,j,k) - dpo(1,j,k))*D0_5 + ddus(j,k) = ddu(1,j,k) & + + (u(1,j,k) + uc(1,j,k)*D0_5)*ddpu(1,j,k) & ! new 05/03/2019 + + wg_hiord*vf(1,j,k)*(dpn(1,j,k) - dpo(1,j,k))*D0_5 dpns(j,k) = dpn(1,j,k) do i = 2, im - ddus(j,k) = ddus(j,k) + ddu(i,j,k) +(u(i,j,k)+uc(i,j,k)/D4_0)*ddpu(i,j,k) - & - vf(i,j,k)*(dpn(i,j,k)-dpo(i,j,k))*D0_5 + ddus(j,k) = ddus(j,k) & + + ddu(i,j,k) & + + (u(i,j,k)+uc(i,j,k)*D0_5)*ddpu(i,j,k) & ! new 05/03/2019 + + wg_hiord*vf(i,j,k)*(dpn(i,j,k)-dpo(i,j,k))*D0_5 dpns(j,k) = dpns(j,k) + dpn(i,j,k) end do ddus(j,k) = ddus(j,k)/dpns(j,k) +!+tht 12.10.2017 taper beyond 72S/N + tpr = max(abs(-2.5_r8 + ((j-1)-0.5_r8)*(5._r8/(jm-1))),2._r8) + tpr = cos(pi*tpr)**2 + ddus(j,k)=ddus(j,k)*tpr +!-tht 12.10.2017 end do end do @@ -1349,6 +1402,9 @@ subroutine cd_core(grid, nx, u, v, pt, & do j = js4g0, jn3g0 do i = 1, im !+++++++++++++++++++++++++++++++++++++++++++++ uc(i,j,k) = uc(i,j,k) + ddus(j,k) ! APPLY AM CORRECTION +!+tht correction diagnostic + ucc(i,j,k)= ddus(j,k) +!-tht enddo !+++++++++++++++++++++++++++++++++++++++++++++ enddo enddo @@ -1356,26 +1412,40 @@ subroutine cd_core(grid, nx, u, v, pt, & end if ! (am_correction) if (am_fixer) then - + if (.not.am_geom_crrct) then +!$omp parallel do private(i, j, k) + do k = kfirst, klast + do j = js2g0, jlast + do i = 1, im + dpn(i,j,k)=(help(i,j,k) +help(i,j-1,k) )/( 2._r8 ) + dpo(i,j,k)=(kelp(i,j,k) +kelp(i,j-1,k) )/( 2._r8 ) + end do + end do + if (jfirst.eq.1) then + do i = 1, im + dpn(i, 2,k)=(help(i, 2 ,k) + help(i, 1,k) )/( 2._r8 ) + dpo(i, 2,k)=(kelp(i, 2 ,k) + kelp(i, 1,k) )/( 2._r8 ) + end do + endif + if (jlast.eq.jm) then + do i = 1, im + dpn(i,jm,k)=(help(i,jm-1,k) + help(i,jm,k) )/( 2._r8 ) + dpo(i,jm,k)=(kelp(i,jm-1,k) + kelp(i,jm,k) )/( 2._r8 ) + end do + endif + end do + endif !$omp parallel do private(i, j, k) do k = kfirst, klast do j = js2g0, jlast do i = 1, im don(j,k) = don(j,k) + (cosp(j) + cosp(j-1))*cose(j) & *(uc(i,j,k)*dpn(i,j,k) & - + (u(i,j,k) + cose(j)*oma)*(dpn(i,j,k) - dpo(i,j,k))) + +(u(i,j,k) + cose(j)*oma)*(dpn(i,j,k)-dpo(i,j,k))) dod(j,k) = dod(j,k) + (cosp(j) + cosp(j-1))*cose(j)**2*dpn(i,j,k) end do end do - - ! north pole - if (jfirst == 1) then - do i = 1, im - dod(1,k) = dod(1,k) + grid%acap/(D0_5*im)*cose(1)**2*help(i,1,k) - end do - end if end do - end if ! (am_fixer) call FVstopclock(grid,'---dp4corr_COMM_2') @@ -1683,8 +1753,8 @@ subroutine cd_core(grid, nx, u, v, pt, & end if call FVstopclock(grid,'---PRE_D_PGRAD_COMM_1') #endif - - if (am_correction) then + + if (am_press_crrct) then ! AM correction (pressure, prognostic winds): pkc -> ptr !$omp parallel do private(i, j, k) do k = kfirst, klast+1 @@ -1705,7 +1775,7 @@ subroutine cd_core(grid, nx, u, v, pt, & end do endif - if (am_correction) then + if (am_press_crrct) then !$omp parallel do private(i, j, k) ! Beware k+1 references directly below (AAM) do k = kfirst, klast @@ -1758,7 +1828,7 @@ subroutine cd_core(grid, nx, u, v, pt, & cycle end if - if (am_correction) then + if (am_press_crrct) then do j=js2g1,jn2g0 ! wk3 needed S wk3(1,j) = (wz(1,j,k)+wz(im,j,k)) * & (ptr(1,j,k) - ptr(im,j,k)) @@ -1808,7 +1878,7 @@ subroutine cd_core(grid, nx, u, v, pt, & ! N-S walls do j=js2g0,jn1g1 ! wk1 needed N - if (am_correction) then + if (am_press_crrct) then do i=1,im wk1(i,j) = (wz(i,j,k) + wz(i,j-1,k))*(ptr(i,j,k) - ptr(i,j-1,k)) enddo @@ -1846,7 +1916,7 @@ subroutine cd_core(grid, nx, u, v, pt, & enddo enddo - if (am_correction) then + if (am_press_crrct) then ! use true pressure for wk1, then update it do j = js1g1, jn1g1 @@ -1873,7 +1943,7 @@ subroutine cd_core(grid, nx, u, v, pt, & !$omp parallel do private(i, j, k, wk, wk1, wk2, wk3) do k = kfirst, klast - if (am_correction) then + if (am_press_crrct) then do j = js1g1, jn1g1 wk1(1,j) = dpr(1,j,k) + dpr(im,j,k) do i = 2, im @@ -1913,7 +1983,16 @@ subroutine cd_core(grid, nx, u, v, pt, & * (wk2(im,j)-wk2(1,j)+wz3(im,j,k+1)-wz3(im,j,k)) end do - if (am_correction) then +!+tht replace in output adv.tend. diag with correction diag 3/7/2017 + !do j = js2g0, jlast + ! do i = 1, im-1 + ! uc(i,j,k) = ucc(i,j,k) + ! end do + ! uc(im,j,k) = ucc(im,j,k) + !end do +!-tht + + if (am_geom_crrct) then ! apply cos-weighted avg'ing do j = js2g0, jn2g0 ! Assumes wk2 ghosted on N do i = 1, im diff --git a/src/dynamics/fv/ctem.F90 b/src/dynamics/fv/ctem.F90 index 4d39bb6105..f036875f3e 100644 --- a/src/dynamics/fv/ctem.F90 +++ b/src/dynamics/fv/ctem.F90 @@ -57,7 +57,7 @@ subroutine ctem_diags( u3, v3, omga, pt, h2o, ps, pe, grid) ! ... local variables !------------------------------------------------------------- real(r8), parameter :: hscale = 7000._r8 ! pressure scale height - real(r8), parameter :: navp = 1.e35_r8 + real(r8), parameter :: navp = 1.e35_r8 !+tht use this only for T, missing winds are set to zero real(r8) :: pinterp real(r8) :: w(grid%ifirstxy:grid%ilastxy,plev,grid%jfirstxy:grid%jlastxy) ! vertical velocity @@ -301,19 +301,24 @@ subroutine ctem_diags( u3, v3, omga, pt, h2o, ps, pe, grid) do k = ip_b+1, plevp if( has_zm(k,j) ) then rdiv(k) = 1._r8/count( ip_gm1g(:,j) >= k ) +!+tht define zonal mean winds taking zero for below-ground value + u2d(k,j) = um(k) * rplon + v2d(k,j) = vm(k) * rplon + w2d(k,j) = wm(k) * rplon +!-tht um(k) = um(k) * rdiv(k) vm(k) = vm(k) * rdiv(k) wm(k) = wm(k) * rdiv(k) thm(k) = thm(k) * rdiv(k) - u2d(k,j) = um(k) - v2d(k,j) = vm(k) + !u2d(k,j) = um(k) !+tht c'd out + !v2d(k,j) = vm(k) !+tht c'd out th2d(k,j) = thm(k) - w2d(k,j) = wm(k) + !w2d(k,j) = wm(k) !+tht c'd out else - u2d(k,j) = navp - v2d(k,j) = navp + u2d(k,j) = 0._r8 ! navp + v2d(k,j) = 0._r8 ! navp th2d(k,j) = navp - w2d(k,j) = navp + w2d(k,j) = 0._r8 ! navp end if end do @@ -411,10 +416,10 @@ subroutine ctem_diags( u3, v3, omga, pt, h2o, ps, pe, grid) uw(k,j) = uw(k,j) * rdiv(k) uv(k,j) = uv(k,j) * rdiv(k) else - vth(k,j) = navp - wth(k,j) = navp - uw(k,j) = navp - uv(k,j) = navp + vth(k,j) = 0._r8 ! navp + wth(k,j) = 0._r8 ! navp + uw(k,j) = 0._r8 ! navp + uv(k,j) = 0._r8 ! navp end if end do diff --git a/src/dynamics/fv/d2a3dikj.F90 b/src/dynamics/fv/d2a3dikj.F90 index fe3ffbb8c3..2ff9bbd748 100644 --- a/src/dynamics/fv/d2a3dikj.F90 +++ b/src/dynamics/fv/d2a3dikj.F90 @@ -14,7 +14,7 @@ module d2a3dikj_mod ! ! !INTERFACE: - subroutine d2a3dikj(grid, am_correction, u, v, ua, va) + subroutine d2a3dikj(grid, am_geom_crrct, u, v, ua, va) ! !USES: @@ -36,7 +36,7 @@ subroutine d2a3dikj(grid, am_correction, u, v, ua, va) implicit none ! !INPUT PARAMETERS: type (t_fvdycore_grid), intent(in) :: grid - logical, intent(in) :: am_correction + logical, intent(in) :: am_geom_crrct real(r8), intent(in) :: u(grid%ifirstxy:grid%ilastxy, & grid%jfirstxy:grid%jlastxy,grid%km) ! U-Wind real(r8), intent(in) :: v(grid%ifirstxy:grid%ilastxy, & @@ -127,7 +127,7 @@ subroutine d2a3dikj(grid, am_correction, u, v, ua, va) if ( jlastxy .lt. jm ) then - if (am_correction) then + if (am_geom_crrct) then !$omp parallel do private(i, k) do k = 1, km do i = ifirstxy, ilastxy @@ -146,7 +146,7 @@ subroutine d2a3dikj(grid, am_correction, u, v, ua, va) end if #endif - if (am_correction) then + if (am_geom_crrct) then !$omp parallel do private(i,j,k) do k = 1, km do j = jfirstxy, jlastxy-1 diff --git a/src/dynamics/fv/dp_coupling.F90 b/src/dynamics/fv/dp_coupling.F90 index 61f2465308..031084bfa7 100644 --- a/src/dynamics/fv/dp_coupling.F90 +++ b/src/dynamics/fv/dp_coupling.F90 @@ -270,7 +270,7 @@ subroutine d_p_coupling(grid, phys_state, phys_tend, pbuf2d, dyn_out) allocate (v3(ifirstxy:ilastxy, km, jfirstxy:jlastxy)) if (iam .lt. grid%npes_xy) then - call d2a3dikj(grid, dyn_state%am_correction, u3sxy, v3sxy, u3, v3) + call d2a3dikj(grid, dyn_state%am_geom_crrct, u3sxy, v3sxy, u3, v3) end if ! (iam .lt. grid%npes_xy) call t_stopf ('d2a3dikj') @@ -303,9 +303,9 @@ subroutine d_p_coupling(grid, phys_state, phys_tend, pbuf2d, dyn_out) if (iam .lt. grid%npes_xy) then ! (note dummy use of dva3 hence call order matters) - call d2a3dikj(grid, dyn_state%am_correction,duf3sxy, dummy, duf3 ,dva3) - call d2a3dikj(grid, dyn_state%am_correction,dua3sxy, dva3sxy, dua3, dva3) - call d2a3dikj(grid, dyn_state%am_correction, du3sxy, dv3sxy, du3 , dv3 ) + call d2a3dikj(grid, dyn_state%am_geom_crrct,duf3sxy, dummy, duf3 ,dva3) + call d2a3dikj(grid, dyn_state%am_geom_crrct,dua3sxy, dva3sxy, dua3, dva3) + call d2a3dikj(grid, dyn_state%am_geom_crrct, du3sxy, dv3sxy, du3 , dv3 ) end if ! (iam .lt. grid%npes_xy) call t_startf('DP_CPLN_fv_am') @@ -949,7 +949,7 @@ subroutine p_d_coupling(grid, phys_state, phys_tend, & call t_startf('uv3s_update') if (iam .lt. grid%npes_xy) then call uv3s_update(grid, dudtxy, u3sxy, dvdtxy, v3sxy, dt5, & - dyn_state%am_correction) + dyn_state%am_geom_crrct) end if ! (iam .lt. grid%npes_xy) call t_stopf('uv3s_update') diff --git a/src/dynamics/fv/dyn_comp.F90 b/src/dynamics/fv/dyn_comp.F90 index a16f0672e0..a8a2e2fe88 100644 --- a/src/dynamics/fv/dyn_comp.F90 +++ b/src/dynamics/fv/dyn_comp.F90 @@ -183,15 +183,18 @@ subroutine dyn_readnl(nlfilename) real(r8):: fv_del2coef = 3.e5_r8 ! strength of 2nd order velocity damping logical :: fv_high_altitude = .false. ! switch to apply variables appropriate for high-altitude physics - logical :: fv_am_correction = .false. ! apply correction for angular momentum (AM) - ! conservation in SW eqns - logical :: fv_am_fixer = .false. ! apply global fixer to conserve AM - logical :: fv_am_fix_lbl = .false. ! apply global AM fixer level by level - logical :: fv_am_diag = .false. ! turns on an AM diagnostic calculation written to log file + logical :: fv_high_order_top=.false.! do not degrade calculation to 1st order near the model top + + logical :: fv_am_correction=.false. ! apply correction for angular momentum (AM) in SW eqns + logical :: fv_am_geom_crrct=.false. ! apply correction for angular momentum (AM) in geometry + logical :: fv_am_fixer =.false. ! apply global fixer to conserve AM + logical :: fv_am_fix_lbl =.false. ! apply global AM fixer level by level + logical :: fv_am_diag =.false. ! turns on an AM diagnostic calculation written to log file namelist /dyn_fv_inparm/ fv_nsplit, fv_nspltrac, fv_nspltvrm, fv_iord, fv_jord, & fv_kord, fv_conserve, fv_filtcw, fv_fft_flt, & - fv_div24del2flag, fv_del2coef, fv_am_correction, & + fv_div24del2flag, fv_del2coef, fv_high_order_top, & + fv_am_correction, fv_am_geom_crrct, & fv_am_fixer, fv_am_fix_lbl, fv_am_diag, fv_high_altitude, & fv_print_dpcoup_warn @@ -253,9 +256,15 @@ subroutine dyn_readnl(nlfilename) call mpi_bcast(fv_del2coef, 1, mpi_real8, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: fv_del2coef") + call mpi_bcast(fv_high_order_top, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: fv_high_order_top") + call mpi_bcast(fv_am_correction, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: fv_am_correction") + call mpi_bcast(fv_am_geom_crrct, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: fv_am_geom_crrct") + ! if fv_am_fix_lbl is true then fv_am_fixer must also be true. if (fv_am_fix_lbl .and. .not. fv_am_fixer) then fv_am_fixer = .true. @@ -326,7 +335,9 @@ subroutine dyn_readnl(nlfilename) dyn_state%div24del2flag = fv_div24del2flag dyn_state%del2coef = fv_del2coef + dyn_state%high_order_top= fv_high_order_top dyn_state%am_correction = fv_am_correction + dyn_state%am_geom_crrct = fv_am_geom_crrct dyn_state%am_fixer = fv_am_fixer dyn_state%am_fix_lbl = fv_am_fix_lbl dyn_state%am_diag = fv_am_diag @@ -349,7 +360,8 @@ subroutine dyn_readnl(nlfilename) write(iulog,*)' FFT filter (fv_fft_flt) = ', fv_fft_flt write(iulog,*)' Divergence/velocity damping (fv_div24del2flag) = ', fv_div24del2flag write(iulog,*)' Coef for 2nd order velocity damping (fv_del2coef) = ', fv_del2coef - write(iulog,*)' ' + write(iulog,*)' High-order top = ', fv_high_order_top + write(iulog,*)' Geometry & pressure corr. for AM (fv_am_geom_crrct) = ', fv_am_geom_crrct write(iulog,*)' Angular momentum (AM) correction (fv_am_correction) = ', fv_am_correction write(iulog,*)' Apply AM fixer (fv_am_fixer) = ', fv_am_fixer write(iulog,*)' Level by level AM fixer (fv_am_fix_lbl) = ', fv_am_fix_lbl @@ -1033,6 +1045,7 @@ subroutine dyn_run(ptop, ndt, te0, dyn_state, dyn_in, dyn_out, rc) ! angular momentum (AM) conservation logical :: am_correction ! apply AM correction? + logical :: am_geom_crrct ! apply AM geom. corr? logical :: am_fixer ! apply AM fixer? logical :: am_fix_lbl ! apply fixer separately on each shallow-water layer? logical :: am_fix_taper=.false. ! def. no tapering; modified if global fixer applied or high_order_top=.false. @@ -1072,7 +1085,7 @@ subroutine dyn_run(ptop, ndt, te0, dyn_state, dyn_in, dyn_out, rc) ! NOTE -- model behaviour with high_order_top=true is still under validation and may require ! some other form of enhanced damping in the top layer - logical, parameter :: high_order_top=.false. + logical :: high_order_top !-------------------------------------------------------------------------------------- kmtp=dyn_state%grid%km/8 @@ -1118,7 +1131,9 @@ subroutine dyn_run(ptop, ndt, te0, dyn_state, dyn_in, dyn_out, rc) high_alt = grid%high_alt consv = dyn_state%consv + high_order_top= dyn_state%high_order_top am_correction = dyn_state%am_correction + am_geom_crrct = dyn_state%am_geom_crrct am_fixer = dyn_state%am_fixer am_fix_lbl = dyn_state%am_fix_lbl am_diag = dyn_state%am_diag @@ -1856,7 +1871,7 @@ subroutine dyn_run(ptop, ndt, te0, dyn_state, dyn_in, dyn_out, rc) cxtaga, cytaga, mfxtaga, mfytaga, cdcreqs(1,1), & cdcreqs(1,2), cdcreqs(1,3), cdcreqs(1,4), & kmtp, & - am_correction, am_fix_out, dod, don ,high_order_top) + am_correction, am_geom_crrct, am_fix_out, dod, don ,high_order_top) ctreqs(2,:) = cdcreqs(:,1) ctreqs(3,:) = cdcreqs(:,2) @@ -2620,7 +2635,7 @@ subroutine dyn_run(ptop, ndt, te0, dyn_state, dyn_in, dyn_out, rc) phisxy, cp3v, cap3v, kord, pelnxy, & te0, tempxy, dp0xy, mfxxy, mfyxy, & uc_i, vc_i, du_fix_s, du_fix_i, & - am_correction, (am_fixer.or.am_diag) ) + am_geom_crrct, (am_fixer.or.am_diag) ) if (am_diag) then !$omp parallel do private(i,j,k) diff --git a/src/dynamics/fv/dyn_grid.F90 b/src/dynamics/fv/dyn_grid.F90 index eaf43e2d5e..722fd8e6fe 100644 --- a/src/dynamics/fv/dyn_grid.F90 +++ b/src/dynamics/fv/dyn_grid.F90 @@ -130,7 +130,7 @@ subroutine dyn_grid_init() ! Initialize FV specific grid object variables dt = get_step_size() call grid_vars_init(pi, rearth, omega, dt, state%fft_flt, & - state%am_correction, grid) + state%am_geom_crrct, grid) ! initialize commap variables diff --git a/src/dynamics/fv/dynamics_vars.F90 b/src/dynamics/fv/dynamics_vars.F90 index 3f66fb538a..dc07854fb7 100644 --- a/src/dynamics/fv/dynamics_vars.F90 +++ b/src/dynamics/fv/dynamics_vars.F90 @@ -295,6 +295,8 @@ module dynamics_vars integer :: div24del2flag ! 2 for 2nd order div damping, 4 for 4th order div damping, ! 42 for 4th order div damping plus 2nd order velocity damping real(r8) :: del2coef ! strength of 2nd order velocity damping + logical :: high_order_top! use normal 4-order PPM calculation near the model top + logical :: am_geom_crrct ! apply correction for angular momentum (AM) conservation in geometry logical :: am_correction ! apply correction for angular momentum (AM) conservation in SW eqns logical :: am_fixer ! apply global fixer to conserve AM logical :: am_fix_lbl ! apply global AM fixer level by level @@ -720,7 +722,7 @@ end subroutine spmd_vars_init !======================================================================================== subroutine grid_vars_init(pi, ae, om, dt, fft_flt, & - am_correction, grid) + am_geom_crrct, grid) ! Initialize FV specific GRID vars ! @@ -739,7 +741,7 @@ subroutine grid_vars_init(pi, ae, om, dt, fft_flt, & real(r8), intent(in) :: om ! angular velocity of earth's rotation real(r8), intent(in) :: dt integer, intent(in) :: fft_flt - logical, intent(in) :: am_correction + logical, intent(in) :: am_geom_crrct type( T_FVDYCORE_GRID ), intent(inout) :: grid @@ -812,7 +814,7 @@ subroutine grid_vars_init(pi, ae, om, dt, fft_flt, & ! Define cosine at edges.. - if (am_correction) then + if (am_geom_crrct) then do j = 2, jm ph5 = -0.5_r8*pi + ((j-1)-0.5_r8)*(pi/(jm-1._r8)) cose(j) = cos(ph5) @@ -830,7 +832,7 @@ subroutine grid_vars_init(pi, ae, om, dt, fft_flt, & sinp( 1) = -1._r8 sinp(jm) = 1._r8 - if (am_correction) then + if (am_geom_crrct) then do j = 2, jm-1 sinp(j) = (cose(j) - cose(j+1))/grid%dp ! sqrt(cosp^2+sinp^2)=1 end do @@ -954,7 +956,7 @@ subroutine grid_vars_init(pi, ae, om, dt, fft_flt, & ! Compute coriolis parameter at cell corners. - if (am_correction) then + if (am_geom_crrct) then do j = js2gc, jn1gc grid%fc(j) = (om+om)*grid%sine(j) end do diff --git a/src/dynamics/fv/sw_core.F90 b/src/dynamics/fv/sw_core.F90 index 823e8c9b10..654b7d151a 100644 --- a/src/dynamics/fv/sw_core.F90 +++ b/src/dynamics/fv/sw_core.F90 @@ -63,7 +63,7 @@ module sw_core subroutine c_sw(grid, u, v, pt, delp, & u2, v2, & uc, vc, ptc, delpf, ptk, & - tiny, iord, jord, am_correction) + tiny, iord, jord, am_geom_crrct) ! Routine for shallow water dynamics on the C-grid @@ -78,7 +78,7 @@ subroutine c_sw(grid, u, v, pt, delp, & type (T_FVDYCORE_GRID), intent(in) :: grid integer, intent(in):: iord integer, intent(in):: jord - logical, intent(in):: am_correction + logical, intent(in):: am_geom_crrct real(r8), intent(in):: u2(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) real(r8), intent(in):: v2(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) @@ -267,7 +267,7 @@ subroutine c_sw(grid, u, v, pt, delp, & ! New va definition - if (am_correction) then + if (am_geom_crrct) then do j=js2g1,jn2g0 ! va needed on S (for YCC, iv==1) do i=1,im ! weight by cos @@ -504,11 +504,11 @@ end subroutine c_sw ! !INTERFACE: subroutine d_sw( grid, u, v, uc, vc, & pt, delp, delpf, cx3, cy3, & - mfx, mfy, cdx, cdy, & + mfx, mfy, cdx, cdy, & cdxde, cdxdp, cdyde, cdydp, & !ldel2 variables cdxdiv, cdydiv, cdx4, cdy4, cdtau4, & ldiv2, ldiv4, ldel2, & - iord, jord, tiny, am_correction, & + iord, jord, tiny, am_correction, & ddp, duc, vf) !-------------------------------------------------------------------------- ! Routine for shallow water dynamics on the D-grid @@ -1376,7 +1376,7 @@ end subroutine d_sw ! ! !INTERFACE: subroutine d2a2c_winds(grid, u, v, ua, va, uc, vc, u_cen, v_cen, & - reset_winds, met_rlx, am_correction) + reset_winds, met_rlx, am_geom_crrct) implicit none @@ -1395,7 +1395,7 @@ subroutine d2a2c_winds(grid, u, v, ua, va, uc, vc, u_cen, v_cen, & real(r8), intent(in):: u_cen(grid%im,grid%jfirst-grid%ng_d:grid%jlast+grid%ng_d) real(r8), intent(in):: v_cen(grid%im,grid%jfirst-grid%ng_s:grid%jlast+grid%ng_d) real(r8), intent(in):: met_rlx - logical, intent(in):: am_correction + logical, intent(in):: am_geom_crrct ! !DESCRIPTION: ! @@ -1553,7 +1553,7 @@ subroutine d2a2c_winds(grid, u, v, ua, va, uc, vc, u_cen, v_cen, & va(im,j) = v(im,j) + v(1,j) enddo - if (am_correction) then + if (am_geom_crrct) then do j = js2gd, jn2gsm1 do i = 1, im ua(i,j) =(u(i,j)*cose(j) + u(i,j+1)*cose(j+1))/cosp(j) ! curl free -> curl free @@ -1637,7 +1637,7 @@ subroutine d2a2c_winds(grid, u, v, ua, va, uc, vc, u_cen, v_cen, & enddo enddo - if (am_correction) then + if (am_geom_crrct) then do j = js2g2, jn1g2 ! vc needed N*2, S*2 (for ycc), va defined at poles do i = 1, im vc(i,j) = D0_25*(va(i,j)*cosp(j) + va(i,j-1)*cosp(j-1))/cose(j) ! div free -> div free diff --git a/src/dynamics/fv/te_map.F90 b/src/dynamics/fv/te_map.F90 index 04fc3a1b72..7044974a45 100644 --- a/src/dynamics/fv/te_map.F90 +++ b/src/dynamics/fv/te_map.F90 @@ -18,7 +18,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & hs, cp3v, cap3v, kord, peln, & te0, te, dz, mfx, mfy, & uc, vc, du_s, du_w, & - am_correction, am_diag_lbl) + am_geom_crrct, am_diag_lbl) ! ! !USES: @@ -84,7 +84,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & real(r8) pkz(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy,grid%km) ! layer-mean pk for converting t to pt ! AM conservation mods - logical, intent(in) :: am_correction ! logical switch for AM correction + logical, intent(in) :: am_geom_crrct ! logical switch for AM correction logical, intent(in) :: am_diag_lbl ! input real(r8), intent(in) :: du_s(grid%km) @@ -628,7 +628,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & if(j /= 1) then - if (am_correction) then + if (am_geom_crrct) then ! WS 99.07.29 : protect j==jfirst case if (j > jfirst) then @@ -678,7 +678,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & enddo enddo - else ! not am_correction + else ! not am_geom_crrct ! WS 99.07.29 : protect j==jfirst case if (j > jfirst) then @@ -710,7 +710,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & #endif endif ! (j > jfirst) - endif ! (am_correction) + endif ! (am_geom_crrct) !------------------------------- @@ -720,7 +720,7 @@ subroutine te_map(grid, consv, convt, ps, omga, & 0, 0, itot, i1-ifirst+1, i2-ifirst+1, & j, jfirst, jlast, -1, kord) - if (am_correction) then + if (am_geom_crrct) then ! compute zonal momentum difference due to remapping do k=1,km diff --git a/src/dynamics/fv/tp_core.F90 b/src/dynamics/fv/tp_core.F90 index 1265dc1582..e27f845a94 100644 --- a/src/dynamics/fv/tp_core.F90 +++ b/src/dynamics/fv/tp_core.F90 @@ -334,8 +334,8 @@ subroutine xtpv(im, ffslv, fxv, qv, cv, iord, mfxv, & real (r8) cos_ppm !critical cosine for ppm parameter (cos_upw = D0_05) !roughly at 87 deg. - parameter (cos_van = D0_25) !roughly at 75 deg. - parameter (cos_ppm = D0_25) + parameter (cos_van = 0.1_r8) !roughly at 84 deg. + parameter (cos_ppm = 0.1_r8) integer i, imp, j real (r8) qmax, qmin diff --git a/src/dynamics/fv/uv3s_update.F90 b/src/dynamics/fv/uv3s_update.F90 index bcf29be3e4..ffd082a82a 100644 --- a/src/dynamics/fv/uv3s_update.F90 +++ b/src/dynamics/fv/uv3s_update.F90 @@ -5,7 +5,7 @@ ! !INTERFACE: subroutine uv3s_update(grid, dua, u3s, dva, v3s, dt5, & - am_correction) + am_geom_crrct) ! !USES: @@ -27,7 +27,7 @@ subroutine uv3s_update(grid, dua, u3s, dva, v3s, dt5, & ! dvdt on A-grid real(r8),intent(in) :: dva(grid%ifirstxy:grid%ilastxy,grid%km,grid%jfirstxy:grid%jlastxy) real(r8),intent(in) :: dt5 ! weighting factor - logical, intent(in) :: am_correction + logical, intent(in) :: am_geom_crrct ! !INPUT/OUTPUT PARAMETERS: real(r8), intent(inout) :: u3s(grid%ifirstxy:grid%ilastxy,grid%jfirstxy:grid%jlastxy, & @@ -121,7 +121,7 @@ subroutine uv3s_update(grid, dua, u3s, dva, v3s, dt5, & ! Adjust D-grid winds by interpolating A-grid tendencies. ! - if (am_correction) then + if (am_geom_crrct) then do j = jfirstxy+1, jlastxy do i = ifirstxy, ilastxy tmp = u3s(i,j,k) @@ -149,7 +149,7 @@ subroutine uv3s_update(grid, dua, u3s, dva, v3s, dt5, & enddo #if defined( SPMD ) - if (am_correction) then + if (am_geom_crrct) then if ( jfirstxy .gt. 1 ) then do i = ifirstxy, ilastxy tmp = u3s(i,jfirstxy,k) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 8b046924d1..0ef3a86f54 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -43,6 +43,7 @@ module cam_diagnostics diag_surf, &! output diagnostics of the surface diag_export, &! output export state diag_physvar_ic, & + diag_phys_writeout_dry, &! output diagnostics of the dynamics nsurf @@ -205,6 +206,15 @@ subroutine diag_init_dry(pbuf2d) call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') if ( dycore_is('LR') .or. dycore_is('SE') ) then call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') +!+tht + call addfld ('EBREAK', horiz_only, 'A','W/m2', 'Global-mean energy-nonconservation (W/m2)') + call addfld ('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & + 'T-tendency due to dry mass adjustment at the end of tphysac' ) + call addfld ('IETEND_DME', horiz_only, 'A','W/m2 ', & + 'Column DSE tendency due to mass adjustment at end of tphysac' ) + call addfld ('EFLX ' , horiz_only, 'A','W/m2 ', & + 'Material enthalpy flux due to mass adjustment at end of tphysac') +!-tht end if call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') @@ -335,6 +345,12 @@ subroutine diag_init_dry(pbuf2d) call add_default (apcnst(1) , history_budget_histfile_num, ' ') if ( dycore_is('LR') .or. dycore_is('SE') ) then call add_default ('TFIX ' , history_budget_histfile_num, ' ') +!+tht + call add_default ('EBREAK ' , history_budget_histfile_num, ' ') + call add_default ('PTTEND_DME', history_budget_histfile_num, ' ') + call add_default ('IETEND_DME', history_budget_histfile_num, ' ') + call add_default ('EFLX ' , history_budget_histfile_num, ' ') +!-tht end if end if @@ -1470,7 +1486,9 @@ subroutine diag_phys_writeout(state, pbuf) type(physics_state), intent(inout) :: state type(physics_buffer_desc), pointer :: pbuf(:) + ! ! Local variable + ! real(r8) :: p_surf_t(pcols, nsurf) ! data interpolated to a pressure surface call diag_phys_writeout_dry(state, pbuf, p_surf_t) @@ -1938,7 +1956,8 @@ end subroutine diag_physvar_ic !####################################################################### - subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + !subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht !--------------------------------------------------------------- ! @@ -1957,13 +1976,18 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) type(physics_tend ), intent(in) :: tend real(r8), intent(in) :: ztodt ! physics timestep + real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) + real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + !---------------------------Local workspace----------------------------- integer :: lchnk ! chunk index integer :: ncol ! number of columns in chunk real(r8) :: ftem2(pcols) ! Temporary workspace for outfld variables real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables - real(r8) :: heat_glob ! global energy integral (FV only) + real(r8) :: heat_glob ! tht: T-tend from fixer (FV only) + real(r8) :: tedif_glob !+tht energy flux from fixer (FV only) ! CAM pointers to get variables from the physics buffer real(r8), pointer, dimension(:,:) :: t_ttend integer :: itim_old,m @@ -1979,13 +2003,25 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) call outfld('UAP', state%u, pcols, lchnk ) call outfld('VAP', state%v, pcols, lchnk ) + !tht: heat tendencies from dme_adjust + if (dycore_is('LR')) then + tmp_t(:ncol,:pver) = (state%t(:ncol,:pver) - tmp_t(:ncol,:pver))/ztodt ! T tendency + call outfld('PTTEND_DME', tmp_t, pcols, lchnk ) + if(present(dsema))call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy + if(present(eflx) )call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy + end if + ! Total physics tendency for Temperature ! (remove global fixer tendency from total for FV and SE dycores) if (dycore_is('LR') .or. dycore_is('SE')) then - call check_energy_get_integrals( heat_glob_out=heat_glob ) + call check_energy_get_integrals( heat_glob_out=heat_glob , tedif_glob_out=tedif_glob ) !+tht tedif ftem2(:ncol) = heat_glob/cpair call outfld('TFIX', ftem2, pcols, lchnk ) +!+tht + ftem2(:ncol) = tedif_glob/ztodt + call outfld('EBREAK', ftem2, pcols, lchnk ) +!-tht ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair else ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) @@ -2113,7 +2149,8 @@ end subroutine diag_phys_tend_writeout_moist !####################################################################### subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & - tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) + ! tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) + tmp_q, tmp_t, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini, eflx, dsema) !+tht !--------------------------------------------------------------- ! @@ -2129,15 +2166,19 @@ subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & type(physics_tend ), intent(in) :: tend real(r8), intent(in) :: ztodt ! physics timestep real(r8) , intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics + real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. !----------------------------------------------------------------------- - call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + !call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht if (moist_physics) then call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index ae5724f938..4bb3da9cce 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -955,7 +955,7 @@ subroutine calc_te_and_aam_budgets(state, outfld_name_suffix) mo_cnst = omega*rearth**4/gravit do k = 1, pver do i = 1, ncol - cos_lat = cos(state%lat(i)) + cos_lat = cos(state%lat(i)) ! *180._r8/pi) !+tht bug fix mr_tmp = mr_cnst*state%u(i,k)*state%pdel(i,k)*cos_lat mo_tmp = mo_cnst*state%pdel(i,k)*cos_lat**2 diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 2531857278..7ba8cc2e66 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -865,6 +865,8 @@ subroutine clubb_ini_cam(pbuf2d) 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') @@ -2600,6 +2602,8 @@ subroutine clubb_tend_cam( & ! 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) diff --git a/src/physics/cam/clubb_intr.F90.beta07 b/src/physics/cam/clubb_intr.F90.beta07 new file mode 100644 index 0000000000..4a998dec85 --- /dev/null +++ b/src/physics/cam/clubb_intr.F90.beta07 @@ -0,0 +1,3649 @@ +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 :: 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, & ! CLUBB eddy diffusivity on thermo levels + kvm_idx, & ! CLUBB eddy diffusivity on mom 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('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_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 + + !----- 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") + + ! 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 ('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', 'Vertical Diffusivity') + + ! 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 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 on momentum grids [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(:,:) :: khzt ! eddy diffusivity on thermo levels [m^2/s] + real(r8), pointer, dimension(:,:) :: khzm ! eddy diffusivity on momentum 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 + +#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, kvm_idx, khzt) + 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. 300._r8) + 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('clubb_tend_cam: CLUBB time step and HOST time step NOT compatible') + endif + + ! 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%lhf(i)/(latvap*rho_ds_zm(1)) ! Latent heat flux + 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) + khzt(i,pverp-k+1) = khzt_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 + khzt(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 + te_b(i) = te_b(i)+(cam_in%shf(i)+(cam_in%lhf(i)/latvap)*(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. + do k=clubbtop+1,pver + clubb_s(k) = clubb_s(k) - se_dis*gravit + enddo + + ! 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', khzt, 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 + + do k=1,pver + do i=1,ncol + if( state1%t(i,k) > 268.15_r8 ) then + dum1 = 0.0_r8 + elseif ( state1%t(i,k) < 238.15_r8 ) then + dum1 = 1.0_r8 + else + dum1 = ( 268.15_r8 - state1%t(i,k) ) / 30._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', temp2d, 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)) + call calc_obklen( ncol, th(1:ncol,pver), thv(1:ncol,pver), cam_in%lhf(1:ncol)/latvap, 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) + + ! 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/physics/cam/phys_control.F90 b/src/physics/cam/phys_control.F90 index 743bcf80ff..45d94af8af 100644 --- a/src/physics/cam/phys_control.F90 +++ b/src/physics/cam/phys_control.F90 @@ -66,8 +66,8 @@ module phys_control logical :: history_chemistry = .true. ! output default chemistry-related variables logical :: history_carma = .false. ! output default CARMA-related variables logical :: history_clubb = .true. ! output default CLUBB-related variables -logical :: history_cesm_forcing = .false. logical :: history_dust = .false. +logical :: history_cesm_forcing = .false. logical :: history_scwaccm_forcing = .false. logical :: history_chemspecies_srf = .false. @@ -100,6 +100,9 @@ module phys_control ! FV dycore angular momentum correction logical, public, protected :: fv_am_correction = .false. +!tht: energy adjustment in dry mass adjustment +logical, public, protected :: dme_energy_adjust = .false. + !======================================================================= contains !======================================================================= @@ -126,7 +129,7 @@ subroutine phys_ctl_readnl(nlfile) history_cesm_forcing, history_scwaccm_forcing, history_chemspecies_srf, & do_clubb_sgs, state_debug_checks, use_hetfrz_classnuc, use_gw_oro, use_gw_front, & use_gw_front_igw, use_gw_convect_dp, use_gw_convect_sh, cld_macmic_num_steps, & - offline_driver, convproc_do_aer + offline_driver, convproc_do_aer, dme_energy_adjust !+tht !----------------------------------------------------------------------------- if (masterproc) then @@ -169,9 +172,9 @@ subroutine phys_ctl_readnl(nlfile) call mpi_bcast(history_chemistry, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_carma, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_clubb, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(history_dust, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_cesm_forcing, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_chemspecies_srf, 1, mpi_logical, masterprocid, mpicom, ierr) - call mpi_bcast(history_dust, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(history_scwaccm_forcing, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(do_clubb_sgs, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(state_debug_checks, 1, mpi_logical, masterprocid, mpicom, ierr) @@ -184,6 +187,7 @@ subroutine phys_ctl_readnl(nlfile) call mpi_bcast(cld_macmic_num_steps, 1, mpi_integer, masterprocid, mpicom, ierr) call mpi_bcast(offline_driver, 1, mpi_logical, masterprocid, mpicom, ierr) call mpi_bcast(convproc_do_aer, 1, mpi_logical, masterprocid, mpicom, ierr) + call mpi_bcast(dme_energy_adjust, 1, mpi_logical, masterprocid, mpicom, ierr) !+tht use_spcam = ( cam_physpkg_is('spcam_sam1mom') & .or. cam_physpkg_is('spcam_m2005')) @@ -280,7 +284,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi history_cesm_forcing_out, history_scwaccm_forcing_out, history_chemspecies_srf_out, & cam_chempkg_out, prog_modal_aero_out, macrop_scheme_out, & do_clubb_sgs_out, use_spcam_out, state_debug_checks_out, cld_macmic_num_steps_out, & - offline_driver_out, convproc_do_aer_out) + offline_driver_out, convproc_do_aer_out, dme_energy_adjust_out) !+tht !----------------------------------------------------------------------- ! Purpose: Return runtime settings ! deep_scheme_out : deep convection scheme @@ -312,9 +316,9 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi logical, intent(out), optional :: history_chemistry_out logical, intent(out), optional :: history_carma_out logical, intent(out), optional :: history_clubb_out + logical, intent(out), optional :: history_dust_out logical, intent(out), optional :: history_cesm_forcing_out logical, intent(out), optional :: history_chemspecies_srf_out - logical, intent(out), optional :: history_dust_out logical, intent(out), optional :: history_scwaccm_forcing_out logical, intent(out), optional :: do_clubb_sgs_out character(len=32), intent(out), optional :: cam_chempkg_out @@ -323,6 +327,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi integer, intent(out), optional :: cld_macmic_num_steps_out logical, intent(out), optional :: offline_driver_out logical, intent(out), optional :: convproc_do_aer_out + logical, intent(out), optional :: dme_energy_adjust_out !+tht if ( present(deep_scheme_out ) ) deep_scheme_out = deep_scheme if ( present(shallow_scheme_out ) ) shallow_scheme_out = shallow_scheme @@ -357,6 +362,7 @@ subroutine phys_getopts(deep_scheme_out, shallow_scheme_out, eddy_scheme_out, mi if ( present(cld_macmic_num_steps_out) ) cld_macmic_num_steps_out = cld_macmic_num_steps if ( present(offline_driver_out ) ) offline_driver_out = offline_driver if ( present(convproc_do_aer_out ) ) convproc_do_aer_out = convproc_do_aer + if ( present(dme_energy_adjust_out ) ) dme_energy_adjust_out = dme_energy_adjust !+tht end subroutine phys_getopts diff --git a/src/physics/cam/physics_types.F90 b/src/physics/cam/physics_types.F90 index f08911ad50..4d1524722f 100644 --- a/src/physics/cam/physics_types.F90 +++ b/src/physics/cam/physics_types.F90 @@ -7,7 +7,7 @@ module physics_types use ppgrid, only: pcols, pver, psubcols use constituents, only: pcnst, qmin, cnst_name use geopotential, only: geopotential_dse, geopotential_t - use physconst, only: zvir, gravit, cpair, rair, cpairv, rairv + use physconst, only: zvir, gravit, cpair, rair, cpairv, rairv, cpliq, cpwv !+tht use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -17,14 +17,14 @@ module physics_types implicit none private ! Make default type private to the module - logical, parameter :: adjust_te = .FALSE. + !logical, parameter :: adjust_te = .FALSE.!-tht (c'd out) ! Public types: public physics_state public physics_tend public physics_ptend - + ! Public interfaces public physics_update @@ -72,15 +72,15 @@ module physics_types u, &! zonal wind (m/s) v, &! meridional wind (m/s) s, &! dry static energy - omega, &! vertical pressure velocity (Pa/s) - pmid, &! midpoint pressure (Pa) - pmiddry, &! midpoint pressure dry (Pa) + omega, &! vertical pressure velocity (Pa/s) + pmid, &! midpoint pressure (Pa) + pmiddry, &! midpoint pressure dry (Pa) pdel, &! layer thickness (Pa) pdeldry, &! layer thickness dry (Pa) rpdel, &! reciprocal of layer thickness (Pa) rpdeldry,&! recipricol layer thickness dry (Pa) lnpmid, &! ln(pmid) - lnpmiddry,&! log midpoint pressure dry (Pa) + lnpmiddry,&! log midpoint pressure dry (Pa) exner, &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp) zm ! geopotential height above surface at midpoints (m) @@ -89,9 +89,9 @@ module physics_types real(r8), dimension(:,:),allocatable :: & pint, &! interface pressure (Pa) - pintdry, &! interface pressure dry (Pa) + pintdry, &! interface pressure dry (Pa) lnpint, &! ln(pint) - lnpintdry,&! log interface pressure dry (Pa) + lnpintdry,&! log interface pressure dry (Pa) zi ! geopotential height above surface at interfaces (m) real(r8), dimension(:),allocatable :: & @@ -171,7 +171,7 @@ subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcol type(physics_tend), pointer :: phys_tend(:) integer, intent(in) :: begchunk, endchunk integer, intent(in) :: psetcols - + integer :: ierr=0, lchnk type(physics_state), pointer :: state type(physics_tend), pointer :: tend @@ -230,8 +230,8 @@ subroutine physics_update(state, ptend, dt, tend) real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer - real(r8),allocatable :: cpairv_loc(:,:,:) - real(r8),allocatable :: rairv_loc(:,:,:) + real(r8),allocatable :: cpairv_loc(:,:) + real(r8),allocatable :: rairv_loc(:,:) ! PERGRO limits cldliq/ice for macro/microphysics: character(len=24), parameter :: pergro_cldlim_names(4) = & @@ -272,29 +272,6 @@ subroutine physics_update(state, ptend, dt, tend) end if end if - !----------------------------------------------------------------------- - ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend - ! If psetcols == pcols, the cpairv is the correct size and just copy - ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair - if (state%psetcols == pcols) then - allocate (cpairv_loc(state%psetcols,pver,begchunk:endchunk)) - cpairv_loc(:,:,:) = cpairv(:,:,:) - else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then - allocate(cpairv_loc(state%psetcols,pver,begchunk:endchunk)) - cpairv_loc(:,:,:) = cpair - else - call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on') - end if - if (state%psetcols == pcols) then - allocate (rairv_loc(state%psetcols,pver,begchunk:endchunk)) - rairv_loc(:,:,:) = rairv(:,:,:) - else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then - allocate(rairv_loc(state%psetcols,pver,begchunk:endchunk)) - rairv_loc(:,:,:) = rair - else - call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on') - end if - !----------------------------------------------------------------------- call phys_getopts(state_debug_checks_out=state_debug_checks) @@ -394,14 +371,35 @@ subroutine physics_update(state, ptend, dt, tend) !------------------------------------------------------------------------ ! Get indices for molecular weights and call WACCM-X physconst_update !------------------------------------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then call physconst_update(state%q, state%t, state%lchnk, ncol) endif - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - zvirv(:,:) = shr_const_rwv / rairv_loc(:,:,state%lchnk) - 1._r8 + + !----------------------------------------------------------------------- + ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend + ! If psetcols == pcols, the cpairv is the correct size and just copy + ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair + allocate(cpairv_loc(state%psetcols,pver)) + if (state%psetcols == pcols) then + cpairv_loc(:,:) = cpairv(:,:,state%lchnk) + else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then + cpairv_loc(:,:) = cpair else - zvirv(:,:) = zvir + call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on') + end if + allocate(rairv_loc(state%psetcols,pver)) + if (state%psetcols == pcols) then + rairv_loc(:,:) = rairv(:,:,state%lchnk) + else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then + rairv_loc(:,:) = rair + else + call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on') + end if + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8 + else + zvirv(:,:) = zvir endif !------------------------------------------------------------------------------------------------------------- @@ -410,9 +408,9 @@ subroutine physics_update(state, ptend, dt, tend) if(ptend%ls) then do k = ptend%top_level, ptend%bot_level - state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k,state%lchnk) + state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k) if (present(tend)) & - tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k,state%lchnk) + tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k) end do end if @@ -421,11 +419,11 @@ subroutine physics_update(state, ptend, dt, tend) if (ptend%ls .or. ptend%lq(1)) then call geopotential_t ( & state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & - state%t , state%q(:,:,1), rairv_loc(:,:,state%lchnk), gravit , zvirv , & + state%t , state%q(:,:,1), rairv_loc(:,:), gravit , zvirv , & state%zi , state%zm , ncol ) ! update dry static energy for use in next process do k = ptend%top_level, ptend%bot_level - state%s(:ncol,k) = state%t(:ncol,k )*cpairv_loc(:ncol,k,state%lchnk) & + state%s(:ncol,k) = state%t(:ncol,k )*cpairv_loc(:ncol,k) & + gravit*state%zm(:ncol,k) + state%phis(:ncol) end do end if @@ -691,19 +689,19 @@ subroutine physics_ptend_sum(ptend, ptend_sum, ncol) if (ptend%psetcols /= ptend_sum%psetcols) then call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols') end if - + if (ncol > ptend_sum%psetcols) then call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols') end if - + psetcols = ptend_sum%psetcols - + ptend_sum%top_level = ptend%top_level ptend_sum%bot_level = ptend%bot_level ! Update u,v fields if(ptend%lu) then - if (.not. allocated(ptend_sum%u)) then + if (.not. allocated(ptend_sum%u)) then allocate(ptend_sum%u(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u') ptend_sum%u=0.0_r8 @@ -730,7 +728,7 @@ subroutine physics_ptend_sum(ptend, ptend_sum, ncol) end if if(ptend%lv) then - if (.not. allocated(ptend_sum%v)) then + if (.not. allocated(ptend_sum%v)) then allocate(ptend_sum%v(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v') ptend_sum%v=0.0_r8 @@ -758,7 +756,7 @@ subroutine physics_ptend_sum(ptend, ptend_sum, ncol) if(ptend%ls) then - if (.not. allocated(ptend_sum%s)) then + if (.not. allocated(ptend_sum%s)) then allocate(ptend_sum%s(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s') ptend_sum%s=0.0_r8 @@ -794,7 +792,7 @@ subroutine physics_ptend_sum(ptend, ptend_sum, ncol) allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf') ptend_sum%cflx_srf=0.0_r8 - + allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top') ptend_sum%cflx_top=0.0_r8 @@ -912,7 +910,7 @@ subroutine physics_ptend_copy(ptend, ptend_cp) ptend_cp%hflux_srf = ptend%hflux_srf ptend_cp%hflux_top = ptend%hflux_top end if - + if (ptend_cp%lu) then ptend_cp%u = ptend%u ptend_cp%taux_srf = ptend%taux_srf @@ -988,10 +986,10 @@ subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq) logical, optional :: lu ! if true, then fields to support dudt are allocated logical, optional :: lv ! if true, then fields to support dvdt are allocated logical, dimension(pcnst),optional :: lq ! if true, then fields to support dqdt are allocated - + !----------------------------------------------------------------------- - if (allocated(ptend%s)) then + if (allocated(ptend%s)) then call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine') end if @@ -1132,29 +1130,63 @@ subroutine init_geo_unique(phys_state,ncol) end subroutine init_geo_unique !=============================================================================== - subroutine physics_dme_adjust(state, tend, qini, dt) - !----------------------------------------------------------------------- - ! + subroutine physics_dme_adjust(state, tend, qini, dt, eflx, ent_tnd, ohf_adjust, ocnfrac, sst, ts) + + use phys_control, only: phys_getopts + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: dt + real(r8), intent(out), optional :: eflx (pcols) ! energy flux for use in check_energy + real(r8), intent(out), optional :: ent_tnd(pcols) ! column-integrated enthalpy tendency + logical , intent(in) , optional :: ohf_adjust !+tht 03/11/2015 + real(r8), intent(in) , optional :: ocnfrac(pcols) ! Ocean fraction (fraction) + real(r8), intent(in) , optional :: sst (pcols) ! Sea surface temperature + real(r8), intent(in) , optional :: ts (pcols) ! Surface temperature + logical :: dme_energy_adjust + + call phys_getopts(dme_energy_adjust_out=dme_energy_adjust) + + if (dme_energy_adjust) then + if (present(eflx) .and. present(ent_tnd).and. present(ohf_adjust) & + .and. present(ocnfrac) .and. present(sst) .and. present(ts)) then + call physics_dme_adjust_THT(state, tend, qini, dt, eflx, ent_tnd, ohf_adjust, ocnfrac, sst, ts) + else if (present(eflx)) then + call physics_dme_adjust_THT(state, tend, qini, dt, eflx) + else + call physics_dme_adjust_THT(state, tend, qini, dt) + endif + else + call physics_dme_adjust_BAB(state, tend, qini, dt) + end if + + end subroutine physics_dme_adjust + +!=============================================================================== + subroutine physics_dme_adjust_BAB(state, tend, qini, dt) + !----------------------------------------------------------------------- + ! ! Purpose: Adjust the dry mass in each layer back to the value of physics input state - ! + ! ! Method: Conserve the integrated mass, momentum and total energy in each layer ! by scaling the specific mass of consituents, specific momentum (velocity) ! and specific total energy by the relative change in layer mass. Solve for ! the new temperature by subtracting the new kinetic energy from total energy ! and inverting the hydrostatic equation ! - ! The mass in each layer is modified, changing the relationship of the layer - ! interfaces and midpoints to the surface pressure. The result is no longer in - ! the original hybrid coordinate. + ! The mass in each layer is modified, changing the relationship of the layer + ! interfaces and midpoints to the surface pressure. The result is no longer in + ! the original hybrid coordinate. ! ! This procedure cannot be applied to the "eul" or "sld" dycores because they ! require the hybrid coordinate. - ! + ! ! Author: Byron Boville ! !REVISION HISTORY: ! 03.03.28 Boville Created, partly from code by Lin in p_d_adjust - ! + ! !----------------------------------------------------------------------- use constituents, only : cnst_get_type_byind @@ -1181,16 +1213,19 @@ subroutine physics_dme_adjust(state, tend, qini, dt) real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer - real(r8),allocatable :: cpairv_loc(:,:,:) + real(r8),allocatable :: cpairv_loc(:,:) ! !----------------------------------------------------------------------- if (state%psetcols .ne. pcols) then call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') end if - if (adjust_te) then - call endrun('physics_dme_adjust: must update code based on the "correct" energy before turning on "adjust_te"') - end if +!+tht N.B. adjust_te is hard-wired to .false. and has to be because associated code is nonsense. +! There must be some religious sect at NCAR that demands both the logical and the code to +! be preserved for no purpose at all (other than demonstrating an ability to write bad code). + !if (adjust_te) then + ! call endrun('physics_dme_adjust: must update code based on the "correct" energy before turning on "adjust_te"') + !end if lchnk = state%lchnk ncol = state%ncol @@ -1208,24 +1243,24 @@ subroutine physics_dme_adjust(state, tend, qini, dt) state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) end do - if (adjust_te) then - ! compute specific total energy of unadjusted state (J/kg) - te(:ncol) = state%s(:ncol,k) + 0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) - - ! recompute initial u,v from the new values and the tendencies - utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) - vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) - ! adjust specific total energy and specific momentum (velocity) to conserve each - te (:ncol) = te (:ncol) / fdq(:ncol) - state%u(:ncol,k) = state%u(:ncol,k ) / fdq(:ncol) - state%v(:ncol,k) = state%v(:ncol,k ) / fdq(:ncol) - ! compute adjusted u,v tendencies - tend%dudt(:ncol,k) = (state%u(:ncol,k) - utmp(:ncol)) / dt - tend%dvdt(:ncol,k) = (state%v(:ncol,k) - vtmp(:ncol)) / dt - - ! compute adjusted static energy - state%s(:ncol,k) = te(:ncol) - 0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) - end if + !if (adjust_te) then + ! ! compute specific total energy of unadjusted state (J/kg) + ! te(:ncol) = state%s(:ncol,k) + 0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) + ! + ! ! recompute initial u,v from the new values and the tendencies + ! utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) + ! vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) + ! ! adjust specific total energy and specific momentum (velocity) to conserve each + ! te (:ncol) = te (:ncol) / fdq(:ncol) + ! state%u(:ncol,k) = state%u(:ncol,k ) / fdq(:ncol) + ! state%v(:ncol,k) = state%v(:ncol,k ) / fdq(:ncol) + ! ! compute adjusted u,v tendencies + ! tend%dudt(:ncol,k) = (state%u(:ncol,k) - utmp(:ncol)) / dt + ! tend%dvdt(:ncol,k) = (state%v(:ncol,k) - vtmp(:ncol)) / dt + ! + ! ! compute adjusted static energy + ! state%s(:ncol,k) = te(:ncol) - 0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) + !end if ! compute new total pressure variables state%pdel (:ncol,k ) = state%pdel(:ncol,k ) * fdq(:ncol) @@ -1235,45 +1270,399 @@ subroutine physics_dme_adjust(state, tend, qini, dt) state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k ) end do - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 else - zvirv(:,:) = zvir + zvirv(:,:) = zvir endif ! compute new T,z from new s,q,dp - if (adjust_te) then - + !if (adjust_te) then + ! ! cpairv_loc needs to be allocated to a size which matches state and ptend ! If psetcols == pcols, cpairv is the correct size and just copy into cpairv_loc ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair + ! + ! if (state%psetcols == pcols) then + ! cpairv_loc(:,:,:) = cpairv(:,:,state%lchnk) + ! else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then + ! cpairv_loc(:,:) = cpair + ! else + ! call endrun('physics_dme_adjust: cpairv is not allowed to vary when subcolumns are turned on') + ! end if + ! + ! call geopotential_dse(state%lnpint, state%lnpmid, state%pint, & + ! state%pmid , state%pdel , state%rpdel, & + ! state%s , state%q(:,:,1), state%phis , rairv(:,:,state%lchnk), & + ! gravit, cpairv_loc(:,:), zvirv, & + ! state%t , state%zi , state%zm , ncol) + ! + ! deallocate(cpairv_loc) + ! + !end if + + end subroutine physics_dme_adjust_BAB +!----------------------------------------------------------------------- - if (state%psetcols == pcols) then - allocate (cpairv_loc(state%psetcols,pver,begchunk:endchunk)) - cpairv_loc(:,:,:) = cpairv(:,:,:) - else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then - allocate(cpairv_loc(state%psetcols,pver,begchunk:endchunk)) - cpairv_loc(:,:,:) = cpair - else - call endrun('physics_dme_adjust: cpairv is not allowed to vary when subcolumns are turned on') - end if + subroutine physics_dme_adjust_THT(state, tend, qini, dt, eflx, ent_tnd, ohf_adjust, ocnfrac, sst, ts) + !----------------------------------------------------------------------- + ! + ! Purpose: Adjust the dry mass in each layer back to the value of physics input state + ! Adjust air specific enthalpy accordingly. Diagnose boundart enthalpy flux. + ! + ! Method + ! Revised adjustment towards consistency with local energy conservation. + ! Hydrostatic pressure work, de = alpha * dp, where alpha is the specific volume + ! pressure adjustment, is added locally as an source of enthalpy. An enthalpy of + ! mass (water) exchange with the surface is also defined, which should be passed + ! to the surface model components (ocean/land/ice etc). + ! If moist thermodynamics where handled correctly in CAM, the two terms would + ! match, guaranteeing local energy conservation. + ! With the present CAM formulation (constant dry heat capacity, constant latent + ! heat of condensation valid for 0 degree C), consistency demands one of these + ! choices: + ! 1. no pressure work and no boundary enthalpy flux (CESM) + ! 2. correct local pressure work and boundary enthalpy flux equal to (S dp/g) + ! where S=local *dry* static energy of air + ! 3. same as 2., but with different specific enthalpy of boundary mass exchange, + ! CONDEPS, and a matching heat exchange betweeen air and condensated + ! = (S - CONDEPS) dp/g (sign is for a heat source for air). + ! Choice 3. is taken here which will allow adaptation once moist thermodynamics + ! is introduced in the CAM in some hopeful future. For CONDEPS the following + ! choice is made: CONDEPS = cpcond *ocnfrac *SST + cpcond *(1-ocnfrac) *TS + ! cpcond is a parameter representing the heat capacity of the condensate phase. + ! The boundary enthalpy flux is at present not passed to other model components, + ! so it is treated as internal CAM non-conservation and folded into fix_energy. + ! Consistently, cpcond is at present set to be =cpair, resulting in a mild + ! (stability-dependent) heat source for (dry) air during precipitation. + ! An option to return fields valid on the initial hybrid levels is included. + ! + ! Author: Thomas Toniazzo (17.07.21) + ! + !----------------------------------------------------------------------- - call geopotential_dse(state%lnpint, state%lnpmid, state%pint, & - state%pmid , state%pdel , state%rpdel, & - state%s , state%q(:,:,1), state%phis , rairv(:,:,state%lchnk), & - gravit, cpairv_loc(:,:,state%lchnk), zvirv, & - state%t , state%zi , state%zm , ncol) + use constituents, only : cnst_get_type_byind + use ppgrid, only : begchunk, endchunk + use hycoef, only : hyai, hybi, ps0, hyam, hybm - deallocate(cpairv_loc) + implicit none + ! + ! Arguments + ! + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity + real(r8), intent(in ) :: dt ! model physics timestep + real(r8), intent(out), optional :: eflx (pcols) ! diagnostic: boundary enthalpy flux + real(r8), intent(out), optional :: ent_tnd(pcols) ! diagnostic: column-integrated enthalpy tendency + logical , intent(in) , optional :: ohf_adjust ! flag to set temperature of water condensates + real(r8), intent(in) , optional :: ocnfrac(pcols) ! Ocean fraction (fraction) + real(r8), intent(in) , optional :: sst (pcols) ! Sea surface temperature + real(r8), intent(in) , optional :: ts (pcols) ! Surface temperature + + !---------------------------Local workspace----------------------------- + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k,m ! Longitude, level indices + integer :: ierr ! error flag + real(r8) :: fdq (pcols) ! mass adjustment factor + real(r8) :: fdq_ke(pcols) ! mass adjustment factor to conserve momentum or kinetic energy + + real(r8) :: te (pcols) ! total energy in a layer + real(r8) :: utmp (pcols) ! temp variable for recalculating the initial u values + real(r8) :: vtmp (pcols) ! temp variable for recalculating the initial v values + + real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer + + real(r8) :: ps_old(pcols) ! old surface pressure + real(r8) :: pdel_new(pcols) ! Layer thickness (pint(k+1) - pint(k)) + real(r8) :: mdq(pcols,pver) ! mass adjustment + + real(r8) :: pdot (pcols) ! total (lagrangian) pressure adjustment + real(r8) :: edot (pcols) ! advective pressure adjustment + + real(r8) :: condeps(pcols) ! specific enthalpy of moist reservoir with which q is exchanged + real(r8) :: htx (pcols) ! heat exchange with condensates + + real(r8) :: qf(pcols,pcnst), qtmp(pcols,pcnst), uf(pcols), vf(pcols) ! work arrays + + logical,parameter :: hybrid_coord=.false. ! Flag for hybrid (=T) or lagrangian (=F) coord + +!+tht 17.11.2015 option to use virtual temperature for T update + logical, parameter :: l_virtual = .true. ! convert T to T_v, run adjustment loop, then convert back + real(r8) :: tp(pcols,pver) ! work array for T/Tv + real(r8) :: rr(pcols) ! dry/moist R + + real(r8), parameter :: Tcond = 291.16_r8 ! 18C= preindustrial global average SST +!+tht +! N.B.: RCP=1 -> use T, RCP.ne.1 -> use a virtual (heat) temperature + ! OPTION 0 + ! reference temperature of condensates (=0, cp_wv set to cpair ) + !real(r8), parameter :: condTr = 0._r8 + !real(r8), parameter :: cpcond =cpair + !real(r8), parameter :: rcp=1._r8 + real(r8) :: condTr, cpcond, rcp + condTr = 0._r8 + cpcond =cpair + rcp=1._r8 + ! OPTION 1 + !! reference temperature of condensates (=0, cp_wv set to cp_liq) + ! real(r8), parameter :: condTr = 0._r8 + ! real(r8), parameter :: cpcond =cpliq + ! real(r8), parameter :: rcp=cpliq/cpair + ! OPTION 2 + !! reference temperature of condensates (=0, cp_liq set to cp_wv) + ! real(r8) :: cpcond, rcp + ! real(r8), parameter :: condTr = 0._r8 + ! cpcond=cpwv + ! rcp=cpwv/cpair + ! OPTION 3 + !! reference temperature of condensates (=triple point, according to constant value of L adopted elsewhere) + !real(r8) :: rcp + !real(r8), parameter :: condTr = 273.16_r8 + !real(r8), parameter :: cpcond = cpliq + ! rcp=cpwv/cpair +!-tht + + !if (.not. dycore_is('LR') ) return + + if (state%psetcols .ne. pcols) then + call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns') end if - end subroutine physics_dme_adjust -!----------------------------------------------------------------------- +!-------------------- initialise adjustment loop ------------------------------------ + lchnk = state%lchnk + ncol = state%ncol + + ! virtual temperature + do k = 1, pver + tp(:ncol,k) = state%t(:ncol,k) *((1._r8+rcp*qini(:ncol,k))/(1._r8+qini(:ncol,k))) + enddo + + ! old surface pressure + ps_old (:ncol) = state%ps(:ncol) + + state%ps(:ncol) = state%pint(:ncol,1) + do k = 1, pver + ! specific enthalpy before adjustment + state%s(:ncol,k)= tp(:ncol,k)*cpairv(:ncol,k,lchnk) & + +0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) + ! Dp'/Dp + mdq (:ncol,k)= state%q(:ncol,k,1) - qini(:ncol,k) ! only water-vapor mass change considered + ! new surface pressure + state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + end do + + ! lagrangian & advective pressure change at top interface + pdot (:ncol) = 0._r8 + edot (:ncol) = 0._r8 + + ! heat exchange with condensates + htx (:ncol) = 0._r8 !+tht 07.11.2015 + + ! energy change due to mass sources + if (present(eflx)) eflx(:ncol) = 0._r8 + + ! store old enthalpy integral + if (present(ent_tnd)) then + ent_tnd(:ncol)=0._r8 + do k=1,pver + ent_tnd(:ncol)=ent_tnd-(state%t(:ncol,k)*cpairv(:ncol,k,lchnk) & + +0.5_r8*(state%u(:ncol,k)**2+state%v(:ncol,k)**2))*state%pdel(:ncol,k) + enddo + endif + +!------------------- start adjustment loop ------------------------------------------ + do k = 1, pver + + if (rcp.eq.1._r8) then + rr(:ncol) = (1._r8+(zvir+1._r8)*.5_r8*(qini(:ncol,k)+state%q(:ncol,k,1))) & + /(1._r8+.5_r8*(qini(:ncol,k)+state%q(:ncol,k,1))) + else + rr(:ncol) = 1._r8 + endif + + ! new Dp (=:Dp") for either lagrangian or hybrid-coordinate adjustment + if (hybrid_coord) then ! hybrid-level adjustment (Dp".ne.Dp') + pdel_new(:ncol) = (hyai(k+1)-hyai(k))*ps0 & + +(hybi(k+1)-hybi(k))*state%ps(:ncol) + else ! lagrangian adjustment (Dp".eq.Dp') + pdel_new(:ncol) = state%pdel(:ncol,k)*(1._r8 + mdq(:ncol,k)) + endif + + fdq(:ncol) = pdel_new(:ncol)/state%pdel(:ncol,k) ! this is Dp"/Dp + + ! humidity adjustment: remapping flux from previous interface, /Dp" + if (hybrid_coord .and. k.gt.1) then + do m=1,pcnst + qf (:ncol,m) = .5_r8*(state%q(:ncol,k,m)+qtmp(:ncol,m))*edot(:ncol)/pdel_new(:ncol) + enddo + else + do m=1,pcnst + qf (:ncol,m) = 0._r8 + enddo + endif + + ! wind adjustment increments + if (hybrid_coord .and. k.gt.1) then ! here u,vtmp = u,v(k-1) + uf (:ncol) = .5_r8*(state%u(:ncol,k)+utmp(:ncol))*edot(:ncol)/pdel_new(:ncol) + vf (:ncol) = .5_r8*(state%v(:ncol,k)+vtmp(:ncol))*edot(:ncol)/pdel_new(:ncol) + else + uf (:ncol) = 0. + vf (:ncol) = 0. + endif + ! u,vtmp set to pre-physics u,v from the updated values and the tendencies + utmp(:ncol) = state%u(:ncol,k) - dt * tend%dudt(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) - dt * tend%dvdt(:ncol,k) + + ! adjust specific enthalpy + if (hybrid_coord .and. k.gt.1) then ! remapping flux from previous interface, /Dp" + te (:ncol) = .5_r8*(state%s(:ncol,k)+state%s(:ncol,k-1))*edot(:ncol)/pdel_new(:ncol) + else + te (:ncol) = 0._r8 + endif + + ! lagrangian pressure change at mid-level + pdot(:ncol) = pdot(:ncol) + .5_r8*state%pdel(:ncol,k)*mdq(:ncol,k) + ! enthalpy change by hydrost. pressure work in full adjustment + te (:ncol) = te(:ncol) + state%s(:ncol,k)/(fdq(:ncol)/(1._r8+mdq(:ncol,k))) & ! te *(Dp'/Dp") + + rairv(:ncol,k,lchnk)*rr(:ncol)*state%t(:ncol,k)/state%pmid(:ncol,k) & ! alpha (use Tv) + *pdot(:ncol)/fdq(:ncol) & ! *dp*(Dp/Dp") + -(.5_r8*(state%zi(:ncol,k+1)+state%zi(:ncol,k))-state%zm(:ncol,k))*gravit & ! probably =0. + *mdq(:ncol,k)/fdq(:ncol) ! *dq*(Dp/Dp") + ! lagrangian pressure change at next interface + pdot(:ncol) = pdot(:ncol) + .5_r8*state%pdel(:ncol,k)*mdq(:ncol,k) + + + ! specific enthalpy of condensates + condeps(:ncol) = cpcond*(state%t(:ncol,k)-condtr)+cpwv*condtr & + +0.5_r8*(state%u(:ncol,k)**2+state%v(:ncol,k)**2) +gravit*state%zm(:ncol,k) + if (present(ohf_adjust)) then + if (ohf_adjust) then + if ( present(ocnfrac) .and. present(sst) .and. present(ts) ) then + condeps(:ncol) = ocnfrac(:ncol) *(cpcond*(sst(:ncol)-condtr)+cpwv*condtr) & + + (1._r8-ocnfrac(:ncol))*(cpcond*(ts (:ncol)-condtr)+cpwv*condtr) + else + if ( present(sst) ) then + condeps(:ncol) = cpcond*(sst(:ncol)-condtr)+cpwv*condtr + else if ( present(ts) ) then + condeps(:ncol) = cpcond*(ts (:ncol)-condtr)+cpwv*condtr + else ! fixed temperature of all condensates + condeps(:ncol) = cpcond*(tcond-condtr)+cpwv *condtr + endif + endif + endif ! if ohf_adjust=F, keep local specific enthalpy + endif ! if ohf_adjust not present, treated as F + + ! boundary-flux diagnostic associated with water exchanged (column water-vapour gained/lost) + if (present(eflx)) & + eflx (:ncol) = eflx(:ncol) + mdq(:ncol,k)/dt*state%pdel(:ncol,k)/gravit *condeps(:ncol) + + ! sensible heat exchange between atm. column and water reservoire + if (present(ohf_adjust)) then + if (ohf_adjust) then + ! the heat here is exchanged in the column between the local level and the surface, + ! i.e. over indices j with (k.le.j.le.pver) + htx (:ncol) = htx(:ncol) + & + pdel_new(:ncol)/(state%ps(:ncol)-state%pint(:ncol,k)) & + * mdq(:ncol,k)/fdq(:ncol) & + *(condeps(:ncol)-(state%s(:ncol,k)+gravit*state%zm(:ncol,k))) + ! local heating would be just: + !htx (:ncol) = mdq(:ncol,k)/fdq(:ncol) & + ! *(condeps(:ncol)-(state%s(:ncol,k)+gravit*state%zm(:ncol,k))) + te (:ncol) = te(:ncol) + htx(:ncol) + endif ! nothing to be done if OHF_ADJUST either .false. ... + endif ! ... or not present + + if (hybrid_coord .and. k.lt.pver) then ! remapping flux from next interface, /Dp" + edot(:ncol) = pdot(:ncol) - hybi(k+1)*(state%ps(:ncol)-ps_old(:ncol)) + te (:ncol) = te(:ncol) - .5_r8*(state%s(:ncol,k)+state%s(:ncol,k+1))*edot(:ncol)/pdel_new(:ncol) + endif + + if (hybrid_coord .and. k.lt.pver) then ! remapping flux from next interface, /Dp" + do m=1,pcnst + qf (:ncol,m) = qf(:ncol,m) & + - .5_r8*(state%q(:ncol,k,m)+state%q(:ncol,k+1,m))*edot(:ncol)/pdel_new(:ncol) + enddo + uf (:ncol) = uf(:ncol) - .5_r8*(state%u(:ncol,k)+state%u(:ncol,k+1))*edot(:ncol)/pdel_new(:ncol) + vf (:ncol) = vf(:ncol) - .5_r8*(state%v(:ncol,k)+state%v(:ncol,k+1))*edot(:ncol)/pdel_new(:ncol) + endif + + ! adjust constituents to conserve mass in each layer + do m = 1, pcnst + ! store unadjusted q for use in next k + qtmp (:ncol ,m) = state%q(:ncol,k,m) + state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol) + qf(:ncol,m) + end do + + ! compute adjusted u,v + uf(:ncol) = state%u(:ncol,k ) / fdq(:ncol) + uf(:ncol) + vf(:ncol) = state%v(:ncol,k ) / fdq(:ncol) + vf(:ncol) + ! adjusted u,v tendencies + tend%dudt(:ncol,k) = (uf(:ncol) - utmp(:ncol)) / dt + tend%dvdt(:ncol,k) = (vf(:ncol) - vtmp(:ncol)) / dt + ! store unadjusted u,v for use in next k + utmp(:ncol) = state%u(:ncol,k) + vtmp(:ncol) = state%v(:ncol,k) + ! write adjusted u,v + state%u(:ncol,k) = uf(:ncol) + state%v(:ncol,k) = vf(:ncol) + + ! compute adjusted temperature + tp(:ncol,k) =(te(:ncol) - 0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2)) & + /cpairv(:ncol,k,lchnk) + +! compute new total pressure variables + state%pint (:ncol,k+1) = state%pint(:ncol,k ) + pdel_new(:ncol) + state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1)) + state%pdel (:ncol,k ) = pdel_new(:ncol) + state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k ) + + end do +!------------------- end adjustment loop -------------------------------------------- + + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8 + else + zvirv(:,:) = zvir + endif + + ! update T + do k = 1, pver + state%t(:ncol,k) = tp(:ncol,k) /((1._r8+rcp*state%q(:ncol,k,1))/(1._r8+state%q(:ncol,k,1))) + enddo + + ! diagnose total internal enthalpy change: will *not* match EFLX if RCP.ne.1 + if (present(ent_tnd)) then + do k=1,pver + ent_tnd(:ncol) = ent_tnd(:ncol) + state%pdel(:ncol,k) & + *(state%t(:ncol,k)*cpairv(:ncol,k,lchnk) & + +0.5_r8*(state%u(:ncol,k)**2 + state%v(:ncol,k)**2) ) + enddo + ent_tnd(:ncol)=ent_tnd(:ncol)/dt/gravit + endif + call geopotential_t ( & + state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , & + state%t , state%q(:,:,1), rairv(:,:,state%lchnk), gravit , zvirv , & + state%zi , state%zm , ncol ) + + ! update original dry static energy + do k = 1, pver + state%s(:ncol,k) = state%t(:ncol,k )*cpairv(:ncol,k,lchnk) & + + gravit*state%zm(:ncol,k) + state%phis(:ncol) + enddo + + ! update dry pressure (OK after set_dry_to_wet was called in tphysac). + call set_state_pdry(state) + + end subroutine physics_dme_adjust_THT !=============================================================================== subroutine physics_state_copy(state_in, state_out) - + use ppgrid, only: pver, pverp use constituents, only: pcnst @@ -1294,71 +1683,71 @@ subroutine physics_state_copy(state_in, state_out) call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols) ncol = state_in%ncol - + state_out%psetcols = state_in%psetcols state_out%ngrdcol = state_in%ngrdcol state_out%lchnk = state_in%lchnk - state_out%ncol = state_in%ncol - state_out%count = state_in%count + state_out%ncol = state_in%ncol + state_out%count = state_in%count do i = 1, ncol state_out%lat(i) = state_in%lat(i) state_out%lon(i) = state_in%lon(i) state_out%ps(i) = state_in%ps(i) state_out%phis(i) = state_in%phis(i) - state_out%te_ini(i) = state_in%te_ini(i) - state_out%te_cur(i) = state_in%te_cur(i) - state_out%tw_ini(i) = state_in%tw_ini(i) - state_out%tw_cur(i) = state_in%tw_cur(i) + state_out%te_ini(i) = state_in%te_ini(i) + state_out%te_cur(i) = state_in%te_cur(i) + state_out%tw_ini(i) = state_in%tw_ini(i) + state_out%tw_cur(i) = state_in%tw_cur(i) end do do k = 1, pver do i = 1, ncol - state_out%t(i,k) = state_in%t(i,k) - state_out%u(i,k) = state_in%u(i,k) - state_out%v(i,k) = state_in%v(i,k) - state_out%s(i,k) = state_in%s(i,k) - state_out%omega(i,k) = state_in%omega(i,k) - state_out%pmid(i,k) = state_in%pmid(i,k) - state_out%pdel(i,k) = state_in%pdel(i,k) - state_out%rpdel(i,k) = state_in%rpdel(i,k) - state_out%lnpmid(i,k) = state_in%lnpmid(i,k) - state_out%exner(i,k) = state_in%exner(i,k) + state_out%t(i,k) = state_in%t(i,k) + state_out%u(i,k) = state_in%u(i,k) + state_out%v(i,k) = state_in%v(i,k) + state_out%s(i,k) = state_in%s(i,k) + state_out%omega(i,k) = state_in%omega(i,k) + state_out%pmid(i,k) = state_in%pmid(i,k) + state_out%pdel(i,k) = state_in%pdel(i,k) + state_out%rpdel(i,k) = state_in%rpdel(i,k) + state_out%lnpmid(i,k) = state_in%lnpmid(i,k) + state_out%exner(i,k) = state_in%exner(i,k) state_out%zm(i,k) = state_in%zm(i,k) end do end do do k = 1, pverp do i = 1, ncol - state_out%pint(i,k) = state_in%pint(i,k) - state_out%lnpint(i,k) = state_in%lnpint(i,k) - state_out%zi(i,k) = state_in% zi(i,k) + state_out%pint(i,k) = state_in%pint(i,k) + state_out%lnpint(i,k) = state_in%lnpint(i,k) + state_out%zi(i,k) = state_in% zi(i,k) end do end do do i = 1, ncol - state_out%psdry(i) = state_in%psdry(i) + state_out%psdry(i) = state_in%psdry(i) end do do k = 1, pver do i = 1, ncol - state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k) - state_out%pmiddry(i,k) = state_in%pmiddry(i,k) - state_out%pdeldry(i,k) = state_in%pdeldry(i,k) - state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k) + state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k) + state_out%pmiddry(i,k) = state_in%pmiddry(i,k) + state_out%pdeldry(i,k) = state_in%pdeldry(i,k) + state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k) end do end do do k = 1, pverp do i = 1, ncol state_out%pintdry(i,k) = state_in%pintdry(i,k) - state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k) + state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k) end do end do do m = 1, pcnst do k = 1, pver do i = 1, ncol - state_out%q(i,k,m) = state_in%q(i,k,m) + state_out%q(i,k,m) = state_in%q(i,k,m) end do end do end do @@ -1367,9 +1756,9 @@ end subroutine physics_state_copy !=============================================================================== subroutine physics_tend_init(tend) - + implicit none - + ! ! Arguments ! @@ -1389,7 +1778,7 @@ subroutine physics_tend_init(tend) tend%flx_net = 0._r8 tend%te_tnd = 0._r8 tend%tw_tnd = 0._r8 - + end subroutine physics_tend_init !=============================================================================== @@ -1402,7 +1791,7 @@ subroutine set_state_pdry (state,pdeld_calc) type(physics_state), intent(inout) :: state logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default] - ! .false. don't calculate pdeld + ! .false. don't calculate pdeld integer ncol integer i, k logical do_pdeld_calc @@ -1412,7 +1801,7 @@ subroutine set_state_pdry (state,pdeld_calc) else do_pdeld_calc = .true. endif - + ncol = state%ncol @@ -1434,7 +1823,7 @@ subroutine set_state_pdry (state,pdeld_calc) state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:)) state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:)) -end subroutine set_state_pdry +end subroutine set_state_pdry !=============================================================================== @@ -1445,7 +1834,7 @@ subroutine set_wet_to_dry (state) type(physics_state), intent(inout) :: state integer m, ncol - + ncol = state%ncol do m = 1,pcnst @@ -1454,7 +1843,7 @@ subroutine set_wet_to_dry (state) endif end do -end subroutine set_wet_to_dry +end subroutine set_wet_to_dry !=============================================================================== @@ -1465,7 +1854,7 @@ subroutine set_dry_to_wet (state) type(physics_state), intent(inout) :: state integer m, ncol - + ncol = state%ncol do m = 1,pcnst @@ -1504,106 +1893,106 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%lat(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat') - + allocate(state%lon(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon') - + allocate(state%ps(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps') - + allocate(state%psdry(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry') - + allocate(state%phis(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis') - + allocate(state%ulat(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat') - + allocate(state%ulon(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon') - + allocate(state%t(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t') - + allocate(state%u(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u') - + allocate(state%v(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v') - + allocate(state%s(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s') - + allocate(state%omega(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega') - + allocate(state%pmid(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid') - + allocate(state%pmiddry(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry') - + allocate(state%pdel(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel') - + allocate(state%pdeldry(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry') - + allocate(state%rpdel(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel') - + allocate(state%rpdeldry(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry') - + allocate(state%lnpmid(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid') - + allocate(state%lnpmiddry(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry') - + allocate(state%exner(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner') - + allocate(state%zm(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm') - + allocate(state%q(psetcols,pver,pcnst), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q') - + allocate(state%pint(psetcols,pver+1), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint') - + allocate(state%pintdry(psetcols,pver+1), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry') - + allocate(state%lnpint(psetcols,pver+1), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint') - + allocate(state%lnpintdry(psetcols,pver+1), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry') - + allocate(state%zi(psetcols,pver+1), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi') - + allocate(state%te_ini(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini') - + allocate(state%te_cur(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur') - + allocate(state%tw_ini(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini') - + allocate(state%tw_cur(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur') - + allocate(state%latmapback(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback') - + allocate(state%lonmapback(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback') - + allocate(state%cid(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid') @@ -1630,13 +2019,13 @@ subroutine physics_state_alloc(state,lchnk,psetcols) state%exner(:,:) = inf state%zm(:,:) = inf state%q(:,:,:) = inf - + state%pint(:,:) = inf state%pintdry(:,:) = inf state%lnpint(:,:) = inf state%lnpintdry(:,:) = inf state%zi(:,:) = inf - + state%te_ini(:) = inf state%te_cur(:) = inf state%tw_ini(:) = inf @@ -1655,103 +2044,103 @@ subroutine physics_state_dealloc(state) deallocate(state%lat, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat') - + deallocate(state%lon, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon') - + deallocate(state%ps, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps') - + deallocate(state%psdry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry') - + deallocate(state%phis, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis') - + deallocate(state%ulat, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat') - + deallocate(state%ulon, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon') - + deallocate(state%t, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t') - + deallocate(state%u, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u') - + deallocate(state%v, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v') - + deallocate(state%s, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s') - + deallocate(state%omega, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega') - + deallocate(state%pmid, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid') - + deallocate(state%pmiddry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry') - + deallocate(state%pdel, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel') - + deallocate(state%pdeldry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry') - + deallocate(state%rpdel, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel') - + deallocate(state%rpdeldry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry') - + deallocate(state%lnpmid, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid') - + deallocate(state%lnpmiddry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry') - + deallocate(state%exner, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner') - + deallocate(state%zm, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm') - + deallocate(state%q, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q') - + deallocate(state%pint, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint') - + deallocate(state%pintdry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry') - + deallocate(state%lnpint, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint') - + deallocate(state%lnpintdry, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry') - + deallocate(state%zi, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi') deallocate(state%te_ini, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini') - + deallocate(state%te_cur, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur') - + deallocate(state%tw_ini, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini') - + deallocate(state%tw_cur, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur') - + deallocate(state%latmapback, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback') - + deallocate(state%lonmapback, stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback') @@ -1856,7 +2245,7 @@ subroutine physics_ptend_alloc(ptend,psetcols) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top') end if - if (ptend%lu) then + if (ptend%lu) then allocate(ptend%u(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u') @@ -1867,7 +2256,7 @@ subroutine physics_ptend_alloc(ptend,psetcols) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top') end if - if (ptend%lv) then + if (ptend%lv) then allocate(ptend%v(psetcols,pver), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v') @@ -1878,7 +2267,7 @@ subroutine physics_ptend_alloc(ptend,psetcols) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top') end if - if (any(ptend%lq)) then + if (any(ptend%lq)) then allocate(ptend%q(psetcols,pver,pcnst), stat=ierr) if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q') diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 7982432814..35ef4aa6ba 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -1303,6 +1303,7 @@ subroutine tphysac (ztodt, cam_in, & real(r8) :: tmp_cldice(pcols,pver) ! tmp space real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space + real(r8) :: tmp_t (pcols,pver) !+tht tmp space real(r8) :: tmp_ps (pcols) ! tmp space ! physics buffer fields for total energy and mass adjustment @@ -1315,6 +1316,10 @@ subroutine tphysac (ztodt, cam_in, & real(r8), pointer, dimension(:,:) :: dtcore real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction + !tht: variables for dme_energy_adjust + real(r8):: eflx(pcols), dsema(pcols) + logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy + !----------------------------------------------------------------------- lchnk = state%lchnk ncol = state%ncol @@ -1565,6 +1570,7 @@ subroutine tphysac (ztodt, cam_in, & ! Scale dry mass and energy (does nothing if dycore is EUL or SLD) call cnst_get_ind('CLDLIQ', ixcldliq) call cnst_get_ind('CLDICE', ixcldice) + tmp_t (:ncol,:pver) = state%t(:ncol,:pver) !+tht tmp_q (:ncol,:pver) = state%q(:ncol,:pver,1) tmp_cldliq(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) tmp_cldice(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) @@ -1589,7 +1595,11 @@ subroutine tphysac (ztodt, cam_in, & end if if (dycore_is('LR')) then - call physics_dme_adjust(state, tend, qini, ztodt) +!+tht + !call physics_dme_adjust(state, tend, qini, ztodt) + call physics_dme_adjust(state, tend, qini, ztodt, eflx, dsema, & + ohf_adjust, cam_in%ocnfrac, cam_in%sst, cam_in%ts) +!-tht call calc_te_and_aam_budgets(state, 'pAM') endif @@ -1609,12 +1619,16 @@ subroutine tphysac (ztodt, cam_in, & if (cam_in%ocnfrac(i) /= 1._r8) labort = .true. end do if (labort) then - call endrun ('TPHYSAC error: grid contains non-ocean point') + call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') endif endif - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & - qini, cldliqini, cldiceini) +!+tht + !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & + ! qini, cldliqini, cldiceini) + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & + qini, cldliqini, cldiceini, eflx, dsema) +!-tht call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) diff --git a/src/physics/cam/physpkg.F90.beta07 b/src/physics/cam/physpkg.F90.beta07 new file mode 100644 index 0000000000..42828cf8df --- /dev/null +++ b/src/physics/cam/physpkg.F90.beta07 @@ -0,0 +1,2351 @@ +module physpkg + !----------------------------------------------------------------------- + ! Purpose: + ! + ! Provides the interface to CAM physics package + ! + ! Revision history: + ! Aug 2005, E. B. Kluzek, Creation of module from physpkg subroutine + ! 2005-10-17 B. Eaton Add contents of inti.F90 to phys_init(). Add + ! initialization of grid info in phys_state. + ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use physconst, only: latvap, latice, rh2o + use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & + physics_ptend, physics_tend_init, physics_update, & + physics_type_alloc, physics_ptend_dealloc,& + physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc + use phys_grid, only: get_ncols_p + use phys_gmean, only: gmean_mass + use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols + use constituents, only: pcnst, cnst_name, cnst_get_ind + use camsrfexch, only: cam_out_t, cam_in_t + + use cam_control_mod, only: ideal_phys, adiabatic + use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is + use scamMod, only: single_column, scm_crm_mode + use flux_avg, only: flux_avg_init + use infnan, only: posinf, assignment(=) + use perf_mod + use cam_logfile, only: iulog + use camsrfexch, only: cam_export + + use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg + use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg + + implicit none + private + save + + ! Public methods + public phys_register ! was initindx - register physics methods + public phys_init ! Public initialization method + public phys_run1 ! First phase of the public run method + public phys_run2 ! Second phase of the public run method + public phys_final ! Public finalization method + + ! Private module data + + ! Physics package options + character(len=16) :: shallow_scheme + character(len=16) :: macrop_scheme + character(len=16) :: microp_scheme + integer :: cld_macmic_num_steps ! Number of macro/micro substeps + logical :: do_clubb_sgs + logical :: use_subcol_microp ! if true, use subcolumns in microphysics + logical :: state_debug_checks ! Debug physics_state. + logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols + logical :: prog_modal_aero ! Prognostic modal aerosols present + + ! Physics buffer index + integer :: teout_idx = 0 + + integer :: landm_idx = 0 + integer :: sgh_idx = 0 + integer :: sgh30_idx = 0 + + integer :: qini_idx = 0 + integer :: cldliqini_idx = 0 + integer :: cldiceini_idx = 0 + + integer :: prec_str_idx = 0 + integer :: snow_str_idx = 0 + integer :: prec_sed_idx = 0 + integer :: snow_sed_idx = 0 + integer :: prec_pcw_idx = 0 + integer :: snow_pcw_idx = 0 + integer :: prec_dp_idx = 0 + integer :: snow_dp_idx = 0 + integer :: prec_sh_idx = 0 + integer :: snow_sh_idx = 0 + integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. + +!======================================================================= +contains +!======================================================================= + + subroutine phys_register + !----------------------------------------------------------------------- + ! + ! Purpose: Register constituents and physics buffer fields. + ! + ! Author: CSM Contact: M. Vertenstein, Aug. 1997 + ! B.A. Boville, Oct 2001 + ! A. Gettelman, Nov 2010 - put micro/macro physics into separate routines + ! + !----------------------------------------------------------------------- + use cam_abortutils, only: endrun + use physics_buffer, only: pbuf_init_time + use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use constituents, only: pcnst, cnst_add, cnst_chk_dim, cnst_name + + use cam_control_mod, only: moist_physics + use chemistry, only: chem_register + use cloud_fraction, only: cldfrc_register + use rk_stratiform, only: rk_stratiform_register + use microp_driver, only: microp_driver_register + use microp_aero, only: microp_aero_register + use macrop_driver, only: macrop_driver_register + use clubb_intr, only: clubb_register_cam + use conv_water, only: conv_water_register + use physconst, only: mwdry, cpair, mwh2o, cpwv + use tracers, only: tracers_register + use check_energy, only: check_energy_register + use carma_intr, only: carma_register + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_register + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_register + use ghg_data, only: ghg_data_register + use vertical_diffusion, only: vd_register + use convect_deep, only: convect_deep_register + use convect_shallow, only: convect_shallow_register + use radiation, only: radiation_register + use co2_cycle, only: co2_register + use flux_avg, only: flux_avg_register + use iondrag, only: iondrag_register + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_reg + use string_utils, only: to_lower + use prescribed_ozone, only: prescribed_ozone_register + use prescribed_volcaero,only: prescribed_volcaero_register + use prescribed_strataero,only: prescribed_strataero_register + use prescribed_aero, only: prescribed_aero_register + use prescribed_ghg, only: prescribed_ghg_register + use sslt_rebin, only: sslt_rebin_register + use aoa_tracers, only: aoa_tracers_register + use aircraft_emit, only: aircraft_emit_register + use cam_diagnostics, only: diag_register + use cloud_diagnostics, only: cloud_diagnostics_register + use cospsimulator_intr, only: cospsimulator_intr_register + use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not + use subcol, only: subcol_register + use subcol_utils, only: is_subcol_on + use dyn_comp, only: dyn_register + use spcam_drivers, only: spcam_register + use offline_driver, only: offline_driver_reg + + !---------------------------Local variables----------------------------- + ! + integer :: m ! loop index + integer :: mm ! constituent index + integer :: nmodes + !----------------------------------------------------------------------- + + ! Get physics options + call phys_getopts(shallow_scheme_out = shallow_scheme, & + macrop_scheme_out = macrop_scheme, & + microp_scheme_out = microp_scheme, & + cld_macmic_num_steps_out = cld_macmic_num_steps, & + do_clubb_sgs_out = do_clubb_sgs, & + use_subcol_microp_out = use_subcol_microp, & + state_debug_checks_out = state_debug_checks) + + ! Initialize dyn_time_lvls + call pbuf_init_time() + + ! Register the subcol scheme + call subcol_register() + + ! Register water vapor. + ! ***** N.B. ***** This must be the first call to cnst_add so that + ! water vapor is constituent 1. + if (moist_physics) then + call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & + longname='Specific humidity', readiv=.true., is_convtran1=.true.) + else + call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & + longname='Specific humidity', readiv=.false., is_convtran1=.true.) + end if + + ! Topography file fields. + call pbuf_add_field('LANDM', 'global', dtype_r8, (/pcols/), landm_idx) + call pbuf_add_field('SGH', 'global', dtype_r8, (/pcols/), sgh_idx) + call pbuf_add_field('SGH30', 'global', dtype_r8, (/pcols/), sgh30_idx) + + ! Fields for physics package diagnostics + call pbuf_add_field('QINI', 'physpkg', dtype_r8, (/pcols,pver/), qini_idx) + call pbuf_add_field('CLDLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), cldliqini_idx) + call pbuf_add_field('CLDICEINI', 'physpkg', dtype_r8, (/pcols,pver/), cldiceini_idx) + + ! check energy package + call check_energy_register + + ! If using a simple physics option (e.g., held_suarez, adiabatic), + ! the normal CAM physics parameterizations are not called. + if (moist_physics) then + + ! register fluxes for saving across time + if (phys_do_flux_avg()) call flux_avg_register() + + call cldfrc_register() + + ! cloud water + if( microp_scheme == 'RK' ) then + call rk_stratiform_register() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_register() + call microp_aero_register() + call microp_driver_register() + end if + + ! Register CLUBB_SGS here + if (do_clubb_sgs) call clubb_register_cam() + + + call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) + call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) + call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) + call pbuf_add_field('SNOW_PCW', 'physpkg',dtype_r8,(/pcols/),snow_pcw_idx) + call pbuf_add_field('PREC_SED', 'physpkg',dtype_r8,(/pcols/),prec_sed_idx) + call pbuf_add_field('SNOW_SED', 'physpkg',dtype_r8,(/pcols/),snow_sed_idx) + if (is_subcol_on()) then + call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) + call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) + call pbuf_register_subcol('PREC_PCW', 'phys_register', prec_pcw_idx) + call pbuf_register_subcol('SNOW_PCW', 'phys_register', snow_pcw_idx) + call pbuf_register_subcol('PREC_SED', 'phys_register', prec_sed_idx) + call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) + end if + + ! Who should add FRACIS? + ! -- It does not seem that aero_intr should add it since FRACIS is used in convection + ! even if there are no prognostic aerosols ... so do it here for now + call pbuf_add_field('FRACIS','physpkg',dtype_r8,(/pcols,pver,pcnst/),m) + + call conv_water_register() + + ! Determine whether its a 'modal' aerosol simulation or not + call rad_cnst_get_info(0, nmodes=nmodes) + clim_modal_aero = (nmodes > 0) + + if (clim_modal_aero) then + call modal_aero_calcsize_reg() + call modal_aero_wateruptake_reg() + endif + + ! register chemical constituents including aerosols ... + call chem_register() + + ! co2 constituents + call co2_register() + + ! register data model ozone with pbuf + if (cam3_ozone_data_on) then + call cam3_ozone_data_register() + end if + call prescribed_volcaero_register() + call prescribed_strataero_register() + call prescribed_ozone_register() + call prescribed_aero_register() + call prescribed_ghg_register() + call sslt_rebin_register + + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) then + call cam3_aero_data_register() + end if + + ! register various data model gasses with pbuf + call ghg_data_register() + + ! carma microphysics + ! + call carma_register() + + ! Register iondrag variables with pbuf + call iondrag_register() + + ! Register ionosphere variables with pbuf if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_reg() + endif + + call aircraft_emit_register() + + ! deep convection + call convect_deep_register + + ! shallow convection + call convect_shallow_register + + + call spcam_register + + ! radiation + call radiation_register + call cloud_diagnostics_register + + ! COSP + call cospsimulator_intr_register + + ! vertical diffusion + call vd_register() + else + ! held_suarez/adiabatic physics option should be in simple_physics + call endrun('phys_register: moist_physics configuration error') + end if + + ! Register diagnostics PBUF + call diag_register() + + ! Register age of air tracers + call aoa_tracers_register() + + ! Register test tracers + call tracers_register() + + call dyn_register() + + ! All tracers registered, check that the dimensions are correct + call cnst_chk_dim() + + ! ***NOTE*** No registering constituents after the call to cnst_chk_dim. + + call offline_driver_reg() + + end subroutine phys_register + + + + !======================================================================= + + subroutine phys_inidat( cam_out, pbuf2d ) + use cam_abortutils, only: endrun + + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field, dyn_time_lvls + + + use cam_initfiles, only: initial_file_get_id, topo_file_get_id + use cam_grid_support, only: cam_grid_check, cam_grid_id + use cam_grid_support, only: cam_grid_get_dim_names + use pio, only: file_desc_t + use ncdio_atm, only: infld + use dycore, only: dycore_is + use polar_avg, only: polar_average + use short_lived_species, only: initialize_short_lived_species + use cam_control_mod, only: aqua_planet + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_inidat + + type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + integer :: lchnk, m, n, i, k, ncol + type(file_desc_t), pointer :: fh_ini, fh_topo + character(len=8) :: fieldname + real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) + real(r8), pointer :: qpert(:,:) + + character(len=11) :: subname='phys_inidat' ! subroutine name + integer :: tpert_idx, qpert_idx, pblh_idx + + logical :: found=.false., found2=.false. + integer :: ierr + character(len=8) :: dim1name, dim2name + integer :: ixcldice, ixcldliq + integer :: grid_id ! grid ID for data mapping + nullify(tptr,tptr_2,tptr3d,tptr3d_2) + + fh_ini => initial_file_get_id() + fh_topo => topo_file_get_id() + + ! dynamics variables are handled in dyn_init - here we read variables needed for physics + ! but not dynamics + + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + + allocate(tptr(1:pcols,begchunk:endchunk)) + + if (associated(fh_topo) .and. .not. aqua_planet) then + call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not. found) call endrun('ERROR: SGH not found on topo file') + + call pbuf_set_field(pbuf2d, sgh_idx, tptr) + + allocate(tptr_2(1:pcols,begchunk:endchunk)) + call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr_2, found, gridname='physgrid') + if(found) then + call pbuf_set_field(pbuf2d, sgh30_idx, tptr_2) + else + if (masterproc) write(iulog,*) 'Warning: Error reading SGH30 from topo file.' + if (masterproc) write(iulog,*) 'The field SGH30 will be filled using data from SGH.' + call pbuf_set_field(pbuf2d, sgh30_idx, tptr) + end if + + deallocate(tptr_2) + + call infld('LANDM_COSLAT', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + + if(.not.found) call endrun(' ERROR: LANDM_COSLAT not found on topo dataset.') + + call pbuf_set_field(pbuf2d, landm_idx, tptr) + + else + call pbuf_set_field(pbuf2d, sgh_idx, 0._r8) + call pbuf_set_field(pbuf2d, sgh30_idx, 0._r8) + call pbuf_set_field(pbuf2d, landm_idx, 0._r8) + end if + + call infld('PBLH', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'PBLH initialized to 0.' + end if + pblh_idx = pbuf_get_index('pblh') + + call pbuf_set_field(pbuf2d, pblh_idx, tptr) + + call infld('TPERT', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr(:,:), found, gridname='physgrid') + if(.not. found) then + tptr(:,:) = 0._r8 + if (masterproc) write(iulog,*) 'TPERT initialized to 0.' + end if + tpert_idx = pbuf_get_index( 'tpert') + call pbuf_set_field(pbuf2d, tpert_idx, tptr) + + fieldname='QPERT' + qpert_idx = pbuf_get_index( 'qpert',ierr) + if (qpert_idx > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not. found) then + tptr=0_r8 + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk)) + tptr3d_2 = 0_r8 + tptr3d_2(:,1,:) = tptr(:,:) + + call pbuf_set_field(pbuf2d, qpert_idx, tptr3d_2) + deallocate(tptr3d_2) + end if + + fieldname='CUSH' + m = pbuf_get_index('cush', ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & + tptr, found, gridname='physgrid') + if(.not.found) then + if(masterproc) write(iulog,*) trim(fieldname), ' initialized to 1000.' + tptr=1000._r8 + end if + do n=1,dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr, start=(/1,n/), kount=(/pcols,1/)) + end do + deallocate(tptr) + end if + + do lchnk=begchunk,endchunk + cam_out(lchnk)%tbot(:) = posinf + end do + + ! + ! 3-D fields + ! + + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname='CLOUD' + m = pbuf_get_index('CLD') + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + fieldname='QCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not. found) then + call infld('Q',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with Q' + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + call endrun(' '//trim(subname)//' Error: Q must be on Initial File') + end if + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + fieldname = 'ICCWAT' + m = pbuf_get_index(fieldname, ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call cnst_get_ind('CLDICE', ixcldice) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + end if + if (masterproc) then + if (found) then + write(iulog,*) trim(fieldname), ' initialized with CLDICE' + else + write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + end if + end if + end if + + fieldname = 'LCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + allocate(tptr3d_2(pcols,pver,begchunk:endchunk)) + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + call infld('CLDLIQ',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d_2, found2, gridname='physgrid') + if(found .and. found2) then + do lchnk = begchunk, endchunk + ncol = get_ncols_p(lchnk) + tptr3d(:ncol,:,lchnk)=tptr3d(:ncol,:,lchnk)+tptr3d_2(:ncol,:,lchnk) + end do + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE + CLDLIQ' + else if (found) then ! Data already loaded in tptr3d + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE only' + else if (found2) then + tptr3d(:,:,:)=tptr3d_2(:,:,:) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDLIQ only' + end if + + if (found .or. found2) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + if(dycore_is('LR')) call polar_average(pver, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.0' + end if + deallocate(tptr3d_2) + end if + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname = 'TCWAT' + m = pbuf_get_index(fieldname,ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(.not.found) then + call infld('T', fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(dycore_is('LR')) call polar_average(pver, tptr3d) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized with T' + end if + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pverp,begchunk:endchunk)) + + fieldname = 'TKE' + m = pbuf_get_index( 'tke') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0.01_r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.01' + end if + + + fieldname = 'KVM' + m = pbuf_get_index('kvm') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + + fieldname = 'KVH' + m = pbuf_get_index('kvh') + call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if (found) then + call pbuf_set_field(pbuf2d, m, tptr3d) + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname = 'CONCLD' + m = pbuf_get_index('CONCLD',ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + deallocate (tptr3d) + end if + + call initialize_short_lived_species(fh_ini, pbuf2d) + + !--------------------------------------------------------------------------------- + ! If needed, get ion and electron temperature fields from initial condition file + !--------------------------------------------------------------------------------- + + call waccmx_phys_ion_elec_temp_inidat(fh_ini,pbuf2d) + + end subroutine phys_inidat + + + subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) + + !----------------------------------------------------------------------- + ! + ! Initialization of physics package. + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index + use physconst, only: rair, cpair, gravit, stebol, tmelt, & + latvap, latice, rh2o, rhoh2o, pstd, zvir, & + karman, rhodair, physconst_init + use ref_pres, only: pref_edge, pref_mid + + use carma_intr, only: carma_init + use cam_control_mod, only: initial_run + use check_energy, only: check_energy_init + use chemistry, only: chem_init + use prescribed_ozone, only: prescribed_ozone_init + use prescribed_ghg, only: prescribed_ghg_init + use prescribed_aero, only: prescribed_aero_init + use aerodep_flx, only: aerodep_flx_init + use aircraft_emit, only: aircraft_emit_init + use prescribed_volcaero,only: prescribed_volcaero_init + use prescribed_strataero,only: prescribed_strataero_init + use cloud_fraction, only: cldfrc_init + use cldfrc2m, only: cldfrc2m_init + use co2_cycle, only: co2_init, co2_transport + use convect_deep, only: convect_deep_init + use convect_shallow, only: convect_shallow_init + use cam_diagnostics, only: diag_init + use gw_drag, only: gw_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_init + use radheat, only: radheat_init + use radiation, only: radiation_init + use cloud_diagnostics, only: cloud_diagnostics_init + use rk_stratiform, only: rk_stratiform_init + use wv_saturation, only: wv_sat_init + use microp_driver, only: microp_driver_init + use microp_aero, only: microp_aero_init + use macrop_driver, only: macrop_driver_init + use conv_water, only: conv_water_init + use spcam_drivers, only: spcam_init + use tracers, only: tracers_init + use aoa_tracers, only: aoa_tracers_init + use rayleigh_friction, only: rayleigh_friction_init + use pbl_utils, only: pbl_utils_init + use vertical_diffusion, only: vertical_diffusion_init + use phys_debug_util, only: phys_debug_init + use phys_debug, only: phys_debug_state_init + use rad_constituents, only: rad_cnst_init + use aer_rad_props, only: aer_rad_props_init + use subcol, only: subcol_init + use qbo, only: qbo_init + use iondrag, only: iondrag_init, do_waccm_ions +#if ( defined OFFLINE_DYN ) + use metdata, only: metdata_phys_init +#endif + use epp_ionization, only: epp_ionization_init, epp_ionization_active + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) + use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) + use clubb_intr, only: clubb_ini_cam + use sslt_rebin, only: sslt_rebin_init + use tropopause, only: tropopause_init + use solar_data, only: solar_data_init + use dadadj_cam, only: dadadj_init + use cam_abortutils, only: endrun + + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) + + ! local variables + integer :: lchnk + integer :: ierr + + !----------------------------------------------------------------------- + + call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) + + do lchnk = begchunk, endchunk + call physics_state_set_grid(lchnk, phys_state(lchnk)) + end do + + !------------------------------------------------------------------------------------------- + ! Initialize any variables in physconst which are not temporally and/or spatially constant + !------------------------------------------------------------------------------------------- + call physconst_init() + + ! Initialize debugging a physics column + call phys_debug_init() + + call pbuf_initialize(pbuf2d) + + ! Initialize subcol scheme + call subcol_init(pbuf2d) + + ! diag_init makes addfld calls for dynamics fields that are output from + ! the physics decomposition + call diag_init(pbuf2d) + + call check_energy_init() + + call tracers_init() + + ! age of air tracers + call aoa_tracers_init() + + teout_idx = pbuf_get_index( 'TEOUT') + + ! adiabatic or ideal physics should be only used if in simple_physics + if (adiabatic .or. ideal_phys) then + if (adiabatic) then + call endrun('phys_init: adiabatic configuration error') + else + call endrun('phys_init: ideal_phys configuration error') + end if + end if + + if (initial_run) then + call phys_inidat(cam_out, pbuf2d) + end if + + ! wv_saturation is relatively independent of everything else and + ! low level, so init it early. Must at least do this before radiation. + call wv_sat_init + + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) + + ! Initialize rad constituents and their properties + call rad_cnst_init() + call aer_rad_props_init() + + ! initialize carma + call carma_init() + + ! solar irradiance data modules + call solar_data_init() + + ! Prognostic chemistry. + call chem_init(phys_state,pbuf2d) + + ! Prescribed tracers + call prescribed_ozone_init() + call prescribed_ghg_init() + call prescribed_aero_init() + call aerodep_flx_init() + call aircraft_emit_init() + call prescribed_volcaero_init() + call prescribed_strataero_init() + + ! co2 cycle + if (co2_transport()) then + call co2_init() + end if + + ! CAM3 prescribed ozone + if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) + + call gw_init() + + call rayleigh_friction_init() + + call pbl_utils_init(gravit, karman, cpair, rair, zvir) + call vertical_diffusion_init(pbuf2d) + + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_init () + ! Initialization of ionosphere module if mode set to ionosphere + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_init(pbuf2d) + endif + endif + + call radiation_init(pbuf2d) + + call cloud_diagnostics_init() + + call radheat_init(pref_mid) + + call convect_shallow_init(pref_edge, pbuf2d) + + call cldfrc_init() + call cldfrc2m_init() + + call convect_deep_init(pref_edge) + + if( microp_scheme == 'RK' ) then + call rk_stratiform_init() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) + call microp_aero_init() + call microp_driver_init(pbuf2d) + call conv_water_init + elseif( microp_scheme == 'SPCAM_m2005') then + call conv_water_init + end if + + + ! initiate CLUBB within CAM + if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) + + call spcam_init(pbuf2d) + + call qbo_init + + call iondrag_init(pref_mid) + ! Geomagnetic module -- after iondrag_init + if (epp_ionization_active) then + call epp_ionization_init() + endif + +#if ( defined OFFLINE_DYN ) + call metdata_phys_init() +#endif + call sslt_rebin_init() + call tropopause_init() + call dadadj_init() + + prec_dp_idx = pbuf_get_index('PREC_DP') + snow_dp_idx = pbuf_get_index('SNOW_DP') + prec_sh_idx = pbuf_get_index('PREC_SH') + snow_sh_idx = pbuf_get_index('SNOW_SH') + + dlfzm_idx = pbuf_get_index('DLFZM', ierr) + + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + + if (clim_modal_aero) then + + ! If climate calculations are affected by prescribed modal aerosols, the + ! the initialization routine for the dry mode radius calculation is called + ! here. For prognostic MAM the initialization is called from + ! modal_aero_initialize + if (.not. prog_modal_aero) then + call modal_aero_calcsize_init(pbuf2d) + endif + + call modal_aero_wateruptake_init(pbuf2d) + + end if + + end subroutine phys_init + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! First part of atmospheric physics package before updating of surface models + ! + !----------------------------------------------------------------------- + use time_manager, only: get_nstep + use cam_diagnostics,only: diag_allocate, diag_physvar_ic + use check_energy, only: check_energy_gmean + use phys_control, only: phys_getopts + use spcam_drivers, only: tphysbc_spcam + use spmd_utils, only: mpicom + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate +#if (defined BFB_CAM_SCAM_IOP ) + use cam_history, only: outfld +#endif + use cam_abortutils, only: endrun +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf1 +#endif + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + + type(physics_buffer_desc), pointer, dimension(:,:) :: pbuf2d + type(cam_in_t), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), dimension(begchunk:endchunk) :: cam_out + !----------------------------------------------------------------------- + ! + !---------------------------Local workspace----------------------------- + ! + integer :: c ! indices + integer :: ncol ! number of columns + integer :: nstep ! current timestep number + logical :: use_spcam + type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) + + call t_startf ('physpkg_st1') + nstep = get_nstep() + +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SNOWH and TS for micro-phys + ! + call get_met_srf1( cam_in ) +#endif + + ! The following initialization depends on the import state (cam_in) + ! being initialized. This isn't true when cam_init is called, so need + ! to postpone this initialization to here. + if (nstep == 0 .and. phys_do_flux_avg()) call flux_avg_init(cam_in, pbuf2d) + + ! Compute total energy of input state and previous output state + call t_startf ('chk_en_gmean') + call check_energy_gmean(phys_state, pbuf2d, ztodt, nstep) + call t_stopf ('chk_en_gmean') + + call t_stopf ('physpkg_st1') + + call t_startf ('physpkg_st1') + + call pbuf_allocate(pbuf2d, 'physpkg') + call diag_allocate() + + !----------------------------------------------------------------------- + ! Advance time information + !----------------------------------------------------------------------- + + call phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) + + call t_stopf ('physpkg_st1') + +#ifdef TRACER_CHECK + call gmean_mass ('before tphysbc DRY', phys_state) +#endif + + + !----------------------------------------------------------------------- + ! Tendency physics before flux coupler invocation + !----------------------------------------------------------------------- + ! + +#if (defined BFB_CAM_SCAM_IOP ) + do c=begchunk, endchunk + call outfld('Tg',cam_in(c)%ts,pcols ,c ) + end do +#endif + + call t_barrierf('sync_bc_physics', mpicom) + call t_startf ('bc_physics') + call t_adj_detailf(+1) + + call phys_getopts( use_spcam_out = use_spcam) + +!$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) + do c=begchunk, endchunk + ! + ! Output physics terms to IC file + ! + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + + call t_startf ('diag_physvar_ic') + call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) + call t_stopf ('diag_physvar_ic') + + if (use_spcam) then + call tphysbc_spcam (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + else + call tphysbc (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + end if + + end do + + call t_adj_detailf(-1) + call t_stopf ('bc_physics') + + ! Don't call the rest in CRM mode + if(single_column.and.scm_crm_mode) return + +#ifdef TRACER_CHECK + call gmean_mass ('between DRY', phys_state) +#endif + + end subroutine phys_run1 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & + cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Second part of atmospheric physics package after updating of surface models + ! + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_deallocate, pbuf_update_tim_idx + use mo_lightning, only: lightning_no_prod + use cam_diagnostics, only: diag_deallocate, diag_surf + use physconst, only: stebol, latvap + use carma_intr, only: carma_accumulate_stats + use spmd_utils, only: mpicom +#if ( defined OFFLINE_DYN ) + use metdata, only: get_met_srf2 +#endif + ! + ! Input arguments + ! + real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 + ! + ! Input/Output arguments + ! + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend + type(physics_buffer_desc),pointer, dimension(:,:) :: pbuf2d + + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + ! + !----------------------------------------------------------------------- + !---------------------------Local workspace----------------------------- + ! + integer :: c ! chunk index + integer :: ncol ! number of columns + type(physics_buffer_desc),pointer, dimension(:) :: phys_buffer_chunk + ! + ! If exit condition just return + ! + + if(single_column.and.scm_crm_mode) return + + !----------------------------------------------------------------------- + ! Tendency physics after coupler + ! Not necessary at terminal timestep. + !----------------------------------------------------------------------- + ! +#if ( defined OFFLINE_DYN ) + ! + ! if offline mode set SHFLX QFLX TAUX TAUY for vert diffusion + ! + call get_met_srf2( cam_in ) +#endif + ! Set lightning production of NO + call t_startf ('lightning_no_prod') + call lightning_no_prod( phys_state, pbuf2d, cam_in ) + call t_stopf ('lightning_no_prod') + + call t_barrierf('sync_ac_physics', mpicom) + call t_startf ('ac_physics') + call t_adj_detailf(+1) + +!$OMP PARALLEL DO PRIVATE (C, NCOL, phys_buffer_chunk) + + do c=begchunk,endchunk + ncol = get_ncols_p(c) + phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) + ! + ! surface diagnostics for history files + ! + call t_startf('diag_surf') + call diag_surf(cam_in(c), cam_out(c), phys_state(c), phys_buffer_chunk) + call t_stopf('diag_surf') + + call tphysac(ztodt, cam_in(c), & + cam_out(c), & + phys_state(c), phys_tend(c), phys_buffer_chunk) + end do ! Chunk loop + + call t_adj_detailf(-1) + call t_stopf('ac_physics') + +#ifdef TRACER_CHECK + call gmean_mass ('after tphysac FV:WET)', phys_state) +#endif + + call t_startf ('carma_accumulate_stats') + call carma_accumulate_stats() + call t_stopf ('carma_accumulate_stats') + + call t_startf ('physpkg_st2') + call pbuf_deallocate(pbuf2d, 'physpkg') + + call pbuf_update_tim_idx() + call diag_deallocate() + call t_stopf ('physpkg_st2') + + end subroutine phys_run2 + + ! + !----------------------------------------------------------------------- + ! + + subroutine phys_final( phys_state, phys_tend, pbuf2d ) + use physics_buffer, only : physics_buffer_desc, pbuf_deallocate + use chemistry, only : chem_final + use carma_intr, only : carma_final + use wv_saturation, only : wv_sat_final + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Finalization of physics package + ! + !----------------------------------------------------------------------- + ! Input/output arguments + type(physics_state), pointer :: phys_state(:) + type(physics_tend ), pointer :: phys_tend(:) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + if(associated(pbuf2d)) then + call pbuf_deallocate(pbuf2d,'global') + deallocate(pbuf2d) + end if + deallocate(phys_state) + deallocate(phys_tend) + call chem_final + call carma_final + call wv_sat_final + + end subroutine phys_final + + + subroutine tphysac (ztodt, cam_in, & + cam_out, state, tend, pbuf) + !----------------------------------------------------------------------- + ! + ! Tendency physics after coupling to land, sea, and ice models. + ! + ! Computes the following: + ! + ! o Aerosol Emission at Surface + ! o Source-Sink for Advected Tracers + ! o Symmetric Turbulence Scheme - Vertical Diffusion + ! o Rayleigh Friction + ! o Dry Deposition of Aerosol + ! o Enforce Charge Neutrality ( Only for WACCM ) + ! o Gravity Wave Drag + ! o QBO Relaxation ( Only for WACCM ) + ! o Ion Drag ( Only for WACCM ) + ! o Scale Dry Mass Energy + !----------------------------------------------------------------------- + use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx + use shr_kind_mod, only: r8 => shr_kind_r8 + use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions + use cam_diagnostics, only: diag_phys_tend_writeout + use gw_drag, only: gw_tend + use vertical_diffusion, only: vertical_diffusion_tend + use rayleigh_friction, only: rayleigh_friction_tend + use constituents, only: cnst_get_ind + use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & + physics_dme_adjust, set_dry_to_wet, physics_state_check + use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X + use aoa_tracers, only: aoa_tracers_timestep_tend + use physconst, only: rhoh2o, latvap,latice + use aero_model, only: aero_model_drydep + use carma_intr, only: carma_emission_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_aerosol, carma_do_emission + use check_energy, only: check_energy_chng + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use time_manager, only: get_nstep + use cam_abortutils, only: endrun + use dycore, only: dycore_is + use cam_control_mod, only: aqua_planet + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_set + use charge_neutrality, only: charge_balance + use qbo, only: qbo_relax + use iondrag, only: iondrag_calc, do_waccm_ions + use perf_mod + use flux_avg, only: flux_avg_run + use unicon_cam, only: unicon_cam_org_diags + + ! + ! Arguments + ! + real(r8), intent(in) :: ztodt ! Two times model timestep (2 delta-t) + + type(cam_in_t), intent(inout) :: cam_in + type(cam_out_t), intent(inout) :: cam_out + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + + type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes + + ! + !---------------------------Local workspace----------------------------- + ! + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + + integer :: nstep ! current timestep number + real(r8) :: zero(pcols) ! array of zeros + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer i,k,m ! Longitude, level indices + integer :: yr, mon, day, tod ! components of a date + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + + logical :: labort ! abort flag + + real(r8) tvm(pcols,pver) ! virtual temperature + real(r8) prect(pcols) ! total precipitation + real(r8) surfric(pcols) ! surface friction velocity + real(r8) obklen(pcols) ! Obukhov length + real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. + real(r8) :: tmp_q (pcols,pver) ! tmp space + real(r8) :: tmp_cldliq(pcols,pver) ! tmp space + real(r8) :: tmp_cldice(pcols,pver) ! tmp space + real(r8) :: tmp_t (pcols,pver) !tht: tmp space + + ! physics buffer fields for total energy and mass adjustment + integer itim_old, ifld + + real(r8), pointer, dimension(:,:) :: cld + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction + + !tht: variables for dme_energy_adjust + real(r8):: eflx(pcols), dsema(pcols) + logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy + + !----------------------------------------------------------------------- + lchnk = state%lchnk + ncol = state%ncol + + nstep = get_nstep() + + ! Adjust the surface fluxes to reduce instabilities in near sfc layer + if (phys_do_flux_avg()) then + call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) + endif + + ! Validate the physics state. + if (state_debug_checks) & + call physics_state_check(state, name="before tphysac") + + call t_startf('tphysac_init') + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + + + ifld = pbuf_get_index('DTCORE') + call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, start=(/1,1,itim_old/),kount=(/pcols,pver,1/)) + + ifld = pbuf_get_index('AST') + call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ! + ! accumulate fluxes into net flux array for spectral dycores + ! jrm Include latent heat of fusion for snow + ! + do i=1,ncol + tend%flx_net(i) = tend%flx_net(i) + cam_in%shf(i) + (cam_out%precc(i) & + + cam_out%precl(i))*latvap*rhoh2o & + + (cam_out%precsc(i) + cam_out%precsl(i))*latice*rhoh2o + end do + + ! emissions of aerosols and gas-phase chemistry constituents at surface + call chem_emissions( state, cam_in ) + + if (carma_do_emission) then + ! carma emissions + call carma_emission_tend (state, ptend, cam_in, ztodt) + call physics_update(state, ptend, ztodt, tend) + end if + + ! get nstep and zero array for energy checker + zero = 0._r8 + nstep = get_nstep() + call check_tracers_init(state, tracerint) + + ! Check if latent heat flux exceeds the total moisture content of the + ! lowest model layer, thereby creating negative moisture. + + call qneg4('TPHYSAC ' ,lchnk ,ncol ,ztodt , & + state%q(1,pver,1),state%rpdel(1,pver) ,cam_in%shf , & + cam_in%lhf , cam_in%cflx ) + + call t_stopf('tphysac_init') + !=================================================== + ! Source/sink terms for advected tracers. + !=================================================== + call t_startf('adv_tracer_src_snk') + ! Test tracers + + call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) + call physics_update(state, ptend, ztodt, tend) + call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & + cam_in%cflx) + + !=================================================== + ! Chemistry and MAM calculation + ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. + ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and + ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before + ! Gas chemistry and MAM core aerosol conversion. + ! Note that surface flux is not added into the atmosphere, but elevated emission is + ! added into the atmosphere as tendency. + !=================================================== + if (chem_is_active()) then + call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & + pbuf, fh2o=fh2o) + + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) + call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & + cam_in%cflx) + end if + call t_stopf('adv_tracer_src_snk') + + !=================================================== + ! Vertical diffusion/pbl calculation + ! Call vertical diffusion code (pbl, free atmosphere and molecular) + !=================================================== + + call t_startf('vertical_diffusion_tend') + call vertical_diffusion_tend (ztodt ,state , cam_in, & + surfric ,obklen ,ptend ,ast ,pbuf ) + + !------------------------------------------ + ! Call major diffusion for extended model + !------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_tend (ztodt ,state ,ptend) + endif + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf ('vertical_diffusion_tend') + + !=================================================== + ! Rayleigh friction calculation + !=================================================== + call t_startf('rayleigh_friction') + call rayleigh_friction_tend( ztodt, state, ptend) + call physics_update(state, ptend, ztodt, tend) + call t_stopf('rayleigh_friction') + + if (do_clubb_sgs) then + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) + else + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & + zero, cam_in%shf) + endif + + call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) + + ! aerosol dry deposition processes + call t_startf('aero_drydep') + call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf('aero_drydep') + + ! CARMA microphysics + ! + ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing the dry + ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, so that + ! obklen and surfric have been calculated. It needs to follow aero_model_drydep, so + ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and cam_out + ! can be added to for CARMA aerosols. + if (carma_do_aerosol) then + call t_startf('carma_timestep_tend') + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) + call physics_update(state, ptend, ztodt, tend) + + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('carma_timestep_tend') + end if + + + !--------------------------------------------------------------------------------- + ! ... enforce charge neutrality + !--------------------------------------------------------------------------------- + call charge_balance(state, pbuf) + + !=================================================== + ! Gravity wave drag + !=================================================== + call t_startf('gw_tend') + + call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) + + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & + zero, zero, flx_heat) + call t_stopf('gw_tend') + + ! QBO relaxation + call qbo_relax(state, pbuf, ptend) + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) + + ! Ion drag calculation + call t_startf ( 'iondrag' ) + + if ( do_waccm_ions ) then + call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + else + call iondrag_calc( lchnk, ncol, state, ptend) + endif + !---------------------------------------------------------------------------- + ! Call ionosphere routines for extended model if mode is set to ionosphere + !---------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) + endif + + call physics_update(state, ptend, ztodt, tend) + + !--------------------------------------------------------------------------------- + ! Enforce charge neutrality after O+ change from ionos_tend + !--------------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call charge_balance(state, pbuf) + endif + + ! Check energy integrals + call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) + + call t_stopf ( 'iondrag' ) + + !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + + ! Save total energy for global fixer in next timestep (FV and SE dycores) + call pbuf_set_field(pbuf, teout_idx, state%te_cur, (/1,itim_old/),(/pcols,1/)) + + if (shallow_scheme .eq. 'UNICON') then + + ! ------------------------------------------------------------------------ + ! Insert the organization-related heterogeneities computed inside the + ! UNICON into the tracer arrays here before performing advection. + ! This is necessary to prevent any modifications of organization-related + ! heterogeneities by non convection-advection process, such as + ! dry and wet deposition of aerosols, MAM, etc. + ! Again, note that only UNICON and advection schemes are allowed to + ! changes to organization at this stage, although we can include the + ! effects of other physical processes in future. + ! ------------------------------------------------------------------------ + + call unicon_cam_org_diags(state, pbuf) + + end if + ! + ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust + ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. + if ( dycore_is('LR') .or. dycore_is('SE')) call set_dry_to_wet(state) ! Physics had dry, dynamics wants moist + + ! Scale dry mass and energy (does nothing if dycore is EUL or SLD) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + tmp_t (:ncol,:pver) = state%t(:ncol,:pver) + tmp_q (:ncol,:pver) = state%q(:ncol,:pver,1) + tmp_cldliq(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + tmp_cldice(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + + !call physics_dme_adjust(state, tend, qini, ztodt) + call physics_dme_adjust(state, tend, qini, ztodt, eflx, dsema, & + ohf_adjust, cam_in%ocnfrac, cam_in%sst, cam_in%ts) !tht + +!!! REMOVE THIS CALL, SINCE ONLY Q IS BEING ADJUSTED. WON'T BALANCE ENERGY. TE IS SAVED BEFORE THIS +!!! call check_energy_chng(state, tend, "drymass", nstep, ztodt, zero, zero, zero, zero) + + ! store T in buffer for use in computing dynamics T-tendency in next timestep + do k = 1,pver + dtcore(:ncol,k) = state%t(:ncol,k) + end do + + !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + if (aqua_planet) then + labort = .false. + do i=1,ncol + if (cam_in%ocnfrac(i) /= 1._r8) labort = .true. + end do + if (labort) then + call endrun ('TPHYSAC error: grid contains non-ocean point') + endif + endif + + !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & + ! qini, cldliqini, cldiceini) + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & + qini, cldliqini, cldiceini, eflx, dsema) !tht + + call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) + + end subroutine tphysac + + subroutine tphysbc (ztodt, state, & + tend, pbuf, & + cam_out, cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Evaluate and apply physical processes that are calculated BEFORE + ! coupling to land, sea, and ice models. + ! + ! Processes currently included are: + ! + ! o Resetting Negative Tracers to Positive + ! o Global Mean Total Energy Fixer + ! o Dry Adjustment + ! o Asymmetric Turbulence Scheme : Deep Convection & Shallow Convection + ! o Stratiform Macro-Microphysics + ! o Wet Scavenging of Aerosol + ! o Radiation + ! + ! Method: + ! + ! Each parameterization should be implemented with this sequence of calls: + ! 1) Call physics interface + ! 2) Check energy + ! 3) Call physics_update + ! See Interface to Column Physics and Chemistry Packages + ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html + ! + !----------------------------------------------------------------------- + + use physics_buffer, only: physics_buffer_desc, pbuf_get_field + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx + use physics_buffer, only: col_type_subcol, dyn_time_lvls + use shr_kind_mod, only: r8 => shr_kind_r8 + + use dadadj_cam, only: dadadj_tend + use rk_stratiform, only: rk_stratiform_tend + use microp_driver, only: microp_driver_tend + use microp_aero, only: microp_aero_run + use macrop_driver, only: macrop_driver_tend + use physics_types, only: physics_state, physics_tend, physics_ptend, & + physics_update, physics_ptend_init, physics_ptend_sum, & + physics_state_check, physics_ptend_scale + use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write + use cam_history, only: outfld + use physconst, only: cpair, latvap + use constituents, only: pcnst, qmin, cnst_get_ind + use convect_deep, only: convect_deep_tend, convect_deep_tend_2, deep_scheme_does_scav_trans + use time_manager, only: is_first_step, get_nstep + use convect_shallow, only: convect_shallow_tend + use check_energy, only: check_energy_chng, check_energy_fix, check_energy_timestep_init + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use dycore, only: dycore_is + use aero_model, only: aero_model_wetdep + use carma_intr, only: carma_wetdep_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep + use radiation, only: radiation_tend + use cloud_diagnostics, only: cloud_diagnostics_calc + use perf_mod + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_adj + use clubb_intr, only: clubb_tend_cam + use sslt_rebin, only: sslt_rebin_adv + use tropopause, only: tropopause_output + use cam_abortutils, only: endrun + use subcol, only: subcol_gen, subcol_ptend_avg + use subcol_utils, only: subcol_ptend_copy, is_subcol_on + + ! Arguments + + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) + + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + + + ! + !---------------------------Local workspace----------------------------- + ! + + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_state) :: state_sc ! state for sub-columns + type(physics_ptend) :: ptend_sc ! ptend for sub-columns + type(physics_ptend) :: ptend_aero ! ptend for microp_aero + type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns + type(physics_tend) :: tend_sc ! tend for sub-columns + + integer :: nstep ! current timestep number + + real(r8) :: net_flx(pcols) + + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + integer :: i ! column indicex + integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep + ! physics buffer fields to compute tendencies for stratiform package + integer itim_old, ifld + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction + + + ! physics buffer fields for total energy and mass adjustment + real(r8), pointer, dimension(: ) :: teout + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: dtcore + + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + + ! convective precipitation variables + real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8),pointer :: snow_dp(:) ! snow from ZM convection + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection + + ! carma precipitation variables + real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) + real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) + + ! energy checking variables + real(r8) :: zero(pcols) ! array of zeros + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: flx_cnd(pcols) + real(r8) :: flx_heat(pcols) + type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes + real(r8) :: zero_tracers(pcols,pcnst) + + logical :: lq(pcnst) + !----------------------------------------------------------------------- + + call t_startf('bc_init') + + zero = 0._r8 + zero_tracers(:,:) = 0._r8 + zero_sc(:) = 0._r8 + + lchnk = state%lchnk + ncol = state%ncol + + nstep = get_nstep() + + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) + + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) + + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + + ifld = pbuf_get_index('DTCORE') + call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + ifld = pbuf_get_index('FRACIS') + call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + fracis (:ncol,:,1:pcnst) = 1._r8 + + ! Set physics tendencies to 0 + tend %dTdt(:ncol,:pver) = 0._r8 + tend %dudt(:ncol,:pver) = 0._r8 + tend %dvdt(:ncol,:pver) = 0._r8 + + ! Verify state coming from the dynamics + if (state_debug_checks) & + call physics_state_check(state, name="before tphysbc (dycore?)") + + call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) + + ! Since clybry_fam_adj operates directly on the tracers, and has no + ! physics_update call, re-run qneg3. + + call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,state%q ) + + ! Validate output of clybry_fam_adj. + if (state_debug_checks) & + call physics_state_check(state, name="clybry_fam_adj") + + ! + ! Dump out "before physics" state + ! + call diag_state_b4_phys_write (state) + + ! compute mass integrals of input tracers state + call check_tracers_init(state, tracerint) + + call t_stopf('bc_init') + + !=================================================== + ! Global mean total energy fixer + !=================================================== + call t_startf('energy_fixer') + + if (dycore_is('LR') .or. dycore_is('SE')) then + call check_energy_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) + end if + ! Save state for convective tendency calculations. + call diag_conv_tend_ini(state, pbuf) + + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + qini (:ncol,:pver) = state%q(:ncol,:pver, 1) + cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + + call outfld('TEOUT', teout , pcols, lchnk ) + call outfld('TEINP', state%te_ini, pcols, lchnk ) + call outfld('TEFIX', state%te_cur, pcols, lchnk ) + + ! T tendency due to dynamics + if( nstep > dyn_time_lvls-1 ) then + dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt + call outfld( 'DTCORE', dtcore, pcols, lchnk ) + end if + + call t_stopf('energy_fixer') + ! + !=================================================== + ! Dry adjustment + ! This code block is not a good example of interfacing a parameterization + !=================================================== + call t_startf('dry_adjustment') + + call dadadj_tend(ztodt, state, ptend) + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf('dry_adjustment') + + !=================================================== + ! Moist convection + !=================================================== + call t_startf('moist_convection') + + call t_startf ('convect_deep_tend') + + call convect_deep_tend( & + cmfmc, cmfcme, & + pflx, zdu, & + rliq, rice, & + ztodt, & + state, ptend, cam_in%landfrac, pbuf) + + call physics_update(state, ptend, ztodt, tend) + + call t_stopf('convect_deep_tend') + + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + ! Check energy integrals, including "reserved liquid" + flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) + snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) + call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) + snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) + + ! + ! Call Hack (1994) convection scheme to deal with shallow/mid-level convection + ! + call t_startf ('convect_shallow_tend') + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + call convect_shallow_tend (ztodt , cmfmc, & + dlf , dlf2 , rliq , rliq2, & + state , ptend , pbuf, cam_in) + call t_stopf ('convect_shallow_tend') + + call physics_update(state, ptend, ztodt, tend) + + flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) + call check_energy_chng(state, tend, "convect_shallow", nstep, ztodt, zero, flx_cnd, snow_sh, zero) + + call check_tracers_chng(state, tracerint, "convect_shallow", nstep, ztodt, zero_tracers) + + call t_stopf('moist_convection') + + ! Rebin the 4-bin version of sea salt into bins for coarse and accumulation + ! modes that correspond to the available optics data. This is only necessary + ! for CAM-RT. But it's done here so that the microphysics code which is called + ! from the stratiform interface has access to the same aerosols as the radiation + ! code. + call sslt_rebin_adv(pbuf, state) + + !=================================================== + ! Calculate tendencies from CARMA bin microphysics. + !=================================================== + ! + ! If CARMA is doing detrainment, then on output, rliq no longer represents water reserved + ! for detrainment, but instead represents potential snow fall. The mass and number of the + ! snow are stored in the physics buffer and will be incorporated by the MG microphysics. + ! + ! Currently CARMA cloud microphysics is only supported with the MG microphysics. + call t_startf('carma_timestep_tend') + + if (carma_do_cldice .or. carma_do_cldliq) then + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & + prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) + call physics_update(state, ptend, ztodt, tend) + + ! Before the detrainment, the reserved condensate is all liquid, but if CARMA is doing + ! detrainment, then the reserved condensate is snow. + if (carma_do_detrain) then + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) + else + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + end if + end if + + call t_stopf('carma_timestep_tend') + + if( microp_scheme == 'RK' ) then + + !=================================================== + ! Calculate stratiform tendency (sedimentation, detrain, cloud fraction and microphysics ) + !=================================================== + call t_startf('rk_stratiform_tend') + + call rk_stratiform_tend(state, ptend, pbuf, ztodt, & + cam_in%icefrac, cam_in%landfrac, cam_in%ocnfrac, & + cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + rliq , & ! check energy after detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu) + + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "cldwat_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + + call t_stopf('rk_stratiform_tend') + + elseif( microp_scheme == 'MG' ) then + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps + + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 + + do macmic_it = 1, cld_macmic_num_steps + + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== + + call t_startf('macrop_tend') + + ! don't call Park macrophysics if CLUBB is called + if (macrop_scheme .ne. 'CLUBB_SGS') then + + call macrop_driver_tend( & + state, ptend, cld_macmic_ztodt, & + cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu, & + pbuf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & + zero, flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + + else ! Calculate CLUBB macrophysics + + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== + + call clubb_tend_cam(state,ptend,pbuf,cld_macmic_ztodt,& + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & + cam_in%lhf(:ncol)/latvap/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + + endif + + call t_stopf('macrop_tend') + + !=================================================== + ! Calculate cloud microphysics + !=================================================== + + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) + + ! Generate sub-columns using the requested scheme + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if + + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') + + call t_startf('microp_tend') + + if (use_subcol_microp) then + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) + + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) + + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, & + prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & + snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) + + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) + + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + + call physics_update (state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & + zero, prec_str(:ncol)/cld_macmic_num_steps, & + snow_str(:ncol)/cld_macmic_num_steps, zero) + + call t_stopf('microp_tend') + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + + end do ! end substepping over macrophysics/microphysics + + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + + endif + + ! Add the precipitation from CARMA to the precipitation from stratiform. + if (carma_do_cldice .or. carma_do_cldliq) then + prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) + snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) + end if + + if ( .not. deep_scheme_does_scav_trans() ) then + + ! ------------------------------------------------------------------------------- + ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. + ! 2. Convective Transport of Non-Water Aerosol Species. + ! + ! . Aerosol wet chemistry determines scavenging fractions, and transformations + ! . Then do convective transport of all trace species except qv,ql,qi. + ! . We needed to do the scavenging first to determine the interstitial fraction. + ! . When UNICON is used as unified convection, we should still perform + ! wet scavenging but not 'convect_deep_tend2'. + ! ------------------------------------------------------------------------------- + + call t_startf('bc_aerosols') + if (clim_modal_aero .and. .not. prog_modal_aero) then + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + endif + call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) + call physics_update(state, ptend, ztodt, tend) + + + if (carma_do_wetdep) then + ! CARMA wet deposition + ! + ! NOTE: It needs to follow aero_model_wetdep, so that cam_out%xxxwetxxx + ! fields have already been set for CAM aerosols and cam_out can be added + ! to for CARMA aerosols. + call t_startf ('carma_wetdep_tend') + call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('carma_wetdep_tend') + end if + + call t_startf ('convect_deep_tend2') + call convect_deep_tend_2( state, ptend, ztodt, pbuf ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('convect_deep_tend2') + + ! check tracer integrals + call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) + + call t_stopf('bc_aerosols') + + endif + + !=================================================== + ! Moist physical parameteriztions complete: + ! send dynamical variables, and derived variables to history file + !=================================================== + + call t_startf('bc_history_write') + call diag_phys_writeout(state, cam_out%psl) + call diag_conv(state, ztodt, pbuf) + + call t_stopf('bc_history_write') + + !=================================================== + ! Write cloud diagnostics on history file + !=================================================== + + call t_startf('bc_cld_diag_history_write') + + call cloud_diagnostics_calc(state, pbuf) + + call t_stopf('bc_cld_diag_history_write') + + !=================================================== + ! Radiation computations + !=================================================== + call t_startf('radiation') + + + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) + + ! Set net flux used by spectral dycores + do i=1,ncol + tend%flx_net(i) = net_flx(i) + end do + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) + + call t_stopf('radiation') + + ! Diagnose the location of the tropopause and its location to the history file(s). + call t_startf('tropopause') + call tropopause_output(state) + call t_stopf('tropopause') + + ! Save atmospheric fields to force surface models + call t_startf('cam_export') + call cam_export (state,cam_out,pbuf) + call t_stopf('cam_export') + + ! Write export state to history file + call t_startf('diag_export') + call diag_export(cam_out) + call t_stopf('diag_export') + + end subroutine tphysbc + +subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) +!----------------------------------------------------------------------------------- +! +! Purpose: The place for parameterizations to call per timestep initializations. +! Generally this is used to update time interpolated fields from boundary +! datasets. +! +!----------------------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 + use chemistry, only: chem_timestep_init + use chem_surfvals, only: chem_surfvals_set + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc + use carma_intr, only: carma_timestep_init + use ghg_data, only: ghg_data_timestep_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_timestep_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_timestep_init + use aoa_tracers, only: aoa_tracers_timestep_init + use vertical_diffusion, only: vertical_diffusion_ts_init + use radheat, only: radheat_timestep_init + use solar_data, only: solar_data_advance + use qbo, only: qbo_timestep_init + use iondrag, only: do_waccm_ions, iondrag_timestep_init + use perf_mod + + use prescribed_ozone, only: prescribed_ozone_adv + use prescribed_ghg, only: prescribed_ghg_adv + use prescribed_aero, only: prescribed_aero_adv + use aerodep_flx, only: aerodep_flx_adv + use aircraft_emit, only: aircraft_emit_adv + use prescribed_volcaero, only: prescribed_volcaero_adv + use prescribed_strataero,only: prescribed_strataero_adv + use mo_apex, only: mo_apex_init + use epp_ionization, only: epp_ionization_active + use iop_forcing, only: scam_use_iop_srf + use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_stepinit + + implicit none + + type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state + type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in + type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + !----------------------------------------------------------------------------- + + if (single_column) call scam_use_iop_srf(cam_in) + + ! update geomagnetic coordinates + if (epp_ionization_active .or. do_waccm_ions) then + call mo_apex_init(phys_state) + endif + + ! Chemistry surface values + call chem_surfvals_set() + + ! Solar irradiance + call solar_data_advance() + + ! Time interpolate for chemistry. + call chem_timestep_init(phys_state, pbuf2d) + + ! Prescribed tracers + call prescribed_ozone_adv(phys_state, pbuf2d) + call prescribed_ghg_adv(phys_state, pbuf2d) + call prescribed_aero_adv(phys_state, pbuf2d) + call aircraft_emit_adv(phys_state, pbuf2d) + call prescribed_volcaero_adv(phys_state, pbuf2d) + call prescribed_strataero_adv(phys_state, pbuf2d) + + ! prescribed aerosol deposition fluxes + call aerodep_flx_adv(phys_state, pbuf2d, cam_out) + + ! CAM3 prescribed aerosol masses + if (cam3_aero_data_on) call cam3_aero_data_timestep_init(pbuf2d, phys_state) + + ! CAM3 prescribed ozone data + if (cam3_ozone_data_on) call cam3_ozone_data_timestep_init(pbuf2d, phys_state) + + ! Time interpolate data models of gasses in pbuf2d + call ghg_data_timestep_init(pbuf2d, phys_state) + + ! Upper atmosphere radiative processes + call radheat_timestep_init(phys_state, pbuf2d) + + ! Time interpolate for vertical diffusion upper boundary condition + call vertical_diffusion_ts_init(pbuf2d, phys_state) + + !---------------------------------------------------------------------- + ! update QBO data for this time step + !---------------------------------------------------------------------- + call qbo_timestep_init + + call iondrag_timestep_init() + + !---------------------------------------------------------------------- + ! update waccmx Te / Ti module + !---------------------------------------------------------------------- + call waccmx_phys_ion_elec_temp_stepinit() + + call carma_timestep_init() + + ! age of air tracers + call aoa_tracers_timestep_init(phys_state) + +end subroutine phys_timestep_init + +end module physpkg diff --git a/src/physics/cam/vertical_diffusion.F90.beta07 b/src/physics/cam/vertical_diffusion.F90.beta07 new file mode 100644 index 0000000000..f59f4aedca --- /dev/null +++ b/src/physics/cam/vertical_diffusion.F90.beta07 @@ -0,0 +1,1532 @@ +module vertical_diffusion + +!----------------------------------------------------------------------------------------------------- ! +! Module to compute vertical diffusion of momentum, moisture, trace constituents ! +! and static energy. Separate modules compute ! +! 1. stresses associated with turbulent flow over orography ! +! ( turbulent mountain stress ) ! +! 2. eddy diffusivities, including nonlocal tranport terms ! +! 3. molecular diffusivities ! +! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! +! differencing the diffused and initial states. ! +! ! +! Calling sequence: ! +! ! +! vertical_diffusion_init Initializes vertical diffustion constants and modules ! +! init_molec_diff Initializes molecular diffusivity module ! +! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! +! init_tms Initializes turbulent mountain stress module ! +! init_vdiff Initializes diffusion solver module ! +! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! +! vertical_diffusion_tend Computes vertical diffusion tendencies ! +! compute_tms Computes turbulent mountain stresses ! +! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! +! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! +! ! +!----------------------------------------------------------------------------------------------------- ! +! Some notes on refactoring changes made in 2015, which were not quite finished. ! +! ! +! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! +! removing these arguments, and referring to pbuf fields instead, is not complete. ! +! ! +! - compute_vdiff was intended to be split up into three components: ! +! ! +! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! +! ! +! 2. Turbulent diffusion of a single constituent ! +! ! +! 3. Molecular diffusion of a single constituent ! +! ! +! This reorganization would allow the three resulting functions to each use a simpler interface ! +! than the current combined version, and possibly also remove the need to use the fieldlist ! +! object at all. ! +! ! +! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! +! pull out these diagnostic calculations and outfld calls into separate functions. ! +! ! +!---------------------------Code history-------------------------------------------------------------- ! +! J. Rosinski : Jun. 1992 ! +! J. McCaa : Sep. 2004 ! +! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! +!----------------------------------------------------------------------------------------------------- ! + +use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 +use ppgrid, only : pcols, pver, pverp +use constituents, only : pcnst +use diffusion_solver, only : vdiff_selector +use cam_abortutils, only : endrun +use error_messages, only : handle_errmsg +use physconst, only : & + cpair , & ! Specific heat of dry air + gravit , & ! Acceleration due to gravity + rair , & ! Gas constant for dry air + zvir , & ! rh2o/rair - 1 + latvap , & ! Latent heat of vaporization + latice , & ! Latent heat of fusion + karman , & ! von Karman constant + mwdry , & ! Molecular weight of dry air + avogad ! Avogadro's number +use cam_history, only : fieldname_len +use perf_mod +use cam_logfile, only : iulog +use ref_pres, only : do_molec_diff, nbot_molec +use phys_control, only : phys_getopts +use time_manager, only : is_first_step + +implicit none +private +save + +! ----------------- ! +! Public interfaces ! +! ----------------- ! + +public vd_readnl +public vd_register ! Register multi-time-level variables with physics buffer +public vertical_diffusion_init ! Initialization +public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) +public vertical_diffusion_tend ! Full vertical diffusion routine + +! ------------ ! +! Private data ! +! ------------ ! + +character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change +! 'HB' = Holtslag and Boville (default) +! 'HBR' = Holtslag and Boville and Rash +! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) +logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure +! ( when 'diag_TKE' scheme is selected ) +logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion + +character(len=16) :: shallow_scheme ! Shallow convection scheme + +type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion +type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion +type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion +integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer +integer :: kvt_idx ! Index for kinematic molecular conductivity +integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions +integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress + +character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies +integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water +integer :: ixnumice, ixnumliq + +integer :: pblh_idx, tpert_idx, qpert_idx + +! pbuf fields for unicon +integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on +integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on + +! pbuf fields for tms +integer :: ksrftms_idx = -1 +integer :: tautmsx_idx = -1 +integer :: tautmsy_idx = -1 + +! pbuf fields for blj (Beljaars) +integer :: dragblj_idx = -1 +integer :: taubljx_idx = -1 +integer :: taubljy_idx = -1 + +logical :: diff_cnsrv_mass_check ! do mass conservation check +logical :: do_iss ! switch for implicit turbulent surface stress +logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present +integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents +integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols + +logical :: do_pbl_diags = .false. +logical :: waccmx_mode = .false. + +contains + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! +subroutine vd_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom + use shr_log_mod, only: errMsg => shr_log_errMsg + use trb_mtn_stress_cam, only: trb_mtn_stress_readnl + use beljaars_drag_cam, only: beljaars_drag_readnl + use eddy_diff_cam, only: eddy_diff_readnl + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'vd_readnl' + + namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'vert_diff_nl', status=ierr) + if (ierr == 0) then + read(unitn, vert_diff_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + + ! Get eddy_scheme setting from phys_control. + call phys_getopts( eddy_scheme_out = eddy_scheme, & + shallow_scheme_out = shallow_scheme ) + + ! TMS reads its own namelist. + call trb_mtn_stress_readnl(nlfile) + + ! Beljaars reads its own namelist. + call beljaars_drag_readnl(nlfile) + + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) + +end subroutine vd_readnl + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vd_register() + + !------------------------------------------------ ! + ! Register physics buffer fields and constituents ! + !------------------------------------------------ ! + + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + use trb_mtn_stress_cam, only : trb_mtn_stress_register + use beljaars_drag_cam, only : beljaars_drag_register + use eddy_diff_cam, only : eddy_diff_register + + ! Add fields to physics buffer + + ! kvt is used by gw_drag. only needs physpkg scope. + call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) + + + 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('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) + call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) + call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) + + call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) + call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) + + call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) + call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) + call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) + end if + + ! diag_TKE fields + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then + call eddy_diff_register() + end if + + ! TMS fields + call trb_mtn_stress_register() + + ! Beljaars fields + call beljaars_drag_register() + +end subroutine vd_register + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_init(pbuf2d) + + !------------------------------------------------------------------! + ! Initialization of time independent fields for vertical diffusion ! + ! Calls initialization routines for subsidiary modules ! + !----------------------------------------------------------------- ! + + use cam_history, only : addfld, add_default, horiz_only + use cam_history, only : register_vector_field + use eddy_diff_cam, only : eddy_diff_init + use hb_diff, only : init_hb_diff + use molec_diff, only : init_molec_diff + use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select + use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind + use spmd_utils, only : masterproc + use ref_pres, only : press_lim_idx, pref_mid + use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc + use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & + rad_cnst_get_mam_mmr_idx + use trb_mtn_stress_cam,only : trb_mtn_stress_init + use beljaars_drag_cam, only : beljaars_drag_init + use upper_bc, only : ubc_init + use phys_control, only : waccmx_is, fv_am_correction + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + character(128) :: errstring ! Error status for init_vdiff + 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 :: k ! Vertical loop index + + real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) + + integer :: im, l, m, nmodes, nspec + + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_eddy ! output the eddy variables + logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi + integer :: history_budget_histfile_num ! output history file number for budget fields + logical :: history_waccm ! output variables of interest for WACCM runs + + ! ----------------------------------------------------------------- ! + + if (masterproc) then + write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' + end if + + ! Check to see if WACCM-X is on (currently we don't care whether the + ! ionosphere is on or not, since this neutral diffusion code is the + ! same either way). + waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') + + ! ----------------------------------------------------------------- ! + ! Get indices of cloud liquid and ice within the constituents array ! + ! ----------------------------------------------------------------- ! + + call cnst_get_ind( 'CLDLIQ', ixcldliq ) + call cnst_get_ind( 'CLDICE', ixcldice ) + ! These are optional; with the CAM4 microphysics, there are no number + ! constituents. + call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) + call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) + + ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + if (prog_modal_aero) then + + ! Get the constituent indices of the number and mass mixing ratios of the modal + ! aerosols. + ! + ! N.B. - This implementation assumes that the prognostic modal aerosols are + ! impacting the climate calculation (i.e., can get info from list 0). + ! + + ! First need total number of mam constituents + call rad_cnst_get_info(0, nmodes=nmodes) + do m = 1, nmodes + call rad_cnst_get_info(0, m, nspec=nspec) + pmam_ncnst = pmam_ncnst + 1 + nspec + end do + + allocate(pmam_cnst_idx(pmam_ncnst)) + + ! Get the constituent indicies + im = 1 + do m = 1, nmodes + call rad_cnst_get_mode_num_idx(m, pmam_cnst_idx(im)) + im = im + 1 + call rad_cnst_get_info(0, m, nspec=nspec) + do l = 1, nspec + call rad_cnst_get_mam_mmr_idx(m, l, pmam_cnst_idx(im)) + im = im + 1 + end do + end do + end if + + ! Initialize upper boundary condition module + + call ubc_init() + + ! ---------------------------------------------------------------------------------------- ! + ! Initialize molecular diffusivity module ! + ! Note that computing molecular diffusivities is a trivial expense, but constituent ! + ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! + ! for each constituent is a needless expense unless the diffusivity is significant. ! + ! ---------------------------------------------------------------------------------------- ! + + !---------------------------------------------------------------------------------------- + ! Initialize molecular diffusion and get top and bottom molecular diffusion limits + !---------------------------------------------------------------------------------------- + + if( do_molec_diff ) then + call init_molec_diff( r8, pcnst, mwdry, avogad, & + errstring) + + call handle_errmsg(errstring, subname="init_molec_diff") + + call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) + if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec + end if + + ! ---------------------------------- ! + ! Initialize eddy diffusivity module ! + ! ---------------------------------- ! + + ! ntop_eddy must be 1 or <= nbot_molec + ! Currently, it is always 1 except for WACCM-X. + if ( waccmx_mode ) then + ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) + else + ntop_eddy = 1 + end if + nbot_eddy = pver + + if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy + + select case ( eddy_scheme ) + case ( 'diag_TKE', 'SPCAM_m2005' ) + if( masterproc ) write(iulog,*) & + 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' + call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) + case ( 'HB', 'HBR', 'SPCAM_sam1mom') + if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' + call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & + karman, eddy_scheme) + call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) + case ( 'CLUBB_SGS' ) + do_pbl_diags = .true. + end select + + ! ------------------------------------------- ! + ! Initialize turbulent mountain stress module ! + ! ------------------------------------------- ! + + call trb_mtn_stress_init() + + ! ----------------------------------- ! + ! Initialize Beljaars SGO drag module ! + ! ----------------------------------- ! + + call beljaars_drag_init() + + ! ---------------------------------- ! + ! Initialize diffusion solver module ! + ! ---------------------------------- ! + + call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) + call handle_errmsg(errstring, subname="init_vdiff") + + ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) + ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. + + fieldlist_wet = new_fieldlist_vdiff( pcnst) + fieldlist_dry = new_fieldlist_vdiff( pcnst) + fieldlist_molec = new_fieldlist_vdiff( pcnst) + + if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) + if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) + if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) + + constit_loop: do k = 1, pcnst + + if (prog_modal_aero) then + ! Do not diffuse droplet number - treated in dropmixnuc + if (k == ixnumliq) cycle constit_loop + ! Don't diffuse modal aerosol - treated in dropmixnuc + do m = 1, pmam_ncnst + if (k == pmam_cnst_idx(m)) cycle constit_loop + enddo + end if + + if( cnst_get_type_byind(k) .eq. 'wet' ) then + if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) + else + if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) + endif + + ! ----------------------------------------------- ! + ! Select constituents for molecular diffusion ! + ! ----------------------------------------------- ! + if ( cnst_get_molec_byind(k) .eq. 'minor' ) then + if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) + endif + + end do constit_loop + + ! ------------------------ ! + ! Diagnostic output fields ! + ! ------------------------ ! + + do k = 1, pcnst + vdiffnam(k) = 'VD'//cnst_name(k) + if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** + call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) + end do + + if (.not. do_pbl_diags) then + call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) + call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) + call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) + call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) + call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) + call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) + call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) + call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) + call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) + + call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) + call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) + call register_vector_field('UFLX', 'VFLX') + end if + + call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) + call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) + call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) + call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') + call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) + call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) + call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) + call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) + call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) + + ! ---------------------------------------------------------------------------- ! + ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! + ! ---------------------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) + call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) + call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) + call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) + call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) + call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) + call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) + call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) + call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) + call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) + + call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) + call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) + call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) + call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) + call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) + call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) + call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) + call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) + call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) + call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) + + call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) + call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) + call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) + call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) + + call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) + call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) + call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) + call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) + + call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) + call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) + call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) + call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) + call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) + call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) + call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) + call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) + call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) + + end if + + call addfld ('ustar',horiz_only, 'A', ' ',' ') + call addfld ('obklen',horiz_only, 'A', ' ',' ') + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + + call phys_getopts( history_amwg_out = history_amwg, & + history_eddy_out = history_eddy, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + if (history_amwg) then + call add_default( vdiffnam(1), 1, ' ' ) + call add_default( 'DTV' , 1, ' ' ) + if (.not. do_pbl_diags) then + call add_default( 'PBLH' , 1, ' ' ) + end if + endif + + if (history_eddy) then + call add_default( 'UFLX ', 1, ' ' ) + call add_default( 'VFLX ', 1, ' ' ) + endif + + if( history_budget ) then + call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) + if( history_budget_histfile_num > 1 ) then + call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) + call add_default( 'DTV' , history_budget_histfile_num, ' ' ) + end if + end if + + if ( history_waccm ) then + if (do_molec_diff) then + call add_default ( 'TTPXMLC', 1, ' ' ) + end if + call add_default( 'DUV' , 1, ' ' ) + call add_default( 'DVV' , 1, ' ' ) + end if + ! ---------------------------- + + + ksrftms_idx = pbuf_get_index('ksrftms') + tautmsx_idx = pbuf_get_index('tautmsx') + tautmsy_idx = pbuf_get_index('tautmsy') + + dragblj_idx = pbuf_get_index('dragblj') + taubljx_idx = pbuf_get_index('taubljx') + taubljy_idx = pbuf_get_index('taubljy') + + ! Initialization of some pbuf fields + if (is_first_step()) then + ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat + call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) + call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) + end if + end if + +end subroutine vertical_diffusion_init + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_ts_init( pbuf2d, state ) + + !-------------------------------------------------------------- ! + ! Timestep dependent setting, ! + ! At present only invokes upper bc code ! + !-------------------------------------------------------------- ! + use upper_bc, only : ubc_timestep_init + use physics_types , only : physics_state + use ppgrid , only : begchunk, endchunk + + use physics_buffer, only : physics_buffer_desc + + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + call ubc_timestep_init( pbuf2d, state) + +end subroutine vertical_diffusion_ts_init + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine vertical_diffusion_tend( & + ztodt , state , cam_in, & + ustar , obklen , ptend , & + cldn , pbuf) + !---------------------------------------------------- ! + ! This is an interface routine for vertical diffusion ! + !---------------------------------------------------- ! + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field + use physics_types, only : physics_state, physics_ptend, physics_ptend_init + use camsrfexch, only : cam_in_t + use cam_history, only : outfld + + use trb_mtn_stress_cam, only : trb_mtn_stress_tend + use beljaars_drag_cam, only : beljaars_drag_tend + use eddy_diff_cam, only : eddy_diff_tend + use hb_diff, only : compute_hb_diff + use wv_saturation, only : qsat + use molec_diff, only : compute_molec_diff, vd_lu_qdecomp + use constituents, only : qmincg, qmin + use diffusion_solver, only : compute_vdiff, any, operator(.not.) + use physconst, only : cpairv, rairv !Needed for calculation of upward H flux + use time_manager, only : get_nstep + use constituents, only : cnst_get_type_byind, cnst_name, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx + use physconst, only : pi + use pbl_utils, only : virtem, calc_obklen, calc_ustar + use upper_bc, only : ubc_get_vals + use coords_1d, only : Coords1D + + ! --------------- ! + ! Input Arguments ! + ! --------------- ! + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in ! Surface inputs + + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] + + ! ---------------------- ! + ! Input-Output Arguments ! + ! ---------------------- ! + + type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + ! ---------------- ! + ! Output Arguments ! + ! ---------------- ! + + real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] + real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + + character(128) :: errstring ! Error status for compute_vdiff + + integer :: lchnk ! Chunk identifier + integer :: ncol ! Number of atmospheric columns + integer :: i, k, l, m ! column, level, constituent indices + + real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation + real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] + integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] + real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function + ! ( 0<= <=4.964 and 1 at neutral ) + + real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql + real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi + + real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] + real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat + real(r8) :: rztodt ! 1./ztodt [ 1/s ] + real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] + real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] + real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] + real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] + + real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] + real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] + + real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] + real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] + real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] + real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] + real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] + real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] + real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] + real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call + real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] + real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] + real(r8) :: sl(pcols,pver) + real(r8) :: qt(pcols,pver) + real(r8) :: slv(pcols,pver) + real(r8) :: sl_prePBL(pcols,pver) + real(r8) :: qt_prePBL(pcols,pver) + real(r8) :: slv_prePBL(pcols,pver) + real(r8) :: slten(pcols,pver) + real(r8) :: qtten(pcols,pver) + real(r8) :: slflx(pcols,pverp) + real(r8) :: qtflx(pcols,pverp) + real(r8) :: uflx(pcols,pverp) + real(r8) :: vflx(pcols,pverp) + real(r8) :: slflx_cg(pcols,pverp) + real(r8) :: qtflx_cg(pcols,pverp) + real(r8) :: uflx_cg(pcols,pverp) + real(r8) :: vflx_cg(pcols,pverp) + real(r8) :: th(pcols,pver) ! Potential temperature + real(r8) :: topflx(pcols) ! Molecular heat flux at top interface + real(r8) :: rhoair + + real(r8) :: ri(pcols,pver) ! richardson number (HB output) + + ! for obklen calculation outside HB + real(r8) :: thvs(pcols) ! Virtual potential temperature at surface + real(r8) :: rrho(pcols) ! Reciprocal of density at surface + real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] + real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] + real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] + + real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL + real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH + real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion + real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion + real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion + real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion + real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion + real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion + real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion + real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion + real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion + real(r8) :: qv_pro(pcols,pver) + real(r8) :: ql_pro(pcols,pver) + real(r8) :: qi_pro(pcols,pver) + real(r8) :: s_pro(pcols,pver) + real(r8) :: t_pro(pcols,pver) + real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct + real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. + + ! Interpolated interface values. + real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] + real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] + real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] + real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] + + ! Upper boundary conditions + real(r8) :: ubc_t(pcols) ! Temperature [ K ] + real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] + real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) + + ! Pressure coordinates used by the solver. + type(Coords1D) :: p + type(Coords1D) :: p_dry + + real(r8), pointer :: tpert(:) + real(r8), pointer :: qpert(:) + real(r8), pointer :: pblh(:) + + real(r8) :: tmp1(pcols) ! Temporary storage + + integer :: nstep + real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sflx + + ! Copy state so we can pass to intent(inout) routines that return + ! new state instead of a tendency. + real(r8) :: s_tmp(pcols,pver) + real(r8) :: u_tmp(pcols,pver) + real(r8) :: v_tmp(pcols,pver) + real(r8) :: q_tmp(pcols,pver,pcnst) + + ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity + real(r8) :: kq_scal(pcols,pver+1) + ! composition dependent mw_fac on interface level + real(r8) :: mw_fac(pcols,pver+1,pcnst) + + ! Dry static energy top boundary condition. + real(r8) :: dse_top(pcols) + + ! Copies of flux arrays used to zero out any parts that are applied + ! elsewhere (e.g. by CLUBB). + real(r8) :: taux(pcols) + real(r8) :: tauy(pcols) + real(r8) :: shflux(pcols) + real(r8) :: cflux(pcols,pcnst) + + logical :: lq(pcnst) + + ! ----------------------- ! + ! Main Computation Begins ! + ! ----------------------- ! + + rztodt = 1._r8 / ztodt + lchnk = state%lchnk + ncol = state%ncol + + call pbuf_get_field(pbuf, tauresx_idx, tauresx) + call pbuf_get_field(pbuf, tauresy_idx, tauresy) + call pbuf_get_field(pbuf, tpert_idx, tpert) + call pbuf_get_field(pbuf, qpert_idx, qpert) + call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, turbtype_idx, turbtype) + + ! Interpolate temperature to interfaces. + do k = 2, pver + do i = 1, ncol + tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) + end do + end do + tint(:ncol,pver+1) = state%t(:ncol,pver) + + ! Get upper boundary values + call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & + ubc_t, ubc_mmr, ubc_flux ) + + ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? + ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures + if (do_molec_diff) then + if (waccmx_mode) then + tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) + else + tint (:ncol,1) = ubc_t(:ncol) + endif + else + tint(:ncol,1) = state%t(:ncol,1) + end if + + ! Set up pressure coordinates for solver calls. + p = Coords1D(state%pint(:ncol,:)) + p_dry = Coords1D(state%pintdry(:ncol,:)) + + !------------------------------------------------------------------------ + ! Check to see if constituent dependent gas constant needed (WACCM-X) + !------------------------------------------------------------------------ + if (waccmx_mode) then + rairi(:ncol,1) = rairv(:ncol,1,lchnk) + do k = 2, pver + do i = 1, ncol + rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) + end do + end do + rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) + else + rairi(:ncol,:pver+1) = rair + endif + + ! Compute rho at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! Compute rho_dry at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! ---------------------------------------- ! + ! Computation of turbulent mountain stress ! + ! ---------------------------------------- ! + + ! Consistent with the computation of 'normal' drag coefficient, we are using + ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' + ! within the iteration loop of the PBL scheme. + + call trb_mtn_stress_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) + call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) + call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) + + tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) + tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) + + ! ------------------------------------- ! + ! Computation of Beljaars SGO form drag ! + ! ------------------------------------- ! + + call beljaars_drag_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, dragblj_idx, dragblj) + call pbuf_get_field(pbuf, taubljx_idx, taubljx) + call pbuf_get_field(pbuf, taubljy_idx, taubljy) + + ! Add Beljaars integrated drag + + tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) + tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) + + !----------------------------------------------------------------------- ! + ! Computation of eddy diffusivities - Select appropriate PBL scheme ! + !----------------------------------------------------------------------- ! + call pbuf_get_field(pbuf, kvm_idx, kvm_in) + call pbuf_get_field(pbuf, kvh_idx, kvh_in) + call pbuf_get_field(pbuf, smaw_idx, smaw) + call pbuf_get_field(pbuf, tke_idx, tke) + + ! Get potential temperature. + th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) + + select case (eddy_scheme) + case ( 'diag_TKE', 'SPCAM_m2005' ) + + call eddy_diff_tend(state, pbuf, cam_in, & + ztodt, p, tint, rhoi, cldn, wstarent, & + kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & + rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & + tke, sprod, sfi, turbtype, smaw) + + ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. + ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + + case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) + + ! Modification : We may need to use 'taux' instead of 'tautotx' here, for + ! consistency with the previous HB scheme. + + call compute_hb_diff( lchnk , ncol , & + th , state%t , state%q , state%zm , state%zi, & + state%pmid, state%u , state%v , tautotx , tautoty , & + cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & + kvm , kvh , kvq , cgh , cgs , & + tpert , qpert , cldn , cam_in%ocnfrac , tke , & + ri , & + eddy_scheme ) + + call outfld( 'HB_ri', ri, pcols, lchnk ) + + case ( 'CLUBB_SGS' ) + + ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the + ! PBL diffusion will happen before coupling, so vertical_diffusion + ! is only handling other things, e.g. some boundary conditions, tms, + ! and molecular diffusion. + + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + + call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & + cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) + call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%lhf(:ncol)/latvap, & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + ! These tendencies all applied elsewhere. + kvm = 0._r8 + kvh = 0._r8 + kvq = 0._r8 + + ! Not defined since PBL is not actually running here. + cgh = 0._r8 + cgs = 0._r8 + + end select + + call outfld( 'ustar', ustar(:), pcols, lchnk ) + call outfld( 'obklen', obklen(:), pcols, lchnk ) + + ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff + ! on the next timestep. It is not updated by the compute_vdiff call below. + call pbuf_set_field(pbuf, kvh_idx, kvh) + + ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. + ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below + ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. + call pbuf_set_field(pbuf, kvm_idx, kvm) + + !------------------------------------ ! + ! Application of diffusivities ! + !------------------------------------ ! + + ! Set arrays from input state. + q_tmp(:ncol,:,:) = state%q(:ncol,:,:) + s_tmp(:ncol,:) = state%s(:ncol,:) + u_tmp(:ncol,:) = state%u(:ncol,:) + v_tmp(:ncol,:) = state%v(:ncol,:) + + !------------------------------------------------------ ! + ! Write profile output before applying diffusion scheme ! + !------------------------------------------------------ ! + + if (.not. do_pbl_diags) then + sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) + + call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & + tem2(:ncol,:), ftem(:ncol,:)) + ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + + call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) + call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) + call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) + call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) + call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) + call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) + call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) + + end if + + ! --------------------------------------------------------------------------------- ! + ! Call the diffusivity solver and solve diffusion equation ! + ! The final two arguments are optional function references to ! + ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! + ! --------------------------------------------------------------------------------- ! + + ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and + ! separately print out as diagnostic output, because these are different from + ! the explicit 'tautotx, tautoty' computed above. + ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. + + call pbuf_get_field(pbuf, kvt_idx, kvt) + + if (do_molec_diff .and. .not. waccmx_mode) then + ! Top boundary condition for dry static energy + dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & + gravit * state%zi(:ncol,1) + else + dse_top(:ncol) = 0._r8 + end if + + select case (eddy_scheme) + case ('CLUBB_SGS') + ! CLUBB applies some fluxes itself, but we still want constituent + ! fluxes applied here (except water vapor). + taux = 0._r8 + tauy = 0._r8 + shflux = 0._r8 + cflux(:,1) = 0._r8 + cflux(:,2:) = cam_in%cflx(:,2:) + case default + taux = cam_in%wsx + tauy = cam_in%wsy + shflux = cam_in%shf + cflux = cam_in%cflx + end select + + if( any(fieldlist_wet) ) then + + if (do_molec_diff) then + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p , state%t , rhoi, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_wet , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx , tautmsy , dtk , topflx , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff, waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmid, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_wet call from vertical_diffusion.") + + end if + + if( any( fieldlist_dry ) ) then + + if( do_molec_diff ) then + ! kvm is unused in the output here (since it was assigned + ! above), so we use a temp kvm for the inout argument, and + ! ignore the value output by compute_molec_diff. + kvm_temp = kvm + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p_dry , state%t , rhoi_dry, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_dry , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff , waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmiddry, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_dry call from vertical_diffusion.") + + end if + + if (prog_modal_aero) then + + ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the + ! lowest layer + + tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) + do m = 1, pmam_ncnst + l = pmam_cnst_idx(m) + q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) + enddo + end if + + ! -------------------------------------------------------- ! + ! Diagnostics and output writing after applying PBL scheme ! + ! -------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) + + slflx(:ncol,1) = 0._r8 + qtflx(:ncol,1) = 0._r8 + uflx(:ncol,1) = 0._r8 + vflx(:ncol,1) = 0._r8 + + slflx_cg(:ncol,1) = 0._r8 + qtflx_cg(:ncol,1) = 0._r8 + uflx_cg(:ncol,1) = 0._r8 + vflx_cg(:ncol,1) = 0._r8 + + do k = 2, pver + do i = 1, ncol + rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) + slflx(i,k) = kvh(i,k) * & + ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + cgh(i,k) ) + qtflx(i,k) = kvh(i,k) * & + ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) + uflx(i,k) = kvm(i,k) * & + ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + vflx(i,k) = kvm(i,k) * & + ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + slflx_cg(i,k) = kvh(i,k) * cgh(i,k) + qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & + cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) + uflx_cg(i,k) = 0._r8 + vflx_cg(i,k) = 0._r8 + end do + end do + + ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. + ! Note also that 'tautotx' is explicit total stress, different from + ! the ones that have been actually added into the atmosphere. + + slflx(:ncol,pverp) = cam_in%shf(:ncol) + qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) + uflx(:ncol,pverp) = tautotx(:ncol) + vflx(:ncol,pverp) = tautoty(:ncol) + + slflx_cg(:ncol,pverp) = 0._r8 + qtflx_cg(:ncol,pverp) = 0._r8 + uflx_cg(:ncol,pverp) = 0._r8 + vflx_cg(:ncol,pverp) = 0._r8 + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + qtl_flx(:ncol,1) = 0._r8 + qti_flx(:ncol,1) = 0._r8 + do k = 2, pver + do i = 1, ncol + ! For use in the cloud macrophysics + ! Note that density is not added here. Also, only consider local transport term. + qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& + (state%zm(i,k-1)-state%zm(i,k)) + qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& + (state%zm(i,k-1)-state%zm(i,k)) + end do + end do + do i = 1, ncol + rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) + qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + end do + end if + + end if + + ! --------------------------------------------------------------- ! + ! Convert the new profiles into vertical diffusion tendencies. ! + ! Convert KE dissipative heat change into "temperature" tendency. ! + ! --------------------------------------------------------------- ! + + ! All variables are modified by vertical diffusion + + lq(:) = .TRUE. + call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & + ls=.true., lu=.true., lv=.true., lq=lq) + + ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt + ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt + ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt + ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt + if (.not. do_pbl_diags) then + slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt + qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt + end if + + ! ------------------------------------------------------------ ! + ! In order to perform 'pseudo-conservative variable diffusion' ! + ! perform the following two stages: ! + ! ! + ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! + ! (2) 'sten' by 'slten', and ! + ! (3) 'qlten = qiten = 0' ! + ! ! + ! II. Apply 'positive_moisture' ! + ! ! + ! ------------------------------------------------------------ ! + + if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then + + ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) + ptend%s(:ncol,:pver) = slten(:ncol,:pver) + ptend%q(:ncol,:pver,ixcldliq) = 0._r8 + ptend%q(:ncol,:pver,ixcldice) = 0._r8 + if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 + if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 + + do i = 1, ncol + do k = 1, pver + qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt + ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt + qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt + s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt + t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt + end do + end do + + call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & + qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & + ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & + ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) + + end if + + ! ----------------------------------------------------------------- ! + ! Re-calculate diagnostic output variables after vertical diffusion ! + ! ----------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt + ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt + qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt + s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt + t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair + + u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt + v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt + + call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & + tem2(:ncol,:pver), ftem(:ncol,:pver)) + ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 + + tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt + rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt + + end if + + ! -------------------------------------------------------------- ! + ! mass conservation check......... + ! -------------------------------------------------------------- ! + if (diff_cnsrv_mass_check) then + + ! Conservation check + do m = 1, pcnst + fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then + col_loop: do i = 1, ncol + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + do k = 1, pver + if(cnst_get_type_byind(m).eq.'wet') then + pdelx = state%pdel(i,k) + else + pdelx = state%pdeldry(i,k) + endif + sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column + sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied + sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column + enddo + sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) + sflx = (cam_in%cflx(i,m) * ztodt) + if (sum1>1.e-36_r8) then + if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then + nstep = get_nstep() + write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & + 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & + trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & + sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 + call endrun('vertical_diffusion_tend : mass not conserved' ) + endif + endif + enddo col_loop + endif fixed_ubc + enddo + endif + + ! -------------------------------------------------------------- ! + ! Writing state variables after PBL scheme for detailed analysis ! + ! -------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) + call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) + call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) + call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) + call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) + call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) + call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) + call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) + call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) + call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) + call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) + call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) + call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) + call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) + call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) + call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) + call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) + call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) + call outfld( 'slten_PBL' , slten, pcols, lchnk ) + call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'tten_PBL' , tten, pcols, lchnk ) + call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) + + end if + + ! ------------------------------------------- ! + ! Writing the other standard output variables ! + ! ------------------------------------------- ! + + if (.not. do_pbl_diags) then + call outfld( 'QT' , qt, pcols, lchnk ) + call outfld( 'SL' , sl, pcols, lchnk ) + call outfld( 'SLV' , slv, pcols, lchnk ) + call outfld( 'SLFLX' , slflx, pcols, lchnk ) + call outfld( 'QTFLX' , qtflx, pcols, lchnk ) + call outfld( 'UFLX' , uflx, pcols, lchnk ) + call outfld( 'VFLX' , vflx, pcols, lchnk ) + call outfld( 'TKE' , tke, pcols, lchnk ) + + call outfld( 'PBLH' , pblh, pcols, lchnk ) + call outfld( 'TPERT' , tpert, pcols, lchnk ) + call outfld( 'QPERT' , qpert, pcols, lchnk ) + end if + call outfld( 'USTAR' , ustar, pcols, lchnk ) + call outfld( 'KVH' , kvh, pcols, lchnk ) + call outfld( 'KVT' , kvt, pcols, lchnk ) + call outfld( 'KVM' , kvm, pcols, lchnk ) + call outfld( 'CGS' , cgs, pcols, lchnk ) + dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history + call outfld( 'DTVKE' , dtk, pcols, lchnk ) + dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk + call outfld( 'DTV' , dtk, pcols, lchnk ) + call outfld( 'DUV' , ptend%u, pcols, lchnk ) + call outfld( 'DVV' , ptend%v, pcols, lchnk ) + do m = 1, pcnst + call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) + end do + if( do_molec_diff ) then + call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) + end if + + call p%finalize() + call p_dry%finalize() + +end subroutine vertical_diffusion_tend + +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & + dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) + ! ------------------------------------------------------------------------------- ! + ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! + ! force them to be larger than minimum value by (1) condensating water vapor ! + ! into liquid or ice, and (2) by transporting water vapor from the very lower ! + ! layer. '2._r8' is multiplied to the minimum values for safety. ! + ! Update final state variables and tendencies associated with this correction. ! + ! If any condensation happens, update (s,t) too. ! + ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! + ! input tendencies. ! + ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! + ! ------------------------------------------------------------------------------- ! + implicit none + integer, intent(in) :: ncol, mkx + real(r8), intent(in) :: cp, xlv, xls + real(r8), intent(in) :: dt, qvmin, qlmin, qimin + real(r8), intent(in) :: dp(ncol,mkx) + real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) + real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) + integer i, k + real(r8) dql, dqi, dqv, sum, aa, dum + + ! Modification : I should check whether this is exactly same as the one used in + ! shallow convection and cloud macrophysics. + + do i = 1, ncol + do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface + dql = max(0._r8,1._r8*qlmin-ql(i,k)) + dqi = max(0._r8,1._r8*qimin-qi(i,k)) + qlten(i,k) = qlten(i,k) + dql/dt + qiten(i,k) = qiten(i,k) + dqi/dt + qvten(i,k) = qvten(i,k) - (dql+dqi)/dt + sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) + ql(i,k) = ql(i,k) + dql + qi(i,k) = qi(i,k) + dqi + qv(i,k) = qv(i,k) - dql - dqi + s(i,k) = s(i,k) + xlv * dql + xls * dqi + t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp + dqv = max(0._r8,1._r8*qvmin-qv(i,k)) + qvten(i,k) = qvten(i,k) + dqv/dt + qv(i,k) = qv(i,k) + dqv + if( k .ne. 1 ) then + qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) + qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt + endif + qv(i,k) = max(qv(i,k),qvmin) + ql(i,k) = max(ql(i,k),qlmin) + qi(i,k) = max(qi(i,k),qimin) + end do + ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv .gt. 1.e-20_r8 ) then + sum = 0._r8 + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) + enddo + aa = dqv*dp(i,1)/max(1.e-20_r8,sum) + if( aa .lt. 0.5_r8 ) then + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) then + dum = aa*qv(i,k) + qv(i,k) = qv(i,k) - dum + qvten(i,k) = qvten(i,k) - dum/dt + endif + enddo + else + write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' + endif + endif + end do + return + +end subroutine positive_moisture + +end module vertical_diffusion diff --git a/src/physics/cam_oslo/aero_to_srf.F90 b/src/physics/cam_oslo/aero_to_srf.F90 new file mode 100644 index 0000000000..4dee8566e2 --- /dev/null +++ b/src/physics/cam_oslo/aero_to_srf.F90 @@ -0,0 +1,332 @@ +module aero_to_srf + +!------------------------------------------------------------------------------------------------ +! Purpose: +! +! Partition the contributions from modal components of wet and dry +! deposition at the surface into the fields passed to the coupler. +! +! *** N.B. *** Currently only a simple scheme for the 3-mode version +! of MAM has been implemented. +! +! Revision history: +! Feb 2009 M. Flanner, B. Eaton Original version for trop_mam3. +! Sept 2009 � Seland Modified to CAM-Oslo aerosol physics. +! The initialisation part is not used at present time. +!------------------------------------------------------------------------------------------------ + +#include + +use shr_kind_mod, only: r8 => shr_kind_r8 +use camsrfexch, only: cam_out_t +use constituents, only: pcnst, cnst_get_ind +use ppgrid, only: pcols +use aerosoldef +implicit none +private +save + +public :: & + modal_aero_deposition_init, & + set_srf_drydep, & + set_srf_wetdep + +! Private module data +integer :: idx_bc1 = -1 +integer :: idx_pom1 = -1 +integer :: idx_soa1 = -1 +integer :: idx_soa2 = -1 +integer :: idx_dst1 = -1 +integer :: idx_dst3 = -1 +integer :: idx_ncl3 = -1 +integer :: idx_so43 = -1 +integer :: idx_num3 = -1 + +!============================================================================== +contains +!============================================================================== + +subroutine modal_aero_deposition_init() + +! set aerosol indices for re-mapping surface deposition fluxes: +! *_a1 = accumulation mode +! *_a2 = aitken mode +! *_a3 = coarse mode + + ! Currently only trop_mam3 scheme is implemented. +#ifndef MODAL_AERO_3MODE + return +#endif + + call cnst_get_ind('bc_a1', idx_bc1) + call cnst_get_ind('pom_a1', idx_pom1) + call cnst_get_ind('soa_a1', idx_soa1) + call cnst_get_ind('soa_a2', idx_soa2) + call cnst_get_ind('dst_a1', idx_dst1) + call cnst_get_ind('dst_a3', idx_dst3) + call cnst_get_ind('ncl_a3', idx_ncl3) + call cnst_get_ind('so4_a3', idx_so43) + call cnst_get_ind('num_a3', idx_num3) + +end subroutine modal_aero_deposition_init + +!============================================================================== +subroutine set_srf_wetdep(wetdepflx, cam_out) + +! Set surface wet deposition fluxes passed to coupler. + + ! Arguments: +!Does not differentiate between different wet scavenging processes +! real(r8), intent(in) :: aerdepwetis(pcols,pcnst) +! aerosol wet deposition (interstitial) +! aerosol wet deposition (cloud water) + real(r8), intent(in) :: wetdepflx(pcols,pcnst) + + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i + integer :: ncol ! number of columns +!cak +! Mass fractions of deposited sea-salt modes a2 and a3 which belong to size bins 1-4. +! Particle diameters < 0.1 um and > 20 um are not included (size bins are defined w.r.t. +! particle diameters, confirmed by Mark Flanner) +real(r8), parameter :: fdst1a2 = 5.55e-1_r8 +real(r8), parameter :: fdst2a2 = 4.29e-1_r8 +real(r8), parameter :: fdst3a2 = 1.59e-2_r8 +real(r8), parameter :: fdst4a2 = 1.32e-4_r8 +real(r8), parameter :: fdst1a3 = 4.84e-3_r8 +real(r8), parameter :: fdst2a3 = 1.01e-1_r8 +real(r8), parameter :: fdst3a3 = 2.96e-1_r8 +real(r8), parameter :: fdst4a3 = 5.99e-1_r8 +!with cut-off at 10 um (not recommended by Mark Flanner) as for the optics calculations: +!real(r8), parameter :: fdst4a3 = 3.73e-1_r8 +!cak + !---------------------------------------------------------------------------- + + ! Currently only trop_mam3 scheme is implemented. + ! CAM_OSLO added +#ifdef AEROFFL + return +#endif + + ncol = cam_out%ncol + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! CLM wants positive definite fluxes. +! OS Only bcphi and dst1 is used + do i = 1, ncol + ! black carbon fluxes + cam_out%bcphiwet(i) = - (wetdepflx(i,l_bc_n)+wetdepflx(i,l_bc_ax) & + +wetdepflx(i,l_bc_ni)+wetdepflx(i,l_bc_a) & + +wetdepflx(i,l_bc_ai)+wetdepflx(i,l_bc_ac)) +!(aerdepwetis(i,idx_bc1)+aerdepwetcw(i,idx_bc1)) + + ! organic carbon fluxes +! cam_out%ocphiwet(i) = -(aerdepwetis(i,idx_pom1)+aerdepwetis(i,idx_soa1)+aerdepwetcw(i,idx_pom1)+aerdepwetcw(i,idx_soa1)) +!cak_temp + cam_out%ocphiwet(i) = 0._r8 +! cam_out%ocphiwet(i) = 1.e-20_r8 +!cak_temp + + ! dust fluxes + ! + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: +! os All dust aerosols +!cak cam_out%dstwet1(i) = -(wetdepflx(i,l_dst_a2)+wetdepflx(i,l_dst_a3)) + cam_out%dstwet1(i) = -(fdst1a2*wetdepflx(i,l_dst_a2)+fdst1a3*wetdepflx(i,l_dst_a3)) +!cak + +!(aerdepwetis(i,idx_dst1)+aerdepwetcw(i,idx_dst1)) + +! ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: +! cam_out%dstwet2(i) = 0._r8 +! cam_out%dstwet3(i) = -(aerdepwetis(i,idx_dst3)+aerdepwetcw(i,idx_dst3)) +! cam_out%dstwet4(i) = 0._r8 + + ! in rare cases, integrated deposition tendency is upward + if (cam_out%bcphiwet(i) .lt. 0._r8) cam_out%bcphiwet(i) = 0._r8 +!t2 if (cam_out%bcphiwet(i) .lt. 0._r8) cam_out%bcphiwet(i) = 1.e-20_r8 +! if (cam_out%bcphiwet(i) .le. 0._r8) cam_out%bcphiwet(i) = 1.e-20_r8 +!feil if (cam_out%dstwet3(i) .lt. 0._r8) cam_out%dstwet3(i) = 0._r8 + if (cam_out%dstwet1(i) .lt. 0._r8) cam_out%dstwet1(i) = 0._r8 +!t2 if (cam_out%dstwet1(i) .lt. 0._r8) cam_out%dstwet1(i) = 1.e-20_r8 +! if (cam_out%dstwet1(i) .le. 0._r8) cam_out%dstwet1(i) = 1.e-20_r8 +!cak_temp + cam_out%dstwet2(i) = -(fdst2a2*wetdepflx(i,l_dst_a2)+fdst2a3*wetdepflx(i,l_dst_a3)) + cam_out%dstwet3(i) = -(fdst3a2*wetdepflx(i,l_dst_a2)+fdst3a3*wetdepflx(i,l_dst_a3)) + cam_out%dstwet4(i) = -(fdst4a2*wetdepflx(i,l_dst_a2)+fdst4a3*wetdepflx(i,l_dst_a3)) + if (cam_out%dstwet2(i).lt.0._r8) cam_out%dstwet2(i) = 0._r8 + if (cam_out%dstwet3(i).lt.0._r8) cam_out%dstwet3(i) = 0._r8 + if (cam_out%dstwet4(i).lt.0._r8) cam_out%dstwet4(i) = 0._r8 +!t2 if (cam_out%dstwet2(i).lt.0._r8) cam_out%dstwet2(i) = 1.e-20_r8 +!t2 if (cam_out%dstwet3(i).lt.0._r8) cam_out%dstwet3(i) = 1.e-20_r8 +!t2 if (cam_out%dstwet4(i).lt.0._r8) cam_out%dstwet4(i) = 1.e-20_r8 +! if (cam_out%dstwet2(i).le.0._r8) cam_out%dstwet2(i) = 1.e-20_r8 +! if (cam_out%dstwet3(i).le.0._r8) cam_out%dstwet3(i) = 1.e-20_r8 +! if (cam_out%dstwet4(i).le.0._r8) cam_out%dstwet4(i) = 1.e-20_r8 +!cak_temp + +!cak_0 +! cam_out%bcphiwet(i) = 1.e-20_r8 +! cam_out%ocphiwet(i) = 1.e-20_r8 +! cam_out%dstwet1(i) = 1.e-20_r8 +! cam_out%dstwet2(i) = 1.e-20_r8 +! cam_out%dstwet3(i) = 1.e-20_r8 +! cam_out%dstwet4(i) = 1.e-20_r8 +! cam_out%bcphiwet(i) = 1.e-7_r8 ! TEST !!! +! cam_out%dstwet1(i) = 1.e-11_r8 +! cam_out%dstwet2(i) = 1.e-10_r8 +! cam_out%dstwet3(i) = 1.e-09_r8 +! cam_out%dstwet4(i) = 1.e-08_r8 +! if(i==ncol) then +! write(*,*) 'bcphiwet = ', cam_out%bcphiwet(i) +! write(*,*) 'dstwet1 = ', cam_out%dstwet1(i) +! write(*,*) 'dstwet2 = ', cam_out%dstwet2(i) +! write(*,*) 'dstwet3 = ', cam_out%dstwet3(i) +! write(*,*) 'dstwet4 = ', cam_out%dstwet4(i) +! endif +!cak_0 + + enddo + +end subroutine set_srf_wetdep + +!============================================================================== + +subroutine set_srf_drydep(sflx, cam_out) + +! Set surface dry deposition fluxes passed to coupler. + + ! Arguments: + real(r8), intent(in) :: sflx(pcols,pcnst) ! aerosol dry deposition (interstitial) + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i + integer :: ncol ! number of columns +!cak +! Mass fractions of deposited sea-salt modes a2 and a3 which belong to size bins 1-4. +! Particle diameters < 0.1 um and > 20 um are not included (size bins are defined w.r.t. +! particle diameters, confirmed by Mark Flanner) +real(r8), parameter :: fdst1a2 = 5.55e-1_r8 +real(r8), parameter :: fdst2a2 = 4.29e-1_r8 +real(r8), parameter :: fdst3a2 = 1.59e-2_r8 +real(r8), parameter :: fdst4a2 = 1.32e-4_r8 +real(r8), parameter :: fdst1a3 = 4.84e-3_r8 +real(r8), parameter :: fdst2a3 = 1.01e-1_r8 +real(r8), parameter :: fdst3a3 = 2.96e-1_r8 +real(r8), parameter :: fdst4a3 = 5.99e-1_r8 +!with cut-off at 10 um (not recommended by Mark Flanner) as for the optics calculations: +!real(r8), parameter :: fdst4a3 = 3.73e-1_r8 +!cak + !---------------------------------------------------------------------------- + +!cak write(*,*) 'test dry 1' + + ! Currently only trop_mam3 scheme is implemented. +#ifdef AEROFFL + return +#endif + +!cak write(*,*) 'test dry 2' + + ncol = cam_out%ncol + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! CLM wants positive definite fluxes. +!cak: all cam_out fluxes are positive definite here... + do i = 1, ncol + ! black carbon fluxes +!cak_old cam_out%bcphidry(i) = -(sflx(i,l_bc_n)+sflx(i,l_bc_ax) & +!cak_old + sflx(i,l_bc_ni)+sflx(i,l_bc_a)+sflx(i,l_bc_ai)+sflx(i,l_bc_ac)) + cam_out%bcphidry(i) = -(sflx(i,l_bc_ni)+sflx(i,l_bc_a)+sflx(i,l_bc_ai)+sflx(i,l_bc_ac)) +!cak_temp + cam_out%bcphodry(i) = -(sflx(i,l_bc_n)+sflx(i,l_bc_ax)) +!cak_old cam_out%bcphodry(i) = 0._r8 +! cam_out%bcphodry(i) = 1.e-20_r8 +!cak_temp + + ! organic carbon fluxes +! cam_out%ocphidry(i) = aerdepdryis(i,idx_pom1)+aerdepdryis(i,idx_soa1)+aer!depdrycw(i,idx_pom1)+aerdepdrycw(i,idx_soa1) +! cam_out%ocphodry(i) = aerdepdryis(i,idx_soa2)+aerdepdrycw(i,idx_soa2) +!cak_temp + cam_out%ocphidry(i) = 0._r8 + cam_out%ocphodry(i) = 0._r8 +! cam_out%ocphidry(i) = 1.e-20_r8 +! cam_out%ocphodry(i) = 1.e-20_r8 +!cak_temp + + ! dust fluxes + ! + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: +!cak cam_out%dstdry1(i) = -(sflx(i,l_dst_a2)+sflx(i,l_dst_a3)) + cam_out%dstdry1(i) = -(fdst1a2*sflx(i,l_dst_a2)+fdst1a3*sflx(i,l_dst_a3)) +!cak +!aerdepdryis(i,idx_dst1)+aerdepdrycw(i,idx_dst1) + + ! Two options for partitioning deposition into bins 2-4: + ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: +! cam_out%dstdry2(i) = 0._r8 +! cam_out%dstdry3(i) = aerdepdryis(i,idx_dst3)+aerdepdrycw(i,idx_dst3) +! cam_out%dstdry4(i) = 0._r8 + + ! in rare cases, integrated deposition tendency is upward + if (cam_out%bcphidry(i) .lt. 0._r8) cam_out%bcphidry(i) = 0._r8 +!t2 if (cam_out%bcphidry(i) .lt. 0._r8) cam_out%bcphidry(i) = 1.e-20_r8 +! if (cam_out%bcphidry(i) .le. 0._r8) cam_out%bcphidry(i) = 1.e-20_r8 + if (cam_out%dstdry1(i) .lt. 0._r8) cam_out%dstdry1(i) = 0._r8 +!t2 if (cam_out%dstdry1(i) .lt. 0._r8) cam_out%dstdry1(i) = 1.e-20_r8 +! if (cam_out%dstdry1(i) .le. 0._r8) cam_out%dstdry1(i) = 1.e-20_r8 +!cak_temp +! cam_out%dstdry2(i) = 0._r8 +! cam_out%dstdry3(i) = 0._r8 +! cam_out%dstdry4(i) = 0._r8 + cam_out%dstdry2(i) = -(fdst2a2*sflx(i,l_dst_a2)+fdst2a3*sflx(i,l_dst_a3)) + cam_out%dstdry3(i) = -(fdst3a2*sflx(i,l_dst_a2)+fdst3a3*sflx(i,l_dst_a3)) + cam_out%dstdry4(i) = -(fdst4a2*sflx(i,l_dst_a2)+fdst4a3*sflx(i,l_dst_a3)) + if (cam_out%dstdry2(i).lt.0._r8) cam_out%dstdry2(i) = 0._r8 + if (cam_out%dstdry3(i).lt.0._r8) cam_out%dstdry3(i) = 0._r8 + if (cam_out%dstdry4(i).lt.0._r8) cam_out%dstdry4(i) = 0._r8 +!t2 if (cam_out%dstdry2(i).lt.0._r8) cam_out%dstdry2(i) = 1.e-20_r8 +!t2 if (cam_out%dstdry3(i).lt.0._r8) cam_out%dstdry3(i) = 1.e-20_r8 +!t2 if (cam_out%dstdry4(i).lt.0._r8) cam_out%dstdry4(i) = 1.e-20_r8 +! if (cam_out%dstdry2(i).le.0._r8) cam_out%dstdry2(i) = 1.e-20_r8 +! if (cam_out%dstdry3(i).le.0._r8) cam_out%dstdry3(i) = 1.e-20_r8 +! if (cam_out%dstdry4(i).le.0._r8) cam_out%dstdry4(i) = 1.e-20_r8 +!cak_temp + +!cak_0 +! cam_out%bcphidry(i) = 1.e-20_r8 +! cam_out%bcphodry(i) = 1.e-20_r8 +! cam_out%ocphidry(i) = 1.e-20_r8 +! cam_out%ocphodry(i) = 1.e-20_r8 +! cam_out%dstdry1(i) = 1.e-20_r8 +! cam_out%dstdry2(i) = 1.e-20_r8 +! cam_out%dstdry3(i) = 1.e-20_r8 +! cam_out%dstdry4(i) = 1.e-20_r8 +! cam_out%bcphidry(i) = 1.e-7_r8 ! TEST !!! +! cam_out%dstdry1(i) = 1.e-11_r8 +! cam_out%dstdry2(i) = 1.e-10_r8 +! cam_out%dstdry3(i) = 1.e-09_r8 +! cam_out%dstdry4(i) = 1.e-08_r8 +! if(i==ncol) then +! write(*,*) 'bcphidry = ', cam_out%bcphidry(i) +! write(*,*) 'dstdry1 = ', cam_out%dstdry1(i) +! write(*,*) 'dstdry2 = ', cam_out%dstdry2(i) +! write(*,*) 'dstdry3 = ', cam_out%dstdry3(i) +! write(*,*) 'dstdry4 = ', cam_out%dstdry4(i) +! endif +!cak_0 + + enddo + +end subroutine set_srf_drydep + +!============================================================================== + +end module aero_to_srf diff --git a/src/physics/cam_oslo/aerocopt.h b/src/physics/cam_oslo/aerocopt.h new file mode 100644 index 0000000000..bc48cfbe37 --- /dev/null +++ b/src/physics/cam_oslo/aerocopt.h @@ -0,0 +1,8 @@ +! For subroutines initaeropt and intaeropt1to3,4,6to10: + + common /aerocopt1/ bep1, bep2to3, bep4, bep5to10 + + real(r8) bep1(38,10,6,16,6) + real(r8) bep2to3(38,10,16,6,2:3) + real(r8) bep4(38,10,6,16,6,6) + real(r8) bep5to10(38,10,6,6,6,6,5:10) diff --git a/src/physics/cam_oslo/aerocopt2.h b/src/physics/cam_oslo/aerocopt2.h new file mode 100644 index 0000000000..7272b9e2d0 --- /dev/null +++ b/src/physics/cam_oslo/aerocopt2.h @@ -0,0 +1,9 @@ +! For subroutines initaeropt and intaeropt0: + + common /aerocopt2/ bex440, bax440, bex500, bax500, bax550, & + bex670, bax670, bex870, bax870, & + bex550lt1, bex550gt1, backscx550 + + real(r8) bex440, bax440, bex500, bax500, bax550, & + bex670, bax670, bex870, bax870, & + bex550lt1, bex550gt1, backscx550 diff --git a/src/physics/cam_oslo/aerodry.h b/src/physics/cam_oslo/aerodry.h new file mode 100644 index 0000000000..03ca519713 --- /dev/null +++ b/src/physics/cam_oslo/aerodry.h @@ -0,0 +1,13 @@ +! For subroutine initdryp and intdrypar: + + common /dryarr1/ & + a0cintbg, a0cintbg05, a0cintbg125, & + a0aaeros, a0aaerol, a0vaeros, a0vaerol, & + a1var, a2to3var, a4var, a5to10var + + real(r8) a0cintbg, a0cintbg05, a0cintbg125, & + a0aaeros, a0aaerol, a0vaeros, a0vaerol + real(r8) a1var(19,6,16,6) + real(r8) a2to3var(19,16,6,2:3) + real(r8) a4var(19,6,16,6,6) + real(r8) a5to10var(19,6,6,6,6,5:10) diff --git a/src/physics/cam_oslo/checkTableHeader.F90 b/src/physics/cam_oslo/checkTableHeader.F90 new file mode 100644 index 0000000000..20a8f3615a --- /dev/null +++ b/src/physics/cam_oslo/checkTableHeader.F90 @@ -0,0 +1,25 @@ + + subroutine checkTableHeader (ifil) + +! This subroutine reads the header-text in a look-up table (in file with iu=ifil). +! Later: use it to also check AeroTab - CAM5-Oslo consistency w.r.t. assumed modal +! radii, mass densities, etc... + + integer, intent(in) :: ifil + character*80 headertext + character*12 text0, text1 + + + text0='X-CHECK LUT' + text1='none ' + do while (text1(2:12).ne.text0(2:12)) + read(ifil,1000) headertext + text1=headertext(2:12) +! write(*,*) 'text0, text1 =', text0, text1 + enddo + + + 1000 format(A) + + return + end subroutine checkTableHeader \ No newline at end of file diff --git a/src/physics/cam_oslo/coltst4intcons.F90 b/src/physics/cam_oslo/coltst4intcons.F90 new file mode 100644 index 0000000000..e95de3f58a --- /dev/null +++ b/src/physics/cam_oslo/coltst4intcons.F90 @@ -0,0 +1,302 @@ + +subroutine coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & + dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & + dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & + dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) + +! Testing column burdens for internal consistency between intdrypar +! (use of aerodryk*.out look-up tables) and calculations directly +! from the qm1 array. Made by Alf Kirkevag 8/12-2015. + +! Due to a problem with initialization of some values (seemingly), +! the output variables COLR* (column burden ratio for tracers *) +! should not be checked for the first output file from an initial run. +! Initial test results after coorecting a bug in AeroTab October 2016: +! Results from month 5 in a test simulation with 2000 aerosol emissions +! and f10_f10 resolution (10x15_10x15) gave the following globally +! averaged COLR* values: +! +! COLRBC0 = 1.000015 ; +! COLRBC12 = 0.9991855 ; +! COLRBC14 = 0.9992678 ; +! COLRBC2 = 0.9991855 ; +! COLRBC4 = 0.9997123 ; +! COLRBCAC = 1.000379 ; +! COLROC14 = 0.9989312 ; +! COLROC4 = 0.9995964 ; +! COLROCAC = 0.9993698 ; +! COLRSUL1 = 1.034586 ; +! COLRSUL5 = 1.03905 ; +! COLRSULA = 1.000236 ; +! +! with regional variations within 0.01 for all tracers except for the +! externally mixed tracers so4_na (COLRSUL1 = 1.02 - 1.04) and so4_pr +! (COLRSUL5 = 1.035 - 1.039). The biases for COLRSUL1 and COLRSUL5 are +! consistent with a ratio between mass density for sulfuric acid and +! ammonium sulfate (1841/1769=1.041), and that CAM5-Olso does not take +! into account the former. + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst + use aerosoldef + use cam_history, only: outfld + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) + real(r8), intent(in) :: deltah_km(pcols,pver) ! Layer thickness, unit km + real(r8), intent(in) :: rhoda(pcols,pver) + real(r8), intent(in) :: fnbc(pcols,pver) + real(r8), intent(in) :: dload_mi(pcols) + real(r8), intent(in) :: dload_ss(pcols) + real(r8), intent(in) :: dload_s4(pcols) + real(r8), intent(in) :: dload_oc(pcols) + real(r8), intent(in) :: dload_bc(pcols) + real(r8), intent(in) :: dload_bc_0(pcols) + real(r8), intent(in) :: dload_bc_2(pcols) + real(r8), intent(in) :: dload_bc_4(pcols) + real(r8), intent(in) :: dload_bc_12(pcols) + real(r8), intent(in) :: dload_bc_14(pcols) + real(r8), intent(in) :: dload_bc_ac(pcols) + real(r8), intent(in) :: dload_oc_4(pcols) + real(r8), intent(in) :: dload_oc_14(pcols) + real(r8), intent(in) :: dload_oc_ac(pcols) + real(r8), intent(in) :: dload_s4_a(pcols) + real(r8), intent(in) :: dload_s4_1(pcols) + real(r8), intent(in) :: dload_s4_5(pcols) +! +!---------------------------Local variables----------------------------- +! + integer icol, k + real(r8) columnb(pcols), colratio(pcols) +! strict test, only expected to apply for some externally mixed modes: +! real(r8), parameter :: oneplus = 1.003_r8 +! real(r8), parameter :: oneminus = 0.997_r8 +! less strict test, expected to apply for externally mixed modes, except +! in the first time-steps, seemingly due to problem with initialization: + real(r8), parameter :: oneplus = 1.05_r8 + real(r8), parameter :: oneminus = 0.95_r8 +! +! +!---------------------------Test calculations--------------------------- + +!BC: + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_ax)*rhoda(icol,k) + colratio(icol) = dload_bc_0(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc 0 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBC0 ', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_a)*rhoda(icol,k) + colratio(icol) = dload_bc_2(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc 2 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBC2 ', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_ai)*rhoda(icol,k) + colratio(icol) = dload_bc_4(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc 4 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBC4 ', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_n)*rhoda(icol,k) + colratio(icol) = dload_bc_12(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc 12 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBC12', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_ni)*rhoda(icol,k) + colratio(icol) = dload_bc_14(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc 14 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBC14 ', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_bc_ac)*rhoda(icol,k) + colratio(icol) = dload_bc_ac(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my bc ac ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRBCAC', colratio, pcols,lchnk) + +!OC: + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_om_ai)*rhoda(icol,k) + colratio(icol) = dload_oc_4(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my oc 4 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLROC4 ', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*qm1(icol,k,l_om_ni)*rhoda(icol,k) + colratio(icol) = dload_oc_14(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my oc 14 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLROC14', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*(qm1(icol,k,l_om_ac)+qm1(icol,k,l_soa_a1))*rhoda(icol,k) + colratio(icol) = dload_oc_ac(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my oc ac and soa a1 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLROCAC', colratio, pcols,lchnk) + +!Sulfate: + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*(qm1(icol,k,l_so4_a1) & + + qm1(icol,k,l_so4_a2) & + + qm1(icol,k,l_so4_ac))*rhoda(icol,k) + colratio(icol) = dload_s4_a(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my sulfate a ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRSULA', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*(qm1(icol,k,l_so4_na))*rhoda(icol,k) + colratio(icol) = dload_s4_1(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my sulfate 1 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRSUL1', colratio, pcols,lchnk) + + do icol=1,ncol + columnb(icol) = 0.0_r8 + colratio(icol) = 0.0_r8 + end do + do icol=1,ncol + do k=1,pver + columnb(icol) = columnb(icol)+deltah_km(icol,k) & + * 1.e9*(qm1(icol,k,l_so4_pr))*rhoda(icol,k) + colratio(icol) = dload_s4_5(icol)/columnb(icol) + end do +! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then +! write(99,*) 'my sulfate 5 ratio =', icol, colratio(icol) +! endif + end do + + call outfld('COLRSUL5', colratio, pcols,lchnk) + + return +end subroutine coltst4intcons diff --git a/src/physics/cam_oslo/initaeropt.F90 b/src/physics/cam_oslo/initaeropt.F90 new file mode 100644 index 0000000000..18be036917 --- /dev/null +++ b/src/physics/cam_oslo/initaeropt.F90 @@ -0,0 +1,581 @@ +subroutine initaeropt + +!Purpose: To read in the AeroCom look-up tables for aerosol optical properties. +! The grid for discrete input-values in the look-up tables is defined in opptab. + +! Tabulating the 'aerocomk'-files to save computing time. +! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 +! Extended for new SOA treatment - Alf Kirkevaag, September 2015. +! Modified for optimized added masses and mass fractions for +! concentrations from condensation, coagulation or cloud-processing +! - Alf Kirkevaag, May 2016. +! Modified for optimized added masses and mass fractions for concentrations from +! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + use oslo_control, only: oslo_getopts, dir_string_length + use shr_kind_mod, only: r8 => shr_kind_r8 + use commondefinitions, only: nmodes, nbmodes + use opttab, only: cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use cam_logfile, only: iulog + + implicit none + +#include +#include + + integer kcomp, irelh, ictot, ifac, ifbc, ifaq + integer ifombg, ifbcbg + integer ic, ifil, lin, iv + real(r8) catot, relh, frombg, frbcbg, frac, fabc, fraq, & + bext440, babs440, bext500, babs500, babs550, & + bext670, babs670, bext870, babs870, & + bebg440, babg440, bebg500, babg500, babg550, & + bebg670, babg670, bebg870, babg870, & + bebc440, babc440, bebc500, babc500, babc550, & + bebc670, babc670, bebc870, babc870, & + beoc440, baoc440, beoc500, baoc500, baoc550, & + beoc670, baoc670, beoc870, baoc870, & + besu440, basu440, besu500, basu500, basu550, & + besu670, basu670, besu870, basu870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550 + + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' & + ,form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' & + ,form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' & + ,form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' & + ,form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' & + ,form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' & + ,form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' & + ,form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' & + ,form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out' & + ,form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' & + ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' & + ,form='formatted',status='old') + +! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 0, BC(ax +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + + read(9+ifil,996) kcomp, relh, & + bex440, bax440, bex500, bax500, bax550, bex670, bax670, & + bex870, bax870, bex550lt1, bex550gt1, backscx550 + + if(bex440<=0.0_r8) then + write(*,*) 'bex440 =', bex440 + write(*,*) 'Error in initialization of bex1' + stop + endif + + write(iulog,*)'aerocom mode 0 ok' + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! New mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 1 + do lin = 1,5760 ! 10x6x16x6 + + read(20+ifil,997) kcomp, relh, frombg, catot, frac, & + bext440, bext500, bext670, bext870, & + bebg440, bebg500, bebg670, bebg870, & + bebc440, bebc500, bebc670, bebc870, & + beoc440, beoc500, beoc670, beoc870, & + besu440, besu500, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550, babg550, babc550, baoc550, basu550 + + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 + use oslo_control, only: oslo_getopts, dir_string_length + use commondefinitions, only: nmodes, nbmodes + use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg + use cam_logfile, only: iulog + + implicit none + +!Purpose: To read in the AeroCom look-up tables for calculation of dry +! aerosol size and mass distribution properties. The grid for discrete +! input-values in the look-up tables is defined in opptab. + +! Tabulating the 'aerodryk'-files to save computing time. Routine +! originally made by Alf Kirkevaag, and modified for new aerosol +! schemes in January 2006. +! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, +! May 2013, and extended for new SOA treatment October 2015. +! Modified for optimized added masses and mass fractions for +! concentrations from condensation, coagulation or cloud-processing +! - Alf Kirkevaag, May 2016. +! Modified for optimized added masses and mass fractions for concentrations from +! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + +#include + + integer iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq + integer ic, ifil, lin + real(r8) frombg, frbcbg, catot, frac, fabc, fraq, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' & + ,form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' & + ,form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' & + ,form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' & + ,form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' & + ,form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' & + ,form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' & + ,form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' & + ,form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' & + ,form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' & + ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' & + ,form='formatted',status='old') + +! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 0, BC(ax) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + + read(9+ifil,996) kcomp, cintbg, cintbg05, cintbg125, & + aaeros, aaerol, vaeros, vaerol + +! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, +! since BC(ax) is purely externally mixed + + a0cintbg=cintbg + a0cintbg05=cintbg05 + a0cintbg125=cintbg125 + + a0aaeros=aaeros + a0aaerol=aaerol + a0vaeros=vaeros + a0vaerol=vaerol + + write(iulog,*)'mode 0 ok' + + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 1 + do lin = 1,576 ! 6x16x6 + + read(20+ifil,997) kcomp, frombg, catot, frac, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + + do ic=1,6 + if(abs(frombg-fombg(ic)) shr_kind_r8 + use opttab, only: fombg, fbcbg, cate, cat, fac, faq, fbc, rh, eps + use commondefinitions, only: nbmodes, nmodes + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: rhum(pcols,pver) ! level relative humidity (fraction) + real(r8), intent(in) :: f_soana(pcols,pver) ! SOA/(SOA+H2SO4) mass fraction for the background in mode 1 + real(r8), intent(in) :: faitbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 4 + real(r8), intent(in) :: fnbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 14 + real(r8), intent(in) :: focm(pcols,pver,4) ! fraction of added mass which is either SOA condensate or OC coagulate + real(r8), intent(in) :: Cam(pcols,pver,nbmodes) ! added internally mixed SO4+BC+OC concentration for a normalized mode + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: fcm(pcols,pver,nbmodes) ! fraction of added mass which is either BC or OC/SOA (carbonaceous) + real(r8), intent(in) :: fbcm(pcols,pver,nbmodes) ! fraction of added mass as BC/(BC+OC) + real(r8), intent(in) :: faqm(pcols,pver,nbmodes) ! fraction of added sulfate which is from aqueous phase (ammonium sulfate) + real(r8) :: eps10 = 1.e-10_r8 +! +! Output arguments +! + real(r8), intent(out) :: xrh(pcols,pver) ! rhum for use in the interpolations + integer, intent(out) :: irh1(pcols,pver) + real(r8), intent(out) :: xfombg(pcols,pver) ! f_soana for use in the interpolations (mode 1) + integer, intent(out) :: ifombg1(pcols,pver) + real(r8), intent(out) :: xfbcbg(pcols,pver) ! faitbc for use in the interpolations (mode 4) + integer, intent(out) :: ifbcbg1(pcols,pver) + real(r8), intent(out) :: xfbcbgn(pcols,pver) ! fnbc for use in the interpolations (mode 14) + integer, intent(out) :: ifbcbgn1(pcols,pver) + real(r8), intent(out) :: xct(pcols,pver,nmodes) ! Cam/Nnatk for use in the interpolations + integer, intent(out) :: ict1(pcols,pver,nmodes) + real(r8), intent(out) :: xfac(pcols,pver,nbmodes) ! focm (1-4) or fcm (5-10) for use in the interpolations + integer, intent(out) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(out) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(out) :: ifaq1(pcols,pver,nbmodes) +! +!---------------------------Local variables----------------------------- +! + integer k, icol, i, irelh +! +!------------------------------------------------------------------------ +! + +! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol + xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) + end do + end do + +! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh).and. & + xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + endif + end do + end do + end do +! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) + + do k=1,pver + do icol=1,ncol +! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines + xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) + ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + + do k=1,pver + do icol=1,ncol +! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines + xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) +! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines + xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) + end do + enddo + + do i=1,4 + do k=1,pver + do icol=1,ncol +! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol +! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + + do i=1,nbmodes + do k=1,pver + do icol=1,ncol +! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines + xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 + ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) + end do + enddo + enddo + + do i=1,nbmodes + do k=1,pver + do icol=1,ncol +! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines + xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) + ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + +! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 + do i=1,4 + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) + if(i.le.2) then + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) + elseif(i.eq.3) then ! mode not used + xct(icol,k,i)=cate(i,1) + ict1(icol,k,i)=1 + else + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) + endif + end do + end do + end do + + do i=5,10 + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) + if(i.eq.5) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) + elseif(i.eq.6) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) + elseif(i.eq.7) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + elseif(i.eq.8) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) + elseif(i.eq.9) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) + else + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + endif + end do + end do + end do + + do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=cate(i-10,1) + ict1(icol,k,i)=1 + end do + end do + end do + + return + +end subroutine inputForInterpol diff --git a/src/physics/cam_oslo/intaeropt0.F90 b/src/physics/cam_oslo/intaeropt0.F90 new file mode 100644 index 0000000000..c44729668b --- /dev/null +++ b/src/physics/cam_oslo/intaeropt0.F90 @@ -0,0 +1,207 @@ +subroutine intaeropt0 (lchnk, ncol, Nnatk, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backsc550, babg550, babc550, baoc550, basu550) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, faq, fbc + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration +! +! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) +! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). +! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). + + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & + bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & + bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & + beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & + besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + + integer i, iv, ierr, k, kcomp, icol + + kcomp=0 + +! BC(ax) mode: + +! initialize all output fields + do k=1,pver + do icol=1,ncol + bext440(icol,k,kcomp)=0.0_r8 + babs440(icol,k,kcomp)=0.0_r8 + bext500(icol,k,kcomp)=0.0_r8 + babs500(icol,k,kcomp)=0.0_r8 + bext550(icol,k,kcomp)=0.0_r8 + babs550(icol,k,kcomp)=0.0_r8 + bext670(icol,k,kcomp)=0.0_r8 + babs670(icol,k,kcomp)=0.0_r8 + bext870(icol,k,kcomp)=0.0_r8 + babs870(icol,k,kcomp)=0.0_r8 + bebg440(icol,k,kcomp)=0.0_r8 +! babg440(icol,k,kcomp)=0.0_r8 + bebg500(icol,k,kcomp)=0.0_r8 +! babg500(icol,k,kcomp)=0.0_r8 + bebg550(icol,k,kcomp)=0.0_r8 + babg550(icol,k,kcomp)=0.0_r8 + bebg670(icol,k,kcomp)=0.0_r8 +! babg670(icol,k,kcomp)=0.0_r8 + bebg870(icol,k,kcomp)=0.0_r8 +! babg870(icol,k,kcomp)=0.0_r8 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc550(icol,k,kcomp)=0.0_r8 + babc550(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc550(icol,k,kcomp)=0.0_r8 + baoc550(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu550(icol,k,kcomp)=0.0_r8 + basu550(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=0.0_r8 + bebg550gt1(icol,k,kcomp)=0.0_r8 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=0.0_r8 + end do + end do + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp).gt.0) then + + bext440(icol,k,kcomp)=bex440 + babs440(icol,k,kcomp)=bax440 + bext500(icol,k,kcomp)=bex500 + babs500(icol,k,kcomp)=bax500 + bext550(icol,k,kcomp)=bex550lt1+bex550gt1 + babs550(icol,k,kcomp)=bax550 + bext670(icol,k,kcomp)=bex670 + babs670(icol,k,kcomp)=bax670 + bext870(icol,k,kcomp)=bex870 + babs870(icol,k,kcomp)=bax870 + bebg440(icol,k,kcomp)=bex440 +! babg440(icol,k,kcomp)=bax440 + bebg500(icol,k,kcomp)=bex500 +! babg500(icol,k,kcomp)=bax500 + bebg550(icol,k,kcomp)=bex550lt1+bex550gt1 + babg550(icol,k,kcomp)=bax550 + bebg670(icol,k,kcomp)=bex670 +! babg670(icol,k,kcomp)=bax670 + bebg870(icol,k,kcomp)=bex870 +! babg870(icol,k,kcomp)=bax870 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=bex550lt1 + bebg550gt1(icol,k,kcomp)=bex550gt1 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=backscx550 + + endif + + end do ! icol + end do ! k + + return +end subroutine intaeropt0 + + + + diff --git a/src/physics/cam_oslo/intaeropt1.F90 b/src/physics/cam_oslo/intaeropt1.F90 new file mode 100644 index 0000000000..a80a204940 --- /dev/null +++ b/src/physics/cam_oslo/intaeropt1.F90 @@ -0,0 +1,317 @@ +subroutine intaeropt1 (lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backsc550, babg550, babc550, baoc550, basu550) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, fombg, cat, fac, faq, fbc, rh + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + +! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) +! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). +! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). +! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for +! interpolations using common subroutines interpol*dim. + + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & + bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & + bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & + beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & + besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + + real(r8) a, b, e, eps + + integer i, iv, ierr, irelh, ifombg, ictot, ifac, kcomp, k, icol, kc10 + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ifo1, t_ifo2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_xrh, t_rh1, t_rh2, t_fombg1, t_fombg2, t_xfombg + real(r8) t_xct, t_cat1, t_cat2 + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) opt1, opt2, opt(38) + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! SO4/SOA(Ait) mode: + + do kcomp=1,1 + +! write(*,*) 'kcomp = ', kcomp + +! initialize all output fields Bruk For All istedet? + do k=1,pver + do icol=1,ncol + bext440(icol,k,kcomp)=0.0_r8 + babs440(icol,k,kcomp)=0.0_r8 + bext500(icol,k,kcomp)=0.0_r8 + babs500(icol,k,kcomp)=0.0_r8 + bext550(icol,k,kcomp)=0.0_r8 + babs550(icol,k,kcomp)=0.0_r8 + bext670(icol,k,kcomp)=0.0_r8 + babs670(icol,k,kcomp)=0.0_r8 + bext870(icol,k,kcomp)=0.0_r8 + babs870(icol,k,kcomp)=0.0_r8 + bebg440(icol,k,kcomp)=0.0_r8 +! babg440(icol,k,kcomp)=0.0_r8 + bebg500(icol,k,kcomp)=0.0_r8 +! babg500(icol,k,kcomp)=0.0_r8 + bebg550(icol,k,kcomp)=0.0_r8 + babg550(icol,k,kcomp)=0.0_r8 + bebg670(icol,k,kcomp)=0.0_r8 +! babg670(icol,k,kcomp)=0.0_r8 + bebg870(icol,k,kcomp)=0.0_r8 +! babg870(icol,k,kcomp)=0.0_r8 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc550(icol,k,kcomp)=0.0_r8 + babc550(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc550(icol,k,kcomp)=0.0_r8 + baoc550(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu550(icol,k,kcomp)=0.0_r8 + basu550(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=0.0_r8 + bebg550gt1(icol,k,kcomp)=0.0_r8 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=0.0_r8 + end do + end do + + if(mplus10==0) then + kc10=kcomp + else + write(*,*) "mplus10=1 is no loger an option for kcomp=1." + stop + endif + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kc10).gt.0) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfombg = xfombg(icol,k) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fombg2-t_xfombg) + dxm1(2) = (t_xfombg-t_fombg1) + invd(2) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + + do iv=1,38 ! variable number + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + +! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & + /(t_rh2-t_rh1) + +! if(mplus10==1) then +! write(*,*) 'kcomp, iv, opt(iv) =', kcomp, iv, opt(iv) +! write(*,*) 'kc10, Nnatk =', kc10, Nnatk(icol,k,kc10) +! endif + + end do ! iv=1,38 + + bext440(icol,k,kcomp)=opt(1) + bext500(icol,k,kcomp)=opt(2) + bext670(icol,k,kcomp)=opt(3) + bext870(icol,k,kcomp)=opt(4) + bebg440(icol,k,kcomp)=opt(5) + bebg500(icol,k,kcomp)=opt(6) + bebg670(icol,k,kcomp)=opt(7) + bebg870(icol,k,kcomp)=opt(8) + bebc440(icol,k,kcomp)=opt(9) + bebc500(icol,k,kcomp)=opt(10) + bebc670(icol,k,kcomp)=opt(11) + bebc870(icol,k,kcomp)=opt(12) + beoc440(icol,k,kcomp)=opt(13) + beoc500(icol,k,kcomp)=opt(14) + beoc670(icol,k,kcomp)=opt(15) + beoc870(icol,k,kcomp)=opt(16) + besu440(icol,k,kcomp)=opt(17) + besu500(icol,k,kcomp)=opt(18) + besu670(icol,k,kcomp)=opt(19) + besu870(icol,k,kcomp)=opt(20) + babs440(icol,k,kcomp)=opt(21) + babs500(icol,k,kcomp)=opt(22) + babs550(icol,k,kcomp)=opt(23) + babs670(icol,k,kcomp)=opt(24) + babs870(icol,k,kcomp)=opt(25) + bebg550lt1(icol,k,kcomp)=opt(26) + bebg550gt1(icol,k,kcomp)=opt(27) + bebc550lt1(icol,k,kcomp)=opt(28) + bebc550gt1(icol,k,kcomp)=opt(29) + beoc550lt1(icol,k,kcomp)=opt(30) + beoc550gt1(icol,k,kcomp)=opt(31) + besu550lt1(icol,k,kcomp)=opt(32) + besu550gt1(icol,k,kcomp)=opt(33) + backsc550(icol,k,kcomp)=opt(34) + babg550(icol,k,kcomp)=opt(35) + babc550(icol,k,kcomp)=opt(36) + baoc550(icol,k,kcomp)=opt(37) + basu550(icol,k,kcomp)=opt(38) + bebg550(icol,k,kcomp)=opt(26)+opt(27) + bebc550(icol,k,kcomp)=opt(28)+opt(29) + beoc550(icol,k,kcomp)=opt(30)+opt(31) + besu550(icol,k,kcomp)=opt(32)+opt(33) + bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + endif + + end do ! icol + end do ! k + + end do ! kcomp + + return + +end subroutine intaeropt1 + + + + diff --git a/src/physics/cam_oslo/intaeropt2to3.F90 b/src/physics/cam_oslo/intaeropt2to3.F90 new file mode 100644 index 0000000000..20ab80818b --- /dev/null +++ b/src/physics/cam_oslo/intaeropt2to3.F90 @@ -0,0 +1,299 @@ +subroutine intaeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backsc550, babg550, babc550, baoc550, basu550) + +! Extended by Alf Kirkevaag to include SOA in September 2015 + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, faq, fbc, rh + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) +! +! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) +!old: for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). +! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). +! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). +! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for +! interpolations using common subroutines interpol*dim. + + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & + bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & + bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & + beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & + besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + + real(r8) a, b, e, eps + + integer i, iv, kcomp, k, icol, kc10 + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & + t_cat1, t_cat2 + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) opt3d(2,2,2) + real(r8) opt1, opt2, opt(38) + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! SO4(Ait), BC(Ait) and OC(Ait) modes: + + do kcomp=2,3 + +! write(*,*) 'kcomp = ', kcomp + + +! initialize all output fields Bruk For All istedet? + do k=1,pver + do icol=1,ncol + bext440(icol,k,kcomp)=0.0_r8 + babs440(icol,k,kcomp)=0.0_r8 + bext500(icol,k,kcomp)=0.0_r8 + babs500(icol,k,kcomp)=0.0_r8 + bext550(icol,k,kcomp)=0.0_r8 + babs550(icol,k,kcomp)=0.0_r8 + bext670(icol,k,kcomp)=0.0_r8 + babs670(icol,k,kcomp)=0.0_r8 + bext870(icol,k,kcomp)=0.0_r8 + babs870(icol,k,kcomp)=0.0_r8 + bebg440(icol,k,kcomp)=0.0_r8 +! babg440(icol,k,kcomp)=0.0_r8 + bebg500(icol,k,kcomp)=0.0_r8 +! babg500(icol,k,kcomp)=0.0_r8 + bebg550(icol,k,kcomp)=0.0_r8 + babg550(icol,k,kcomp)=0.0_r8 + bebg670(icol,k,kcomp)=0.0_r8 +! babg670(icol,k,kcomp)=0.0_r8 + bebg870(icol,k,kcomp)=0.0_r8 +! babg870(icol,k,kcomp)=0.0_r8 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc550(icol,k,kcomp)=0.0_r8 + babc550(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc550(icol,k,kcomp)=0.0_r8 + baoc550(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu550(icol,k,kcomp)=0.0_r8 + basu550(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=0.0_r8 + bebg550gt1(icol,k,kcomp)=0.0_r8 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=0.0_r8 + end do + end do + + end do ! kcomp + + do kcomp=2,2 ! kcomp=3 is no longer used + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kc10).gt.0) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + + do iv=1,38 ! variable number + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=bep2to3(iv,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=bep2to3(iv,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=bep2to3(iv,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=bep2to3(iv,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=bep2to3(iv,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=bep2to3(iv,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=bep2to3(iv,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=bep2to3(iv,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) + +! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & + /(t_rh2-t_rh1) + + + end do ! iv=1,38 + + bext440(icol,k,kcomp)=opt(1) + bext500(icol,k,kcomp)=opt(2) + bext670(icol,k,kcomp)=opt(3) + bext870(icol,k,kcomp)=opt(4) + bebg440(icol,k,kcomp)=opt(5) + bebg500(icol,k,kcomp)=opt(6) + bebg670(icol,k,kcomp)=opt(7) + bebg870(icol,k,kcomp)=opt(8) + bebc440(icol,k,kcomp)=opt(9) + bebc500(icol,k,kcomp)=opt(10) + bebc670(icol,k,kcomp)=opt(11) + bebc870(icol,k,kcomp)=opt(12) + beoc440(icol,k,kcomp)=opt(13) + beoc500(icol,k,kcomp)=opt(14) + beoc670(icol,k,kcomp)=opt(15) + beoc870(icol,k,kcomp)=opt(16) + besu440(icol,k,kcomp)=opt(17) + besu500(icol,k,kcomp)=opt(18) + besu670(icol,k,kcomp)=opt(19) + besu870(icol,k,kcomp)=opt(20) + babs440(icol,k,kcomp)=opt(21) + babs500(icol,k,kcomp)=opt(22) + babs550(icol,k,kcomp)=opt(23) + babs670(icol,k,kcomp)=opt(24) + babs870(icol,k,kcomp)=opt(25) + bebg550lt1(icol,k,kcomp)=opt(26) + bebg550gt1(icol,k,kcomp)=opt(27) + bebc550lt1(icol,k,kcomp)=opt(28) + bebc550gt1(icol,k,kcomp)=opt(29) + beoc550lt1(icol,k,kcomp)=opt(30) + beoc550gt1(icol,k,kcomp)=opt(31) + besu550lt1(icol,k,kcomp)=opt(32) + besu550gt1(icol,k,kcomp)=opt(33) + backsc550(icol,k,kcomp)=opt(34) + babg550(icol,k,kcomp)=opt(35) + babc550(icol,k,kcomp)=opt(36) + baoc550(icol,k,kcomp)=opt(37) + basu550(icol,k,kcomp)=opt(38) + bebg550(icol,k,kcomp)=opt(26)+opt(27) + bebc550(icol,k,kcomp)=opt(28)+opt(29) + beoc550(icol,k,kcomp)=opt(30)+opt(31) + besu550(icol,k,kcomp)=opt(32)+opt(33) + bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + endif ! Nnatk > 0 + + + end do ! icol + end do ! k + + + end do ! kcomp + + return +end subroutine intaeropt2to3 + + + + diff --git a/src/physics/cam_oslo/intaeropt4.F90 b/src/physics/cam_oslo/intaeropt4.F90 new file mode 100644 index 0000000000..42ab4e583c --- /dev/null +++ b/src/physics/cam_oslo/intaeropt4.F90 @@ -0,0 +1,339 @@ +subroutine intaeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backsc550, babg550, babc550, baoc550, basu550) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: fbcbg, cate, cat, fac, faq, fbc, rh + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xfbcbg(pcols,pver) + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + +! +! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) +! for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). +! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). +! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for +! interpolations using common subroutines interpol*dim. + + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & + bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & + bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & + beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & + besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer i, iv, kcomp, k, icol, kc10 + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) t_fbcbg1, t_fbcbg2 + integer t_ifb1, t_ifb2 + real(r8) t_faq1, t_faq2, t_xfaq + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_xrh, t_xct, t_rh1, t_rh2 + real(r8) t_cat1, t_cat2 + real(r8) t_xfbcbg + real(r8) d2mx(5), dxm1(5), invd(5) + real(r8) opt5d(2,2,2,2,2) + real(r8) opt1, opt2, opt(38) + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! BC&OC(Ait) mode: + + do kcomp=4,4 + +! write(*,*) 'kcomp = ', kcomp + +! initialize all output fields + do k=1,pver + do icol=1,ncol + bext440(icol,k,kcomp)=0.0_r8 + babs440(icol,k,kcomp)=0.0_r8 + bext500(icol,k,kcomp)=0.0_r8 + babs500(icol,k,kcomp)=0.0_r8 + bext550(icol,k,kcomp)=0.0_r8 + babs550(icol,k,kcomp)=0.0_r8 + bext670(icol,k,kcomp)=0.0_r8 + babs670(icol,k,kcomp)=0.0_r8 + bext870(icol,k,kcomp)=0.0_r8 + babs870(icol,k,kcomp)=0.0_r8 + bebg440(icol,k,kcomp)=0.0_r8 +! babg440(icol,k,kcomp)=0.0_r8 + bebg500(icol,k,kcomp)=0.0_r8 +! babg500(icol,k,kcomp)=0.0_r8 + bebg550(icol,k,kcomp)=0.0_r8 + babg550(icol,k,kcomp)=0.0_r8 + bebg670(icol,k,kcomp)=0.0_r8 +! babg670(icol,k,kcomp)=0.0_r8 + bebg870(icol,k,kcomp)=0.0_r8 +! babg870(icol,k,kcomp)=0.0_r8 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc550(icol,k,kcomp)=0.0_r8 + babc550(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc550(icol,k,kcomp)=0.0_r8 + baoc550(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu550(icol,k,kcomp)=0.0_r8 + basu550(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=0.0_r8 + bebg550gt1(icol,k,kcomp)=0.0_r8 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=0.0_r8 + end do + end do + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kc10).gt.0) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + + opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + +! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & + /(t_rh2-t_rh1) + +! write(*,*) opt(iv) + + end do ! iv=1,38 + + bext440(icol,k,kcomp)=opt(1) + bext500(icol,k,kcomp)=opt(2) + bext670(icol,k,kcomp)=opt(3) + bext870(icol,k,kcomp)=opt(4) + bebg440(icol,k,kcomp)=opt(5) + bebg500(icol,k,kcomp)=opt(6) + bebg670(icol,k,kcomp)=opt(7) + bebg870(icol,k,kcomp)=opt(8) + bebc440(icol,k,kcomp)=opt(9) + bebc500(icol,k,kcomp)=opt(10) + bebc670(icol,k,kcomp)=opt(11) + bebc870(icol,k,kcomp)=opt(12) + beoc440(icol,k,kcomp)=opt(13) + beoc500(icol,k,kcomp)=opt(14) + beoc670(icol,k,kcomp)=opt(15) + beoc870(icol,k,kcomp)=opt(16) + besu440(icol,k,kcomp)=opt(17) + besu500(icol,k,kcomp)=opt(18) + besu670(icol,k,kcomp)=opt(19) + besu870(icol,k,kcomp)=opt(20) + babs440(icol,k,kcomp)=opt(21) + babs500(icol,k,kcomp)=opt(22) + babs550(icol,k,kcomp)=opt(23) + babs670(icol,k,kcomp)=opt(24) + babs870(icol,k,kcomp)=opt(25) + bebg550lt1(icol,k,kcomp)=opt(26) + bebg550gt1(icol,k,kcomp)=opt(27) + bebc550lt1(icol,k,kcomp)=opt(28) + bebc550gt1(icol,k,kcomp)=opt(29) + beoc550lt1(icol,k,kcomp)=opt(30) + beoc550gt1(icol,k,kcomp)=opt(31) + besu550lt1(icol,k,kcomp)=opt(32) + besu550gt1(icol,k,kcomp)=opt(33) + backsc550(icol,k,kcomp)=opt(34) + babg550(icol,k,kcomp)=opt(35) + babc550(icol,k,kcomp)=opt(36) + baoc550(icol,k,kcomp)=opt(37) + basu550(icol,k,kcomp)=opt(38) + bebg550(icol,k,kcomp)=opt(26)+opt(27) + bebc550(icol,k,kcomp)=opt(28)+opt(29) + beoc550(icol,k,kcomp)=opt(30)+opt(31) + besu550(icol,k,kcomp)=opt(32)+opt(33) + bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + endif + + end do ! icol + end do ! k + + end do ! kcomp + + return + +end subroutine intaeropt4 + + + + diff --git a/src/physics/cam_oslo/intaeropt5to10.F90 b/src/physics/cam_oslo/intaeropt5to10.F90 new file mode 100644 index 0000000000..11226da38d --- /dev/null +++ b/src/physics/cam_oslo/intaeropt5to10.F90 @@ -0,0 +1,334 @@ +subroutine intaeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backsc550, babg550, babc550, baoc550, basu550) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, faq, fbc, rh + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) +! +! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) +! for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). +! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). +! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for +! interpolations using common subroutines interpol*dim. +! + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & + bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & + bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & + beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & + besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer i, iv, kcomp, k, icol + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) t_faq1, t_faq2, t_xfaq + real(r8) t_fbc1, t_fbc2, t_xfbc + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_xrh, t_xct, t_rh1, t_rh2 + real(r8) t_cat1, t_cat2 + real(r8) d2mx(5), dxm1(5), invd(5) + real(r8) opt5d(2,2,2,2,2) + real(r8) opt1, opt2, opt(38) + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + +! write(*,*) 'kcomp = ', kcomp + +! initialize all output fields + do k=1,pver + do icol=1,ncol + bext440(icol,k,kcomp)=0.0_r8 + babs440(icol,k,kcomp)=0.0_r8 + bext500(icol,k,kcomp)=0.0_r8 + babs500(icol,k,kcomp)=0.0_r8 + bext550(icol,k,kcomp)=0.0_r8 + babs550(icol,k,kcomp)=0.0_r8 + bext670(icol,k,kcomp)=0.0_r8 + babs670(icol,k,kcomp)=0.0_r8 + bext870(icol,k,kcomp)=0.0_r8 + babs870(icol,k,kcomp)=0.0_r8 + bebg440(icol,k,kcomp)=0.0_r8 +! babg440(icol,k,kcomp)=0.0_r8 + bebg500(icol,k,kcomp)=0.0_r8 +! babg500(icol,k,kcomp)=0.0_r8 + bebg550(icol,k,kcomp)=0.0_r8 + babg550(icol,k,kcomp)=0.0_r8 + bebg670(icol,k,kcomp)=0.0_r8 +! babg670(icol,k,kcomp)=0.0_r8 + bebg870(icol,k,kcomp)=0.0_r8 +! babg870(icol,k,kcomp)=0.0_r8 + bebc440(icol,k,kcomp)=0.0_r8 +! babc440(icol,k,kcomp)=0.0_r8 + bebc500(icol,k,kcomp)=0.0_r8 +! babc500(icol,k,kcomp)=0.0_r8 + bebc550(icol,k,kcomp)=0.0_r8 + babc550(icol,k,kcomp)=0.0_r8 + bebc670(icol,k,kcomp)=0.0_r8 +! babc670(icol,k,kcomp)=0.0_r8 + bebc870(icol,k,kcomp)=0.0_r8 +! babc870(icol,k,kcomp)=0.0_r8 + beoc440(icol,k,kcomp)=0.0_r8 +! baoc440(icol,k,kcomp)=0.0_r8 + beoc500(icol,k,kcomp)=0.0_r8 +! baoc500(icol,k,kcomp)=0.0_r8 + beoc550(icol,k,kcomp)=0.0_r8 + baoc550(icol,k,kcomp)=0.0_r8 + beoc670(icol,k,kcomp)=0.0_r8 +! baoc670(icol,k,kcomp)=0.0_r8 + beoc870(icol,k,kcomp)=0.0_r8 +! baoc870(icol,k,kcomp)=0.0_r8 + besu440(icol,k,kcomp)=0.0_r8 +! basu440(icol,k,kcomp)=0.0_r8 + besu500(icol,k,kcomp)=0.0_r8 +! basu500(icol,k,kcomp)=0.0_r8 + besu550(icol,k,kcomp)=0.0_r8 + basu550(icol,k,kcomp)=0.0_r8 + besu670(icol,k,kcomp)=0.0_r8 +! basu670(icol,k,kcomp)=0.0_r8 + besu870(icol,k,kcomp)=0.0_r8 +! basu870(icol,k,kcomp)=0.0_r8 + bebg550lt1(icol,k,kcomp)=0.0_r8 + bebg550gt1(icol,k,kcomp)=0.0_r8 + bebc550lt1(icol,k,kcomp)=0.0_r8 + bebc550gt1(icol,k,kcomp)=0.0_r8 + beoc550lt1(icol,k,kcomp)=0.0_r8 + beoc550gt1(icol,k,kcomp)=0.0_r8 + besu550lt1(icol,k,kcomp)=0.0_r8 + besu550gt1(icol,k,kcomp)=0.0_r8 + backsc550(icol,k,kcomp)=0.0_r8 + end do + end do + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp).gt.0) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + + opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before opt' + + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & + /(t_rh2-t_rh1) + +! write(*,*) opt(iv) + + end do ! iv=1,38 + + bext440(icol,k,kcomp)=opt(1) + bext500(icol,k,kcomp)=opt(2) + bext670(icol,k,kcomp)=opt(3) + bext870(icol,k,kcomp)=opt(4) + bebg440(icol,k,kcomp)=opt(5) + bebg500(icol,k,kcomp)=opt(6) + bebg670(icol,k,kcomp)=opt(7) + bebg870(icol,k,kcomp)=opt(8) + bebc440(icol,k,kcomp)=opt(9) + bebc500(icol,k,kcomp)=opt(10) + bebc670(icol,k,kcomp)=opt(11) + bebc870(icol,k,kcomp)=opt(12) + beoc440(icol,k,kcomp)=opt(13) + beoc500(icol,k,kcomp)=opt(14) + beoc670(icol,k,kcomp)=opt(15) + beoc870(icol,k,kcomp)=opt(16) + besu440(icol,k,kcomp)=opt(17) + besu500(icol,k,kcomp)=opt(18) + besu670(icol,k,kcomp)=opt(19) + besu870(icol,k,kcomp)=opt(20) + babs440(icol,k,kcomp)=opt(21) + babs500(icol,k,kcomp)=opt(22) + babs550(icol,k,kcomp)=opt(23) + babs670(icol,k,kcomp)=opt(24) + babs870(icol,k,kcomp)=opt(25) + bebg550lt1(icol,k,kcomp)=opt(26) + bebg550gt1(icol,k,kcomp)=opt(27) + bebc550lt1(icol,k,kcomp)=opt(28) + bebc550gt1(icol,k,kcomp)=opt(29) + beoc550lt1(icol,k,kcomp)=opt(30) + beoc550gt1(icol,k,kcomp)=opt(31) + besu550lt1(icol,k,kcomp)=opt(32) + besu550gt1(icol,k,kcomp)=opt(33) + backsc550(icol,k,kcomp)=opt(34) + babg550(icol,k,kcomp)=opt(35) + babc550(icol,k,kcomp)=opt(36) + baoc550(icol,k,kcomp)=opt(37) + basu550(icol,k,kcomp)=opt(38) + bebg550(icol,k,kcomp)=opt(26)+opt(27) + bebc550(icol,k,kcomp)=opt(28)+opt(29) + beoc550(icol,k,kcomp)=opt(30)+opt(31) + besu550(icol,k,kcomp)=opt(32)+opt(33) + bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + endif + + + end do ! icol + end do ! k + + end do ! kcomp + + return + +end subroutine intaeropt5to10 + + + + diff --git a/src/physics/cam_oslo/intdrypar0.F90 b/src/physics/cam_oslo/intdrypar0.F90 new file mode 100644 index 0000000000..21c416a048 --- /dev/null +++ b/src/physics/cam_oslo/intdrypar0.F90 @@ -0,0 +1,148 @@ +subroutine intdrypar0 (lchnk, ncol, Nnatk, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, faq, fbc, rh + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration +! +! Input-Output arguments +! + real(r8), intent(inout) :: & + cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) +! +! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) +! (for AeroCom determination of particle effective radii) of each constituent. cint*05 +! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are +! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. +! + real(r8), intent(out) :: & + cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer i, ierr, kcomp, k, icol + + parameter (eps=1.0e-60_r8) + +! Mode 0, BC(ax): + + kcomp=0 + +! initialize output fields + do k=1,pver + do icol=1,ncol + cintbg(icol,k,kcomp)=0.0_r8 + cintbg05(icol,k,kcomp)=0.0_r8 + cintbg125(icol,k,kcomp)=0.0_r8 + cintbc(icol,k,kcomp)=0.0_r8 + cintbc05(icol,k,kcomp)=0.0_r8 + cintbc125(icol,k,kcomp)=0.0_r8 + cintoc(icol,k,kcomp)=0.0_r8 + cintoc05(icol,k,kcomp)=0.0_r8 + cintoc125(icol,k,kcomp)=0.0_r8 + cintsc(icol,k,kcomp)=0.0_r8 + cintsc05(icol,k,kcomp)=0.0_r8 + cintsc125(icol,k,kcomp)=0.0_r8 + cintsa(icol,k,kcomp)=0.0_r8 + cintsa05(icol,k,kcomp)=0.0_r8 + cintsa125(icol,k,kcomp)=0.0_r8 + aaeros(icol,k,kcomp)=0.0_r8 + aaerol(icol,k,kcomp)=0.0_r8 + vaeros(icol,k,kcomp)=0.0_r8 + vaerol(icol,k,kcomp)=0.0_r8 + end do + end do + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp)>0.0_r8) then + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do i=1,19 ! variable number + + if(i==1) then + cintbg(icol,k,kcomp)=a0cintbg + elseif(i==2) then + cintbg05(icol,k,kcomp)=a0cintbg05 + elseif(i==3) then + cintbg125(icol,k,kcomp)=a0cintbg125 + elseif(i==4) then + cintbc(icol,k,kcomp)=eps + elseif(i==5) then + cintbc05(icol,k,kcomp)=eps + elseif(i==6) then + cintbc125(icol,k,kcomp)=eps + elseif(i==7) then + cintoc(icol,k,kcomp)=eps + elseif(i==8) then + cintoc05(icol,k,kcomp)=eps + elseif(i==9) then + cintoc125(icol,k,kcomp)=eps + elseif(i==10) then + cintsc(icol,k,kcomp)=eps + elseif(i==11) then + cintsc05(icol,k,kcomp)=eps + elseif(i==12) then + cintsc125(icol,k,kcomp)=eps + elseif(i==13) then + cintsa(icol,k,kcomp)=eps + elseif(i==14) then + cintsa05(icol,k,kcomp)=eps + elseif(i==15) then + cintsa125(icol,k,kcomp)=eps + elseif(i==16) then + aaeros(icol,k,kcomp)=a0aaeros + elseif(i==17) then + aaerol(icol,k,kcomp)=a0aaerol + elseif(i==18) then + vaeros(icol,k,kcomp)=a0vaeros + elseif(i==19) then + vaerol(icol,k,kcomp)=a0vaerol + endif + + end do ! i=1,19 + + endif + + cknorm(icol,k,kcomp) = a0cintbg + cknlt05(icol,k,kcomp) = a0cintbg05 + ckngt125(icol,k,kcomp)= a0cintbg125 + +! if(k.eq.1.or.k.eq.pver) write(*,*) 'cknorm =', cknorm(icol,k,kcomp) +! if(k.eq.1.or.k.eq.pver) write(*,*) 'cknlt05 =', cknlt05(icol,k,kcomp) +! if(k.eq.1.or.k.eq.pver) write(*,*) 'ckngt125 =', ckngt125(icol,k,kcomp) + + end do ! icol + end do ! k + + + return +end subroutine intdrypar0 + + + + diff --git a/src/physics/cam_oslo/intdrypar1.F90 b/src/physics/cam_oslo/intdrypar1.F90 new file mode 100644 index 0000000000..6265ce4b66 --- /dev/null +++ b/src/physics/cam_oslo/intdrypar1.F90 @@ -0,0 +1,274 @@ +subroutine intdrypar1 (lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: fombg, cate, cat, fac, faq, nbmp1 + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode (1) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) +! +! Input-Output arguments +! + real(r8), intent(inout) :: & + aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) +! +! +! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) +! (for AeroCom determination of particle effective radii) of each constituent. cint*05 +! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are +! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. +! + real(r8), intent(out) :: & + cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer iv, kcomp, k, icol + +! Temporary storage of often used array elements + integer t_ifo1, t_ifo2 + integer t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_xct, t_cat1, t_cat2 + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_fombg1, t_fombg2, t_xfombg, t_xfombgn + + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) opt3d(2,2,2) + real(r8) opt1, opt2, opt + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! Mode 1, SO4(Ait): + + kcomp=1 + +! initialize output fields + do k=1,pver + do icol=1,ncol + cintbg(icol,k,kcomp)=0.0_r8 + cintbg05(icol,k,kcomp)=0.0_r8 + cintbg125(icol,k,kcomp)=0.0_r8 + cintbc(icol,k,kcomp)=0.0_r8 + cintbc05(icol,k,kcomp)=0.0_r8 + cintbc125(icol,k,kcomp)=0.0_r8 + cintoc(icol,k,kcomp)=0.0_r8 + cintoc05(icol,k,kcomp)=0.0_r8 + cintoc125(icol,k,kcomp)=0.0_r8 + cintsc(icol,k,kcomp)=0.0_r8 + cintsc05(icol,k,kcomp)=0.0_r8 + cintsc125(icol,k,kcomp)=0.0_r8 + cintsa(icol,k,kcomp)=0.0_r8 + cintsa05(icol,k,kcomp)=0.0_r8 + cintsa125(icol,k,kcomp)=0.0_r8 + aaeros(icol,k,kcomp)=0.0_r8 + aaerol(icol,k,kcomp)=0.0_r8 + vaeros(icol,k,kcomp)=0.0_r8 + vaerol(icol,k,kcomp)=0.0_r8 + end do + end do + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp)>0.0_r8) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + t_xfombg = xfombg(icol,k) + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + +! partial lengths along each dimension (1-3) for interpolation + d2mx(1) = (t_fombg2-t_xfombg) + dxm1(1) = (t_xfombg-t_fombg1) + invd(1) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do iv=1,19 ! variable number + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=a1var(iv,t_ifo1,t_ict1,t_ifc1) + opt3d(1,1,2)=a1var(iv,t_ifo1,t_ict1,t_ifc2) + opt3d(1,2,1)=a1var(iv,t_ifo1,t_ict2,t_ifc1) + opt3d(1,2,2)=a1var(iv,t_ifo1,t_ict2,t_ifc2) + opt3d(2,1,1)=a1var(iv,t_ifo2,t_ict1,t_ifc1) + opt3d(2,1,2)=a1var(iv,t_ifo2,t_ict1,t_ifc2) + opt3d(2,2,1)=a1var(iv,t_ifo2,t_ict2,t_ifc1) + opt3d(2,2,2)=a1var(iv,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac and cat dimensions + call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) + +! finally, interpolation in the fombg dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + +! if(k.eq.1) write(*,*) 'opt1 =', opt + + +! write(*,*) 'Before array' + + if(iv==1) then + cintbg(icol,k,kcomp)=opt + elseif(iv==2) then + cintbg05(icol,k,kcomp)=opt + elseif(iv==3) then + cintbg125(icol,k,kcomp)=opt + elseif(iv==4) then + cintbc(icol,k,kcomp)=opt + elseif(iv==5) then + cintbc05(icol,k,kcomp)=opt + elseif(iv==6) then + cintbc125(icol,k,kcomp)=opt + elseif(iv==7) then + cintoc(icol,k,kcomp)=opt + elseif(iv==8) then + cintoc05(icol,k,kcomp)=opt + elseif(iv==9) then + cintoc125(icol,k,kcomp)=opt + elseif(iv==10) then + cintsc(icol,k,kcomp)=opt + elseif(iv==11) then + cintsc05(icol,k,kcomp)=opt + elseif(iv==12) then + cintsc125(icol,k,kcomp)=opt + elseif(iv==13) then + cintsa(icol,k,kcomp)=opt + elseif(iv==14) then + cintsa05(icol,k,kcomp)=opt + elseif(iv==15) then + cintsa125(icol,k,kcomp)=opt + elseif(iv==16) then + aaeros(icol,k,kcomp)=opt + elseif(iv==17) then + aaerol(icol,k,kcomp)=opt + elseif(iv==18) then + vaeros(icol,k,kcomp)=opt + elseif(iv==19) then + vaerol(icol,k,kcomp)=opt + endif + + end do ! iv=1,19 + + endif + + end do ! icol + end do ! k + + +! Dry parameters for externally mixed mode 11, +! SO4(n): + + kcomp=11 + + do k=1,pver + do icol=1,ncol + +! xfombgn(icol,k) = min(max(xfombgnin(icol,k),fombg(1)),fombg(6)) +! write(*,*) 'Before fombg-loop', kcomp +! do ifombg=1,5 +! if(xfombgn(icol,k) >= fombg(ifombg).and. & +! xfombgn(icol,k) <= fombg(ifombg+1)) then +! ifombgn1(icol,k)=ifombg +! ifombgn2(icol,k)=ifombg+1 +! endif +! end do ! ifombg +! t_ifo1 = ifombgn1(icol,k) +! t_ifo2 = ifombgn2(icol,k) +! t_fombg1 = fombg(t_ifo1) +! t_fombg2 = fombg(t_ifo2) +! t_xfombg = xfombgn(icol,k) +! d2mx(1) = (t_fombg2-t_xfombg) +! dxm1(1) = (t_xfombg-t_fombg1) +! invd(1) = 1.0_r8/(t_fombg2-t_fombg1) +!! Only interpolation in the fombg dimension for mode 11 +! opt1 = a1var(1,1,1,1) +! opt2 = a1var(1,2,1,1) +! cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! opt1 = a1var(2,1,1,1) +! opt2 = a1var(2,2,1,1) +! cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! opt1 = a1var(3,1,1,1) +! opt2 = a1var(3,2,1,1) +! ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +!! (The remaining variables are actually independent of fbcbg, +!! but we follow the same procedure anyway:) +! opt1 = a1var(16,1,1,1) +! opt2 = a1var(16,2,1,1) +! aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! opt1 = a1var(17,1,1,1) +! opt2 = a1var(17,2,1,1) +! aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! opt1 = a1var(18,1,1,1) +! opt2 = a1var(18,2,1,1) +! vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! opt1 = a1var(19,1,1,1) +! opt2 = a1var(19,2,1,1) +! vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) +! +! The procedure above is unnessesary, since neither total background +! concentrations (OM + sulfate) nor areas & volumes depend on fombg: + cknorm(icol,k,kcomp) = a1var(1,1,1,1) + cknlt05(icol,k,kcomp) = a1var(2,1,1,1) + ckngt125(icol,k,kcomp) = a1var(3,1,1,1) + aaerosn(icol,k,kcomp) = a1var(16,1,1,1) + aaeroln(icol,k,kcomp) = a1var(17,1,1,1) + vaerosn(icol,k,kcomp) = a1var(18,1,1,1) + vaeroln(icol,k,kcomp) = a1var(19,1,1,1) + + end do ! icol + end do ! k + + + return +end subroutine intdrypar1 diff --git a/src/physics/cam_oslo/intdrypar2to3.F90 b/src/physics/cam_oslo/intdrypar2to3.F90 new file mode 100644 index 0000000000..bf7aebfe4b --- /dev/null +++ b/src/physics/cam_oslo/intdrypar2to3.F90 @@ -0,0 +1,221 @@ +subroutine intdrypar2to3 (lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, nbmp1 + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) +! +! Input-Output arguments +! + real(r8), intent(inout) :: & + aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) +! +! +! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) +! (for AeroCom determination of particle effective radii) of each constituent. cint*05 +! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are +! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. +! + real(r8), intent(out) :: & + cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer iv, kcomp, k, icol + +! Temporary storage of often used array elements + integer t_ict1, t_ict2 + real(r8) t_xct, t_cat1, t_cat2 + real(r8) t_fac1, t_fac2, t_xfac + integer t_ifc1, t_ifc2 + real(r8) d2mx(2), dxm1(2), invd(2) + real(r8) opt2d(2,2) + real(r8) opt1, opt2, opt + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! Modes 1-3, SO4(Ait), BC(Ait) and OC(Ait): + + do kcomp=2,3 + +! initialize output fields + do k=1,pver + do icol=1,ncol + cintbg(icol,k,kcomp)=0.0_r8 + cintbg05(icol,k,kcomp)=0.0_r8 + cintbg125(icol,k,kcomp)=0.0_r8 + cintbc(icol,k,kcomp)=0.0_r8 + cintbc05(icol,k,kcomp)=0.0_r8 + cintbc125(icol,k,kcomp)=0.0_r8 + cintoc(icol,k,kcomp)=0.0_r8 + cintoc05(icol,k,kcomp)=0.0_r8 + cintoc125(icol,k,kcomp)=0.0_r8 + cintsc(icol,k,kcomp)=0.0_r8 + cintsc05(icol,k,kcomp)=0.0_r8 + cintsc125(icol,k,kcomp)=0.0_r8 + cintsa(icol,k,kcomp)=0.0_r8 + cintsa05(icol,k,kcomp)=0.0_r8 + cintsa125(icol,k,kcomp)=0.0_r8 + aaeros(icol,k,kcomp)=0.0_r8 + aaerol(icol,k,kcomp)=0.0_r8 + vaeros(icol,k,kcomp)=0.0_r8 + vaerol(icol,k,kcomp)=0.0_r8 + end do + end do + + end do ! kcomp + + do kcomp=2,2 + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp)>0.0_r8) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_xct = xct(icol,k,kcomp) + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xfac = xfac(icol,k,kcomp) + +! partial lengths along each dimension (1-2) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do iv=1,19 ! variable number + +! end points as basis for multidimentional linear interpolation + opt2d(1,1)=a2to3var(iv,t_ict1,t_ifc1,kcomp) + opt2d(1,2)=a2to3var(iv,t_ict1,t_ifc2,kcomp) + opt2d(2,1)=a2to3var(iv,t_ict2,t_ifc1,kcomp) + opt2d(2,2)=a2to3var(iv,t_ict2,t_ifc2,kcomp) + +! interpolation in the fac dimension + opt1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(2) + opt2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(2) + +! finally, interpolation in the cat dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + +! if(k.eq.1) write(*,*) 'opt2to3 =', opt + +! write(*,*) 'Before array' + + if(iv==1) then + cintbg(icol,k,kcomp)=opt + elseif(iv==2) then + cintbg05(icol,k,kcomp)=opt + elseif(iv==3) then + cintbg125(icol,k,kcomp)=opt + elseif(iv==4) then + cintbc(icol,k,kcomp)=opt + elseif(iv==5) then + cintbc05(icol,k,kcomp)=opt + elseif(iv==6) then + cintbc125(icol,k,kcomp)=opt + elseif(iv==7) then + cintoc(icol,k,kcomp)=opt + elseif(iv==8) then + cintoc05(icol,k,kcomp)=opt + elseif(iv==9) then + cintoc125(icol,k,kcomp)=opt + elseif(iv==10) then + cintsc(icol,k,kcomp)=opt + elseif(iv==11) then + cintsc05(icol,k,kcomp)=opt + elseif(iv==12) then + cintsc125(icol,k,kcomp)=opt + elseif(iv==13) then + cintsa(icol,k,kcomp)=opt + elseif(iv==14) then + cintsa05(icol,k,kcomp)=opt + elseif(iv==15) then + cintsa125(icol,k,kcomp)=opt + elseif(iv==16) then + aaeros(icol,k,kcomp)=opt + elseif(iv==17) then + aaerol(icol,k,kcomp)=opt + elseif(iv==18) then + vaeros(icol,k,kcomp)=opt + elseif(iv==19) then + vaerol(icol,k,kcomp)=opt + endif + end do ! iv=1,19 + + endif + + end do ! icol + end do ! k + + end do ! kcomp + +! Dry parameters for externally mixed modes modes 12-13, +! BC(n) and OC(n): + + do kcomp=12,13 ! using dummy initialization for kcomp=3 +! do kcomp=12,12 + + do k=1,pver + do icol=1,ncol + + cknorm(icol,k,kcomp) = a2to3var(1,1,1,kcomp-10) + cknlt05(icol,k,kcomp) = a2to3var(2,1,1,kcomp-10) + ckngt125(icol,k,kcomp)= a2to3var(3,1,1,kcomp-10) + aaerosn(icol,k,kcomp) = a2to3var(16,1,1,kcomp-10) + aaeroln(icol,k,kcomp) = a2to3var(17,1,1,kcomp-10) + vaerosn(icol,k,kcomp) = a2to3var(18,1,1,kcomp-10) + vaeroln(icol,k,kcomp) = a2to3var(19,1,1,kcomp-10) + + end do ! icol + end do ! k + + end do ! kcomp + + + return +end subroutine intdrypar2to3 diff --git a/src/physics/cam_oslo/intdrypar4.F90 b/src/physics/cam_oslo/intdrypar4.F90 new file mode 100644 index 0000000000..e8fe8f9f40 --- /dev/null +++ b/src/physics/cam_oslo/intdrypar4.F90 @@ -0,0 +1,278 @@ +subroutine intdrypar4 (lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: fbcbg, cate, cat, fac, faq, fbc, nbmp1 + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (4) + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xfbcbgn(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (14) + integer, intent(in) :: ifbcbgn1(pcols,pver) +! +! Input-Output arguments +! + real(r8), intent(inout) :: & + aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) +! +! +! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) +! (for AeroCom determination of particle effective radii) of each constituent. cint*05 +! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are +! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. +! + real(r8), intent(out) :: & + cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer iv, kcomp, k, icol + +! Temporary storage of often used array elements + integer t_ifb1, t_ifb2 + integer t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) t_fbcbg1, t_fbcbg2 + real(r8) t_faq1, t_faq2, t_xfaq + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_xct, t_cat1, t_cat2 + + real(r8) t_xfbcbg + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) opt1, opt2, opt + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! Mode 4, BC&OC(Ait): + + kcomp=4 + +! initialize output fields + do k=1,pver + do icol=1,ncol + cintbg(icol,k,kcomp)=0.0_r8 + cintbg05(icol,k,kcomp)=0.0_r8 + cintbg125(icol,k,kcomp)=0.0_r8 + cintbc(icol,k,kcomp)=0.0_r8 + cintbc05(icol,k,kcomp)=0.0_r8 + cintbc125(icol,k,kcomp)=0.0_r8 + cintoc(icol,k,kcomp)=0.0_r8 + cintoc05(icol,k,kcomp)=0.0_r8 + cintoc125(icol,k,kcomp)=0.0_r8 + cintsc(icol,k,kcomp)=0.0_r8 + cintsc05(icol,k,kcomp)=0.0_r8 + cintsc125(icol,k,kcomp)=0.0_r8 + cintsa(icol,k,kcomp)=0.0_r8 + cintsa05(icol,k,kcomp)=0.0_r8 + cintsa125(icol,k,kcomp)=0.0_r8 + aaeros(icol,k,kcomp)=0.0_r8 + aaerol(icol,k,kcomp)=0.0_r8 + vaeros(icol,k,kcomp)=0.0_r8 + vaerol(icol,k,kcomp)=0.0_r8 + end do + end do + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp)>0.0_r8) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_fbcbg2-t_xfbcbg) + dxm1(1) = (t_xfbcbg-t_fbcbg1) + invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do iv=1,19 ! variable number + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt4d(1,1,1,2)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt4d(1,1,2,1)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt4d(1,1,2,2)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt4d(1,2,1,1)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt4d(1,2,1,2)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt4d(1,2,2,1)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt4d(1,2,2,2)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt4d(2,1,1,1)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt4d(2,1,1,2)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt4d(2,1,2,1)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt4d(2,1,2,2)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt4d(2,2,1,1)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt4d(2,2,1,2)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt4d(2,2,2,1)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt4d(2,2,2,2)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + +! finally, interpolation in the fbcbg dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + +! if(k.eq.1) write(*,*) 'opt4 =', opt + +! write(*,*) 'Before array' + + if(iv==1) then + cintbg(icol,k,kcomp)=opt + elseif(iv==2) then + cintbg05(icol,k,kcomp)=opt + elseif(iv==3) then + cintbg125(icol,k,kcomp)=opt + elseif(iv==4) then + cintbc(icol,k,kcomp)=opt + elseif(iv==5) then + cintbc05(icol,k,kcomp)=opt + elseif(iv==6) then + cintbc125(icol,k,kcomp)=opt + elseif(iv==7) then + cintoc(icol,k,kcomp)=opt + elseif(iv==8) then + cintoc05(icol,k,kcomp)=opt + elseif(iv==9) then + cintoc125(icol,k,kcomp)=opt + elseif(iv==10) then + cintsc(icol,k,kcomp)=opt + elseif(iv==11) then + cintsc05(icol,k,kcomp)=opt + elseif(iv==12) then + cintsc125(icol,k,kcomp)=opt + elseif(iv==13) then + cintsa(icol,k,kcomp)=opt + elseif(iv==14) then + cintsa05(icol,k,kcomp)=opt + elseif(iv==15) then + cintsa125(icol,k,kcomp)=opt + elseif(iv==16) then + aaeros(icol,k,kcomp)=opt + elseif(iv==17) then + aaerol(icol,k,kcomp)=opt + elseif(iv==18) then + vaeros(icol,k,kcomp)=opt + elseif(iv==19) then + vaerol(icol,k,kcomp)=opt + endif + + end do ! iv=1,19 + + endif + + end do ! icol + end do ! k + + kcomp=14 + do k=1,pver + do icol=1,ncol + + t_ifb1 = ifbcbgn1(icol,k) + t_ifb2 = t_ifb1+1 + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_xfbcbg = xfbcbgn(icol,k) + + d2mx(1) = (t_fbcbg2-t_xfbcbg) + dxm1(1) = (t_xfbcbg-t_fbcbg1) + invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + +! Only interpolation in the fbcbg dimension for mode 14 + opt1 = a4var(1,1,1,1,1) + opt2 = a4var(1,2,1,1,1) + cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(2,1,1,1,1) + opt2 = a4var(2,2,1,1,1) + cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(3,1,1,1,1) + opt2 = a4var(3,2,1,1,1) + ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(16,1,1,1,1) + opt2 = a4var(16,2,1,1,1) +! (The remaining variables are actually independent of fbcbg, +! but we follow the same procedure anyway:) + aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(17,1,1,1,1) + opt2 = a4var(17,2,1,1,1) + aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(18,1,1,1,1) + opt2 = a4var(18,2,1,1,1) + vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + opt1 = a4var(19,1,1,1,1) + opt2 = a4var(19,2,1,1,1) + vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + end do ! icol + end do ! k + + return +end subroutine intdrypar4 + + + + diff --git a/src/physics/cam_oslo/intdrypar5to10.F90 b/src/physics/cam_oslo/intdrypar5to10.F90 new file mode 100644 index 0000000000..8ba2a92c0f --- /dev/null +++ b/src/physics/cam_oslo/intdrypar5to10.F90 @@ -0,0 +1,241 @@ +subroutine intdrypar5to10 (lchnk, ncol, Nnatk, xct, ict1, & + xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: cate, cat, fac, faq, fbc, rh, nbmp1 + use commondefinitions, only: nmodes, nbmodes + + implicit none + +#include +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) +! +! Input-Output arguments +! + real(r8), intent(inout) :: & + cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) +! +! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) +! (for AeroCom determination of particle effective radii) of each constituent. cint*05 +! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are +! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. +! + real(r8), intent(out) :: & + cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) +! +!---------------------------Local variables----------------------------- +! + real(r8) a, b, e, eps + + integer iv, kcomp, k, icol + +! Temporary storage of often used array elements + integer t_ict1, t_ict2, t_ifa1, t_ifa2 + integer t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) t_faq1, t_faq2, t_xfaq + real(r8) t_fbc1, t_fbc2, t_xfbc + real(r8) t_fac1, t_fac2, t_xfac + real(r8) t_xct, t_cat1, t_cat2 + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) opt1, opt2, opt + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + +! write(*,*) 'Before kcomp-loop' + +! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + +! initialize output fields + do k=1,pver + do icol=1,ncol + cintbg(icol,k,kcomp)=0.0_r8 + cintbg05(icol,k,kcomp)=0.0_r8 + cintbg125(icol,k,kcomp)=0.0_r8 + cintbc(icol,k,kcomp)=0.0_r8 + cintbc05(icol,k,kcomp)=0.0_r8 + cintbc125(icol,k,kcomp)=0.0_r8 + cintoc(icol,k,kcomp)=0.0_r8 + cintoc05(icol,k,kcomp)=0.0_r8 + cintoc125(icol,k,kcomp)=0.0_r8 + cintsc(icol,k,kcomp)=0.0_r8 + cintsc05(icol,k,kcomp)=0.0_r8 + cintsc125(icol,k,kcomp)=0.0_r8 + cintsa(icol,k,kcomp)=0.0_r8 + cintsa05(icol,k,kcomp)=0.0_r8 + cintsa125(icol,k,kcomp)=0.0_r8 + aaeros(icol,k,kcomp)=0.0_r8 + aaerol(icol,k,kcomp)=0.0_r8 + vaeros(icol,k,kcomp)=0.0_r8 + vaerol(icol,k,kcomp)=0.0_r8 + end do + end do + + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kcomp)>0.0_r8) then + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_fbc2-t_xfbc) + dxm1(3) = (t_xfbc-t_fbc1) + invd(3) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) +!soa + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do iv=1,19 ! variable number + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt4d(1,1,1,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt4d(1,1,2,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt4d(1,1,2,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt4d(1,2,1,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt4d(1,2,1,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt4d(1,2,2,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt4d(1,2,2,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt4d(2,1,1,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt4d(2,1,1,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt4d(2,1,2,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt4d(2,1,2,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt4d(2,2,1,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt4d(2,2,1,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt4d(2,2,2,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt4d(2,2,2,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, and fac and dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + +! finally, interpolation in the cat dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + +! if(k.eq.1.and.kcomp.eq.10) then +! write(*,*) 'a5to10var11=', & +! a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp), iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp +! write(*,*) 'a5to10var12=',& +! a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp), iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp +! endif + + +! write(*,*) 'Before array' + + if(iv==1) then + cintbg(icol,k,kcomp)=opt + elseif(iv==2) then + cintbg05(icol,k,kcomp)=opt + elseif(iv==3) then + cintbg125(icol,k,kcomp)=opt + elseif(iv==4) then + cintbc(icol,k,kcomp)=opt + elseif(iv==5) then + cintbc05(icol,k,kcomp)=opt + elseif(iv==6) then + cintbc125(icol,k,kcomp)=opt + elseif(iv==7) then + cintoc(icol,k,kcomp)=opt + elseif(iv==8) then + cintoc05(icol,k,kcomp)=opt + elseif(iv==9) then + cintoc125(icol,k,kcomp)=opt + elseif(iv==10) then + cintsc(icol,k,kcomp)=opt + elseif(iv==11) then + cintsc05(icol,k,kcomp)=opt + elseif(iv==12) then + cintsc125(icol,k,kcomp)=opt + elseif(iv==13) then + cintsa(icol,k,kcomp)=opt + elseif(iv==14) then + cintsa05(icol,k,kcomp)=opt + elseif(iv==15) then + cintsa125(icol,k,kcomp)=opt + elseif(iv==16) then + aaeros(icol,k,kcomp)=opt + elseif(iv==17) then + aaerol(icol,k,kcomp)=opt + elseif(iv==18) then + vaeros(icol,k,kcomp)=opt + elseif(iv==19) then + vaerol(icol,k,kcomp)=opt + endif + + end do ! iv=1,19 + + endif + + cknorm(icol,k,kcomp) = a5to10var(1,1,1,1,1,kcomp) + cknlt05(icol,k,kcomp) = a5to10var(2,1,1,1,1,kcomp) + ckngt125(icol,k,kcomp)= a5to10var(3,1,1,1,1,kcomp) + + end do ! icol + end do ! k + + end do ! kcomp + + return +end subroutine intdrypar5to10 + + + + diff --git a/src/physics/cam_oslo/intfrh.F90 b/src/physics/cam_oslo/intfrh.F90 new file mode 100644 index 0000000000..2f0bec97a2 --- /dev/null +++ b/src/physics/cam_oslo/intfrh.F90 @@ -0,0 +1,156 @@ + +subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) + +! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 +!o use opttab, only: nbmodes, rh + use opttab, only: rh +! use aerosoldef, only: nmodes + use commondefinitions, only: nmodes + + implicit none + +! Relative humidity intries from opttab.F90: +!! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & +!! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) +! Humidity growth factors which are consistent with the aerosol optics look-up tables: + real(r8), dimension(10) :: fh_SO4 = (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & + 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) + real(r8), dimension(10) :: fh_insol = (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & + 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) + real(r8), dimension(10) :: fh_OC = (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & + 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) + real(r8), dimension(10) :: fh_SS = (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & + 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns +!o real(r8), intent(in) :: v3so4(pcols,pver,nbmodes) ! Modal mass fraction of Sulfate +!o real(r8), intent(in) :: v3insol(pcols,pver,nbmodes)! Modal mass fraction of BC and dust +!o real(r8), intent(in) :: v3oc(pcols,pver,nbmodes) ! Modal mass fraction of OC (POM) +!o real(r8), intent(in) :: v3ss(pcols,pver,nbmodes) ! Modal mass fraction of sea-salt + real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate + real(r8), intent(in) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust + real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) + real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt + real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) +! +! Output arguments +! +!o real(r8), intent(out) :: frh(pcols,pver,nbmodes) ! Modal humidity growth factor + real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor + +! +!---------------------------Local variables----------------------------- +! + integer i, ierr, irelh, kcomp, k, icol + integer irh1(pcols,pver), irh2(pcols,pver) + real(r8) a, b, e, fso4, finsol, foc, fss + real(r8) xrh(pcols,pver) + parameter (e=2.718281828) + +! Temporary storage of often used array elements + integer t_irh1, t_irh2 + real(r8) t_xrh, t_rh1, t_rh2 + +! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol +!test xrh(icol,k) = 0.8 + xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) + end do + end do + +! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh).and. & + xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + irh2(icol,k)=irelh+1 + endif + end do + end do + end do + +!o Loop over all relevant background modes (kcomp=1,2,4-10) +!o do kcomp=1,10 +! Loop over all relevant modes (kcomp=1,2,4-11,13,14) +! (mode 3 is no longer included, and 12 is insoluble) + + do kcomp=1,14 + + do icol=1,ncol + do k=1,pver + frh(icol,k,kcomp)=0.0_r8 + end do + end do + +!o if(kcomp.ne.3) then + if(kcomp.ne.3.and.kcomp.ne.12) then + + do k=1,pver + do icol=1,ncol + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = irh2(icol,k) + +! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + + t_xrh = xrh(icol,k) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: + fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) & + /(t_rh2-t_rh1) + finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) & + /(t_rh2-t_rh1) + foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) & + /(t_rh2-t_rh1) + fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) & + /(t_rh2-t_rh1) + else ! exponential averaging w.r.t. large RH: + a=(log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) + b=(t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) + fso4=e**(a*t_xrh+b) + a=(log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) + b=(t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) + finsol=e**(a*t_xrh+b) + a=(log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) + b=(t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) + foc=e**(a*t_xrh+b) + a=(log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) + b=(t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) + fss=e**(a*t_xrh+b) + endif +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + +! linear interpolation w.r.t. mass fractions of each internally mixed component +! (this assumption is only used here, while the full Koehler equation are solved +! for the look-up tables for log-normal size distributions and aerosol optics): + + frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4+v3insol(icol,k,kcomp)*finsol & + + v3oc(icol,k,kcomp) *foc +v3ss(icol,k,kcomp) *fss + +! write(*,*) 'frh =', frh(icol,k,kcomp) + + end do ! icol + end do ! k + + endif ! kcomp.ne.3.and.kcomp.ne.12 + + end do ! kcomp + + return +end subroutine intfrh diff --git a/src/physics/cam_oslo/lininterpol3dim.F90 b/src/physics/cam_oslo/lininterpol3dim.F90 new file mode 100644 index 0000000000..3781b4c278 --- /dev/null +++ b/src/physics/cam_oslo/lininterpol3dim.F90 @@ -0,0 +1,41 @@ + + subroutine lininterpol3dim (d2mx, dxm1, invd, opt3d, optout1, optout2) + + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + +! +! Input arguments +! + real(r8), intent(in) :: opt3d(2,2,2) + real(r8), intent(in) :: d2mx(3) + real(r8), intent(in) :: dxm1(3) + real(r8), intent(in) :: invd(3) +! +! Output arguments +! + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 +! +!---------------------------Local variables----------------------------- +! + real(r8) opt2d(2,2) +! +!------------------------------------------------------------------------ +! +! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) + opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) + opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) + opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) + +! interpolation in the (third and) second dimension + optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(3)*invd(2) + optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(3)*invd(2) + + + return + +end subroutine lininterpol3dim diff --git a/src/physics/cam_oslo/lininterpol4dim.F90 b/src/physics/cam_oslo/lininterpol4dim.F90 new file mode 100644 index 0000000000..2af2bd5146 --- /dev/null +++ b/src/physics/cam_oslo/lininterpol4dim.F90 @@ -0,0 +1,51 @@ + + subroutine lininterpol4dim (d2mx, dxm1, invd, opt4d, optout1, optout2) + + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + +! +! Input arguments +! + real(r8), intent(in) :: opt4d(2,2,2,2) + real(r8), intent(in) :: d2mx(4) + real(r8), intent(in) :: dxm1(4) + real(r8), intent(in) :: invd(4) +! +! Output arguments +! + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 +! +!---------------------------Local variables----------------------------- +! + real(r8) opt3d(2,2,2), opt2d(2,2) +! +!------------------------------------------------------------------------ +! +! interpolation in the fourth dimension (except invd(4) factor) + opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) + opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) + opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) + opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) + opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) + opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) + opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) + opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) + +! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) + opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) + opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) + opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) + +! interpolation in the (fourth, third and) second dimension + optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(4)*invd(3)*invd(2) + optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(4)*invd(3)*invd(2) + + + return + +end subroutine lininterpol4dim diff --git a/src/physics/cam_oslo/lininterpol5dim.F90 b/src/physics/cam_oslo/lininterpol5dim.F90 new file mode 100644 index 0000000000..b71f529072 --- /dev/null +++ b/src/physics/cam_oslo/lininterpol5dim.F90 @@ -0,0 +1,69 @@ + + subroutine lininterpol5dim (d2mx, dxm1, invd, opt5d, optout1, optout2) + + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + +! +! Input arguments +! + real(r8), intent(in) :: opt5d(2,2,2,2,2) + real(r8), intent(in) :: d2mx(5) + real(r8), intent(in) :: dxm1(5) + real(r8), intent(in) :: invd(5) +! +! Output arguments +! + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 +! +!---------------------------Local variables----------------------------- +! + real(r8) opt4d(2,2,2,2), opt3d(2,2,2), opt2d(2,2) +! +!------------------------------------------------------------------------ +! +! interpolation in the fifth dimension (except invd(5) factor) + opt4d(1,1,1,1)=d2mx(5)*opt5d(1,1,1,1,1)+dxm1(5)*opt5d(1,1,1,1,2) + opt4d(1,1,1,2)=d2mx(5)*opt5d(1,1,1,2,1)+dxm1(5)*opt5d(1,1,1,2,2) + opt4d(1,1,2,1)=d2mx(5)*opt5d(1,1,2,1,1)+dxm1(5)*opt5d(1,1,2,1,2) + opt4d(1,1,2,2)=d2mx(5)*opt5d(1,1,2,2,1)+dxm1(5)*opt5d(1,1,2,2,2) + opt4d(1,2,1,1)=d2mx(5)*opt5d(1,2,1,1,1)+dxm1(5)*opt5d(1,2,1,1,2) + opt4d(1,2,1,2)=d2mx(5)*opt5d(1,2,1,2,1)+dxm1(5)*opt5d(1,2,1,2,2) + opt4d(1,2,2,1)=d2mx(5)*opt5d(1,2,2,1,1)+dxm1(5)*opt5d(1,2,2,1,2) + opt4d(1,2,2,2)=d2mx(5)*opt5d(1,2,2,2,1)+dxm1(5)*opt5d(1,2,2,2,2) + opt4d(2,1,1,1)=d2mx(5)*opt5d(2,1,1,1,1)+dxm1(5)*opt5d(2,1,1,1,2) + opt4d(2,1,1,2)=d2mx(5)*opt5d(2,1,1,2,1)+dxm1(5)*opt5d(2,1,1,2,2) + opt4d(2,1,2,1)=d2mx(5)*opt5d(2,1,2,1,1)+dxm1(5)*opt5d(2,1,2,1,2) + opt4d(2,1,2,2)=d2mx(5)*opt5d(2,1,2,2,1)+dxm1(5)*opt5d(2,1,2,2,2) + opt4d(2,2,1,1)=d2mx(5)*opt5d(2,2,1,1,1)+dxm1(5)*opt5d(2,2,1,1,2) + opt4d(2,2,1,2)=d2mx(5)*opt5d(2,2,1,2,1)+dxm1(5)*opt5d(2,2,1,2,2) + opt4d(2,2,2,1)=d2mx(5)*opt5d(2,2,2,1,1)+dxm1(5)*opt5d(2,2,2,1,2) + opt4d(2,2,2,2)=d2mx(5)*opt5d(2,2,2,2,1)+dxm1(5)*opt5d(2,2,2,2,2) + +! interpolation in the fourth dimension (except invd(4) factor) + opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) + opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) + opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) + opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) + opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) + opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) + opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) + opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) + +! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) + opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) + opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) + opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) + +! interpolation in the (fifth, fourth, third and) second dimension + optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*(invd(5)*invd(4)*invd(3)*invd(2)) + optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*(invd(5)*invd(4)*invd(3)*invd(2)) + + + return + +end subroutine lininterpol5dim diff --git a/src/physics/cam_oslo/opticsAtConstRh.F90 b/src/physics/cam_oslo/opticsAtConstRh.F90 new file mode 100644 index 0000000000..6b82a2968f --- /dev/null +++ b/src/physics/cam_oslo/opticsAtConstRh.F90 @@ -0,0 +1,493 @@ + + subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbc, vaitbc, v_soana, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550, & + bext440n, bext500n, bext550n, bext670n, bext870n, & + bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & + bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & + beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & + besu440n, besu500n, besu550n, besu670n, besu870n, & + babs440n, babs500n, babs550n, babs670n, babs870n, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & + backsc550n, babg550n, babc550n, baoc550n, basu550n) + +! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, +! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use opttab + use const + use aerosoldef + use commondefinitions + use physics_types, only: physics_state + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + integer, intent(in) :: irf + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: vnbc(pcols,pver) + real(r8), intent(in) :: vaitbc(pcols,pver) + real(r8), intent(in) :: v_soana(pcols,pver) + real(r8), intent(in) :: xfombg(pcols,pver) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xfbcbg(pcols,pver) + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xfbcbgn(pcols,pver) + integer, intent(in) :: ifbcbgn1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + +! +! Output arguments +! + real(r8), intent(out) :: & + bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), & + bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & + bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & + beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & + bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes) + + real(r8), intent(out) :: & + bext440n(pcols,pver,0:nbmodes), babs440n(pcols,pver,0:nbmodes), & + bext500n(pcols,pver,0:nbmodes), babs500n(pcols,pver,0:nbmodes), & + bext550n(pcols,pver,0:nbmodes), babs550n(pcols,pver,0:nbmodes), & + bext670n(pcols,pver,0:nbmodes), babs670n(pcols,pver,0:nbmodes), & + bext870n(pcols,pver,0:nbmodes), babs870n(pcols,pver,0:nbmodes), & + bebg440n(pcols,pver,0:nbmodes), & + bebg500n(pcols,pver,0:nbmodes), & + bebg550n(pcols,pver,0:nbmodes), babg550n(pcols,pver,0:nbmodes), & + bebg670n(pcols,pver,0:nbmodes), & + bebg870n(pcols,pver,0:nbmodes), & + bebc440n(pcols,pver,0:nbmodes), & + bebc500n(pcols,pver,0:nbmodes), & + bebc550n(pcols,pver,0:nbmodes), babc550n(pcols,pver,0:nbmodes), & + bebc670n(pcols,pver,0:nbmodes), & + bebc870n(pcols,pver,0:nbmodes), & + beoc440n(pcols,pver,0:nbmodes), & + beoc500n(pcols,pver,0:nbmodes), & + beoc550n(pcols,pver,0:nbmodes), baoc550n(pcols,pver,0:nbmodes), & + beoc670n(pcols,pver,0:nbmodes), & + beoc870n(pcols,pver,0:nbmodes), & + besu440n(pcols,pver,0:nbmodes), & + besu500n(pcols,pver,0:nbmodes), & + besu550n(pcols,pver,0:nbmodes), basu550n(pcols,pver,0:nbmodes), & + besu670n(pcols,pver,0:nbmodes), & + besu870n(pcols,pver,0:nbmodes), & + bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) + +! +!---------------------------Local variables----------------------------- +! + integer i, k, icol, mplus10, irh + integer iloop + + real(r8) deltah + real(r8) dod550rh(pcols), abs550rh(pcols) +! + real(r8) babg440(pcols,pver,0:nbmodes), & + babg500(pcols,pver,0:nbmodes), & + babg670(pcols,pver,0:nbmodes), & + babg870(pcols,pver,0:nbmodes), & + babc440(pcols,pver,0:nbmodes), & + babc500(pcols,pver,0:nbmodes), & + babc670(pcols,pver,0:nbmodes), & + babc870(pcols,pver,0:nbmodes), & + baoc440(pcols,pver,0:nbmodes), & + baoc500(pcols,pver,0:nbmodes), & + baoc670(pcols,pver,0:nbmodes), & + baoc870(pcols,pver,0:nbmodes), & + basu440(pcols,pver,0:nbmodes), & + basu500(pcols,pver,0:nbmodes), & + basu670(pcols,pver,0:nbmodes), & + basu870(pcols,pver,0:nbmodes) + real(r8) ec550rh_aer(pcols,pver), abs550rh_aer(pcols,pver) + real(r8) bebglt1t(pcols,pver), bebclt1t(pcols,pver), & + beoclt1t(pcols,pver), bes4lt1t(pcols,pver) + real(r8) basu550tot(pcols,pver), babc550tot(pcols,pver), baoc550tot(pcols,pver), & + babc550xt(pcols,pver), baoc550xt(pcols,pver), & + ba550x(pcols,pver,nbmp1:nmodes), belt1x(pcols,pver,nbmp1:nmodes) +! Additional AeroCom Phase III output: + real(r8) ec440rh_aer(pcols,pver), abs440rh_aer(pcols,pver), & + ec870rh_aer(pcols,pver), abs870rh_aer(pcols,pver), & + be550lt1_aer(pcols,pver,0:nbmodes), ec550rhlt1_aer(pcols,pver), & + abs550rh_bc(pcols,pver), abs550rh_oc(pcols,pver), & + abs550rh_su(pcols,pver), abs550rh_ss(pcols,pver), & + abs550rh_du(pcols,pver), ec550rhlt1_bc(pcols,pver), & + ec550rhlt1_oc(pcols,pver), ec550rhlt1_su(pcols,pver), & + ec550rhlt1_ss(pcols,pver), ec550rhlt1_du(pcols,pver) +! + real(r8) babg440n(pcols,pver,0:nbmodes), & + babg500n(pcols,pver,0:nbmodes), & + babg670n(pcols,pver,0:nbmodes), & + babg870n(pcols,pver,0:nbmodes), & + babc440n(pcols,pver,0:nbmodes), & + babc500n(pcols,pver,0:nbmodes), & + babc670n(pcols,pver,0:nbmodes), & + babc870n(pcols,pver,0:nbmodes), & + baoc440n(pcols,pver,0:nbmodes), & + baoc500n(pcols,pver,0:nbmodes), & + baoc670n(pcols,pver,0:nbmodes), & + baoc870n(pcols,pver,0:nbmodes), & + basu440n(pcols,pver,0:nbmodes), & + basu500n(pcols,pver,0:nbmodes), & + basu670n(pcols,pver,0:nbmodes), & + basu870n(pcols,pver,0:nbmodes) + + real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & + besslt1(pcols,pver), bessgt1(pcols,pver) + real(r8) bbclt1xt(pcols,pver), & + boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + + character(len=10) :: modeString + character(len=20) :: varname + + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + do iloop=1,1 + +! BC(ax) mode (hydrophobic, so no rhum needed here): + call intaeropt0(lchnk, ncol, Nnatk, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550) + +! SO4(Ait), BC(Ait) and OC(Ait) modes: + mplus10=0 + call intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1,& + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550) + mplus10=0 + call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550) + +! BC&OC(Ait) (4), OC&BC(Ait) mode + mplus10=0 + call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550) + +! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550) + +! then to the externally mixed SO4(n), BC(n) and OC(n) modes: + mplus10=1 + call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + bext440n, bext500n, bext550n, bext670n, bext870n, & + bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & + bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & + beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & + besu440n, besu500n, besu550n, besu670n, besu870n, & + babs440n, babs500n, babs550n, babs670n, babs870n, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & + backsc550n, babg550n, babc550n, baoc550n, basu550n) + +! and finally the BC&OC(n) mode: + mplus10=1 + call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + bext440n, bext500n, bext550n, bext670n, bext870n, & + bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & + bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & + beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & + besu440n, besu500n, besu550n, besu670n, besu870n, & + babs440n, babs500n, babs550n, babs670n, babs870n, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & + backsc550n, babg550n, babc550n, baoc550n, basu550n) + + end do ! iloop + + +! Initialization + do k=1,pver + do icol=1,ncol + ec550rh_aer(icol,k)=0.0_r8 + abs550rh_aer(icol,k)=0.0_r8 + ec550rhlt1_aer(icol,k)=0.0_r8 + abs550rh_bc(icol,k)=0.0_r8 + abs550rh_oc(icol,k)=0.0_r8 + abs550rh_su(icol,k)=0.0_r8 + abs550rh_ss(icol,k)=0.0_r8 + abs550rh_du(icol,k)=0.0_r8 + ec440rh_aer(icol,k)=0.0_r8 + abs440rh_aer(icol,k)=0.0_r8 + ec870rh_aer(icol,k)=0.0_r8 + abs870rh_aer(icol,k)=0.0_r8 + basu550tot(icol,k)=0.0_r8 + babc550tot(icol,k)=0.0_r8 + baoc550tot(icol,k)=0.0_r8 + bebglt1t(icol,k)=0.0_r8 + bebclt1t(icol,k)=0.0_r8 + beoclt1t(icol,k)=0.0_r8 + bes4lt1t(icol,k)=0.0_r8 + bedustlt1(icol,k)=0.0_r8 + besslt1(icol,k)=0.0_r8 + end do + end do + do icol=1,ncol + dod550rh(icol)=0.0_r8 + abs550rh(icol)=0.0_r8 + end do + +! Calculation of extinction at given RH and absorption for all r and for r<0.5um + do k=1,pver + do icol=1,ncol + + do i=0,10 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) + basu550tot(icol,k) = basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) + babc550tot(icol,k) = babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) + baoc550tot(icol,k) = baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) + bes4lt1t(icol,k) = bes4lt1t(icol,k)+Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bebclt1t(icol,k) = bebclt1t(icol,k)+Nnatk(icol,k,i)*bebclt1(icol,k,i) + beoclt1t(icol,k) = beoclt1t(icol,k)+Nnatk(icol,k,i)*beoclt1(icol,k,i) + enddo + do i=11,14 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k)+Nnatk(icol,k,i)*bext550n(icol,k,i-10) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k)+Nnatk(icol,k,i)*bext440n(icol,k,i-10) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k)+Nnatk(icol,k,i)*bext870n(icol,k,i-10) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10) + ba550x(icol,k,i)=babs550n(icol,k,i-10) + belt1x(icol,k,i)=bebglt1n(icol,k,i-10) + enddo + + do i=6,7 + bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + enddo + do i=8,10 + besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + enddo + ec550rhlt1_du(icol,k) = bedustlt1(icol,k) + ec550rhlt1_ss(icol,k) = besslt1(icol,k) + +!soa: *(1-v_soan) for the sulfate volume fraction of mode 11 + bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) +!soa + v_soan part of mode 11 for the OC volume fraction of that mode + boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + +!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5) ! background, SO4(Ait75) mode (5) + ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + Nnatk(icol,k,4)*bebglt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0) ! background, BC(ax) mode (0) +!soa + v_soan part of mode 11 for the OC volume fraction of that mode + ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) + + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) + + Nnatk(icol,k,4)*bebglt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) + + ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & + + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) + ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) + + abs550rh_du(icol,k) = Nnatk(icol,k,6)*babg550(icol,k,6) & + + Nnatk(icol,k,7)*babg550(icol,k,7) + abs550rh_ss(icol,k) = Nnatk(icol,k,8)*babg550(icol,k,8) & + + Nnatk(icol,k,9)*babg550(icol,k,9) & + + Nnatk(icol,k,10)*babg550(icol,k,10) +!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w + + + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*babg550(icol,k,5) ! background, SO4(Ait75) mode (5) + +!soa: *(1-v_soan) for the sulfate volume fraction + babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) + + baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + + abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc(icol,k)*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*babg550(icol,k,0) ! background, BC(ax) mode (0) + + abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) + + v_soana(icol,k)*Nnatk(icol,k,1)*babg550(icol,k,1) & ! SOA fraction of mode 1 + + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) + + deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah + abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah + + ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) + abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) + ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) + abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) + ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) + abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) + + abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) + abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) + abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) + abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) + abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) + + enddo + enddo + + if(irf.eq.1) then + + call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) + call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) + call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable + call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable + call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) + call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) + call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) + call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) + call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) +! Since we do not have enough look-up table info to take abs550rhlt1_aer, +! instead take out abs550rh for each constituent: + call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) + call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) + call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) + call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) + call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) + + elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU + + irh=RF(irf) + + modeString=" " + write(modeString,"(I2)"),irh + if(RF(irf).eq.0) modeString="00" + +!- varName = "EC44RH"//trim(modeString) +!- call outfld(varName,ec440rh_aer(:,:),pcols,lchnk) + varName = "EC55RH"//trim(modeString) + call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) +!- varName = "EC87RH"//trim(modeString) +!- call outfld(varName,ec870rh_aer(:,:),pcols,lchnk) + +!- varName = "AB44RH"//trim(modeString) +!- call outfld(varName,abs440rh_aer(:,:),pcols,lchnk) + varName = "AB55RH"//trim(modeString) + call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) +!- varName = "AB87RH"//trim(modeString) +!- call outfld(varName,abs870rh_aer(:,:),pcols,lchnk) + + end if ! irf + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + + return +end subroutine opticsAtConstRh + diff --git a/src/physics/cam_oslo/optinterpol.F90 b/src/physics/cam_oslo/optinterpol.F90 new file mode 100755 index 0000000000..a9c5d2b254 --- /dev/null +++ b/src/physics/cam_oslo/optinterpol.F90 @@ -0,0 +1,1814 @@ +module optinterpol + +! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. + +! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 +!-------------------------------------------------------------------------------- + +! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. +! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC +! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized +! for for interpolations using common subroutines interpol*dim. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab + use opttab_lw + use commondefinitions, only: nmodes, nbmodes + implicit none + + private + save + + public interpol0 + public interpol1 + public interpol2to3 + public interpol4 + public interpol5to10 + + contains + +!******************************************************************************************** + +subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + logical, intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration +! +! Output arguments +! + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient +! +!---------------------------Local variables----------------------------- +! + integer i, kcomp, k, icol + + + kcomp=0 + + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + +! SW optical parameters + + do k=1,pver + do icol=1,ncol + +! if(Nnatk(icol,k,kcomp)>0.0_r8) then + if(daylight(icol)) then + do i=1,nbands ! i = wavelength index + omega(icol,k,kcomp,i)=om0(i) + gass(icol,k,kcomp,i)=g0(i) + bex(icol,k,kcomp,i)=be0(i) + ske(icol,k,kcomp,i)=ke0(i) + end do ! i + + else ! daylight +! Need be and ke in nband=4 for lw calculation + bex(icol,k,kcomp,4)=be0(4) + ske(icol,k,kcomp,4)=ke0(4) + end if ! daylight + end do ! icol + end do ! k + + if(lw_on) then + +! LW optical parameters + + do k=1,pver + do icol=1,ncol + + do i=1,nlwbands ! i = wavelength index + kabs(icol,k,kcomp,i)=ka0(i) + end do ! i + + end do ! icol + end do ! k + + endif ! lw_on + + return +end subroutine interpol0 + + +!******************************************************************************************** + +subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) +! +! +! Input-Output arguments +! +! +! Output arguments +! + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient +! +!---------------------------Local variables----------------------------- +! + integer i, kcomp, k, icol, kc10 + real(r8) a, b + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & + t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + + +! write(*,*) 'Before kcomp-loop' + do kcomp=1,1 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + +! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + + t_rh1 = rh(t_irh1) +!x t_rh2 = t_rh1+1 + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfombg = xfombg(icol,k) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fombg2-t_xfombg) + dxm1(2) = (t_xfombg-t_fombg1) + invd(2) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + + +! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! single scattering albedo: + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) +!alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! asymmetry factor + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) + +! finally, interpolation in the rh dimension (dim. 1) +! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) +!alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) +!alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) +!alt a=(log(bex2)-log(bex1))*invd(1) +!alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) +!alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + +! if(bex(icol,k,kc10,8)<1.e-20_r8) then +! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) +! endif + else ! daylight + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction used for size information in LW + + i=4 + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + do i=4,4 ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific extinction + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) +!alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) +!alt a=(log(ske2)-log(ske1))*invd(1) +!alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) +!alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + +! LW optical parameters + do i=1,nlwbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific absorption in LW + +! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + +! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30) + kabs2=max(kabs2,1.e-30) + +! write(*,*) 'Before kabs' + if(t_xrh <= 0.37) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + +! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) +! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) +! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) +! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return +end subroutine interpol1 + + +!******************************************************************************************** + +subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) +! +! +! Input-Output arguments +! +! +! Output arguments +! + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient +! +!---------------------------Local variables----------------------------- +! + integer i, kcomp, k, icol, kc10 + real(r8) a, b + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & + t_cat1, t_cat2 + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) opt3d(2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + + +! write(*,*) 'Before kcomp-loop' +! do kcomp=2,3 + do kcomp=2,2 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + +! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + +! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 +! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 +! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 +! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + +! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 +! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + +! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + +! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! single scattering albedo: + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) +! write(*,*) omega(icol,k,kc10,i) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! asymmetry factor + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) +! write(*,*) gass(icol,k,kc10,i) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction used for LW size information + + i=4 +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific extinction + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) + + ske1=max(ske1,1.e-30) + ske2=max(ske2,1.e-30) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before ske' + if(t_xrh <= 0.37) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + +! LW optical parameters + do i=1,nlwbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific absorption in LW + +! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + +! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + +! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + +! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) +! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) +! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) +! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return +end subroutine interpol2to3 + +!******************************************************************************************** + +subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) +! +! Input-Output arguments +! +! +! Output arguments +! + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient +! +!---------------------------Local variables----------------------------- +! + integer i, kcomp, k, kc10, icol + real(r8) a, b + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, & + t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1, & + t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + + real(r8) d2mx(5), dxm1(5), invd(5) + real(r8) opt5d(2,2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + + +! write(*,*) 'Before kcomp-loop' + do kcomp=4,4 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + +! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfbcbg = xfbcbg(icol,k) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + +! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! single scattering albedo: + + opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) +! write(*,*) omega(icol,k,kc10,i) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! asymmetry factor + + opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction called for use in size estimate for use in LW + i=4 + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + + + do i=4,4 ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + +! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + +! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + +! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + +! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) +! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) +! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) +! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) + + end do ! kcomp + + return +end subroutine interpol4 + + +!******************************************************************************************** + +subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & + xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + + +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) +! +! +! Input-Output arguments +! +! +! Output arguments +! + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient +! +!---------------------------Local variables----------------------------- +! + integer i, kcomp, k, icol + real(r8) a, b + +! Temporary storage of often used array elements + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, & + t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1, & + t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) d2mx(5), dxm1(5), invd(5) + real(r8) opt5d(2,2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + + +! write(*,*) 'Before kcomp-loop' + do kcomp=5,10 + +! write(*,*) 'Before init-loop', kcomp + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + +! Collect all the vector elements into temporary storage +! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + +! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + +! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! single scattering albedo: + + opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before omega' + omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) +! write(*,*) omega(icol,k,kcomp,i) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! asymmetry factor + + opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before gass' + gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction + + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol extinction used for aerosol size estimate needed for LW calculations + i=4 + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + +! finally, interpolation in the rh dimension +! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + +! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + +! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + +! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + + + end do ! kcomp + + return +end subroutine interpol5to10 + + +!******************************************************************************************** + + +end module optinterpol diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 new file mode 100644 index 0000000000..094695d8c1 --- /dev/null +++ b/src/physics/cam_oslo/opttab.F90 @@ -0,0 +1,661 @@ +module opttab + +!Purpose: To read in SW look-up tables for calculation of aerosol optical properties, +! and to define the grid for discrete input-values in these look-up tables. + +! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. +! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. +! Extended for new SOA treatment - Alf Kirkevaag, August 2015. +! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction +! koefficients (wrt. all added mass including condensed water vapour) are +! written out for checking against the look-up tables (using xmgrace), e.g. +! as function of RH (to be changed to whatever parameter the user is interested in) +! Modified for optimized added masses and mass fractions for concentrations from +! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. +! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. + +#include + + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_logfile, only: iulog + implicit none + + private + save + + + ! Interfaces + public initopt + + +! integer, public, parameter :: nbands=12 ! number of aerosol spectral bands in CAM4-Oslo + integer, public, parameter :: nbands=14 ! number of aerosol spectral bands in SW + integer, public, parameter :: nbmp1=11 ! number of first non-background mode + + real(r8), public, dimension(10) :: rh + real(r8), public, dimension(6) :: fombg, fbcbg, fac, fbc, faq + real(r8), public, dimension(4,16) :: cate + real(r8), public, dimension(5:10,6) :: cat + + real(r8), public :: om1(nbands,10,6,16,6) + real(r8), public :: g1 (nbands,10,6,16,6) + real(r8), public :: be1(nbands,10,6,16,6) + real(r8), public :: ke1(nbands,10,6,16,6) + + real(r8), public :: om2to3(nbands,10,16,6,2:3) + real(r8), public :: g2to3 (nbands,10,16,6,2:3) + real(r8), public :: be2to3(nbands,10,16,6,2:3) + real(r8), public :: ke2to3(nbands,10,16,6,2:3) + + real(r8), public :: om4(nbands,10,6,16,6,6) + real(r8), public :: g4 (nbands,10,6,16,6,6) + real(r8), public :: be4(nbands,10,6,16,6,6) + real(r8), public :: ke4(nbands,10,6,16,6,6) + + real(r8), public :: om0(nbands) + real(r8), public :: g0(nbands) + real(r8), public :: be0(nbands) + real(r8), public :: ke0(nbands) + + real(r8), public :: om5to10(nbands,10,6,6,6,6,5:10) + real(r8), public :: g5to10(nbands,10,6,6,6,6,5:10) + real(r8), public :: be5to10(nbands,10,6,6,6,6,5:10) + real(r8), public :: ke5to10(nbands,10,6,6,6,6,5:10) + +! relative humidity (RH, as integer for output variable names) for use in AeroCom code + integer, public, dimension(6) :: RF = (/0, 40, 55, 65, 75, 85 /) + +! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + integer, public :: irhrf1(6) + real(r8), public :: xrhrf(6) + + real(r8), public :: e, eps + parameter (e=2.718281828_r8, eps=1.0e-30_r8) + + + contains + +subroutine initopt + +!--------------------------------------------------------------- +! Modified by Egil Storen/NoSerC July 2002. +! The sequence of the indices in arrays om1, g1, be1 and ke1 +! (common block /tab1/) has been rearranged to avoid cache +! problems while running subroutine interpol1. Files also +! involved by this modification: interpol1.F and opttab.h. +! Modified for new aerosol schemes by Alf Kirkevaag in January +! 2006. Modified for new wavelength bands and look-up tables +! by Alf Kirkevaag in December 2013, and for SOA in August 2015. +!--------------------------------------------------------------- + + use oslo_control, only : oslo_getopts, dir_string_length + + implicit none + + integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq, i, irf + integer ifombg, ifbcbg + integer ik, ic, ifil, lin, linmax + real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg + real(r8) ssa, ass, ext, spext + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps3 = 1.e-3_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + character(len=dir_string_length) :: aerotab_table_dir + +! Defining array bounds for tabulated optical parameters (and r and sigma) +! relative humidity (only 0 value used for r and sigma tables): + rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) + +! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + do irf=1,6 + xrhrf(irf) = real(RF(irf))*0.01_r8 + enddo + do irelh=1,9 + do irf=1,6 + if(xrhrf(irf)>=rh(irelh).and.xrhrf(irf)<=rh(irelh+1)) then + irhrf1(irf)=irelh + endif + end do + end do + +! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the +! background modes (fac, faq, faq) + fombg = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + fac = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + faq = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + +! with more weight on low fractions (thus a logaritmic f axis) for BC, +! which is less ambundant than sulfate and OC, and the first value +! corresponding to a clean background mode: + fbcbg(1)=1.e-10_r8 + fbc(1)=1.e-10_r8 + do i=2,6 + fbcbg(i)=10**((i-1)/4.0_r8-1.25_r8) + fbc(i)=fbcbg(i) + end do +! and most weight on small concentrations for added mass onto the background: + do kcomp=1,4 + cate(kcomp,1)=1.e-10_r8 + do i=2,16 + if(kcomp.eq.1.or.kcomp.eq.2) then + cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-6.222_r8) + elseif(kcomp.eq.3) then + cate(kcomp,i)=1.0e-10_r8 ! not used + else + cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-4.301_r8) + endif + end do + end do + do kcomp=5,10 + cat(kcomp,1) =1.e-10_r8 + do i=2,6 + if(kcomp.eq.5) then + cat(kcomp,i)=10.0_r8**((i-1)-3.824_r8) + elseif(kcomp.eq.6) then + cat(kcomp,i)=10.0_r8**((i-1)-3.523_r8) + elseif(kcomp.eq.7) then + cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) + elseif(kcomp.eq.8) then + cat(kcomp,i)=10.0_r8**((i-1)-4.921_r8) + elseif(kcomp.eq.9) then + cat(kcomp,i)=10.0_r8**((i-1)-3.301_r8) + else + cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) + endif + end do + end do + + call oslo_getopts(aerotab_table_dir_out= aerotab_table_dir) + +! Opening the 'kcomp'-files: + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + open(40,file=trim(aerotab_table_dir)//'/kcomp1.out' & + ,form='formatted',status='old') + open(41,file=trim(aerotab_table_dir)//'/kcomp2.out' & + ,form='formatted',status='old') + open(42,file=trim(aerotab_table_dir)//'/kcomp3.out' & + ,form='formatted',status='old') + open(43,file=trim(aerotab_table_dir)//'/kcomp4.out' & + ,form='formatted',status='old') + open(44,file=trim(aerotab_table_dir)//'/kcomp5.out' & + ,form='formatted',status='old') + open(45,file=trim(aerotab_table_dir)//'/kcomp6.out' & + ,form='formatted',status='old') + open(46,file=trim(aerotab_table_dir)//'/kcomp7.out' & + ,form='formatted',status='old') + open(47,file=trim(aerotab_table_dir)//'/kcomp8.out' & + ,form='formatted',status='old') + open(48,file=trim(aerotab_table_dir)//'/kcomp9.out' & + ,form='formatted',status='old') + open(49,file=trim(aerotab_table_dir)//'/kcomp10.out'& + ,form='formatted',status='old') + open(50,file=trim(aerotab_table_dir)//'/kcomp0.out'& + ,form='formatted',status='old') + +! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 40,50 + call checkTableHeader (ifil) + enddo + +! Then reading in the look-up table entries for each file (kcomp*.out) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 0, BC(ax) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + linmax=nbands + do lin = 1,linmax + + read(39+ifil,996) kcomp, iwl, relh, & + ssa, ass, ext, spext + om0(iwl)=ssa + g0 (iwl)=ass + be0(iwl)=ext ! unit km^-1 + ke0(iwl)=spext ! unit m^2/g + +! write(iulog,*) 'kcomp, om =', kcomp, om0(iwl) +! write(iulog,*) 'kcomp, g =', kcomp, g0(iwl) +! write(iulog,*) 'kcomp, be =', kcomp, be0(iwl) +! write(iulog,*) 'kcomp, ke =', kcomp, ke0(iwl) + + end do + + do iwl=1,nbands + if(be0(iwl)<=0.0_r8) then + write(iulog,*) 'be0 =', iwl, be0(iwl) + write(iulog,*) 'Error in initialization of be0' + stop + endif + enddo + + write(iulog,*)'mode 0 ok' + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 1 (H2SO4 and SOA + condesate from H2SO4 and SOA) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + +#ifdef COLTST4INTCONS +! open(101, file='check-kcomp1.out') +#endif + + linmax = nbands*10*6*16*6 ! 14*10*6*16*6 + do ifil = 1,1 + do lin = 1,linmax + + read(39+ifil,995) kcomp, iwl, relh, frombg, catot, frac, & + ssa, ass, ext, spext + + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 + use cam_logfile, only: iulog + use opttab + implicit none + + private + save + + + ! Interfaces + public initopt_lw + + +! Array bounds in the tabulated optical parameters + integer, public, parameter :: nlwbands=16 ! number of aerosol spectral bands in LW + + real(r8), public :: ka0(nlwbands) + real(r8), public :: ka1(nlwbands,10,6,16,6) + real(r8), public :: ka2to3(nlwbands,10,16,6,2:3) + real(r8), public :: ka4(nlwbands,10,6,16,6,6) + real(r8), public :: ka5to10(nlwbands,10,6,6,6,6,5:10) + + + contains + +subroutine initopt_lw + +!--------------------------------------------------------------- +! Modified by Egil Storen/NoSerC July 2002. +! The sequence of the indices in arrays om1, g1, be1 and ke1 +! (common block /tab1/) has been rearranged to avoid cache +! problems while running subroutine interpol1. Files also +! involved by this modification: interpol1.F and opttab.h. +! Modified for new aerosol schemes by Alf Kirkevaag in January +! 2006. Based on opttab.F90 and modified for new wavelength +! bands and look-up tables by Alf Kirkevaag in January 2014, +! and for SOA in August 2015. +!--------------------------------------------------------------- + + use oslo_control, only: oslo_getopts, dir_string_length + + +! implicit none + + integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq + integer ifombg, ifbcbg + integer ic, ifil, lin, linmax + real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg + real(r8) spabs + real(r8) rh2(10) + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps3 = 1.e-3_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + +! Opening the 'lwkcomp'-files: + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' & + ,form="formatted",status="old") + open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' & + ,form="formatted",status="old") + open(42,file=trim(aerotab_table_dir)//'/lwkcomp3.out' & + ,form="formatted",status="old") + open(43,file=trim(aerotab_table_dir)//'/lwkcomp4.out' & + ,form="formatted",status="old") + open(44,file=trim(aerotab_table_dir)//'/lwkcomp5.out' & + ,form="formatted",status="old") + open(45,file=trim(aerotab_table_dir)//'/lwkcomp6.out' & + ,form="formatted",status="old") + open(46,file=trim(aerotab_table_dir)//'/lwkcomp7.out' & + ,form="formatted",status="old") + open(47,file=trim(aerotab_table_dir)//'/lwkcomp8.out' & + ,form="formatted",status="old") + open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' & + ,form="formatted",status="old") + open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& + ,form="formatted",status="old") + open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& + ,form="formatted",status="old") + +! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 40,50 + call checkTableHeader (ifil) + enddo + +! Then reading in the look-up table entries for each file (lwkcomp*.out) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 0, BC(ax) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + linmax=nlwbands + do lin = 1,linmax + + read(39+ifil,996) kcomp, iwl, relh, spabs + + ka0(iwl)=spabs ! unit m^2/g + +! write(*,*) 'kcomp, ka =', kcomp, ka0(iwl) + + end do + + do iwl=1,nlwbands + if(ka0(iwl)<=0.0_r8) then + write(iulog,*) 'ka0 =', iwl, ka0(iwl) + write(iulog,*) 'Error in initialization of ka0' + stop + endif + enddo + + write(iulog,*)'lw mode 0 ok' + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Mode 1 (H2SO4 + condesate from H2SO4 and SOA) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 1 + linmax=nlwbands*10*6*16*6 + do lin = 1,linmax + + read(39+ifil,997) kcomp, iwl, relh, frombg, catot, frac, spabs + + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 +use cam_cpl_indices, only:index_x2a_Faoo_fdms_ocn + +implicit none +private +save + +public :: & + oslo_ctl_readnl, &! read namelist from file + oslo_getopts ! generic query method + +! Private module data + +integer, parameter,public :: dir_string_length=256 +character(len=16), parameter :: unset_str = 'UNSET' +integer, parameter :: unset_int = huge(1) + +! Namelist variables: +real(r8), private :: volc_fraction_coarse = 0.0_r8 !Fraction of volcanic aerosols in coarse mode +character(len=dir_string_length), private :: aerotab_table_dir = unset_str +! DMS/Ocean namelist variables +character(len=20), private :: dms_source = unset_str +character(len=32), private :: dms_source_type = unset_str +character(len=20), private :: opom_source = unset_str +character(len=32), private :: opom_source_type = unset_str +character(len=dir_string_length), private :: ocean_filename = unset_str +character(len=dir_string_length), private :: ocean_filepath = unset_str +integer, private :: dms_cycle_year = 0 ! =unset_int? +integer, private :: opom_cycle_year = 0 ! =unset_int? + +!======================================================================= +contains +!======================================================================= + +subroutine oslo_ctl_readnl(nlfile) + + 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 + character(len=*), parameter :: subname = 'oslo_ctl_readnl' + logical :: dirExists=.FALSE. +!new + logical :: fileExists=.FALSE. + + namelist /oslo_ctl_nl/ volc_fraction_coarse, aerotab_table_dir, dms_source, & + dms_source_type, opom_source, opom_source_type, & + ocean_filename, ocean_filepath, dms_cycle_year, opom_cycle_year + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'oslo_ctl_nl', status=ierr) + if (ierr == 0) then + read(unitn, oslo_ctl_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 + ! Broadcast namelist variables + call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) + call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) +!new dms variables + call mpibcast(dms_source, len(dms_source) , mpichar, 0, mpicom) + call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) + call mpibcast(opom_source, len(opom_source) , mpichar, 0, mpicom) + call mpibcast(opom_source_type, len(opom_source_type) , mpichar, 0, mpicom) + call mpibcast(ocean_filename, len(ocean_filename) , mpichar, 0, mpicom) + call mpibcast(ocean_filepath, len(ocean_filepath) , mpichar, 0, mpicom) + call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) + call mpibcast(opom_cycle_year, 1 , mpiint, 0, mpicom) + +#endif + + ! Error checking: + + ! Defaults for PBL and microphysics are set in build-namelist. Check here that + ! values have been set to guard against problems with hand edited namelists. + if(volc_fraction_coarse .lt. 0.0_r8 .OR. volc_fraction_coarse .gt. 1.0_r8)then + write(iulog,*)'cam_oslo: illegal value of volc_fraction_coarse', volc_fraction_coarse + call endrun('cam_oslo: illegal value of volc_fraction_coarse') + end if + +#if defined CPRGNU || defined __GFORTRAN__ + inquire( file=trim(aerotab_table_dir), exist=dirExists ) +#elif defined CPRINTEL + inquire( directory=trim(aerotab_table_dir), exist=dirExists ) +#else + !Don't know how to check this on other compilres.. Assume exists + !and let crash later.. + dirExists = .TRUE. +#endif + if(.not. dirExists)then + call endrun("cam_oslo: can not find aerotab table directory "//trim(aerotab_table_dir)) + else + write(iulog,*)"Reading aerosol tables from : " // trim(aerotab_table_dir) + endif + + ! Error check for OCEAN file + ! can ocean file be found? + inquire( file=trim(ocean_filepath)//'/'//trim(ocean_filename), exist=fileExists ) + if(.not. fileExists)then + call endrun("oslo_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) + else + write(iulog,*)"Reading ocean tracers from : " // trim(ocean_filepath)//'/'//trim(ocean_filename) + endif + + ! Error check for dms_source from namelist + if (dms_source=='ocean_flux')then + if (index_x2a_Faoo_fdms_ocn == 0) then + call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") + else + write(iulog,*)"DMS emission source is : "// trim(dms_source) + endif + elseif(dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then + write(iulog,*)"DMS emission source is : "// trim(dms_source) + else + call endrun("oslo_control: no valid dms source from namelist: " //trim(dms_source)) + endif + + ! Error check for opom_source from namelist + if(opom_source=='no_file' .or. opom_source=='nilsson' .or. opom_source=='odowd')then + write(iulog,*)"Ocean POM emission source is : "// trim(opom_source) + else + call endrun("oslo_control: no valid opom source from namelist: " //trim(opom_source)) + endif + + + +! more security checks needed? + +! end of test + +end subroutine oslo_ctl_readnl + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +subroutine oslo_getopts(volc_fraction_coarse_out, & + aerotab_table_dir_out, & + dms_source_out, & + dms_source_type_out, & + opom_source_out, & + opom_source_type_out, & + ocean_filename_out, & + ocean_filepath_out, & + opom_cycle_year_out, & + dms_cycle_year_out ) +!----------------------------------------------------------------------- +! Purpose: Return runtime settings +!----------------------------------------------------------------------- + + real(r8), intent(out), optional :: volc_fraction_coarse_out + character(len=dir_string_length), intent(out), optional :: aerotab_table_dir_out + + character(len=dir_string_length), intent(out), optional :: ocean_filename_out + character(len=dir_string_length), intent(out), optional :: ocean_filepath_out + character(len=20), intent(out), optional :: dms_source_out + character(len=32), intent(out), optional :: dms_source_type_out + integer , intent(out), optional :: dms_cycle_year_out + character(len=20), intent(out), optional :: opom_source_out + character(len=32), intent(out), optional :: opom_source_type_out + integer , intent(out), optional :: opom_cycle_year_out + + if ( present(volc_fraction_coarse_out) ) volc_fraction_coarse_out = volc_fraction_coarse + if ( present(aerotab_table_dir_out) ) aerotab_table_dir_out = aerotab_table_dir + + if ( present(ocean_filename_out) ) ocean_filename_out = ocean_filename + if ( present(ocean_filepath_out) ) ocean_filepath_out = ocean_filepath + if ( present(dms_source_out) ) dms_source_out = dms_source + if ( present(dms_source_type_out) )dms_source_type_out = dms_source_type + if ( present(dms_cycle_year_out) ) dms_cycle_year_out = dms_cycle_year + if ( present(opom_source_out) ) opom_source_out = opom_source + if ( present(opom_source_type_out))opom_source_type_out= opom_source_type + if ( present(opom_cycle_year_out) )opom_cycle_year_out = opom_cycle_year +end subroutine oslo_getopts + +!=============================================================================== +end module oslo_control diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/physics/cam_oslo/pmxsub.F90 new file mode 100644 index 0000000000..58687750cb --- /dev/null +++ b/src/physics/cam_oslo/pmxsub.F90 @@ -0,0 +1,2500 @@ +module pmxsub_mod + +#include + +!=============================================================================== +contains +!=============================================================================== + +subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & +#ifdef AEROCOM + aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) +#else + aodvis, absvis) +#endif + +! Optical parameters for a composite aerosol is calculated by interpolation +! from the tables kcomp1.out-kcomp14.out. +! Optimized June 2002 byrild Burud/NoSerC +! Optimized July 2002 by Egil Storen/NoSerC (ces) +! Revised for inclusion of OC and modified aerosol backgeound aerosol +! by Alf Kirkevaag in 2003, and finally rewritten for CAM3 February 2005. +! Modified for new aerosol schemes by Alf Kirkevaag in January 2006. +! Updated by Alf Kirkevåg, May 2013: The SO4(Ait) mode now takes into +! account condensed SOA in addition to H2SO4. +! Updated for CAM5-Oslo with RRTMG by Alf Kirkevåg, 2014-2015, for new +! SOA treatment August/September 2015, and for cleanig up and optimizing +! the code around interpolations in November 2016. + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use physconst, only: rair,pi + use opttab + use oslo_utils, only: calculateNumberConcentration + use parmix_progncdnc, only: calculateBulkProperties, partitionMass + use opttab_lw + use const + use aerosoldef + use commondefinitions + use optinterpol, only: interpol0,interpol1,interpol2to3,interpol4,interpol5to10 + use physics_types, only: physics_state + use wv_saturation, only: qsat_water + + implicit none + +! +! Input arguments + + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) + real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures (K) + real(r8), intent(in) :: cld(pcols,pver) ! cloud fraction + real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) + real(r8), intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8), intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8), intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8), intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8), intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 +! real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) ! for testing bare +! +! Input-output arguments + + real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes)! aerosol mode number concentration + +! Output arguments +! + real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth + real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau + real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau + real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) +! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) +! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8), intent(out) :: aodvis(pcols) ! AOD vis + real(r8), intent(out) :: absvis(pcols) ! AAOD vis + +! +!---------------------------Local variables----------------------------- +! + integer i, k, ib, icol, mplus10 + integer iloop + logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. + + real(r8) aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol + real(r8) absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol +!akc6+ + real(r8) bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol +!akc6- + real(r8) rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations +!tst +! real(r8) aodvis3d(pcols,pver) ! 3D AOD in VIS +!tst + + real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km + +!akc6 real(r8) deltah, airmass(pcols,pver) + real(r8) deltah, airmassl(pcols,pver), airmass(pcols) !akc6 + real(r8) Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) + real(r8) fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver), & + f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc + real(r8) v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) + real(r8) dCtot(pcols,pver), Ctot(pcols,pver) + real(r8) Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes), & + faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes), & + f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) + real(r8) xrh(pcols,pver), xrhnull(pcols,pver) + integer irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) + real(r8) focm(pcols,pver,4) +! real(r8) akso4c(pcols), akbcc(pcols), akocc(pcols) + real(r8) ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands), & + be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands), & + betotvis(pcols,pver), batotvis(pcols,pver) + real(r8) ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo + real(r8) asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor + real(r8) betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient + real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) kalw(pcols,pver,0:nmodes,nlwbands) + real(r8) balw(pcols,pver,0:nmodes,nlwbands) + logical lw_on ! LW calculations are performed in interpol* if true + real(r8) volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 + +#ifdef COLTST4INTCONS +!-3 real(r8) bekc1(pcols,pver), bekc2(pcols,pver), bekc3(pcols,pver), bekc4(pcols,pver), & + real(r8) bekc1(pcols,pver), bekc2(pcols,pver), bekc4(pcols,pver), & + bekc5(pcols,pver), bekc6(pcols,pver), bekc7(pcols,pver), bekc8(pcols,pver), & +!-11 bekc9(pcols,pver), bekc10(pcols,pver), bekc11(pcols,pver), & + bekc9(pcols,pver), bekc10(pcols,pver), & +!-13 bekc12(pcols,pver), bekc13(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) + bekc12(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) + real(r8) taukc1(pcols), taukc2(pcols), taukc3(pcols), taukc4(pcols), taukc5(pcols), & + taukc6(pcols), taukc7(pcols), taukc8(pcols), taukc9(pcols), taukc10(pcols), & + taukc11(pcols), taukc12(pcols), taukc13(pcols), taukc14(pcols), taukc0(pcols) + real(r8) kekc1(pcols,pver), kekc2(pcols,pver), kekc4(pcols,pver), & + kekc5(pcols,pver), kekc6(pcols,pver), kekc7(pcols,pver), kekc8(pcols,pver), & + kekc9(pcols,pver), kekc10(pcols,pver), & + kekc12(pcols,pver), kekc14(pcols,pver), kekc0(pcols,pver) +#ifdef AEROCOM + real(r8) cmodedry(pcols,pver,0:nmodes), & + cmdry0(pcols), cmdry1(pcols), cmdry2(pcols), cmdry4(pcols), & + cmdry5(pcols), cmdry6(pcols), cmdry7(pcols), cmdry8(pcols), & + cmdry9(pcols), cmdry10(pcols), cmdry12(pcols), cmdry14(pcols) +#endif +#endif + real(r8) rh0(pcols,pver), rhoda(pcols,pver) + real(r8) ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) + real(r8) n_aerorig(pcols,pver), n_aer(pcols,pver) + type(physics_state), intent(in), target :: state + real(r8) :: es(pcols,pver) ! saturation vapor pressure + real(r8) :: qs(pcols,pver) ! saturation specific humidity + real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) + real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT + real(r8) xfombg(pcols,pver) + integer ifombg1(pcols,pver), ifombg2(pcols,pver) + real(r8) xct(pcols,pver,nmodes) + integer ict1(pcols,pver,nmodes) + real(r8) xfac(pcols,pver,nbmodes) + integer ifac1(pcols,pver,nbmodes) + real(r8) xfbc(pcols,pver,nbmodes) + integer ifbc1(pcols,pver,nbmodes) + real(r8) xfaq(pcols,pver,nbmodes) + integer ifaq1(pcols,pver,nbmodes) + real(r8) xfbcbg(pcols,pver) + integer ifbcbg1(pcols,pver) + real(r8) xfbcbgn(pcols,pver) + integer ifbcbgn1(pcols,pver) + +#ifdef AEROCOM + real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & + dod550dry(pcols), abs550dry(pcols) + real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & + dload_mi(pcols), dload_ss(pcols), & + dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & + dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) + real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & + dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & + dload_oc_4(pcols), dload_oc_14(pcols) + real(r8) cmin(pcols,pver), cseas(pcols,pver) + real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & + nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & + nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & + nnat_10(pcols,pver), nnat_12(pcols,pver), & + nnat_14(pcols,pver), nnat_0(pcols,pver) + real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & + cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) + real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) + real(r8) cintbg(pcols,pver,0:nbmodes), & + cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), & + cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), & + cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), & + cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), & + cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) + real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & + c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & + c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & + c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & + c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & + c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & + c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & + c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) + real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & + c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & + c_oc_4(pcols,pver), c_oc_14(pcols,pver) + real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) +!akc6+ + real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & + mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) +!akc6- + real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & + vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & + vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & + erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) + real(r8) bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & + bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & + bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & + bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & + bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & + bebg440(pcols,pver,0:nbmodes), babg440(pcols,pver,0:nbmodes), & + bebg500(pcols,pver,0:nbmodes), babg500(pcols,pver,0:nbmodes), & + bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & + bebg670(pcols,pver,0:nbmodes), babg670(pcols,pver,0:nbmodes), & + bebg870(pcols,pver,0:nbmodes), babg870(pcols,pver,0:nbmodes), & + bebc440(pcols,pver,0:nbmodes), babc440(pcols,pver,0:nbmodes), & + bebc500(pcols,pver,0:nbmodes), babc500(pcols,pver,0:nbmodes), & + bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & + bebc670(pcols,pver,0:nbmodes), babc670(pcols,pver,0:nbmodes), & + bebc870(pcols,pver,0:nbmodes), babc870(pcols,pver,0:nbmodes), & + beoc440(pcols,pver,0:nbmodes), baoc440(pcols,pver,0:nbmodes), & + beoc500(pcols,pver,0:nbmodes), baoc500(pcols,pver,0:nbmodes), & + beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & + beoc670(pcols,pver,0:nbmodes), baoc670(pcols,pver,0:nbmodes), & + beoc870(pcols,pver,0:nbmodes), baoc870(pcols,pver,0:nbmodes), & + besu440(pcols,pver,0:nbmodes), basu440(pcols,pver,0:nbmodes), & + besu500(pcols,pver,0:nbmodes), basu500(pcols,pver,0:nbmodes), & + besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & + besu670(pcols,pver,0:nbmodes), basu670(pcols,pver,0:nbmodes), & + besu870(pcols,pver,0:nbmodes), basu870(pcols,pver,0:nbmodes) + real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & + bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & + beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & + bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & + backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & + bs550_aer(pcols,pver) +! Additional AeroCom Phase III output: + real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band +! + real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & + ec550_ss(pcols,pver), ec550_du(pcols,pver) + real(r8) bext440n(pcols,pver,0:nbmodes), babs440n(pcols,pver,0:nbmodes), & + bext500n(pcols,pver,0:nbmodes), babs500n(pcols,pver,0:nbmodes), & + bext550n(pcols,pver,0:nbmodes), babs550n(pcols,pver,0:nbmodes), & + bext670n(pcols,pver,0:nbmodes), babs670n(pcols,pver,0:nbmodes), & + bext870n(pcols,pver,0:nbmodes), babs870n(pcols,pver,0:nbmodes), & + bebg440n(pcols,pver,0:nbmodes), babg440n(pcols,pver,0:nbmodes), & + bebg500n(pcols,pver,0:nbmodes), babg500n(pcols,pver,0:nbmodes), & + bebg550n(pcols,pver,0:nbmodes), babg550n(pcols,pver,0:nbmodes), & + bebg670n(pcols,pver,0:nbmodes), babg670n(pcols,pver,0:nbmodes), & + bebg870n(pcols,pver,0:nbmodes), babg870n(pcols,pver,0:nbmodes), & + bebc440n(pcols,pver,0:nbmodes), babc440n(pcols,pver,0:nbmodes), & + bebc500n(pcols,pver,0:nbmodes), babc500n(pcols,pver,0:nbmodes), & + bebc550n(pcols,pver,0:nbmodes), babc550n(pcols,pver,0:nbmodes), & + bebc670n(pcols,pver,0:nbmodes), babc670n(pcols,pver,0:nbmodes), & + bebc870n(pcols,pver,0:nbmodes), babc870n(pcols,pver,0:nbmodes), & + beoc440n(pcols,pver,0:nbmodes), baoc440n(pcols,pver,0:nbmodes), & + beoc500n(pcols,pver,0:nbmodes), baoc500n(pcols,pver,0:nbmodes), & + beoc550n(pcols,pver,0:nbmodes), baoc550n(pcols,pver,0:nbmodes), & + beoc670n(pcols,pver,0:nbmodes), baoc670n(pcols,pver,0:nbmodes), & + beoc870n(pcols,pver,0:nbmodes), baoc870n(pcols,pver,0:nbmodes), & + besu440n(pcols,pver,0:nbmodes), basu440n(pcols,pver,0:nbmodes), & + besu500n(pcols,pver,0:nbmodes), basu500n(pcols,pver,0:nbmodes), & + besu550n(pcols,pver,0:nbmodes), basu550n(pcols,pver,0:nbmodes), & + besu670n(pcols,pver,0:nbmodes), basu670n(pcols,pver,0:nbmodes), & + besu870n(pcols,pver,0:nbmodes), basu870n(pcols,pver,0:nbmodes) + real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) + real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & + bext500tot(pcols,pver), babs500tot(pcols,pver), & + bext550tot(pcols,pver), babs550tot(pcols,pver), & + bext670tot(pcols,pver), babs670tot(pcols,pver), & + bext870tot(pcols,pver), babs870tot(pcols,pver), & + bebg440tot(pcols,pver), babg440tot(pcols,pver), & + bebg500tot(pcols,pver), babg500tot(pcols,pver), & + bebg550tot(pcols,pver), babg550tot(pcols,pver), & + bebg670tot(pcols,pver), babg670tot(pcols,pver), & + bebg870tot(pcols,pver), babg870tot(pcols,pver), & + bebc440tot(pcols,pver), babc440tot(pcols,pver), & + bebc500tot(pcols,pver), babc500tot(pcols,pver), & + bebc550tot(pcols,pver), babc550tot(pcols,pver), & + bebc670tot(pcols,pver), babc670tot(pcols,pver), & + bebc870tot(pcols,pver), babc870tot(pcols,pver), & + beoc440tot(pcols,pver), baoc440tot(pcols,pver), & + beoc500tot(pcols,pver), baoc500tot(pcols,pver), & + beoc550tot(pcols,pver), baoc550tot(pcols,pver), & + beoc670tot(pcols,pver), baoc670tot(pcols,pver), & + beoc870tot(pcols,pver), baoc870tot(pcols,pver), & + besu440tot(pcols,pver), basu440tot(pcols,pver), & + besu500tot(pcols,pver), basu500tot(pcols,pver), & + besu550tot(pcols,pver), basu550tot(pcols,pver), & + besu670tot(pcols,pver), basu670tot(pcols,pver), & + besu870tot(pcols,pver), basu870tot(pcols,pver) + real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & + bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & + bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) + real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & + be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & + be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & + be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & + be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & + belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) + real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & + bebc500xt(pcols,pver),babc500xt(pcols,pver), & + bebc550xt(pcols,pver),babc550xt(pcols,pver), & + bebc670xt(pcols,pver),babc670xt(pcols,pver), & + bebc870xt(pcols,pver),babc870xt(pcols,pver), & + beoc440xt(pcols,pver),baoc440xt(pcols,pver), & + beoc500xt(pcols,pver),baoc500xt(pcols,pver), & + beoc550xt(pcols,pver),baoc550xt(pcols,pver), & + beoc670xt(pcols,pver),baoc670xt(pcols,pver), & + beoc870xt(pcols,pver),baoc870xt(pcols,pver) + real(r8) bbclt1xt(pcols,pver), & + bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & + bint670du(pcols,pver), bint870du(pcols,pver), & + bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & + bint670ss(pcols,pver), bint870ss(pcols,pver), & + baint550du(pcols,pver), baint550ss(pcols,pver) + real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & + besslt1(pcols,pver), bessgt1(pcols,pver) + real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & + dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & + dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & + dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & + dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & + dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & + dod5003d(pcols,pver), abs5003d(pcols,pver), & + dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & + dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & + dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & + dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & + dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & + dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & + dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & + dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & + dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & + dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & + dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & + dod6703d(pcols,pver), abs6703d(pcols,pver), & + dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & + dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & + dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & + dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & + dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & + dod8703d(pcols,pver), abs8703d(pcols,pver), & + dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & + dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & + dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & + dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & + dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & + dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & + dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & + dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & + dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) + real(r8) dod440(pcols), abs440(pcols), dod500(pcols), abs500(pcols), & + dod550(pcols), abs550(pcols), abs550alt(pcols), dod670(pcols),& + abs670(pcols), dod870(pcols), abs870(pcols), & + dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & + dod440_bc(pcols), dod440_pom(pcols), & + dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & + dod500_bc(pcols), dod500_pom(pcols), & + dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & + dod550_bc(pcols), dod550_pom(pcols), & + dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & + dod670_bc(pcols), dod670_pom(pcols), & + dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & + dod870_bc(pcols), dod870_pom(pcols), & + dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & + dod550gt1_dust(pcols), dod550lt1_so4(pcols), & + dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & + dod550lt1_pom(pcols), dod550gt1_pom(pcols) + real(r8) abs550_ss(pcols), abs550_dust(pcols), & + abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) + real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) +#endif ! AEROCOM +!+ +#ifdef AEROCOM + character(len=10) :: modeString + character(len=20) :: varname + integer irf,irfmax + real(r8) Camrel(pcols,pver,nbmodes) + real(r8) Camtot(pcols,nbmodes) + real(r8) cxsmtot(pcols,nbmodes) + real(r8) cxsmrel(pcols,nbmodes) + real(r8) xctrel,camdiff,cxsm + real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) +#endif +!- + +! +!------------------------------------------------------------------------- +! + +!test: hentet fra aer_rad_props, saa modifisert/rettet (!x) + ! calculate relative humidity for table lookup into rh grid +!x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & + call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & + es(1:ncol,1:pver), qs(1:ncol,1:pver)) + rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) + rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) + + + do k=1,pver + do icol=1,ncol +! Set upper and lower relative humidity for the aerosol calculations + rhum(icol,k) = min(0.995_r8, max(rh_temp(icol,k), 0.01_r8)) + rhoda(icol,k) = pmid(icol,k)/(rair*t(icol,k)) ! unit kg/m^3 +!test rhum(icol,k) = 0.01_r8 + if (cld(icol,k) .lt. 1.0_r8) then + rhum(icol,k) = (rhum(icol,k) - cld(icol,k)) / (1.0_r8 - cld(icol,k)) ! clear portion + end if + rhum(icol,k) = min(0.995_r8, max(rhum(icol,k), 0.01_r8)) + end do + end do + +! Layer thickness with unit km + do icol=1,ncol + do k=1,pver + deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + end do + end do + +! interpol-calculations only when daylight or not: +#ifdef AEROCOM ! always calculate optics (also at (polar) night) + do icol=1,ncol + daylight(icol) = .true. + end do +#else ! calculate optics only in daytime + do icol=1,ncol + if (coszrs(icol) > 0.0_r8) then + daylight(icol) = .true. + else + daylight(icol) = .false. + endif + end do +#endif ! AEROCOM + +! Set SO4, BC and OC concentrations: + +! initialize concentration fields + do i=0,nmodes + do k=1,pver + do icol=1,ncol + Nnatk(icol,k,i) = 0.0_r8 + end do + end do + end do + do k=1,pver + do icol=1,ncol + n_aerorig(icol,k) = 0.0_r8 + n_aer(icol,k) = 0.0_r8 + end do + end do + kalw(:,:,:,:)=0._r8 + be(:,:,:,:)=0._r8 + ke(:,:,:,:)=0._r8 + asym(:,:,:,:)=0._r8 + ssa(:,:,:,:)=0._r8 +! Find process tagged bulk aerosol properies (from the life cycle module): + + call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & + f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) + +! calculating vulume fractions from mass fractions: + do k=1,pver + do icol=1,ncol + v_soana(icol,k) = f_soana(icol,k)/(f_soana(icol,k) & + +(1.0_r8-f_soana(icol,k))*rhopart(l_soa_na)/rhopart(l_so4_na)) + end do + end do + +! Avoid very small numbers + do k=1,pver + do icol=1,ncol + Ca(icol,k) = max(eps,Ca(icol,k)) + f_c(icol,k) = max(eps,f_c(icol,k)) + f_bc(icol,k) = max(eps,f_bc(icol,k)) + f_aq(icol,k) = max(eps,f_aq(icol,k)) + fnbc(icol,k) = max(eps,fnbc(icol,k)) + faitbc(icol,k) = max(eps,faitbc(icol,k)) + end do + end do + +! Calculation of the apportionment of internally mixed SO4, BC and OC +! mass between the various background modes. + + !==> calls modalapp to partition the mass + call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & + cam, fcm, fbcm, faqm, f_condm, f_soam ) + + !The following uses non-standard units, #/cm3 and ug/m3 + Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 + cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 + +! Calculate fraction of added mass which is either SOA condensate or OC coagulate, +! which in AeroTab are both treated as condensate for kcomp=1-4. + do i=1,4 + do k=1,pver + do icol=1,ncol + focm(icol,k,i) = fcm(icol,k,i)*(1.0_r8-fbcm(icol,k,i)) + enddo + enddo + enddo + do k=1,pver + do icol=1,ncol + faqm4(icol,k) = faqm(icol,k,4) + end do + enddo + +! find common input parameters for use in the interpolation routines + + call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & + f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & + fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & + focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) + +! and define the respective RH input variables for dry aerosols + do k=1,pver + do icol=1,ncol + xrhnull(icol,k)=rh(1) + irh1null(icol,k)=1 + end do + enddo + + +#ifdef AEROCOM + +! Initialize overshooting mass summed over all modes + do k=1,pver + do icol=1,ncol + cxstot(icol,k)=0.0_r8 + enddo + enddo + do icol=1,ncol + akcxs(icol)=0.0_r8 + enddo + +! Initializing total and relative exessive (overshooting w.r.t. +! look-up table maxima) added mass column: + do i=1,nbmodes + do icol=1,ncol + Camtot(icol,i)=0.0_r8 + cxsmtot(icol,i)=0.0_r8 + cxsmrel(icol,i)=0.0_r8 + enddo + enddo +! Calculating added internally mixed mass onto each mode 1-10, relative to +! maximum mass which can be added w.r.t. the look-up tables (for level k), +! as well as the relative exessive added mass column: + do i=1,4 + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) + xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) +!t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) +!t + enddo + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) + xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) +!t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) +!t + enddo + enddo + enddo + +! Total overshooting mass summed over all modes and all levels + do icol=1,ncol + do k=1,pver + akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) + enddo + enddo + call outfld('AKCXS ',akcxs ,pcols,lchnk) + + do i=1,nbmodes + do icol=1,ncol + cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) + enddo + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) + enddo + +#endif + + +! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent +! calculation of condensed water mass below... + +#ifdef AEROCOM +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do k=1,pver + do icol=1,ncol + Ctotdry(icol,k)=0.0_r8 + rh0(icol,k)=0.0_r8 + asydry_aer(icol,k)=0.0_r8 + end do + enddo + + lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) + + do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* +! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + + mplus10=0 +! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + +! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + +! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & + xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + +! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop + + + do iloop=1,1 + mplus10=1 +! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + +! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + +enddo ! iloop + + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) +#ifdef COLTST4INTCONS + cmodedry(icol,k,i)=dCtot(icol,k)*Nnatk(icol,k,i) +#endif + end do + enddo + enddo + +!!! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only +!!! (and with no CMIP6 volcnic contribution) + ib=4 + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=0.0_r8 + ssatot(icol,k,ib)=0.0_r8 + asymtot(icol,k,ib)=0.0_r8 + end do + enddo + do i=0,nmodes + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) +! if(ib.eq.4) then +! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) +! write(*,*) 'i, be =', i, be(icol,k,i,ib) +! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) +! endif + + end do + enddo + enddo + do k=1,pver + do icol=1,ncol + ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) + asymtot(icol,k,ib)=asymtot(icol,k,ib) & + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) + asydry_aer(icol,k)=asymtot(icol,k,ib) + end do + enddo +! + call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) +! + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +#endif ! AEROCOM + +! (Wet) Optical properties for each of the aerosol modes: + + lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) + + do iloop=1,1 +! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + + mplus10=0 +! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, & + xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) + +! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + +! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + +! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop + + +! total aerosol number concentrations + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + n_aer(icol,k)=n_aer(icol,k)+Nnatk(icol,k,i) + end do + enddo + enddo + call outfld('N_AER ',n_aer ,pcols,lchnk) + + do iloop=1,1 + mplus10=1 +! SO4/SOA(Ait) mode: + !does no longer exist as an externally mixed mode + +! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + +! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + do k=1,pver + do icol=1,ncol + Ctot(icol,k)=0.0_r8 + end do + enddo + + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + end do + enddo + enddo + +#ifdef AEROCOM +#ifdef COLTST4INTCONS +! initializing modal mass column burdens + do icol=1,ncol + cmdry0(icol)=0.0_r8 + cmdry1(icol)=0.0_r8 + cmdry2(icol)=0.0_r8 + cmdry4(icol)=0.0_r8 + cmdry5(icol)=0.0_r8 + cmdry6(icol)=0.0_r8 + cmdry7(icol)=0.0_r8 + cmdry8(icol)=0.0_r8 + cmdry9(icol)=0.0_r8 + cmdry10(icol)=0.0_r8 + cmdry12(icol)=0.0_r8 + cmdry14(icol)=0.0_r8 + enddo +#endif +! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water + do k=1,pver + do icol=1,ncol + Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) + mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) +#ifdef COLTST4INTCONS +! and dry mass column burdens for each mode/mixture + deltah=deltah_km(icol,k) + cmdry0(icol)=cmdry0(icol)+cmodedry(icol,k,0)*deltah + cmdry1(icol)=cmdry1(icol)+cmodedry(icol,k,1)*deltah + cmdry2(icol)=cmdry2(icol)+cmodedry(icol,k,2)*deltah + cmdry4(icol)=cmdry4(icol)+cmodedry(icol,k,4)*deltah + cmdry5(icol)=cmdry5(icol)+cmodedry(icol,k,5)*deltah + cmdry6(icol)=cmdry6(icol)+cmodedry(icol,k,6)*deltah + cmdry7(icol)=cmdry7(icol)+cmodedry(icol,k,7)*deltah + cmdry8(icol)=cmdry8(icol)+cmodedry(icol,k,8)*deltah + cmdry9(icol)=cmdry9(icol)+cmodedry(icol,k,9)*deltah + cmdry10(icol)=cmdry10(icol)+cmodedry(icol,k,10)*deltah + cmdry12(icol)=cmdry12(icol)+cmodedry(icol,k,12)*deltah + cmdry14(icol)=cmdry14(icol)+cmodedry(icol,k,14)*deltah +#endif + end do + enddo +#endif +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! SW Optical properties of total aerosol: + do ib=1,nbands + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=0.0_r8 + ssatot(icol,k,ib)=0.0_r8 + asymtot(icol,k,ib)=0.0_r8 + end do + enddo + enddo + do ib=1,nbands + do i=0,nmodes + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + end do + enddo + enddo + enddo +! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 +! band numbering identical to the AeroTab numbering (unlike CAM) both +! for SW and LW. I.e., no remapping is required here. +! Info from CMIP_CAM6_radiation_v3.nc +! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, +! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; +! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, +! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; +! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, +! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; +! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, +! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; + do ib=1,nbands + betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib) + ssatot(1:ncol,1:pver,ib) = ssatot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) + asymtot(1:ncol,1:pver,ib) = asymtot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) & + *volc_g_sun(1:ncol,1:pver,ib) + enddo +!akc6+ + bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) +!akc6- +! and then calculate the total bulk optical parameters + do ib=1,nbands + do k=1,pver + do icol=1,ncol + ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) + asymtot(icol,k,ib)=asymtot(icol,k,ib) & + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) + end do + enddo + enddo + +!------------------------------------------------------------------------------------------------ +! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) +! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: +! CAM5 bands AeroTab bands +! 14 3.846 12.195 14 +! 1 3.077 3.846 13 +! 2 2.500 3.077 12 +! 3 2.150 2.500 11 +! 4 1.942 2.150 10 +! 5 1.626 1.942 9 +! 6 1.299 1.626 8 +! 7 1.242 1.299 7 +! 8 0.778 1.242 6 +! 9 0.625 0.778 5 +! 10 0.442 0.625 4 +! 11 0.345 0.442 3 +! 12 0.263 0.345 2 +! 13 0.200 0.263 1 + + do i=1,ncol ! zero aerosol in the top layer + do ib=1,14 ! 1-nbands + per_tau(i,0,ib)= 0._r8 + per_tau_w(i,0,ib)= 0.999_r8 + per_tau_w_g(i,0,ib)= 0.5_r8 + per_tau_w_f(i,0,ib)= 0.25_r8 + end do + do ib=1,14 ! initialize also for the other layers + do k=1,pver + per_tau(i,k,ib)= 0._r8 + per_tau_w(i,k,ib)= 0.999_r8 + per_tau_w_g(i,k,ib)= 0.5_r8 + per_tau_w_f(i,k,ib)= 0.25_r8 + end do + end do + end do +! Remapping of SW wavelength bands from AeroTab to CAM5 + do i=1,ncol + do ib=1,13 + do k=1,pver + per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,14-ib) + per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,14-ib),0.999999_r8),1.e-6_r8) + per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) + per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) +!tst +! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then +! write(*,*) 'per_tau =', per_tau(i,k,ib) +! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) +! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) +! endif +!tst + end do + end do + ib=14 + do k=1,pver + per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,ib) + per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,ib),0.999999_r8),1.e-6_r8) + per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,ib) + per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,ib) + end do + end do ! ncol +!------------------------------------------------------------------------------------------------ + +! LW Optical properties of total aerosol: + do ib=1,nlwbands + do k=1,pver + do icol=1,ncol + batotlw(icol,k,ib)=0.0_r8 + end do + enddo + enddo + do ib=1,nlwbands + do i=0,nmodes + do k=1,pver + do icol=1,ncol + balw(icol,k,i,ib)=kalw(icol,k,i,ib)*(be(icol,k,i,4)/(ke(icol,k,i,4)+eps)) + batotlw(icol,k,ib)=batotlw(icol,k,ib)+Nnatk(icol,k,i)*balw(icol,k,i,ib) + end do + enddo + enddo + enddo + +! Adding also the volcanic contribution (CMIP6), which is also using +! AeroTab band numbering, so that a remapping is required here + do ib=1,nlwbands + volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & + *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) + batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) + enddo + +! Remapping of LW wavelength bands from AeroTab to CAM5 + do ib=1,nlwbands + do i=1,ncol + do k=1,pver + per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) +! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then +! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) +! endif + end do + end do + end do + +#ifdef AEROCOM + do i=1,ncol + do k=1,pver + batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) + batotlw01(i,k)=batotlw(i,k,1) + end do + end do +! These two fields should be close to equal, both representing absorption +! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). + call outfld('BATSW13 ',batotsw13,pcols,lchnk) + call outfld('BATLW01 ',batotlw01,pcols,lchnk) +#endif + +#ifdef COLTST4INTCONS +! initialize modal optical extinctions + do k=1,pver + do icol=1,ncol + bekc0(icol,k)=0.0_r8 + bekc1(icol,k)=0.0_r8 + bekc2(icol,k)=0.0_r8 + bekc4(icol,k)=0.0_r8 + bekc5(icol,k)=0.0_r8 + bekc6(icol,k)=0.0_r8 + bekc7(icol,k)=0.0_r8 + bekc8(icol,k)=0.0_r8 + bekc9(icol,k)=0.0_r8 + bekc10(icol,k)=0.0_r8 + bekc12(icol,k)=0.0_r8 + bekc14(icol,k)=0.0_r8 +! + kekc0(icol,k)=0.0_r8 + kekc1(icol,k)=0.0_r8 + kekc2(icol,k)=0.0_r8 + kekc4(icol,k)=0.0_r8 + kekc5(icol,k)=0.0_r8 + kekc6(icol,k)=0.0_r8 + kekc7(icol,k)=0.0_r8 + kekc8(icol,k)=0.0_r8 + kekc9(icol,k)=0.0_r8 + kekc10(icol,k)=0.0_r8 + kekc12(icol,k)=0.0_r8 + kekc14(icol,k)=0.0_r8 + end do + enddo +! optical depth (in band 4 = vis.) for each of the modes + do k=1,pver + do icol=1,ncol + bekc0(icol,k) =Nnatk(icol,k,0) *be(icol,k,0,4) + bekc1(icol,k) =Nnatk(icol,k,1) *be(icol,k,1,4) + bekc2(icol,k) =Nnatk(icol,k,2) *be(icol,k,2,4) + bekc4(icol,k) =Nnatk(icol,k,4) *be(icol,k,4,4) + bekc5(icol,k) =Nnatk(icol,k,5) *be(icol,k,5,4) + bekc6(icol,k) =Nnatk(icol,k,6) *be(icol,k,6,4) + bekc7(icol,k) =Nnatk(icol,k,7) *be(icol,k,7,4) + bekc8(icol,k) =Nnatk(icol,k,8) *be(icol,k,8,4) + bekc9(icol,k) =Nnatk(icol,k,9) *be(icol,k,9,4) + bekc10(icol,k)=Nnatk(icol,k,10)*be(icol,k,10,4) + bekc12(icol,k)=Nnatk(icol,k,12)*be(icol,k,12,4) + bekc14(icol,k)=Nnatk(icol,k,14)*be(icol,k,14,4) +! + kekc0(icol,k) =ke(icol,k,0,4) + kekc1(icol,k) =ke(icol,k,1,4) + kekc2(icol,k) =ke(icol,k,2,4) + kekc4(icol,k) =ke(icol,k,4,4) + kekc5(icol,k) =ke(icol,k,5,4) + kekc6(icol,k) =ke(icol,k,6,4) + kekc7(icol,k) =ke(icol,k,7,4) + kekc8(icol,k) =ke(icol,k,8,4) + kekc9(icol,k) =ke(icol,k,9,4) + kekc10(icol,k)=ke(icol,k,10,4) + kekc12(icol,k)=ke(icol,k,12,4) + kekc14(icol,k)=ke(icol,k,14,4) + end do + enddo +#endif + + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) +! (in the visible wavelength band) + do k=1,pver + do icol=1,ncol + betotvis(icol,k)=betot(icol,k,4) + batotvis(icol,k)=betotvis(icol,k)*(1.0-ssatot(icol,k,4)) + end do + enddo +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do k=1,pver + do icol=1,ncol + ssavis(icol,k) = 0.0_r8 + asymmvis(icol,k) = 0.0_r8 + extvis(icol,k) = 0.0_r8 + dayfoc(icol,k) = 0.0_r8 + enddo + end do + + do k=1,pver + do icol=1,ncol +! dayfoc < 1 when looping only over gridcells with daylight + if(daylight(icol)) then + dayfoc(icol,k) = 1.0_r8 +! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) + ssavis(icol,k) = ssatot(icol,k,4) + asymmvis(icol,k) = asymtot(icol,k,4) + extvis(icol,k) = betot(icol,k,4) + endif + enddo + end do + +! optical parameters in visible light (0.442-0.625um) + call outfld('SSAVIS ',ssavis,pcols,lchnk) + call outfld('ASYMMVIS',asymmvis,pcols,lchnk) + call outfld('EXTVIS ',extvis,pcols,lchnk) + call outfld('DAYFOC ',dayfoc,pcols,lchnk) + +! Initialize fields + do icol=1,ncol +! akso4c(icol)=0.0_r8 +! akbcc(icol)=0.0_r8 +! akocc(icol)=0.0_r8 + aodvis(icol)=0.0_r8 + absvis(icol)=0.0_r8 + aodvisvolc(icol)=0.0_r8 + absvisvolc(icol)=0.0_r8 + airmass(icol)=0.0_r8 !akc6 +#ifdef COLTST4INTCONS + taukc0(icol)=0.0_r8 + taukc1(icol)=0.0_r8 + taukc2(icol)=0.0_r8 +! taukc3(icol)=0.0_r8 + taukc4(icol)=0.0_r8 + taukc5(icol)=0.0_r8 + taukc6(icol)=0.0_r8 + taukc7(icol)=0.0_r8 + taukc8(icol)=0.0_r8 + taukc9(icol)=0.0_r8 + taukc10(icol)=0.0_r8 +! taukc11(icol)=0.0_r8 + taukc12(icol)=0.0_r8 +! taukc13(icol)=0.0_r8 + taukc14(icol)=0.0_r8 +#endif + enddo + + do icol=1,ncol + if(daylight(icol)) then + do k=1,pver +! Layer thickness, unit km, and layer airmass, unit kg/m2 + deltah=deltah_km(icol,k) +!akc6 airmass(icol,k)=1.e3_r8*deltah*rhoda(icol,k) + airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) + airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 +! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols +!tst +! aodvis3d(icol,k)=betotvis(icol,k)*deltah +!tst + aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah + absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah +! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol + aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah + absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & + *(1.0_r8-volc_omega_sun(icol,k,4))*deltah +#ifdef COLTST4INTCONS +! To check internal consistency of these AOD calculations, make +! sure that sum_i(taukc_i)=aodvis (tested to be ok on 7/1-2016). +! Note that this will not be the case when CMIP6 volcanic forcing +! as optical properties are included, since this comes "on top of" +! the mixtures 0-14 below. + taukc0(icol) =taukc0(icol) +bekc0(icol,k)*deltah + taukc1(icol) =taukc1(icol) +bekc1(icol,k)*deltah + taukc2(icol) =taukc2(icol) +bekc2(icol,k)*deltah + taukc4(icol) =taukc4(icol) +bekc4(icol,k)*deltah + taukc5(icol) =taukc5(icol) +bekc5(icol,k)*deltah + taukc6(icol) =taukc6(icol) +bekc6(icol,k)*deltah + taukc7(icol) =taukc7(icol) +bekc7(icol,k)*deltah + taukc8(icol) =taukc8(icol) +bekc8(icol,k)*deltah + taukc9(icol) =taukc9(icol) +bekc9(icol,k)*deltah + taukc10(icol)=taukc10(icol)+bekc10(icol,k)*deltah + taukc12(icol)=taukc12(icol)+bekc12(icol,k)*deltah + taukc14(icol)=taukc14(icol)+bekc14(icol,k)*deltah +#endif + end do ! k + endif ! daylight + end do ! icol + +! Extinction and absorption for 0.55 um for the total aerosol, and AODs +#ifdef AEROCOM + call outfld('BETOTVIS',betotvis,pcols,lchnk) + call outfld('BATOTVIS',batotvis,pcols,lchnk) +#endif +! call outfld('AODVIS ',aodvis ,pcols,lchnk) + call outfld('AOD_VIS ',aodvis ,pcols,lchnk) + call outfld('ABSVIS ',absvis ,pcols,lchnk) + call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) + call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) +!akc6+ + call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) +!akc6- +!tst +! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) +!tst +#ifdef COLTST4INTCONS + call outfld('TAUKC0 ',taukc0 ,pcols,lchnk) + call outfld('TAUKC1 ',taukc1 ,pcols,lchnk) + call outfld('TAUKC2 ',taukc2 ,pcols,lchnk) + call outfld('TAUKC4 ',taukc4 ,pcols,lchnk) + call outfld('TAUKC5 ',taukc5 ,pcols,lchnk) + call outfld('TAUKC6 ',taukc6 ,pcols,lchnk) + call outfld('TAUKC7 ',taukc7 ,pcols,lchnk) + call outfld('TAUKC8 ',taukc8 ,pcols,lchnk) + call outfld('TAUKC9 ',taukc9 ,pcols,lchnk) + call outfld('TAUKC10 ',taukc10,pcols,lchnk) + call outfld('TAUKC12 ',taukc12,pcols,lchnk) + call outfld('TAUKC14 ',taukc14,pcols,lchnk) +! + call outfld('MECKC0 ',kekc0 ,pcols,lchnk) + call outfld('MECKC1 ',kekc1 ,pcols,lchnk) + call outfld('MECKC2 ',kekc2 ,pcols,lchnk) + call outfld('MECKC4 ',kekc4 ,pcols,lchnk) + call outfld('MECKC5 ',kekc5 ,pcols,lchnk) + call outfld('MECKC6 ',kekc6 ,pcols,lchnk) + call outfld('MECKC7 ',kekc7 ,pcols,lchnk) + call outfld('MECKC8 ',kekc8 ,pcols,lchnk) + call outfld('MECKC9 ',kekc9 ,pcols,lchnk) + call outfld('MECKC10 ',kekc10 ,pcols,lchnk) + call outfld('MECKC12 ',kekc12 ,pcols,lchnk) + call outfld('MECKC14 ',kekc14 ,pcols,lchnk) +#endif + +#ifdef AEROCOM ! AEROCOM***********AEROCOM**************AEROCOM***************below + +! call outfld('BEKC4 ',bekc4 ,pcols,lchnk) + +! Initialize fields + do icol=1,ncol + daerh2o(icol)=0.0_r8 + vaercols(icol)=0.0_r8 + vaercoll(icol)=0.0_r8 + aaercols(icol)=0.0_r8 + aaercoll(icol)=0.0_r8 + do i=0,nmodes + dload(icol,i)=0.0_r8 + enddo + enddo + + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + +! AeroCom diagnostics requiring table look-ups with ambient RH. + + do irf=0,0 + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550, & + bext440n, bext500n, bext550n, bext670n, bext870n, & + bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & + bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & + beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & + besu440n, besu500n, besu550n, besu670n, besu870n, & + babs440n, babs500n, babs550n, babs670n, babs870n, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & + backsc550n, babg550n, babc550n, baoc550n, basu550n) + end do ! irf + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + do k=1,pver + do icol=1,ncol + + bebglt1t(icol,k)=0.0_r8 + bebggt1t(icol,k)=0.0_r8 + bebclt1t(icol,k)=0.0_r8 + bebcgt1t(icol,k)=0.0_r8 + beoclt1t(icol,k)=0.0_r8 + beocgt1t(icol,k)=0.0_r8 + bes4lt1t(icol,k)=0.0_r8 + bes4gt1t(icol,k)=0.0_r8 + bedustlt1(icol,k)=0.0_r8 + bedustgt1(icol,k)=0.0_r8 + besslt1(icol,k)=0.0_r8 + bessgt1(icol,k)=0.0_r8 + + bext440tot(icol,k)=0.0_r8 + babs440tot(icol,k)=0.0_r8 + bext500tot(icol,k)=0.0_r8 + babs500tot(icol,k)=0.0_r8 + bext550tot(icol,k)=0.0_r8 + babs550tot(icol,k)=0.0_r8 + bext670tot(icol,k)=0.0_r8 + babs670tot(icol,k)=0.0_r8 + bext870tot(icol,k)=0.0_r8 + babs870tot(icol,k)=0.0_r8 + + backsc550tot(icol,k)=0.0_r8 + + bebg440tot(icol,k)=0.0_r8 +! babg440tot(icol,k)=0.0_r8 + bebg500tot(icol,k)=0.0_r8 +! babg500tot(icol,k)=0.0_r8 + bebg550tot(icol,k)=0.0_r8 + babg550tot(icol,k)=0.0_r8 + bebg670tot(icol,k)=0.0_r8 +! babg670tot(icol,k)=0.0_r8 + bebg870tot(icol,k)=0.0_r8 +! babg870tot(icol,k)=0.0_r8 + + bebc440tot(icol,k)=0.0_r8 +! babc440tot(icol,k)=0.0_r8 + bebc500tot(icol,k)=0.0_r8 +! babc500tot(icol,k)=0.0_r8 + bebc550tot(icol,k)=0.0_r8 + babc550tot(icol,k)=0.0_r8 + bebc670tot(icol,k)=0.0_r8 +! babc670tot(icol,k)=0.0_r8 + bebc870tot(icol,k)=0.0_r8 +! babc870tot(icol,k)=0.0_r8 + + beoc440tot(icol,k)=0.0_r8 +! baoc440tot(icol,k)=0.0_r8 + beoc500tot(icol,k)=0.0_r8 +! baoc500tot(icol,k)=0.0_r8 + beoc550tot(icol,k)=0.0_r8 + baoc550tot(icol,k)=0.0_r8 + beoc670tot(icol,k)=0.0_r8 +! baoc670tot(icol,k)=0.0_r8 + beoc870tot(icol,k)=0.0_r8 +! baoc870tot(icol,k)=0.0_r8 + + besu440tot(icol,k)=0.0_r8 +! basu440tot(icol,k)=0.0_r8 + besu500tot(icol,k)=0.0_r8 +! basu500tot(icol,k)=0.0_r8 + besu550tot(icol,k)=0.0_r8 + basu550tot(icol,k)=0.0_r8 + besu670tot(icol,k)=0.0_r8 +! basu670tot(icol,k)=0.0_r8 + besu870tot(icol,k)=0.0_r8 +! basu870tot(icol,k)=0.0_r8 + + enddo + enddo + + do i=0,nbmodes + do k=1,pver + do icol=1,ncol +! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um + bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) + babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) + bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) + babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) + bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) + babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) + bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) + babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) + bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) + babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) + backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) +! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um +! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) + bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) +! babg440tot(icol,k)=babg440tot(icol,k)+Nnatk(icol,k,i)*babg440(icol,k,i) + bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) +! babg500tot(icol,k)=babg500tot(icol,k)+Nnatk(icol,k,i)*babg500(icol,k,i) + bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) + babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) + bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) +! babg670tot(icol,k)=babg670tot(icol,k)+Nnatk(icol,k,i)*babg670(icol,k,i) + bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) +! babg870tot(icol,k)=babg870tot(icol,k)+Nnatk(icol,k,i)*babg870(icol,k,i) +! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um +! for each added (internally mixed through Aq./cond./coag.) component (SO4,BC,OC). +! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) +! basu440tot(icol,k)=basu440tot(icol,k)+Nnatk(icol,k,i)*basu440(icol,k,i) + besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) +! basu500tot(icol,k)=basu500tot(icol,k)+Nnatk(icol,k,i)*basu500(icol,k,i) + besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) + basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) + besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) +! basu670tot(icol,k)=basu670tot(icol,k)+Nnatk(icol,k,i)*basu670(icol,k,i) + besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) +! basu870tot(icol,k)=basu870tot(icol,k)+Nnatk(icol,k,i)*basu870(icol,k,i) +! +! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*bebc440(icol,k,i) +! babc440tot(icol,k)=babc440tot(icol,k)+Nnatk(icol,k,i)*babc440(icol,k,i) + bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*bebc500(icol,k,i) +! babc500tot(icol,k)=babc500tot(icol,k)+Nnatk(icol,k,i)*babc500(icol,k,i) + bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*bebc550(icol,k,i) + babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) + bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*bebc670(icol,k,i) +! babc670tot(icol,k)=babc670tot(icol,k)+Nnatk(icol,k,i)*babc670(icol,k,i) + bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*bebc870(icol,k,i) +! babc870tot(icol,k)=babc870tot(icol,k)+Nnatk(icol,k,i)*babc870(icol,k,i) + beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*beoc440(icol,k,i) +! baoc440tot(icol,k)=baoc440tot(icol,k)+Nnatk(icol,k,i)*baoc440(icol,k,i) + beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*beoc500(icol,k,i) +! baoc500tot(icol,k)=baoc500tot(icol,k)+Nnatk(icol,k,i)*baoc500(icol,k,i) + beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*beoc550(icol,k,i) + baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) + beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*beoc670(icol,k,i) +! baoc670tot(icol,k)=baoc670tot(icol,k)+Nnatk(icol,k,i)*baoc670(icol,k,i) + beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*beoc870(icol,k,i) +! baoc870tot(icol,k)=baoc870tot(icol,k)+Nnatk(icol,k,i)*baoc870(icol,k,i) + endif ! i>=1 + if(i==6.or.i==7) then + bedustlt1(icol,k)=bedustlt1(icol,k) & + +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bedustgt1(icol,k)=bedustgt1(icol,k) & + +Nnatk(icol,k,i)*bebggt1(icol,k,i) + elseif(i>=8.and.i<=10) then + besslt1(icol,k)=besslt1(icol,k) & + +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bessgt1(icol,k)=bessgt1(icol,k) & + +Nnatk(icol,k,i)*bebggt1(icol,k,i) + endif +! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + bes4lt1t(icol,k)=bes4lt1t(icol,k) & + +Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bes4gt1t(icol,k)=bes4gt1t(icol,k) & + +Nnatk(icol,k,i)*bes4gt1(icol,k,i) +! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebclt1t(icol,k)=bebclt1t(icol,k) & + +Nnatk(icol,k,i)*bebclt1(icol,k,i) + bebcgt1t(icol,k)=bebcgt1t(icol,k) & + +Nnatk(icol,k,i)*bebcgt1(icol,k,i) + beoclt1t(icol,k)=beoclt1t(icol,k) & + +Nnatk(icol,k,i)*beoclt1(icol,k,i) + beocgt1t(icol,k)=beocgt1t(icol,k) & + +Nnatk(icol,k,i)*beocgt1(icol,k,i) + endif ! i>=1 + end do ! icol + enddo ! k + enddo ! i + +! extinction/absorptions (km-1) for each background component +! in the internal mixture are + do k=1,pver + do icol=1,ncol + bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & + +Nnatk(icol,k,7)*bebg440(icol,k,7) + bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & + +Nnatk(icol,k,7)*bebg500(icol,k,7) + bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & + +Nnatk(icol,k,7)*bebg550(icol,k,7) + bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & + +Nnatk(icol,k,7)*bebg670(icol,k,7) + bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & + +Nnatk(icol,k,7)*bebg870(icol,k,7) + bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & + +Nnatk(icol,k,9)*bebg440(icol,k,9) & + +Nnatk(icol,k,10)*bebg440(icol,k,10) + bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & + +Nnatk(icol,k,9)*bebg500(icol,k,9) & + +Nnatk(icol,k,10)*bebg500(icol,k,10) + bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & + +Nnatk(icol,k,9)*bebg550(icol,k,9) & + +Nnatk(icol,k,10)*bebg550(icol,k,10) + bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & + +Nnatk(icol,k,9)*bebg670(icol,k,9) & + +Nnatk(icol,k,10)*bebg670(icol,k,10) + bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & + +Nnatk(icol,k,9)*bebg870(icol,k,9) & + +Nnatk(icol,k,10)*bebg870(icol,k,10) + baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & + +Nnatk(icol,k,7)*babg550(icol,k,7) + baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & + +Nnatk(icol,k,9)*babg550(icol,k,9) & + +Nnatk(icol,k,10)*babg550(icol,k,10) + end do + enddo + + do i=11,14 + do k=1,pver + do icol=1,ncol + be440x(icol,k,i)=bext440n(icol,k,i-10) + ba440x(icol,k,i)=babs440n(icol,k,i-10) + be500x(icol,k,i)=bext500n(icol,k,i-10) + ba500x(icol,k,i)=babs500n(icol,k,i-10) + be550x(icol,k,i)=bext550n(icol,k,i-10) + ba550x(icol,k,i)=babs550n(icol,k,i-10) + be670x(icol,k,i)=bext670n(icol,k,i-10) + ba670x(icol,k,i)=babs670n(icol,k,i-10) + be870x(icol,k,i)=bext870n(icol,k,i-10) + ba870x(icol,k,i)=babs870n(icol,k,i-10) + belt1x(icol,k,i)=bebglt1n(icol,k,i-10) + begt1x(icol,k,i)=bebggt1n(icol,k,i-10) + backsc550x(icol,k,i)=backsc550n(icol,k,i-10) + end do + enddo + enddo + +! The externally modes' contribution to extinction and absorption: + do k=1,pver + do icol=1,ncol + +!BC + vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & + +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vnbc = vnbcarr(icol,k) + bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) + babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) + bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) + babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) + bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) + babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) + bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) + babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) + bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) + babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) + bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) + bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) +!OC + beoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) + baoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) + beoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) + baoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) + beoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) + baoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) + beoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) + baoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) + beoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) + baoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) + boclt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) + bocgt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) +! Total (for all modes) absorption optical depth and backscattering + abs550_aer(icol,k)=babs550tot(icol,k) & + +Nnatk(icol,k,12)*ba550x(icol,k,12) & + +Nnatk(icol,k,14)*ba550x(icol,k,14) + abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) + bs550_aer(icol,k)= backsc550tot(icol,k) & + +Nnatk(icol,k,12)*backsc550x(icol,k,12) & + +Nnatk(icol,k,14)*backsc550x(icol,k,14) + bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) +! + end do + enddo +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! collect AeroCom-fields for optical depth/absorption of each comp, +! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um +! initialize 2d-fields + do icol=1,ncol + dod440(icol) = 0.0_r8 + abs440(icol) = 0.0_r8 + dod500(icol) = 0.0_r8 + abs500(icol) = 0.0_r8 + dod550(icol) = 0.0_r8 + abs550(icol) = 0.0_r8 + abs550alt(icol) = 0.0_r8 + dod670(icol) = 0.0_r8 + abs670(icol) = 0.0_r8 + dod870(icol) = 0.0_r8 + abs870(icol) = 0.0_r8 +! + abs550_ss(icol) = 0.0_r8 + abs550_dust(icol) = 0.0_r8 + abs550_so4(icol) = 0.0_r8 + abs550_bc(icol) = 0.0_r8 + abs550_pom(icol) = 0.0_r8 +! + dod440_ss(icol) = 0.0_r8 + dod440_dust(icol) = 0.0_r8 + dod440_so4(icol) = 0.0_r8 + dod440_bc(icol) = 0.0_r8 + dod440_pom(icol) = 0.0_r8 + dod500_ss(icol) = 0.0_r8 + dod500_dust(icol) = 0.0_r8 + dod500_so4(icol) = 0.0_r8 + dod500_bc(icol) = 0.0_r8 + dod500_pom(icol) = 0.0_r8 + dod550_ss(icol) = 0.0_r8 + dod550_dust(icol) = 0.0_r8 + dod550_so4(icol) = 0.0_r8 + dod550_bc(icol) = 0.0_r8 + dod550_pom(icol) = 0.0_r8 + dod670_ss(icol) = 0.0_r8 + dod670_dust(icol) = 0.0_r8 + dod670_so4(icol) = 0.0_r8 + dod670_bc(icol) = 0.0_r8 + dod670_pom(icol) = 0.0_r8 + dod870_ss(icol) = 0.0_r8 + dod870_dust(icol) = 0.0_r8 + dod870_so4(icol) = 0.0_r8 + dod870_bc(icol) = 0.0_r8 + dod870_pom(icol) = 0.0_r8 + dod550lt1_ss(icol) = 0.0_r8 + dod550gt1_ss(icol) = 0.0_r8 + dod550lt1_dust(icol) = 0.0_r8 + dod550gt1_dust(icol) = 0.0_r8 + dod550lt1_so4(icol) = 0.0_r8 + dod550gt1_so4(icol) = 0.0_r8 + dod550lt1_bc(icol) = 0.0_r8 + dod550gt1_bc(icol) = 0.0_r8 + dod550lt1_pom(icol) = 0.0_r8 + dod550gt1_pom(icol) = 0.0_r8 + do k=1,pver + abs4403d(icol,k) = 0.0_r8 + abs5003d(icol,k) = 0.0_r8 + abs5503d(icol,k) = 0.0_r8 + abs6703d(icol,k) = 0.0_r8 + abs8703d(icol,k) = 0.0_r8 + abs5503dalt(icol,k) = 0.0_r8 + enddo + enddo + + do icol=1,ncol + do k=1,pver +! Layer thickness, unit km + deltah=deltah_km(icol,k) +! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah +! 3D optical depths for monthly averages +!SS + dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah + dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah + dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah + abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah + dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah + dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah +!DUST + dod4403d_dust(icol,k) = bint440du(icol,k)*deltah + dod5003d_dust(icol,k) = bint500du(icol,k)*deltah + dod5503d_dust(icol,k) = bint550du(icol,k)*deltah + abs5503d_dust(icol,k) = baint550du(icol,k)*deltah + dod6703d_dust(icol,k) = bint670du(icol,k)*deltah + dod8703d_dust(icol,k) = bint870du(icol,k)*deltah +!SO4 +!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) +!BC + vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & + +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vaitbc = vaitbcarr(icol,k) + dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) +!OC +!soa + v_soana part of mode 11 for the OC volume fraction of that mode +! v_soana(icol,k) + dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebg440(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebg500(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebg670(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebg870(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah + ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah + ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah + ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah + ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah + ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & + + ec550_ss(icol,k)+ec550_du(icol,k) + +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Total 3D optical depths/abs. for column integrations + dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & + +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & + +dod4403d_pom(icol,k) + dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & + +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & + +dod5003d_pom(icol,k) + dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & + +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & + +dod5503d_pom(icol,k) + dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & + +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & + +dod6703d_pom(icol,k) + dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & + +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & + +dod8703d_pom(icol,k) + abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & + +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & + +abs5503d_pom(icol,k) +! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. +! regions, compared to abs550. This is most likely most correct, but should be checked!) + do i=0,10 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i)*deltah + enddo + do i=11,14 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500n(icol,k,i-10)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670n(icol,k,i-10)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10)*deltah + enddo +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) +!SS + dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah + dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah +!DUST + dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah + dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah + +!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) +!BC + dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) +!OC +!soa + v_soana part of mode 11 for the OC volume fraction of that mode + dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 +!-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +! Column integrated optical depths/abs., total and for each constituent + dod440(icol) = dod440(icol)+dod4403d(icol,k) + abs440(icol) = abs440(icol)+abs4403d(icol,k) + dod500(icol) = dod500(icol)+dod5003d(icol,k) + abs500(icol) = abs500(icol)+abs5003d(icol,k) + dod550(icol) = dod550(icol)+dod5503d(icol,k) + abs550(icol) = abs550(icol)+abs5503d(icol,k) + abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) + dod670(icol) = dod670(icol)+dod6703d(icol,k) + abs670(icol) = abs670(icol)+abs6703d(icol,k) + dod870(icol) = dod870(icol)+dod8703d(icol,k) + abs870(icol) = abs870(icol)+abs8703d(icol,k) +! Added abs components + abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) + abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) + abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) + abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) + abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) +! + dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) + dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) + dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) + dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) + dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) + dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) + dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) + dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) + dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) + dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) + dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) + dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) + dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) + dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) + dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) + dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) + dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) + dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) + dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) + dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) + dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) + dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) + dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) + dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) + dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) + dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) + dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) + dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) + dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) + dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) + dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) + dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) + dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) + dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) + dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) +!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + enddo ! k + + enddo ! icol + +! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) + call outfld('EC550AER',ec550_aer,pcols,lchnk) + call outfld('ABS550_A',abs550_aer,pcols,lchnk) + call outfld('BS550AER',bs550_aer,pcols,lchnk) +! +! speciated extinction coefficients (m-1) + call outfld('EC550SO4',ec550_so4,pcols,lchnk) + call outfld('EC550BC ',ec550_bc ,pcols,lchnk) + call outfld('EC550POM',ec550_pom,pcols,lchnk) + call outfld('EC550SS ',ec550_ss ,pcols,lchnk) + call outfld('EC550DU ',ec550_du ,pcols,lchnk) +! +! optical depths and absorption as requested by AeroCom +! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um + call outfld('DOD440 ',dod440 ,pcols,lchnk) + call outfld('ABS440 ',abs440 ,pcols,lchnk) + call outfld('DOD500 ',dod500 ,pcols,lchnk) + call outfld('ABS500 ',abs500 ,pcols,lchnk) + call outfld('DOD550 ',dod550 ,pcols,lchnk) + call outfld('ABS550 ',abs550 ,pcols,lchnk) + call outfld('ABS550AL',abs550alt,pcols,lchnk) + call outfld('DOD670 ',dod670 ,pcols,lchnk) + call outfld('ABS670 ',abs670 ,pcols,lchnk) + call outfld('DOD870 ',dod870 ,pcols,lchnk) + call outfld('ABS870 ',abs870 ,pcols,lchnk) + call outfld('A550_SS ',abs550_ss ,pcols,lchnk) + call outfld('A550_DU ',abs550_dust,pcols,lchnk) + call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) + call outfld('A550_BC ',abs550_bc ,pcols,lchnk) + call outfld('A550_POM',abs550_pom ,pcols,lchnk) +! + call outfld('D440_SS ',dod440_ss ,pcols,lchnk) + call outfld('D440_DU ',dod440_dust,pcols,lchnk) + call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) + call outfld('D440_BC ',dod440_bc ,pcols,lchnk) + call outfld('D440_POM',dod440_pom ,pcols,lchnk) + call outfld('D500_SS ',dod500_ss ,pcols,lchnk) + call outfld('D500_DU ',dod500_dust,pcols,lchnk) + call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) + call outfld('D500_BC ',dod500_bc ,pcols,lchnk) + call outfld('D500_POM',dod500_pom ,pcols,lchnk) + call outfld('D550_SS ',dod550_ss ,pcols,lchnk) + call outfld('D550_DU ',dod550_dust,pcols,lchnk) + call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) + call outfld('D550_BC ',dod550_bc ,pcols,lchnk) + call outfld('D550_POM',dod550_pom ,pcols,lchnk) + call outfld('D670_SS ',dod670_ss ,pcols,lchnk) + call outfld('D670_DU ',dod670_dust,pcols,lchnk) + call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) + call outfld('D670_BC ',dod670_bc ,pcols,lchnk) + call outfld('D670_POM',dod670_pom ,pcols,lchnk) + call outfld('D870_SS ',dod870_ss ,pcols,lchnk) + call outfld('D870_DU ',dod870_dust,pcols,lchnk) + call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) + call outfld('D870_BC ',dod870_bc ,pcols,lchnk) + call outfld('D870_POM',dod870_pom ,pcols,lchnk) + call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) + call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) + call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) + call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) + call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) + call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) + call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) + call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) + call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) + call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) +!tst +! call outfld('DOD5503D',dod5503d,pcols,lchnk) +!tst +!- call outfld('ABS5503D',abs5503d,pcols,lchnk) +!- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) +!- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) +!- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) +!- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) +!- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) +!- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) +!- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) +!- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) +!- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) +!- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) +!- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) +!- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) +!- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) +!- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) +!- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) +!- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) +!- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) +!- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) +!- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) +!- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) +!- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) +!- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) +!- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) +!- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) +!- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) + + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + +! Dry parameters of each aerosol component +! BC(ax) mode + call intdrypar0(lchnk, ncol, Nnatk, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) +! SO4&SOA(Ait,n) mode + call intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, & + xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) +! BC(Ait,n) and OC(Ait,n) modes + call intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) +! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead + call intdrypar4(lchnk, ncol, Nnatk, & + xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) +! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: + call intdrypar5to10(lchnk, ncol, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) + + do k=1,pver + do icol=1,ncol + c_ss(icol,k)=0.0_r8 + c_mi(icol,k)=0.0_r8 + enddo + enddo + + do k=1,pver + do icol=1,ncol +! mineral and sea-salt background concentrations, internally mixed + c_mi(icol,k) = Nnatk(icol,k,6)*cintbg(icol,k,6) & + +Nnatk(icol,k,7)*cintbg(icol,k,7) + c_mi05(icol,k) = Nnatk(icol,k,6)*cintbg05(icol,k,6) & + +Nnatk(icol,k,7)*cintbg05(icol,k,7) + c_mi125(icol,k) = Nnatk(icol,k,6)*cintbg125(icol,k,6)& + +Nnatk(icol,k,7)*cintbg125(icol,k,7) + c_ss(icol,k) = Nnatk(icol,k,8)*cintbg(icol,k,8) & + +Nnatk(icol,k,9)*cintbg(icol,k,9) & + +Nnatk(icol,k,10)*cintbg(icol,k,10) + c_ss05(icol,k) = Nnatk(icol,k,8)*cintbg05(icol,k,8) & + +Nnatk(icol,k,9)*cintbg05(icol,k,9) & + +Nnatk(icol,k,10)*cintbg05(icol,k,10) + c_ss125(icol,k) = Nnatk(icol,k,8)*cintbg125(icol,k,8)& + +Nnatk(icol,k,9)*cintbg125(icol,k,9) & + +Nnatk(icol,k,10)*cintbg125(icol,k,10) +! internally mixed bc and oc (from coagulation) and so4 concentrations +! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: +! necessary for calculation of volume fractions!), and total aerosol surface +! areas and volumes. + c_bc(icol,k)=0.0_r8 + c_bc05(icol,k)=0.0_r8 + c_bc125(icol,k)=0.0_r8 + c_oc(icol,k)=0.0_r8 + c_oc05(icol,k)=0.0_r8 + c_oc125(icol,k)=0.0_r8 + c_s4(icol,k)=0.0_r8 + c_s4_a(icol,k)=0.0_r8 + c_s4_1(icol,k)=0.0_r8 + c_s4_5(icol,k)=0.0_r8 + c_sa(icol,k)=0.0_r8 + c_sa05(icol,k)=0.0_r8 + c_sa125(icol,k)=0.0_r8 + c_sc(icol,k)=0.0_r8 + c_sc05(icol,k)=0.0_r8 + c_sc125(icol,k)=0.0_r8 + aaeros_tot(icol,k)=0.0_r8 + aaerol_tot(icol,k)=0.0_r8 + vaeros_tot(icol,k)=0.0_r8 + vaerol_tot(icol,k)=0.0_r8 + c_bc_0(icol,k)=0.0_r8 + c_bc_2(icol,k)=0.0_r8 + c_bc_4(icol,k)=0.0_r8 + c_bc_12(icol,k)=0.0_r8 + c_bc_14(icol,k)=0.0_r8 + c_oc_4(icol,k)=0.0_r8 + c_oc_14(icol,k)=0.0_r8 +!akc6+ + c_tot(icol,k)=0.0_r8 + c_tot125(icol,k)=0.0_r8 + c_tot05(icol,k)=0.0_r8 + c_pm25(icol,k)=0.0_r8 + c_pm1(icol,k)=0.0_r8 + mmr_pm25(icol,k)=0.0_r8 + mmr_pm1(icol,k)=0.0_r8 +!akc6- + + do i=0,nbmodes + if(i.ne.3) then + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,i)*cintbc(icol,k,i) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,i)*cintbc05(icol,k,i) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,i)*cintbc125(icol,k,i) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,i)*cintoc(icol,k,i) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,i)*cintoc05(icol,k,i) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,i)*cintoc125(icol,k,i) + c_sa(icol,k) = c_sa(icol,k) & + +Nnatk(icol,k,i)*cintsa(icol,k,i) + c_sa05(icol,k) = c_sa05(icol,k) & + +Nnatk(icol,k,i)*cintsa05(icol,k,i) + c_sa125(icol,k) = c_sa125(icol,k) & + +Nnatk(icol,k,i)*cintsa125(icol,k,i) + c_sc(icol,k) = c_sc(icol,k) & + +Nnatk(icol,k,i)*cintsc(icol,k,i) + c_sc05(icol,k) = c_sc05(icol,k) & + +Nnatk(icol,k,i)*cintsc05(icol,k,i) + c_sc125(icol,k) = c_sc125(icol,k) & + +Nnatk(icol,k,i)*cintsc125(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) & + +Nnatk(icol,k,i)*aaeros(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) & + +Nnatk(icol,k,i)*aaerol(icol,k,i) + vaeros_tot(icol,k) =vaeros_tot(icol,k) & + +Nnatk(icol,k,i)*vaeros(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) & + +Nnatk(icol,k,i)*vaerol(icol,k,i) + endif + enddo +! add dry aerosol area and volume of externally mixed modes + do i=nbmp1,nmodes + aaeros_tot(icol,k) = aaeros_tot(icol,k) & + +Nnatk(icol,k,i)*aaerosn(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) & + +Nnatk(icol,k,i)*aaeroln(icol,k,i) + vaeros_tot(icol,k) =vaeros_tot(icol,k) & + +Nnatk(icol,k,i)*vaerosn(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) & + +Nnatk(icol,k,i)*vaeroln(icol,k,i) + end do +!c_er3d +! Effective radii for particles smaller and greater than 0.5um, +! and for all radii, in each layer (er=3*V/A): + erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) & + /(aaeros_tot(icol,k)+eps) + ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) & + /(aaerol_tot(icol,k)+eps) + er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) & + /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) +!c_er3d +! column integrated dry aerosol surface areas and volumes +! for r<0.5um and r>0.5um (s and l, respectively). + aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) + aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) + vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) + vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) +! then add background and externally mixed BC, OC and SO4 to mass concentrations + c_bc_ac(icol,k)= c_bc(icol,k) + c_bc_0(icol,k) = Nnatk(icol,k,0)*cintbg(icol,k,0) + c_bc_2(icol,k) = Nnatk(icol,k,2)*cintbg(icol,k,2) + c_bc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) + c_bc_12(icol,k)= Nnatk(icol,k,12)*cknorm(icol,k,12) + c_bc_14(icol,k)= Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,2)*cintbg(icol,k,2) & + +Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg(icol,k,0) & + +Nnatk(icol,k,12)*cknorm(icol,k,12) & + +Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,2)*cintbg05(icol,k,2) & + +Nnatk(icol,k,4)*cintbg05(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg05(icol,k,0) & + +Nnatk(icol,k,12)*cknlt05(icol,k,12) & + +Nnatk(icol,k,14)*cknlt05(icol,k,14)*fnbc(icol,k) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,2)*cintbg125(icol,k,2) & + +Nnatk(icol,k,4)*cintbg125(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg125(icol,k,0) & + +Nnatk(icol,k,12)*ckngt125(icol,k,12) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) + c_oc_ac(icol,k)= c_oc(icol,k) + c_oc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) + c_oc_14(icol,k) = Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,1)*cintbg(icol,k,1)*f_soana(icol,k) & +!-3 +Nnatk(icol,k,3)*cintbg(icol,k,3) & + +Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,1)*cintbg05(icol,k,1)*f_soana(icol,k) & +!-3 +Nnatk(icol,k,3)*cintbg05(icol,k,3) & + +Nnatk(icol,k,4)*cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,1)*cintbg125(icol,k,1)*f_soana(icol,k) & +!-3 +Nnatk(icol,k,3)*cintbg125(icol,k,3) & + +Nnatk(icol,k,4)*cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & + +Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg(icol,k,5) + c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & + +Nnatk(icol,k,1)*cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg05(icol,k,5) + c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & + +Nnatk(icol,k,1)*cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg125(icol,k,5) + +!akc6+ + c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) & + + c_mi(icol,k) + c_ss(icol,k) + c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) & + + c_mi125(icol,k) + c_ss125(icol,k) + c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) & + + c_mi05(icol,k) + c_ss05(icol,k) + c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) + c_pm1(icol,k) = c_tot05(icol,k) +! mass mixing ratio: + mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) + mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) +!akc6- + +! converting from S to SO4 concentrations is no longer necessary, since +! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo +! c_s4(icol,k)=c_s4(icol,k)/3._r8 +! c_s405(icol,k)=c_s405(icol,k)/3._r8 +! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 + + c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) + c_s4_1(icol,k) = Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) + c_s4_5(icol,k) = Nnatk(icol,k,5)*cintbg05(icol,k,5) + + end do ! icol + enddo ! k + +! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) + do icol=1,ncol +! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & +! + c_mi(icol,pver) + c_ss(icol,pver) +! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & +! + c_mi125(icol,pver) + c_ss125(icol,pver) +! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) +!akc6+ + c_tots(icol) = c_tot(icol,pver) + c_tot125s(icol) = c_tot125(icol,pver) + c_pm25s(icol) = c_pm25(icol,pver) +!akc6- + enddo + +! Effective, column integrated, radii for particles +! smaller and greater than 0.5um, and for all radii + do icol=1,ncol + derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) + dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) + der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) & + /(aaercols(icol)+aaercoll(icol)+eps) + enddo + + do icol=1,ncol + dload_s4(icol)=0.0_r8 + dload_s4_a(icol)=0.0_r8 + dload_s4_1(icol)=0.0_r8 + dload_s4_5(icol)=0.0_r8 + dload_oc(icol)=0.0_r8 + dload_bc(icol)=0.0_r8 + dload_bc_ac(icol)=0.0_r8 + dload_bc_0(icol)=0.0_r8 + dload_bc_2(icol)=0.0_r8 + dload_bc_4(icol)=0.0_r8 + dload_bc_12(icol)=0.0_r8 + dload_bc_14(icol)=0.0_r8 + dload_oc_ac(icol)=0.0_r8 + dload_oc_4(icol)=0.0_r8 + dload_oc_14(icol)=0.0_r8 + do k=1,pver +! Layer thickness, unit km +!- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + deltah=deltah_km(icol,k) +! Modal and total mass concentrations for clean and dry aerosol, +! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. +! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. + do i=0,nmodes + ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) + dload3d(icol,k,i)=ck(icol,k,i)*deltah + dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) + enddo + nnat_0(icol,k) =Nnatk(icol,k,0) + nnat_1(icol,k) =Nnatk(icol,k,1) + nnat_2(icol,k) =Nnatk(icol,k,2) + nnat_4(icol,k) =Nnatk(icol,k,4) + nnat_5(icol,k) =Nnatk(icol,k,5) + nnat_6(icol,k) =Nnatk(icol,k,6) + nnat_7(icol,k) =Nnatk(icol,k,7) + nnat_8(icol,k) =Nnatk(icol,k,8) + nnat_9(icol,k) =Nnatk(icol,k,9) + nnat_10(icol,k)=Nnatk(icol,k,10) + nnat_12(icol,k)=Nnatk(icol,k,12) + nnat_14(icol,k)=Nnatk(icol,k,14) +! mineral and sea-salt mass concentrations + cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) + cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) +! Aerocom: Condensed water loading (mg_m2) + daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah +! just for checking purposes: + dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah + dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah + dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah + dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah + dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah + dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah +! + dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah + dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah + dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah + dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah + dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah + dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah + dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah + dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah + dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah +! + end do ! k + dload_mi(icol)=dload(icol,6)+dload(icol,7) + dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) + end do ! icol + +#ifdef COLTST4INTCONS +! Testing column burdens for internal consistency between intdrypar* +! (use of aerodryk*.out look-up tables) and calculations directly +! from the qm1 array. Will only work with #define AEROCOM. +! + call coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & + dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & + dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & + dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) +! +#ifdef AEROCOM + call outfld('CMDRY0 ',cmdry0 ,pcols,lchnk) + call outfld('CMDRY1 ',cmdry1 ,pcols,lchnk) + call outfld('CMDRY2 ',cmdry2 ,pcols,lchnk) + call outfld('CMDRY4 ',cmdry4 ,pcols,lchnk) + call outfld('CMDRY5 ',cmdry5 ,pcols,lchnk) + call outfld('CMDRY6 ',cmdry6 ,pcols,lchnk) + call outfld('CMDRY7 ',cmdry7 ,pcols,lchnk) + call outfld('CMDRY8 ',cmdry8 ,pcols,lchnk) + call outfld('CMDRY9 ',cmdry9 ,pcols,lchnk) + call outfld('CMDRY10 ',cmdry10 ,pcols,lchnk) + call outfld('CMDRY12 ',cmdry12 ,pcols,lchnk) + call outfld('CMDRY14 ',cmdry14 ,pcols,lchnk) +#endif +#endif ! COLTST4INTCONS + +! Internally and externally mixed dry concentrations (ug/m3) of +! SO4, BC and OC, for all r, r<0.5um and r>1.25um... +! call outfld('C_BCPM ',c_bc ,pcols,lchnk) +! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) +! call outfld('C_BC125 ',c_bc125,pcols,lchnk) +! call outfld('C_OCPM ',c_oc ,pcols,lchnk) +! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) +! call outfld('C_OC125 ',c_oc125,pcols,lchnk) +! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) +! call outfld('C_S405 ',c_s405 ,pcols,lchnk) +! call outfld('C_S4125 ',c_s4125,pcols,lchnk) +! ... and of background components for all r, r<0.5um and r>1.25um +! call outfld('C_MIPM ',c_mi ,pcols,lchnk) +! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) +! call outfld('C_MI125 ',c_mi125,pcols,lchnk) +! call outfld('C_SSPM ',c_ss ,pcols,lchnk) +! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) +! call outfld('C_SS125 ',c_ss125,pcols,lchnk) + call outfld('PMTOT ',c_tots ,pcols,lchnk) + call outfld('PM25 ',c_pm25s ,pcols,lchnk) +!akc6+ + call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) + call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) + call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) + call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) +!akc6- +! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) + call outfld('DLOAD_MI',dload_mi,pcols,lchnk) + call outfld('DLOAD_SS',dload_ss,pcols,lchnk) + call outfld('DLOAD_S4',dload_s4,pcols,lchnk) + call outfld('DLOAD_OC',dload_oc,pcols,lchnk) + call outfld('DLOAD_BC',dload_bc,pcols,lchnk) + + call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) + call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) + call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) + call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) + call outfld('LOADBC12',dload_bc_12,pcols,lchnk) + call outfld('LOADBC14',dload_bc_14,pcols,lchnk) + call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) + call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) + call outfld('LOADOC14',dload_oc_14,pcols,lchnk) +! condensed water mmr (kg/kg) + call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) +! condensed water loading (mg/m2) + call outfld('DAERH2O ',daerh2o ,pcols,lchnk) +! number concentrations (1/cm3) + call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) + call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) + call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) +!=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) + call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) + call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) + call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) + call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) + call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) + call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) + call outfld('NNAT_10 ',nnat_10,pcols,lchnk) +!=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) + call outfld('NNAT_12 ',nnat_12,pcols,lchnk) +!=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) + call outfld('NNAT_14 ',nnat_14,pcols,lchnk) +!akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 + +!c_er3d +! effective dry radii (um) in each layer +! call outfld('ERLT053D',erlt053d,pcols,lchnk) +! call outfld('ERGT053D',ergt053d,pcols,lchnk) +! call outfld('ER3D ',er3d ,pcols,lchnk) +!c_er3d +! column integrated effective dry radii (um) + call outfld('DERLT05 ',derlt05,pcols,lchnk) + call outfld('DERGT05 ',dergt05,pcols,lchnk) + call outfld('DER ',der ,pcols,lchnk) +! + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + +! Extra AeroCom diagnostics requiring table look-ups with RH = constant + +#ifdef AEROCOM_INSITU + irfmax=6 +#else + irfmax=1 +#endif ! AEROCOM_INSITU + +! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) + do irf=1,irfmax + do k=1,pver + do icol=1,ncol + xrhnull(icol,k)=xrhrf(irf) + irh1null(icol,k)=irhrf1(irf) + end do + enddo + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & + bext440, bext500, bext550, bext670, bext870, & + bebg440, bebg500, bebg550, bebg670, bebg870, & + bebc440, bebc500, bebc550, bebc670, bebc870, & + beoc440, beoc500, beoc550, beoc670, beoc870, & + besu440, besu500, besu550, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + backsc550, babg550, babc550, baoc550, basu550, & + bext440n, bext500n, bext550n, bext670n, bext870n, & + bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & + bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & + beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & + besu440n, besu500n, besu550n, besu670n, besu870n, & + babs440n, babs500n, babs550n, babs670n, babs870n, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & + backsc550n, babg550n, babc550n, baoc550n, basu550n) + end do ! irf + +!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + +#endif ! ***********AEROCOM***********AEROCOM**************AEROCOM***************above + + + return +end subroutine pmxsub + +end module pmxsub_mod diff --git a/src/physics/cam_oslo/preprocessorDefinitions.h b/src/physics/cam_oslo/preprocessorDefinitions.h new file mode 100644 index 0000000000..a666051540 --- /dev/null +++ b/src/physics/cam_oslo/preprocessorDefinitions.h @@ -0,0 +1,4 @@ +#undef AEROCOM +#undef AEROFFL +#undef COLTST4INTCONS +#undef AEROCOM_INSITU diff --git a/src/physics/cam_oslo/ptaero_table.F90 b/src/physics/cam_oslo/ptaero_table.F90 new file mode 100644 index 0000000000..664c708c5b --- /dev/null +++ b/src/physics/cam_oslo/ptaero_table.F90 @@ -0,0 +1,280 @@ +module ptaero_table + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + save + + integer, parameter :: max_table_rank = 4 + + type one_dim_array_t + real(r8), allocatable :: values(:) + end type + + type ptaero_table_t + integer :: rank !table rank + integer, dimension(max_table_rank) :: dims !Dimension + real(r8), dimension(:,:,:,:), allocatable :: values !Table data + TYPE(one_dim_array_t), dimension(:), allocatable :: axisValues !axis values + end type ptaero_table_t + + + +contains + + subroutine construct(table) + TYPE(ptaero_table_t), intent(inout) :: table + + if(allocated(table%values))deallocate(table%values) + if(allocated(table%values))deallocate(table%axisValues) + table%dims(:)=1 + table%rank = 0 + end subroutine construct + + + subroutine initialize(table, mixture_id, property_id, limits1, limits2, limits3, limits4, data2d, data3d, data4d) + implicit none + TYPE(ptaero_table_t), intent(inout) :: table + integer, intent(in) :: mixture_id !mixture id + integer, intent(in) :: property_id !property (e.g. ssa, sigma, radius, whatever) + real(r8), dimension(:,:), intent(in), optional :: data2d !2d data + real(r8), dimension(:,:,:), intent(in), optional :: data3d !3d data + real(r8), dimension(:,:,:,:), intent(in), optional :: data4d !4d data + real(r8), dimension(:),intent(in),optional :: limits1 + real(r8), dimension(:), intent(in),optional :: limits2 + real(r8), dimension(:), intent(in),optional :: limits3 + real(r8), dimension(:), intent(in),optional :: limits4 + + integer :: i + + !Local variables + logical tableFound + + !local + tableFound=.FALSE. + + if(allocated(table%values))then + stop "error" + end if + + !Find the rank + if(present(data2d))then + table%rank = 2 + tableFound = .TRUE. + table%dims(1) = SIZE(data2d,1) + table%dims(2) = SIZE(data2d,2) + endif + if(present(data3d))then + table%rank = 3 + if(tableFound .eqv. .TRUE.)then + stop "error" + end if + tableFound=.TRUE. + table%dims(1) = SIZE(data3d,1) + table%dims(2) = SIZE(data3d,2) + table%dims(3) = SIZE(data3d,3) + end if + if(present(data4d))then + table%rank = 4 + if(tableFound .eqv. .TRUE.)then + stop "error" + end if + tableFound=.TRUE. + table%dims(1) = SIZE(data4d,1) + table%dims(2) = SIZE(data4d,2) + table%dims(3) = SIZE(data4d,3) + table%dims(4) = SIZE(data4d,4) + end if + + allocate(table%values(table%dims(1), table%dims(2), table%dims(3), table%dims(4))) + + !Allocate space for axis values + allocate(table%axisValues(table%rank)) + do i=1,table%rank + allocate(table%axisValues(i)%values(table%dims(i))) + end do + + do i=1,table%rank + select case(i) + case(1) + table%axisValues(i)%values(:)=limits1(:) + case(2) + table%axisValues(i)%values(:)=limits2(:) + case(3) + table%axisValues(i)%values(:)=limits3(:) + case(4) + table%axisValues(i)%values(:)=limits4(:) + end select + end do + + select case(table%rank) + case(2) + table%values(:,:,1,1) = data2d(:,:) + case(3) + table%values(:,:,:,1) = data3d(:,:,:) + case(4) + table%values(:,:,:,:) = data4d(:,:,:,:) + end select + + end subroutine initialize + + !Search for the property along the array limits + recursive function binary_search(arraylimits, numberToFind, iGuess, iLow, iHigh) result(lowLimitIndex) + implicit none + real(r8), dimension(:),intent(in) :: arrayLimits !Limits along the axis we are searching + real(r8), intent(in) :: numberToFind !The property we are trying to find along the axis + + integer, intent(inout) :: iGuess !Guessed index + integer,intent(inout) :: iLow !Lowest possible index + integer, intent(inout) :: iHigh !Highest possible index + + integer :: lowLimitIndex + + if(numberToFind .lt. arrayLimits(iGuess))then + iHigh = iGuess + iGuess = int(0.5_r8*(iLow+iHigh)) + lowLimitIndex=binary_search(arrayLimits, numberToFind, iGuess, iLow, iHigh) + else if (numberToFind .gt. arrayLimits(iGuess+1))then + iLow = iGuess+1 + iGuess = int(0.5_r8*(iLow+iHigh)) + lowLimitIndex = binary_search(arrayLimits, numberToFind, iGuess, iLow, iHigh) + else !property is between iGuess and iGuess+1 ==> we are ok + lowLimitIndex = iLow + end if + end function binary_search + + + !Search and obtain the value + function searchGetValue(table, axisValuesToFind ) RESULT(output) + implicit none + TYPE(ptaero_table_t), intent(in) :: table + real(r8), dimension(:), intent(in) :: axisValuesToFind !array of numbers on axis + + !local variables + integer, dimension(max_table_rank) :: lowLimit !index of axis value below + integer, dimension(max_table_rank) :: highLimit !index of axis value above + real(r8), dimension(max_table_rank):: lowFraction + real(r8), dimension(max_table_rank):: highFraction + real(r8) :: output + + integer :: iGuess + integer :: iLow + integer :: iHigh + integer :: i + + !Get the indexes in question + do i = 1, table%rank + iLow=1 + iHigh = table%dims(i) + iGuess = int(0.5_r8*(iLow+iHigh)) !Guess middle value + lowLimit(i) = binary_search(table%axisValues(i)%values, axisValuesToFind(i), iGuess, iLow, iHigh ) + highLimit(i) = lowLimit(i)+1 + end do + + do i=1,table%rank + !High fraction is distance to low value divided by total distance + highFraction(i) = (axisValuesToFind(i)-table%axisValues(i)%values(lowLimit(i))) & + /(table%axisValues(i)%values(highLimit(i)) - table%axisValues(i)%values(lowLimit(i))) + !Low fraction is one minus high + lowFraction(i) = 1.0_r8 - highFraction(i) + end do + + !Interpolate along table limits + call interpolate(table, lowLimit, highLimit, lowFraction, highFraction,output) + + end function searchGetValue + + + !****************************************************************** + !Interpolate given that you know which indexes you are interested in + subroutine interpolate(table, lowLimits, highLimits, lowFraction, highFraction,answer) + implicit none + type(ptaero_table_t),intent(in) :: table + integer, intent(in), dimension(:) :: lowLimits + integer, intent(in), dimension(:) :: highLimits + real(r8), intent(in), dimension(:) :: lowFraction + real(r8), intent(in), dimension(:) :: highFraction + real(r8), intent(out) :: answer + + real(r8) , dimension(2,2,2) :: tmp3D + real(r8) , dimension(2,2) :: tmp2D + real(r8) , dimension(2) :: tmp1D + + if(table%rank .eq. 3) then + call extract3D(table%values(:,:,:,1), tmp3D, lowLimits, highLimits) + call interpolate3D(tmp3D, tmp2D, tmp1d, answer, highFraction, lowFraction) + elseif(table%rank .eq. 2) then + !call extract2D(table%values(:,:,1,1), tmp2D, lowLimits, highLimits) + call interpolate2D(tmp2D, tmp1d, answer, lowFraction, highFraction) + else if (table%rank .eq. 1)then + !call extract1D(table%values(:,1,1,1,1), tmp1D, lowLimits, highLimits) + call interpolate1D(tmp1D, answer, lowFraction, highFraction) + end if + + end subroutine + + !Extract a compact 3D-array from the table + subroutine extract3D(tmpIn, tmpOut, lowLimits, highLimits) + implicit none + real(r8), dimension(:,:,:),intent(in) :: tmpIn !Full data array + real(r8), dimension(2,2,2),intent(out) :: tmpOut !Extracted, condensed array + integer, dimension(:) :: lowLimits + integer, dimension(:) :: highLImits + + tmpOut(1,1,1)=tmpIn(lowLimits(1),lowLimits(2),lowLimits(3)) + tmpOut(1,1,2)=tmpIn(lowLimits(1),lowLimits(2),highLimits(3)) + + tmpOut(1,2,1)=tmpIn(lowLimits(1),highLimits(2),lowLimits(3)) + tmpOut(1,2,2)=tmpIn(lowLimits(1),highLimits(2),highLimits(3)) + + tmpOut(2,1,1)=tmpIn(highLimits(1),lowLimits(2),lowLimits(3)) + tmpOut(2,1,2)=tmpIn(highLimits(1),lowLimits(2),highLimits(3)) + + tmpOut(2,2,1)=tmpIn(highLimits(1),highLimits(2),lowLimits(3)) + tmpOut(2,2,2)=tmpIn(highLimits(1),highLimits(2),highLimits(3)) + end subroutine + + !Remove dimension 3 and send back a 2d-array + subroutine interpolate3D(tmp3D, tmp2D, tmp1d, answer, lowFraction, highFraction) + implicit none + real(r8), dimension(2,2,2), intent(in) :: tmp3D + real(r8), dimension(2,2),intent(inout) :: tmp2D + real(r8), dimension(2), intent(inout) :: tmp1d + real(r8) :: answer + real(r8), intent(in), dimension(:) :: highFraction + real(r8), intent(in), dimension(:) :: lowFraction + + tmp2D(1,1) = lowFraction(3)*tmp3D(1,1,1) + highFraction(3)*tmp3D(1,1,2) + tmp2D(1,2) = lowFraction(3)*tmp3D(1,2,1) + highFraction(3)*tmp3D(1,2,2) + tmp2D(2,1) = lowFraction(3)*tmp3D(2,1,1) + highFraction(3)*tmp3D(2,1,2) + tmp2D(2,2) = lowFraction(3)*tmp3D(2,2,1) + highFraction(3)*tmp3D(2,2,2) + + call interpolate2D(tmp2D, tmp1D, answer, lowFraction, highFraction) + + end subroutine + + !Remove dimension 2 and send back a 1d-array + subroutine interpolate2D(tmp2D, tmp1D, answer, lowFraction, highFraction) + implicit none + real(r8), dimension(2,2),intent(in) :: tmp2D + real(r8), dimension(2), intent(inout) :: tmp1D + real(r8), dimension(:), intent(in) :: lowFraction + real(r8), dimension(:), intent(in) :: highFraction + real(r8),intent(out) :: answer + + tmp1D(1) = lowFraction(2)*tmp2D(1,1) + highFraction(2)*tmp2D(1,2) + tmp1D(2) = lowFraction(2)*tmp2D(2,1) + highFraction(2)*tmp2D(2,2) + + call interpolate1D(tmp1D, answer, lowFraction, highFraction) + end subroutine interpolate2D + + !Interpolate a 1d-array + subroutine interpolate1D(tmp1D, answer, lowFraction, highFraction) + implicit none + real(r8), intent(in), dimension(2) :: tmp1D + real(r8), intent(out) :: answer + real(r8), intent(in), dimension(:) :: lowFraction + real(r8), intent(in), dimension(:) :: highFraction + + answer = lowFraction(1)*tmp1D(1) + highFraction(1)*tmp1D(2) + end subroutine interpolate1D + +end module ptaero_table diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 new file mode 100644 index 0000000000..71e5697419 --- /dev/null +++ b/src/physics/cam_oslo/radiation.F90 @@ -0,0 +1,2037 @@ +module radiation + +!--------------------------------------------------------------------------------- +! +! CAM interface to RRTMG radiation parameterization +! +!--------------------------------------------------------------------------------- + +#include + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp, begchunk, endchunk +use physics_types, only: physics_state, physics_ptend +use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx +use camsrfexch, only: cam_out_t, cam_in_t +use physconst, only: cappa, cpair + +use time_manager, only: get_nstep, is_first_restart_step, & + get_curr_calday, get_step_size + +use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & + rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & + liqcldoptics, icecldoptics + +use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & + idx_sw_diag + +use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + +use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs + +use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active +use cam_history_support, only: fillvalue + +use pio, only: file_desc_t, var_desc_t, & + pio_int, pio_noerr, & + pio_seterrorhandling, pio_bcast_error, & + pio_inq_varid, pio_def_var, & + pio_put_var, pio_get_var + +use cam_abortutils, only: endrun +use error_messages, only: handle_err +use perf_mod, only: t_startf, t_stopf +use cam_logfile, only: iulog +#ifdef DIRIND +use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands +use pmxsub_mod, only: pmxsub +#endif + +implicit none +private +save + +public :: & + radiation_readnl, &! read namelist variables + radiation_register, &! registers radiation physics buffer fields + radiation_nextsw_cday, &! calendar day of next radiation calculation + radiation_do, &! query which radiation calcs are done this timestep + radiation_init, &! initialization + radiation_define_restart, &! define variables for restart + radiation_write_restart, &! write variables to restart + radiation_read_restart, &! read variables from restart + radiation_tend, &! compute heating rates and fluxes + rad_out_t ! type for diagnostic outputs + +integer,public, allocatable :: cosp_cnt(:) ! counter for cosp +integer,public :: cosp_cnt_init = 0 !initial value for cosp counter + +type rad_out_t + + real(r8) :: solin(pcols) ! Solar incident flux + + real(r8) :: qrsc(pcols,pver) + + real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA + + real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + + real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb + real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + + real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8) :: qrlc(pcols,pver) + + real(r8) :: flntc(pcols) ! Clear sky lw flux at model top + real(r8) :: flut(pcols) ! Upward flux at top of model + real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) :: lwcf(pcols) ! longwave cloud forcing + + real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb + real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb + real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause + + real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) + + real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) + real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files + + real(r8) :: cld_tau_cloudsim(pcols,pver) + real(r8) :: aer_tau400(pcols,0:pver) + real(r8) :: aer_tau550(pcols,0:pver) + real(r8) :: aer_tau700(pcols,0:pver) + +end type rad_out_t + +! Namelist variables + +integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) + ! or hours (negative). +integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) + ! or hours (negative). + +integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) + ! or hours (negative) SW/LW radiation will be + ! run continuously from the start of an + ! initial or restart run +logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations +!logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. +!#ifdef RFMIPIRF +! logical :: spectralflux = .true. ! calculate fluxes (up and down) per band. +!#else + logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. +!#endif + +! Physics buffer indices +integer :: qrs_idx = 0 +integer :: qrl_idx = 0 +integer :: su_idx = 0 +integer :: sd_idx = 0 +integer :: lu_idx = 0 +integer :: ld_idx = 0 +integer :: fsds_idx = 0 +integer :: fsns_idx = 0 +integer :: fsnt_idx = 0 +integer :: flns_idx = 0 +integer :: flnt_idx = 0 +integer :: cldfsnow_idx = 0 +integer :: cld_idx = 0 +#ifdef DIRIND +integer :: volc_idx = 0 +#endif + +character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) + +! averaging time interval for zenith angle +real(r8) :: dt_avg = 0._r8 + +! PIO descriptors (for restarts) +type(var_desc_t) :: cospcnt_desc + +!=============================================================================== +contains +!=============================================================================== + +subroutine radiation_readnl(nlfile) + + ! Read radiation_nl namelist group. + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + integer :: dtime ! timestep size + character(len=*), parameter :: sub = 'radiation_readnl' + + namelist /radiation_nl/ iradsw, iradlw, irad_always, & + use_rad_dt_cosz, spectralflux + +!#ifdef RFMIPIRF +! spectralflux = .true. ! calculate fluxes (up and down) per band. +!#endif + + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'radiation_nl', status=ierr) + if (ierr == 0) then + read(unitn, radiation_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") + call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") + call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") + call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") + call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") + + ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary + dtime = get_step_size() + if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) + if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) + if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) + + !----------------------------------------------------------------------- + ! Print runtime options to log. + !----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'RRTMG radiation scheme parameters:' + write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux + end if + +10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & + ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & + ' SW/LW calc done every timestep for first N steps. N=',i5/, & + ' Use average zenith angle: ',l5/, & + ' Output spectrally resolved fluxes: ',l5/) + +end subroutine radiation_readnl + +!================================================================================================ + +subroutine radiation_register + + ! Register radiation fields in the physics buffer + + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiation_data, only: rad_data_register + + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate + + call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux + call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux + call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux + + call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux + call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux + + ! If the namelist has been configured for preserving the spectral fluxes, then create + ! physics buffer variables to store the results. +! legg til #ifndef RFMIPIRF her ogsaa?! + if (spectralflux) then + call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) + call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) + call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) + call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) + end if + + call rad_data_register() + +end subroutine radiation_register + +!================================================================================================ + +function radiation_do(op, timestep) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in), optional:: timestep + logical :: radiation_do ! return value + + ! Local variables + integer :: nstep ! current timestep number + !----------------------------------------------------------------------- + + if (present(timestep)) then + nstep = timestep + else + nstep = get_nstep() + end if + + select case (op) + + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case default + call endrun('radiation_do: unknown operation:'//op) + + end select +end function radiation_do + +!================================================================================================ + +real(r8) function radiation_nextsw_cday() + + ! Return calendar day of next sw radiation calculation + + ! Local variables + integer :: nstep ! timestep counter + logical :: dosw ! true => do shosrtwave calc + integer :: offset ! offset for calendar day calculation + integer :: dTime ! integer timestep size + real(r8):: calday ! calendar day of + !----------------------------------------------------------------------- + + radiation_nextsw_cday = -1._r8 + dosw = .false. + nstep = get_nstep() + dtime = get_step_size() + offset = 0 + do while (.not. dosw) + nstep = nstep + 1 + offset = offset + dtime + if (radiation_do('sw', nstep)) then + radiation_nextsw_cday = get_curr_calday(offset=offset) + dosw = .true. + end if + end do + if(radiation_nextsw_cday == -1._r8) then + call endrun('error in radiation_nextsw_cday') + end if + +end function radiation_nextsw_cday + +!================================================================================================ + +subroutine radiation_init(pbuf2d) + + ! Initialize the radiation parameterization, add fields to the history buffer + + use physics_buffer, only: pbuf_get_index, pbuf_set_field + use phys_control, only: phys_getopts + use radsw, only: radsw_init + use radlw, only: radlw_init + use rad_solar_var, only: rad_solar_var_init + use radiation_data, only: rad_data_init + use cloud_rad_props, only: cloud_rad_props_init + use modal_aer_opt, only: modal_aer_opt_init + use rrtmg_state, only: rrtmg_state_init + use time_manager, only: is_first_step + + + ! arguments + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + integer :: icall, nmodes + logical :: active_calls(0:N_DIAG) + integer :: nstep ! current timestep number + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_vdiag ! output the variables used by the AMWG variability diag package + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: err + + integer :: dtime + !----------------------------------------------------------------------- + + call rad_solar_var_init() + call rrtmg_state_init() + call rad_data_init(pbuf2d) ! initialize output fields for offline driver + call radsw_init() + call radlw_init() + call cloud_rad_props_init() + + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) + end if + + + ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dtime = get_step_size() + dt_avg = iradsw*dtime + end if + + call phys_getopts(history_amwg_out = history_amwg, & + history_vdiag_out = history_vdiag, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + ! Determine whether modal aerosols are affecting the climate, and if so + ! then initialize the modal aerosol optics module + call rad_cnst_get_info(0, nmodes=nmodes) + if (nmodes > 0) call modal_aer_opt_init() + + ! "irad_always" is number of time steps to execute radiation continuously from start of + ! initial OR restart run + nstep = get_nstep() + if (irad_always > 0) then + nstep = get_nstep() + irad_always = irad_always + nstep + end if + + if (docosp) call cospsimulator_intr_init + + allocate(cosp_cnt(begchunk:endchunk)) + if (is_first_restart_step()) then + cosp_cnt(begchunk:endchunk) = cosp_cnt_init + else + cosp_cnt(begchunk:endchunk) = 0 + end if + + call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') + + call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + + ! get list of active radiation calls + call rad_cnst_get_call_list(active_calls) + + ! Add shortwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') + + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & + sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & + sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') +!#ifdef AEROFFL +! call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') +! call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') +!#endif + + if (history_amwg) then + call add_default('SOLIN'//diag(icall), 1, ' ') + call add_default('QRS'//diag(icall), 1, ' ') + call add_default('FSNT'//diag(icall), 1, ' ') + call add_default('FSNTC'//diag(icall), 1, ' ') + call add_default('FSNTOA'//diag(icall), 1, ' ') + call add_default('FSNTOAC'//diag(icall), 1, ' ') + call add_default('SWCF'//diag(icall), 1, ' ') + call add_default('FSNS'//diag(icall), 1, ' ') + call add_default('FSNSC'//diag(icall), 1, ' ') + call add_default('FSUTOA'//diag(icall), 1, ' ') + call add_default('FSDSC'//diag(icall), 1, ' ') + call add_default('FSDS'//diag(icall), 1, ' ') + endif + + end if + end do + +#ifdef AEROFFL + call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') +#endif + + if (scm_crm_mode) then + call add_default('FUS ', 1, ' ') + call add_default('FUSC ', 1, ' ') + call add_default('FDS ', 1, ' ') + call add_default('FDSC ', 1, ' ') + endif + + ! Add longwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') + call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & + sampling_seq='rad_lwsw') + call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& + sampling_seq='rad_lwsw') + call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & + sampling_seq='rad_lwsw') + call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') + + call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') + call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') + call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') + call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') + + if (history_amwg) then + call add_default('QRL'//diag(icall), 1, ' ') + call add_default('FLNT'//diag(icall), 1, ' ') + call add_default('FLNTC'//diag(icall), 1, ' ') + call add_default('FLNTCLR'//diag(icall), 1, ' ') + call add_default('FREQCLR'//diag(icall), 1, ' ') + call add_default('FLUT'//diag(icall), 1, ' ') + call add_default('FLUTC'//diag(icall), 1, ' ') + call add_default('LWCF'//diag(icall), 1, ' ') + call add_default('FLNS'//diag(icall), 1, ' ') + call add_default('FLNSC'//diag(icall), 1, ' ') + call add_default('FLDS'//diag(icall), 1, ' ') + endif + + end if + end do + + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') + + if (scm_crm_mode) then + call add_default ('FUL ', 1, ' ') + call add_default ('FULC ', 1, ' ') + call add_default ('FDL ', 1, ' ') + call add_default ('FDLC ', 1, ' ') + endif + + ! Heating rate needed for d(theta)/dt computation + call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') + + if ( history_budget .and. history_budget_histfile_num > 1 ) then + call add_default ('QRL ', history_budget_histfile_num, ' ') + call add_default ('QRS ', history_budget_histfile_num, ' ') + end if + + if (history_vdiag) then + call add_default('FLUT', 2, ' ') + call add_default('FLUT', 3, ' ') + end if + +end subroutine radiation_init + +!=============================================================================== + +subroutine radiation_define_restart(file) + + ! define variables to be written to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + call pio_seterrorhandling(File, PIO_BCAST_ERROR) + + if (docosp) then + ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) + end if + +end subroutine radiation_define_restart + +!=============================================================================== + +subroutine radiation_write_restart(file) + + ! write variables to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + if (docosp) then + ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) + end if + +end subroutine radiation_write_restart + +!=============================================================================== + +subroutine radiation_read_restart(file) + + ! read variables from restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + + integer :: err_handling + integer :: ierr + + type(var_desc_t) :: vardesc + !---------------------------------------------------------------------------- + + if (docosp) then + call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) + ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) + call pio_seterrorhandling(File, err_handling) + if (ierr /= PIO_NOERR) then + cosp_cnt_init = 0 + else + ierr = pio_get_var(File, vardesc, cosp_cnt_init) + end if + end if + +end subroutine radiation_read_restart + +!=============================================================================== + +subroutine radiation_tend( & +!#ifdef SPAERO +! state, ptend, pbuf, cam_out, cam_in, net_flx, xcdnc, rd_out) +!#else + state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) +!#endif + + !----------------------------------------------------------------------- + ! + ! Driver for radiation computation. + ! + ! Revision history: + ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. + ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. + ! + ! + ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the + ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. + !----------------------------------------------------------------------- + + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz + + use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + + use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & + snow_cloud_get_rad_props_lw, get_snow_optics_sw + use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw + use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw + + use rad_solar_var, only: get_variability + use radsw, only: rad_rrtmg_sw + use radlw, only: rad_rrtmg_lw + use radheat, only: radheat_tend + + use radiation_data, only: rad_data_write + use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & + num_rrtmg_levs + + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + +#ifdef DIRIND + use commondefinitions + use aerosoldef + use opttab, only: nbands, eps + use constituents, only: pcnst + use oslo_control, only: oslo_getopts + use physics_buffer, only: pbuf_get_index +!#ifdef SPAERO +! use time_manager, only: get_curr_date +! use physconst, only: rair +!#endif +#endif + +#ifdef DIRIND + real(r8) flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations + real(r8) volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode + integer :: band + character(len=3) :: c3 +#ifdef AEROFFL + logical idrf +#endif +#endif + + ! Arguments + type(physics_state), intent(in), target :: state + type(physics_ptend), intent(out) :: ptend + + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(out) :: net_flx(pcols) + + type(rad_out_t), target, optional, intent(out) :: rd_out + + + ! Local variables + type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object + ! if the argument is not present + logical :: write_output + + integer :: i, k + integer :: lchnk, ncol + logical :: dosw, dolw + +#ifdef DIRIND + real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr + real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) +#endif + real(r8) :: calday ! current calendar day + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: clat(pcols) ! current latitudes(radians) + real(r8) :: clon(pcols) ! current longitudes(radians) + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + + ! Gathered indices of day and night columns + ! chunk_column_index = IdxDay(daylight_column_index) + integer :: Nday ! Number of daylight columns + integer :: Nnite ! Number of night columns + integer :: IdxDay(pcols) ! Indices of daylight columns + integer :: IdxNite(pcols) ! Indices of night columns + + integer :: itim_old + + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate + real(r8), pointer :: fsds(:) ! Surface solar down flux + real(r8), pointer :: fsns(:) ! Surface solar absorbed flux + real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top + real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux + real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + + real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down + real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down + + ! tropopause diagnostic + integer :: troplev(pcols) + real(r8) :: p_trop(pcols) + + type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth + real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w + real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w + real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w + real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth + real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau + real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau + real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau + real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + +!#ifdef SPAERO + ! cloud radiative parameters are "in cloud" not "in cell" with SP aerosols +! real(r8) :: sp_liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth +! real(r8) :: sp_liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau +! real(r8) :: sp_liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w +! real(r8) :: sp_liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w +! real(r8) :: sp_cld_tau (nswbands,pcols,pver) ! liquid extinction optical depth +! real(r8) :: sp_cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau +! real(r8) :: sp_cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau +! real(r8) :: sp_cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau +! real(r8) :: sp_cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) +!#endif + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth + real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau + real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w + real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w + real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) + + ! combined cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) +!#ifdef SPAERO ! and for SP aerosols (only for SW) +! real(r8) :: sp_c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth +! real(r8) :: sp_c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau +! real(r8) :: sp_c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau +! real(r8) :: sp_c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau +!#endif + + real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band + + integer :: icall ! index through climate/diagnostic radiation calls + logical :: active_calls(0:N_DIAG) + + ! Aerosol radiative properties + real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + +#ifdef DIRIND + +!#ifdef SPAERO +! Aerosol optical properties, simple plume aerosols +! real(r8) :: sp_tau (pcols,pver,nswbands) ! aerosol extinction optical depth, simple plumes +! real(r8) :: sp_ssa (pcols,pver,nswbands) ! aerosol single scattering albedo, simple plumes +! real(r8) :: sp_asy (pcols,pver,nswbands) ! aerosol assymetry parameter, simple plumes +! +! Aerosol optical properties, sum of NorESM + simple plume aerosols +! real(r8) :: sp_per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth +! real(r8) :: sp_per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau +! real(r8) :: sp_per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau +! real(r8) :: sp_per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau +! +! real(r8), intent(out) :: xcdnc(pcols) ! CDNC modification factor +! real(r8) :: re_mult(pcols,pver) ! Multiplication factor of liquid cloud effective radius, simple plumes +! real(r8) :: re_multeq1(pcols,pver) ! Dummy multiplication factor (=1.0) of liquid cloud effective radius, simple plumes +! real(r8) :: xcdnceq1(pcols) ! Dummy xcdnc +! +!!ak real(r8) :: sp_relca(pcols,pver) ! Modified liquid cloud effective radius, simple plumes +! +! real(r8) :: year_fr ! Fractional year (1903.0 is the 0Z on the first of January 1903, Gregorian) +! +! integer :: yr, mon, day, tod ! date components +!#endif +!#ifdef RFMIPIRF +! real(r8) :: per_aod (pcols,pver,nswbands) ! aerosol single scattering albedo +! real(r8) :: per_ssa (pcols,pver,nswbands) ! aerosol single scattering albedo +! real(r8) :: per_asy (pcols,pver,nswbands) ! aerosol assymetry parameter +!#endif + +! Local variables used for calculating aerosol optics and direct and indirect forcings. +! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) +! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8) qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations + real(r8) aodvis(pcols) ! AOD vis + real(r8) absvis(pcols) ! absorptive AOD vis + real(r8) clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) +#ifdef AEROCOM + real(r8) dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) + real(r8) clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) +!#ifdef RFMIPIRF +! character(len=2) :: c2 +!#endif +#endif ! AEROCOM + real(r8) ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion + real(r8) Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration + real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) rhoda(pcols,pver) ! air mass density, unit kg/m^3 + real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn + integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn + real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) + real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + integer ns ! spectral loop index + real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 +!#ifdef SPAERO +! real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km +!#endif +#endif + + real(r8) :: fns(pcols,pverp) ! net shortwave flux + real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux + real(r8) :: fnl(pcols,pverp) ! net longwave flux + real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + + ! for COSP + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + + real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns + real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) + + character(*), parameter :: name = 'radiation_tend' + + logical, parameter :: cosz_rad_call=.true. !+tht + !-------------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + if (present(rd_out)) then + rd => rd_out + write_output = .false. + else + allocate(rd) + write_output=.true. + end if + + dosw = radiation_do('sw') ! do shortwave heating calc this timestep? + dolw = radiation_do('lw') ! do longwave heating calc this timestep? + + ! Cosine solar zenith angle for current time step + calday = get_curr_calday() + call get_rlat_all_p(lchnk, ncol, clat) + call get_rlon_all_p(lchnk, ncol, clon) + + call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & + delta, eccf) + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht + end do + + ! Gather night/day column indices. + Nday = 0 + Nnite = 0 + do i = 1, ncol + if ( coszrs(i) > 0.0_r8 ) then + Nday = Nday + 1 + IdxDay(Nday) = i + else + Nnite = Nnite + 1 + IdxNite(Nnite) = i + end if + end do + + ! Associate pointers to physics buffer fields + itim_old = pbuf_old_tim_idx() + if (cldfsnow_idx > 0) then + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, qrl_idx, qrl) + + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, flnt_idx, flnt) + + if (spectralflux) then + call pbuf_get_field(pbuf, su_idx, su) + call pbuf_get_field(pbuf, sd_idx, sd) + call pbuf_get_field(pbuf, lu_idx, lu) + call pbuf_get_field(pbuf, ld_idx, ld) + end if + + ! For CRM, make cloud equal to input observations: + if (scm_crm_mode .and. have_cld) then + do k = 1, pver + cld(:ncol,k)= cldobs(k) + end do + end if + +#ifdef DIRIND + qdirind(:ncol,:,:) = state%q(:ncol,:,:) + if (has_prescribed_volcaero) then + call oslo_getopts(volc_fraction_coarse_out = volc_fraction_coarse) + call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) + qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) + end if +#endif + ! Find tropopause height if needed for diagnostic output + if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then + call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) + endif + + if (dosw .or. dolw) then + + ! construct an RRTMG state object + r_state => rrtmg_state_create( state, cam_in ) + + call t_startf('cldoptics') + + if (cldfsnow_idx > 0) then + do k = 1, pver + do i = 1, ncol + cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) + end do + end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if + + + if (dosw) then + +!#ifdef SPAERO +!*********************************** SPAERO + ********************************************* +! Define anthrop. aerosol optical properties and "cdnc" for the "simple plumes" climatology + +! CALL get_curr_date(yr, mon, day, tod) + +! Petri used a hard-coded year for BACCHUS: either 1850, 1975 or 2005 + +! yr=2005 + +! year_fr = yr + (calday-1.0_r8) / 365.0_r8 + +!ak+ Need deltah_km before pmxsub is called, due to cloud optics (-> input to pmxsub later) +! do k=1,pver +!! NB have to multiply with 10 to get the same values as in pmxsub, due to different p units! +! rhoda(1:ncol,k) = state%pmid(1:ncol,k)/(rair*state%t(1:ncol,k)) ! unit kg/m^3 +! deltah_km(1:ncol,k)=10._r8*1.e-4_r8*(state%pint(1:ncol,k+1)-state%pint(1:ncol,k))/(rhoda(1:ncol,k)*9.8_r8) +! end do + +! initialization +! re_mult(1:ncol,1:pver) = 1._r8 +! xcdnc(1:ncol) = 1._r8 +! for use in calls without the effect of SP aerosols +! re_multeq1(1:ncol,1:pver) = 1._r8 +! xcdnceq1(1:ncol) = 1._r8 +!ak- + +! CALL simple_plumes_interface(lchnk, ncol, nswbands,state%phis, & +! deltah_km, clon, clat, year_fr, & +! sp_tau, sp_ssa, sp_asy, re_mult, xcdnc) + +! When using year 1850 for the MACv2-SP aerosols, switch them off entirely +! IF (yr==1850) THEN +! sp_tau(1:ncol,1:pver,1:nswbands)=0._r8 +! sp_ssa(1:ncol,1:pver,1:nswbands)=0._r8 +! sp_asy(1:ncol,1:pver,1:nswbands)=0._r8 +! re_mult(1:ncol,1:pver) = 1._r8 +! xcdnc(1:ncol) = 1._r8 +! END IF +!*********************************** SPAERO - ********************************************* +!#endif + + if (oldcldoptics) then + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + case ('mitchell') + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + case ('gammadist') + +!#ifdef SPAERO +! The order of the two calls below has been tested not to make any difference +! call get_liquid_optics_sw(state, pbuf, xcdnceq1, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) +! call get_liquid_optics_sw(state, pbuf, xcdnc, sp_liq_tau, sp_liq_tau_w, sp_liq_tau_w_g, sp_liq_tau_w_f) +!#else + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) +!#endif + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + end if + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) +!#ifdef SPAERO +! sp_cld_tau(:,:ncol,:) = sp_liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) +! sp_cld_tau_w(:,:ncol,:) = sp_liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) +! sp_cld_tau_w_g(:,:ncol,:) = sp_liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) +! sp_cld_tau_w_f(:,:ncol,:) = sp_liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) +!#endif + + if (cldfsnow_idx > 0) then + ! add in snow + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + do i = 1, ncol + do k = 1, pver + + if (cldfprime(i,k) > 0._r8) then + + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & + + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do +!#ifdef SPAERO +! do i = 1, ncol +! do k = 1, pver +! if (cldfprime(i,k) > 0._r8) then +! sp_c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & +! + cld(i,k)*sp_cld_tau(:,i,k) )/cldfprime(i,k) +! sp_c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & +! + cld(i,k)*sp_cld_tau_w(:,i,k) )/cldfprime(i,k) +! sp_c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & +! + cld(i,k)*sp_cld_tau_w_g(:,i,k) )/cldfprime(i,k) +! sp_c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & +! + cld(i,k)*sp_cld_tau_w_f(:,i,k) )/cldfprime(i,k) +! else +! sp_c_cld_tau(:,i,k) = 0._r8 +! sp_c_cld_tau_w(:,i,k) = 0._r8 +! sp_c_cld_tau_w_g(:,i,k) = 0._r8 +! sp_c_cld_tau_w_f(:,i,k) = 0._r8 +! end if +! end do +! end do +!#endif + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) +!#ifdef SPAERO +! sp_c_cld_tau(:,:ncol,:) = sp_cld_tau(:,:ncol,:) +! sp_c_cld_tau_w(:,:ncol,:) = sp_cld_tau_w(:,:ncol,:) +! sp_c_cld_tau_w_g(:,:ncol,:) = sp_cld_tau_w_g(:,:ncol,:) +! sp_c_cld_tau_w_f(:,:ncol,:) = sp_cld_tau_w_f(:,:ncol,:) +!#endif + end if + + ! Output cloud optical depth fields for the visible band + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) + rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! add fillvalue for night columns + do i = 1, Nnite + rd%tot_cld_vistau(IdxNite(i),:) = fillvalue + rd%tot_icld_vistau(IdxNite(i),:) = fillvalue + rd%liq_icld_vistau(IdxNite(i),:) = fillvalue + rd%ice_icld_vistau(IdxNite(i),:) = fillvalue + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + if (write_output) call radiation_output_cld(lchnk, ncol, rd) + + end if ! if (dosw) + + if (dolw) then + + if (oldcldoptics) then + call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) + case ('mitchell') + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) + case ('gammadist') + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + + end if + + if (cldfsnow_idx > 0) then + + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + + end if ! if (dolw) + + call t_stopf('cldoptics') + + ! Solar radiation computation + + if (dosw) then + +#ifdef DIRIND +!TEST +! qdirind(:ncol,:,l_soa_a1) = 0.0_r8 +! qdirind(:ncol,:,l_soa_na) = 0.0_r8 +! qdirind(:ncol,:,l_so4_a1) = 0.0_r8 +! qdirind(:ncol,:,l_so4_na) = 0.0_r8 +!TEST +!cak+ Calculate CAM5-Oslo/NorESM2 aerosol optical parameters +! (move to aer_rad_props.F90? No, then it cannot be called for night-time calculations...) +! +! Volcanic optics for solar (SW) bands + do band=1, solar_bands + volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 + volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 + volc_g_sun(1:ncol,1:pver,band)=0.5_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, solar_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif +! Volcanic optics for terrestrial (LW) bands (g is not used here) + do band=1, terrestrial_bands + volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 + volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, terrestrial_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + + volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif + + call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & + coszrs, state, state%t, cld, qdirind, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & +#ifdef AEROCOM + aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) +#else + aodvis, absvis) +#endif + +!#ifdef RFMIPIRF +!! Extra RFMIP-IRF diagnostics for each SW wave-length/number band +! per_aod(:,:,:)=0._r8 +! per_ssa(:,:,:)=0._r8 +! per_asy(:,:,:)=0._r8 +! DO i=1,ncol +!! DO k=0,pver +! DO k=1,pver +! DO ns=1,nswbands +! per_aod(i,k,ns)=per_tau(i,k,ns) +! per_ssa(i,k,ns)=min(per_tau_w(i,k,ns)/(per_tau(i,k,ns)+eps),1._r8) +! per_asy(i,k,ns)=min(per_tau_w_g(i,k,ns)/(per_tau_w(i,k,ns)+eps),1._r8) +! ENDDO +! ENDDO +! ENDDO +! do ns=1,nswbands +! write(c2,'(I2)') ns +! call outfld('AERTAUBND'//trim(adjustl(c2)),per_aod(:,:,ns),pcols,lchnk) +! call outfld('AERSSABND'//trim(adjustl(c2)),per_ssa(:,:,ns),pcols,lchnk) +! call outfld('AERASYBND'//trim(adjustl(c2)),per_asy(:,:,ns),pcols,lchnk) +! enddo +!#endif + +!#ifdef SPAERO +!*********************************** SPAERO + ********************************************* +! Use the anthropogenic aerosol optical properties for the "simple plumes" climatology + +! Add "simple plumes" to NorESM2 aerosols (which should be defined using year 1850 emissions) + +! Set aerosol optical properties zero for the top layer (0) +! sp_per_tau(1:ncol,0,1:nswbands) = 0._r8 +! sp_per_tau_w(1:ncol,0,1:nswbands) = 0._r8 +! sp_per_tau_w_g(1:ncol,0,1:nswbands) = 0._r8 +! sp_per_tau_w_f(1:ncol,0,1:nswbands) = 0._r8 + +! Other layers +! DO i=1,ncol +! DO k=1,pver +! DO ns=1,nswbands +! sp_per_tau(i,k,ns)=per_tau(i,k,ns) + sp_tau(i,k,ns) +! sp_per_tau_w(i,k,ns)=per_tau_w(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns) +! sp_per_tau_w_g(i,k,ns)=per_tau_w_g(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns)*sp_asy(i,k,ns) +! sp_per_tau_w_f(i,k,ns)=per_tau_w_f(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns)*sp_asy(i,k,ns)**2 +! ENDDO +! ENDDO +! ENDDO +!*********************************** SPAERO - ********************************************* +!#endif + +#endif ! DIRIND + + call get_variability(sfac) + + ! Get the active climate/diagnostic shortwave calculations + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the concentrations in the RRTMG state object + call rrtmg_state_update(state, pbuf, icall, r_state) + + !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & + ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) +#ifdef DIRIND +! A first call with Oslo aerosols set to zero for radiative forcing diagnostics +! follwoing the Ghan (2013) method: + +#ifdef AEROFFL ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore + ! (just nudged), but with an extra call with 0 aerosol extiction. +! +!akc6+ + idrf = .true. +!akc6- + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, & +!orig aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & + per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & +!akc6+ +!#ifdef AEROFFL +! cam_out%solld, fns, fcns, fds, fdsc, Nday, Nnite, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & +!#else +! cam_out%solld, fns, fcns, Nday, Nnite, & +!#endif +!akc6- + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + + ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! +!ak Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub + call outfld('QRS_DRF ',ftem ,pcols,lchnk) + ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair + call outfld('QRSC_DRF',ftem ,pcols,lchnk) + call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) + call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) + call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) + call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) +!#ifdef AEROCOM + call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) + call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) + ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) + call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) + call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) +!#endif + idrf = .false. +#endif ! AEROFFL +#endif ! DIRIND + + rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) + rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) + rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) + rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) + +! Then the usual call with Oslo aerosols for radiative forcing diagnostics + + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, & +#ifdef DIRIND + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & +#else + aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & +#endif + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & +!akc6+ +#ifdef AEROFFL +! cam_out%solld, fns, fcns, fds, fdsc, Nday, Nnite, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & +#else + cam_out%solld, fns, fcns, Nday, Nnite, & +#endif +!akc6- + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + +!#ifdef SPAERO + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! +! Added, as for BACCHUS by P. Räisänen +! call outfld('FSNT_SP ',fsnt ,pcols,lchnk) +! call outfld('FSNS_SP ',fsns ,pcols,lchnk) +! call outfld('FSNTC_SP',rd%fsntc ,pcols,lchnk) +! call outfld('FSNSC_SP',rd%fsnsc ,pcols,lchnk) +!#endif + + +!#ifdef SPAERO +!*********************************** SPAERO + ********************************************* +! THIRD CALL INCLUDING SIMPLE PLUME AEROSOLS FOR ONLY THE DIRECT EFFECT (SW ERF ari) + +! call rad_rrtmg_sw( & +! lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & +! cldfprime, & +!ak+ per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & +! sp_per_tau, sp_per_tau_w, sp_per_tau_w_g, sp_per_tau_w_f, & +!ak- +! eccf, coszrs, rd%solin, sfac, cam_in%asdir, & +! cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & +! fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & +! rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & +! rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & +!akc6+ +!#ifdef AEROFFL +! cam_out%solld, fns, fcns, idrf, Nday, Nnite, & +!#else +! cam_out%solld, fns, fcns, Nday, Nnite, & +!#endif +!akc6- +! IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & +! E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & +! E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! +! Added, as for BACCHUS by P. Räisänen +! call outfld('FSNT_SP2',fsnt ,pcols,lchnk) +! call outfld('FSNS_SP2',fsns ,pcols,lchnk) +! call outfld('FSNTCSP2',rd%fsntc ,pcols,lchnk) +! call outfld('FSNSCSP2',rd%fsnsc ,pcols,lchnk) + +! FOURTH CALL INCLUDING SIMPLE PLUME AEROSOLS FOR BOTH THE DIRECT AND THE 1. INDIRECT EFFECT + +! call rad_rrtmg_sw( & +! lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & +! cldfprime, & +!ak+ per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & +! sp_per_tau, sp_per_tau_w, sp_per_tau_w_g, sp_per_tau_w_f, & +!ak- +! eccf, coszrs, rd%solin, sfac, cam_in%asdir, & +! cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & +! fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & +! rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & +! rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & +!akc6+ +!#ifdef AEROFFL +! cam_out%solld, fns, fcns, idrf, Nday, Nnite, & +!#else +! cam_out%solld, fns, fcns, Nday, Nnite, & +!#endif +!akc6- +!ak+ IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & +!ak+ E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & +!ak+ E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) +! IdxDay, IdxNite, su, sd, E_cld_tau=sp_c_cld_tau, & +! E_cld_tau_w=sp_c_cld_tau_w, E_cld_tau_w_g=sp_c_cld_tau_w_g,& +! E_cld_tau_w_f=sp_c_cld_tau_w_f, old_convert=.false.) +!ak- + + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! +! Added, as for BACCHUS by P. Räisänen +! call outfld('FSNT_SP3',fsnt ,pcols,lchnk) +! call outfld('FSNS_SP3',fsns ,pcols,lchnk) +! call outfld('FSNTCSP3',rd%fsntc ,pcols,lchnk) +! call outfld('FSNSCSP3',rd%fsnsc ,pcols,lchnk) + +!*********************************** SPAERO + ********************************************* +!#endif + +!#ifdef RFMIPIRF +! Extra RFMIP-IRF diagnostics for each SW wave-length/number band +! do ns=1,nswbands +! write(c2,'(I2)') ns +! call outfld('SDBND'//trim(adjustl(c2)),sd(:,:,ns),pcols,lchnk) +! call outfld('SUBND'//trim(adjustl(c2)),su(:,:,ns),pcols,lchnk) +! enddo +!#endif + +!ak+ Has been moved from above to after the last rad_rrtmg_sw call... + ! Output net fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) + if (hist_fld_active('FSNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) + end do + end if + if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) +!ak- + end if + end do + + end if + +#ifdef DIRIND + !Calculate cloud-free fraction assuming random overlap + !(kind of duplicated from cloud_cover_diags::cldsav) + cloudfree(1:ncol) = 1.0_r8 + cloudfreemax(1:ncol) = 1.0_r8 + + !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) + do k = 1, pver + do i=1,ncol + cloudfree(i) = cloudfree(i) * cloudfreemax(i) + cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) + end do + end do + + !Calculate AOD (visible) for cloud free + do i = 1, ncol + clearodvis(i)=cloudfree(i)*aodvis(i) + clearabsvis(i)=cloudfree(i)*absvis(i) + end do +! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) +! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values + call outfld('CAODVIS ',clearodvis,pcols,lchnk) + call outfld('CABSVIS ',clearabsvis,pcols,lchnk) + call outfld('CLDFREE ',cloudfree,pcols,lchnk) +#ifdef AEROCOM + do i = 1, ncol + clearod440(i)=cloudfree(i)*dod440(i) + clearod550(i)=cloudfree(i)*dod550(i) + clearod870(i)=cloudfree(i)*dod870(i) + clearabs550(i)=cloudfree(i)*abs550(i) + clearabs550alt(i)=cloudfree(i)*abs550alt(i) + end do + call outfld('CDOD440 ',clearod440 ,pcols,lchnk) + call outfld('CDOD550 ',clearod550 ,pcols,lchnk) + call outfld('CDOD870 ',clearod870 ,pcols,lchnk) + call outfld('CABS550 ',clearabs550 ,pcols,lchnk) + call outfld('CABS550A',clearabs550alt,pcols,lchnk) +#endif ! AEROCOM +#endif ! DIRIND + + ! Output aerosol mmr + call rad_cnst_out(0, state, pbuf) + + ! Longwave radiation computation + + if (dolw) then + + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the conctrations in the RRTMG state object + call rrtmg_state_update( state, pbuf, icall, r_state) + + call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + +#ifdef DIRIND +#ifdef AEROFFL ! for calculation of direct and direct radiative forcing +! + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) + call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) +#endif ! AEROFFL +#endif ! DIRIND + + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & +#ifdef DIRIND + per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & +#else + aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & +#endif + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + +#ifdef DIRIND +#ifdef AEROFFL ! FLNT_ORG is just for temporary testing vs. FLNT +!#ifdef AEROCOM +! call outfld('FLNT_ORG',flnt(:) ,pcols,lchnk) + ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) + call outfld('FLUS ',ftem_1d ,pcols,lchnk) +!#endif ! AEROCOM +#endif ! AEROFFL +!#ifdef AEROCOM +! do i=1,ncol +! do k=1,pver +! aerlwabs01(i,k) = aer_lw_abs(i,k,16) +! end do +! end do +! call outfld('AERLWA01',aerlwabs01,pcols,lchnk) +!#endif + +!#ifdef RFMIPIRF +! Extra RFMIP-IRF diagnostics for each LW wave-length/number band +! do ns=1,nlwbands +! write(c2,'(I2)') ns +! call outfld('LDBND'//trim(adjustl(c2)),ld(:,:,ns),pcols,lchnk) +! call outfld('LUBND'//trim(adjustl(c2)),lu(:,:,ns),pcols,lchnk) +! enddo +!#endif + +#endif ! DIRIND + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) + if (hist_fld_active('FLNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) + end do + end if + + flntclr(:) = 0._r8 + freqclr(:) = 0._r8 + do i = 1, ncol + if (maxval(cldfprime(i,:)) <= 0.1_r8) then + freqclr(i) = 1._r8 + flntclr(i) = rd%flntc(i) + end if + end do + + if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + + end if + end do + + end if + + ! deconstruct the RRTMG state object + call rrtmg_state_destroy(r_state) + + if (docosp) then + + ! initialize and calculate emis + emis(:,:) = 0._r8 + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) + call outfld('EMIS', emis, pcols, lchnk) + + ! compute grid-box mean SW and LW snow optical depth for use by COSP + gb_snow_tau(:,:) = 0._r8 + gb_snow_lw(:,:) = 0._r8 + if (cldfsnow_idx > 0) then + do i = 1, ncol + do k = 1, pver + if (cldfsnow(i,k) > 0._r8) then + gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) + end if + end do + end do + end if + + ! advance counter for this timestep (chunk dimension required for thread safety) + cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 + + ! if counter is the same as cosp_nradsteps, run cosp and reset counter + if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then + + ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave + ! optical depths are passed. + call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& + snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + cosp_cnt(lchnk) = 0 + end if + end if + + else ! if (dosw .or. dolw) then + + ! convert radiative heating rates from Q*dp to Q for energy conservation + do k =1 , pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)/state%pdel(i,k) + qrl(i,k) = qrl(i,k)/state%pdel(i,k) + end do + end do + + end if ! if (dosw .or. dolw) then + + ! output rad inputs and resulting heating rates + call rad_data_write( pbuf, state, cam_in, coszrs ) + + ! Compute net radiative heating tendency + call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + fsnt, flns, flnt, cam_in%asdir, net_flx) + + if (write_output) then + ! Compute heating rate for dtheta/dt + do k = 1, pver + do i = 1, ncol + ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + end do + end do + call outfld('HR', ftem, pcols, lchnk) + end if + + ! convert radiative heating rates to Q*dp for energy conservation + do k = 1, pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)*state%pdel(i,k) + qrl(i,k) = qrl(i,k)*state%pdel(i,k) + end do + end do + + cam_out%netsw(:ncol) = fsns(:ncol) + + if (.not. present(rd_out)) then + deallocate(rd) + end if + +end subroutine radiation_tend + +!=============================================================================== + +subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + + ! Dump shortwave radiation information to history buffer. + + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + + ! local variables + real(r8), pointer :: qrs(:,:) + real(r8), pointer :: fsnt(:) + real(r8), pointer :: fsns(:) + real(r8), pointer :: fsds(:) + + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsds_idx, fsds) + + call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) + + call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) + call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) + call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) + call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) + + ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) + call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) + + call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) + + call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) + call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) + call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) + + call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) + call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) + + call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) + + call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) + call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) + call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) + call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) + + call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) + call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) + + call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) + call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) + +end subroutine radiation_output_sw + + +!=============================================================================== + +subroutine radiation_output_cld(lchnk, ncol, rd) + + ! Dump shortwave cloud optics information to history buffer. + + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + type(rad_out_t), intent(in) :: rd + !---------------------------------------------------------------------------- + + call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) + call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) + call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) + call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) + if (cldfsnow_idx > 0) then + call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) + endif + +end subroutine radiation_output_cld + +!=============================================================================== + +subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + + ! Dump longwave radiation information to history buffer + + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall ! icall=0 for climate diagnostics + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + real(r8), intent(in) :: freqclr(pcols) + real(r8), intent(in) :: flntclr(pcols) + + ! local variables + real(r8), pointer :: qrl(:,:) + real(r8), pointer :: flnt(:) + real(r8), pointer :: flns(:) + + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- + + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, flnt_idx, flnt) + call pbuf_get_field(pbuf, flns_idx, flns) + + call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) + + call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) + call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) + + call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) + call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) + + call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) + call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) + + ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) + call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) + + call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) + call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) + + call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) + + call outfld('FLNS'//diag(icall), flns, pcols, lchnk) + call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) + + call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) + call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) + +end subroutine radiation_output_lw + +!=============================================================================== + +subroutine calc_col_mean(state, mmr_pointer, mean_value) + + ! Compute the column mean mass mixing ratio. + + type(physics_state), intent(in) :: state + real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) + real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr + + integer :: i, k, ncol + real(r8) :: ptot(pcols) + !----------------------------------------------------------------------- + + ncol = state%ncol + mean_value = 0.0_r8 + ptot = 0.0_r8 + + do k=1,pver + do i=1,ncol + mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) + ptot(i) = ptot(i) + state%pdeldry(i,k) + end do + end do + do i=1,ncol + mean_value(i) = mean_value(i) / ptot(i) + end do + +end subroutine calc_col_mean + +!=============================================================================== + +end module radiation + diff --git a/src/physics/cam_oslo/radlw.F90 b/src/physics/cam_oslo/radlw.F90 new file mode 100644 index 0000000000..df8dd0c4b5 --- /dev/null +++ b/src/physics/cam_oslo/radlw.F90 @@ -0,0 +1,324 @@ + +module radlw +!----------------------------------------------------------------------- +! +! Purpose: Longwave radiation calculations. +! +!----------------------------------------------------------------------- + +!akc6+ +#include +!akc6- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use scamMod, only: single_column, scm_crm_mode +use parrrtm, only: nbndlw, ngptlw +use rrtmg_lw_init, only: rrtmg_lw_ini +use rrtmg_lw_rad, only: rrtmg_lw +use spmd_utils, only: masterproc +use perf_mod, only: t_startf, t_stopf +use cam_logfile, only: iulog +use cam_abortutils, only: endrun +use radconstants, only: nlwbands + +implicit none + +private +save + +! Public methods + +public ::& + radlw_init, &! initialize constants + rad_rrtmg_lw ! driver for longwave radiation code + +! Private data +integer :: ntoplw ! top level to solve for longwave cooling + +! Flag for cloud overlap method +! 0=clear, 1=random, 2=maximum/random, 3=maximum +integer, parameter :: icld = 2 + + +!=============================================================================== +CONTAINS +!=============================================================================== + +subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & + pmid ,aer_lw_abs,cld ,tauc_lw, & + qrl ,qrlc , & + flns ,flnt ,flnsc ,flntc ,flwds, & + flut ,flutc ,fnl ,fcnl ,fldsc, & + lu ,ld ) + +!----------------------------------------------------------------------- + use cam_history, only: outfld + use mcica_subcol_gen_lw, only: mcica_subcol_lw + use physconst, only: cpair + use rrtmg_state, only: rrtmg_state_t + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: rrtmg_levs ! number of levels rad is applied + +! +! Input arguments which are only passed to other routines +! + type(rrtmg_state_t), intent(in) :: r_state + + real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure (Pascals) + + real(r8), intent(in) :: aer_lw_abs (pcols,pver,nbndlw) ! aerosol absorption optics depth (LW) + + real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover + real(r8), intent(in) :: tauc_lw(nbndlw,pcols,pver) ! Cloud longwave optical depth by band + +! +! Output arguments +! + real(r8), intent(out) :: qrl (pcols,pver) ! Longwave heating rate + real(r8), intent(out) :: qrlc(pcols,pver) ! Clearsky longwave heating rate + real(r8), intent(out) :: flns(pcols) ! Surface cooling flux + real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux + real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model + real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing + real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux + real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model + real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface + real(r8), intent(out) :: fldsc(pcols) ! Down longwave clear flux at surface + real(r8), intent(out) :: fcnl(pcols,pverp) ! clear sky net flux at interfaces + real(r8), intent(out) :: fnl(pcols,pverp) ! net flux at interfaces + + real(r8), pointer, dimension(:,:,:) :: lu ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld ! longwave spectral flux down + +! +!---------------------------Local variables----------------------------- +! + integer :: i, k, kk, nbnd ! indices + + real(r8) :: ful(pcols,pverp) ! Total upwards longwave flux + real(r8) :: fsul(pcols,pverp) ! Clear sky upwards longwave flux + real(r8) :: fdl(pcols,pverp) ! Total downwards longwave flux + real(r8) :: fsdl(pcols,pverp) ! Clear sky downwards longwv flux + + real(r8) :: tsfc(pcols) ! surface temperature + real(r8) :: emis(pcols,nbndlw) ! surface emissivity + + real(r8) :: taua_lw(pcols,rrtmg_levs-1,nbndlw) ! aerosol optical depth by band + + real(r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day + + ! Cloud arrays for McICA + integer, parameter :: nsubclw = ngptlw ! rrtmg_lw g-point (quadrature point) dimension + integer :: permuteseed ! permute seed for sub-column generator + + real(r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path + real(r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path + real(r8) :: rei(pcols,rrtmg_levs-1) ! ice particle effective radius (microns) + real(r8) :: rel(pcols,rrtmg_levs-1) ! liquid particle radius (micron) + + real(r8) :: cld_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud fraction (mcica) + real(r8) :: cicewp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud ice water path (mcica) + real(r8) :: cliqwp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud liquid water path (mcica) + real(r8) :: rei_stolw(pcols,rrtmg_levs-1) ! ice particle size (mcica) + real(r8) :: rel_stolw(pcols,rrtmg_levs-1) ! liquid particle size (mcica) + real(r8) :: tauc_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud optical depth (mcica - optional) + + ! Includes extra layer above model top + real(r8) :: uflx(pcols,rrtmg_levs+1) ! Total upwards longwave flux + real(r8) :: uflxc(pcols,rrtmg_levs+1) ! Clear sky upwards longwave flux + real(r8) :: dflx(pcols,rrtmg_levs+1) ! Total downwards longwave flux + real(r8) :: dflxc(pcols,rrtmg_levs+1) ! Clear sky downwards longwv flux + real(r8) :: hr(pcols,rrtmg_levs) ! Longwave heating rate (K/d) + real(r8) :: hrc(pcols,rrtmg_levs) ! Clear sky longwave heating rate (K/d) + real(r8) lwuflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux up + real(r8) lwdflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux down + !----------------------------------------------------------------------- + + ! mji/rrtmg + + ! Calculate cloud optical properties here if using CAM method, or if using one of the + ! methods in RRTMG_LW, then pass in cloud physical properties and zero out cloud optical + ! properties here + + ! Zero optional cloud optical depth input array tauc_lw, + ! if inputting cloud physical properties into RRTMG_LW + ! tauc_lw(:,:,:) = 0. + ! Or, pass in CAM cloud longwave optical depth to RRTMG_LW + ! do nbnd = 1, nbndlw + ! tauc_lw(nbnd,:ncol,:pver) = cldtau(:ncol,:pver) + ! end do + + ! Call mcica sub-column generator for RRTMG_LW + + ! Call sub-column generator for McICA in radiation + call t_startf('mcica_subcol_lw') + + ! Set permute seed (must be offset between LW and SW by at least 140 to insure + ! effective randomization) + permuteseed = 150 + + ! These fields are no longer supplied by CAM. + cicewp = 0.0_r8 + cliqwp = 0.0_r8 + rei = 0.0_r8 + rel = 0.0_r8 + + call mcica_subcol_lw(lchnk, ncol, rrtmg_levs-1, icld, permuteseed, pmid(:, pverp-rrtmg_levs+1:pverp-1), & + cld(:, pverp-rrtmg_levs+1:pverp-1), cicewp, cliqwp, rei, rel, tauc_lw(:, :ncol, pverp-rrtmg_levs+1:pverp-1), & + cld_stolw, cicewp_stolw, cliqwp_stolw, rei_stolw, rel_stolw, tauc_stolw) + + call t_stopf('mcica_subcol_lw') + + + call t_startf('rrtmg_lw') + + ! Convert incoming water amounts from specific humidity to vmr as needed; + ! Convert other incoming molecular amounts from mmr to vmr as needed; + ! Convert pressures from Pa to hPa; + ! Set surface emissivity to 1.0 here, this is treated in land surface model; + ! Set surface temperature + ! Set aerosol optical depth to zero for now + + emis(:ncol,:nbndlw) = 1._r8 + tsfc(:ncol) = r_state%tlev(:ncol,rrtmg_levs+1) + taua_lw(:ncol, 1:rrtmg_levs-1, :nbndlw) = aer_lw_abs(:ncol,pverp-rrtmg_levs+1:pverp-1,:nbndlw) + + + if (associated(lu)) lu(1:ncol,:,:) = 0.0_r8 + if (associated(ld)) ld(1:ncol,:,:) = 0.0_r8 +!#ifdef RFMIPIRF +! lu(1:ncol,:,:) = 0.0_r8 +! ld(1:ncol,:,:) = 0.0_r8 +!#endif + + call rrtmg_lw(lchnk ,ncol ,rrtmg_levs ,icld , & + r_state%pmidmb ,r_state%pintmb ,r_state%tlay ,r_state%tlev ,tsfc ,r_state%h2ovmr, & + r_state%o3vmr ,r_state%co2vmr ,r_state%ch4vmr ,r_state%o2vmr ,r_state%n2ovmr ,r_state%cfc11vmr,r_state%cfc12vmr, & + r_state%cfc22vmr,r_state%ccl4vmr ,emis ,& + cld_stolw,tauc_stolw,cicewp_stolw,cliqwp_stolw ,rei, rel, & + taua_lw, & + uflx ,dflx ,hr ,uflxc ,dflxc ,hrc, & + lwuflxs, lwdflxs) + + ! + !---------------------------------------------------------------------- + ! All longitudes: store history tape quantities + ! Flux units are in W/m2 on output from rrtmg_lw and contain output for + ! extra layer above model top with vertical indexing from bottom to top. + ! Heating units are in K/d on output from RRTMG and contain output for + ! extra layer above model top with vertical indexing from bottom to top. + ! Heating units are converted to J/kg/s below for use in CAM. + + flwds(:ncol) = dflx (:ncol,1) + fldsc(:ncol) = dflxc(:ncol,1) + flns(:ncol) = uflx (:ncol,1) - dflx (:ncol,1) + flnsc(:ncol) = uflxc(:ncol,1) - dflxc(:ncol,1) + flnt(:ncol) = uflx (:ncol,rrtmg_levs) - dflx (:ncol,rrtmg_levs) + flntc(:ncol) = uflxc(:ncol,rrtmg_levs) - dflxc(:ncol,rrtmg_levs) + flut(:ncol) = uflx (:ncol,rrtmg_levs) + flutc(:ncol) = uflxc(:ncol,rrtmg_levs) + + ! + ! Reverse vertical indexing here for CAM arrays to go from top to bottom. + ! + ful = 0._r8 + fdl = 0._r8 + fsul = 0._r8 + fsdl = 0._r8 + ful (:ncol,pverp-rrtmg_levs+1:pverp)= uflx(:ncol,rrtmg_levs:1:-1) + fdl (:ncol,pverp-rrtmg_levs+1:pverp)= dflx(:ncol,rrtmg_levs:1:-1) + fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) + fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) + +#ifndef OSLO_AERO + if (single_column.and.scm_crm_mode) then +#endif + call outfld('FUL ',ful,pcols,lchnk) + call outfld('FDL ',fdl,pcols,lchnk) + call outfld('FULC ',fsul,pcols,lchnk) + call outfld('FDLC ',fsdl,pcols,lchnk) +#ifndef OSLO_AERO + endif +#endif + + fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) + ! mji/ cam excluded this? + fcnl(:ncol,:) = fsul(:ncol,:) - fsdl(:ncol,:) + + ! Pass longwave heating to CAM arrays and convert from K/d to J/kg/s + qrl = 0._r8 + qrlc = 0._r8 + qrl (:ncol,pverp-rrtmg_levs+1:pver)=hr (:ncol,rrtmg_levs-1:1:-1)*cpair*dps + qrlc(:ncol,pverp-rrtmg_levs+1:pver)=hrc(:ncol,rrtmg_levs-1:1:-1)*cpair*dps + + ! Return 0 above solution domain + if ( ntoplw > 1 )then + qrl(:ncol,:ntoplw-1) = 0._r8 + qrlc(:ncol,:ntoplw-1) = 0._r8 + end if + + ! Pass spectral fluxes, reverse layering + ! order=(/3,1,2/) maps the first index of lwuflxs to the third index of lu. +!#ifndef RFMIPIRF + if (associated(lu)) then +!#endif + lu(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwuflxs(:,:ncol,rrtmg_levs:1:-1), & + (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) +!#ifndef RFMIPIRF + end if +!#endif + +!#ifndef RFMIPIRF + if (associated(ld)) then +!#endif + ld(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwdflxs(:,:ncol,rrtmg_levs:1:-1), & + (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) +!#ifndef RFMIPIRF + end if +!#endif + + call t_stopf('rrtmg_lw') + +end subroutine rad_rrtmg_lw + +!------------------------------------------------------------------------------- + +subroutine radlw_init() +!----------------------------------------------------------------------- +! +! Purpose: +! Initialize various constants for radiation scheme. +! +!----------------------------------------------------------------------- + + use ref_pres, only : pref_mid + + integer :: k + + ! If the top model level is above ~90 km (0.1 Pa), set the top level to compute + ! longwave cooling to about 80 km (1 Pa) + if (pref_mid(1) .lt. 0.1_r8) then + do k = 1, pver + if (pref_mid(k) .lt. 1._r8) ntoplw = k + end do + else + ntoplw = 1 + end if + if (masterproc) then + write(iulog,*) 'radlw_init: ntoplw =',ntoplw + endif + + call rrtmg_lw_ini + +end subroutine radlw_init + +!------------------------------------------------------------------------------- + +end module radlw diff --git a/src/physics/cam_oslo/radsw.F90 b/src/physics/cam_oslo/radsw.F90 new file mode 100644 index 0000000000..24a3b865fd --- /dev/null +++ b/src/physics/cam_oslo/radsw.F90 @@ -0,0 +1,720 @@ + +module radsw +!----------------------------------------------------------------------- +! +! Purpose: Solar radiation calculations. +! +!----------------------------------------------------------------------- + +!akc6+ +#include +!akc6- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use cam_abortutils, only: endrun +use cam_history, only: outfld +use scamMod, only: single_column,scm_crm_mode,have_asdir, & + asdirobs, have_asdif, asdifobs, have_aldir, & + aldirobs, have_aldif, aldifobs +use cam_logfile, only: iulog +use parrrsw, only: nbndsw, ngptsw +use rrtmg_sw_init, only: rrtmg_sw_ini +use rrtmg_sw_rad, only: rrtmg_sw +use perf_mod, only: t_startf, t_stopf +use radconstants, only: idx_sw_diag + +implicit none + +private +save + +real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band +real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band + +! Public methods + +public ::& + radsw_init, &! initialize constants + rad_rrtmg_sw ! driver for solar radiation code + +! Flag for cloud overlap method +! 0=clear, 1=random, 2=maximum-random, 3=maximum +integer, parameter :: icld = 2 + +!=============================================================================== +CONTAINS +!=============================================================================== + +subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & + E_pmid ,E_cld , & + E_aer_tau,E_aer_tau_w,E_aer_tau_w_g,E_aer_tau_w_f, & + eccf ,E_coszrs ,solin ,sfac , & + E_asdir ,E_asdif ,E_aldir ,E_aldif , & + qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & + fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & + fsnsc ,fsdsc ,fsds ,sols ,soll , & + solsd ,solld ,fns ,fcns , & +!akc6+ +#ifdef AEROFFL +! fds , fdsc , & + idrf , & +#endif +!akc6- + Nday ,Nnite ,IdxDay ,IdxNite , & + su ,sd , & + E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & + old_convert) + + +!----------------------------------------------------------------------- +! +! Purpose: +! Solar radiation code +! +! Method: +! mji/rrtmg +! RRTMG, two-stream, with McICA +! +! Divides solar spectrum into 14 intervals from 0.2-12.2 micro-meters. +! solar flux fractions specified for each interval. allows for +! seasonally and diurnally varying solar input. Includes molecular, +! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud, +! and surface absorption. Computes delta-eddington reflections and +! transmissions assuming homogeneously mixed layers. Adds the layers +! assuming scattering between layers to be isotropic, and distinguishes +! direct solar beam from scattered radiation. +! +! Longitude loops are broken into 1 or 2 sections, so that only daylight +! (i.e. coszrs > 0) computations are done. +! +! Note that an extra layer above the model top layer is added. +! +! mks units are used. +! +! Special diagnostic calculation of the clear sky surface and total column +! absorbed flux is also done for cloud forcing diagnostics. +! +!----------------------------------------------------------------------- + + use cmparray_mod, only: CmpDayNite, ExpDayNite + use phys_control, only: phys_getopts + use mcica_subcol_gen_sw, only: mcica_subcol_sw + use physconst, only: cpair + use rrtmg_state, only: rrtmg_state_t + + ! Minimum cloud amount (as a fraction of the grid-box area) to + ! distinguish from clear sky + real(r8), parameter :: cldmin = 1.0e-80_r8 + + ! Decimal precision of cloud amount (0 -> preserve full resolution; + ! 10^-n -> preserve n digits of cloud amount) + real(r8), parameter :: cldeps = 0.0_r8 + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: rrtmg_levs ! number of levels rad is applied + + type(rrtmg_state_t), intent(in) :: r_state + + integer, intent(in) :: Nday ! Number of daylight columns + integer, intent(in) :: Nnite ! Number of night columns + integer, intent(in), dimension(pcols) :: IdxDay ! Indicies of daylight coumns + integer, intent(in), dimension(pcols) :: IdxNite ! Indicies of night coumns + + real(r8), intent(in) :: E_pmid(pcols,pver) ! Level pressure (Pascals) + real(r8), intent(in) :: E_cld(pcols,pver) ! Fractional cloud cover + + real(r8), intent(in) :: E_aer_tau (pcols, 0:pver, nbndsw) ! aerosol optical depth + real(r8), intent(in) :: E_aer_tau_w (pcols, 0:pver, nbndsw) ! aerosol OD * ssa + real(r8), intent(in) :: E_aer_tau_w_g(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * asm + real(r8), intent(in) :: E_aer_tau_w_f(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * fwd + + real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2) + real(r8), intent(in) :: E_coszrs(pcols) ! Cosine solar zenith angle + real(r8), intent(in) :: E_asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad + real(r8), intent(in) :: E_aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad + real(r8), intent(in) :: E_asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad + real(r8), intent(in) :: E_aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad + real(r8), intent(in) :: sfac(nbndsw) ! factor to account for solar variability in each band + + real(r8), optional, intent(in) :: E_cld_tau (nbndsw, pcols, pver) ! cloud optical depth + real(r8), optional, intent(in) :: E_cld_tau_w (nbndsw, pcols, pver) ! cloud optical + real(r8), optional, intent(in) :: E_cld_tau_w_g(nbndsw, pcols, pver) ! cloud optical + real(r8), optional, intent(in) :: E_cld_tau_w_f(nbndsw, pcols, pver) ! cloud optical + logical, optional, intent(in) :: old_convert + + ! Output arguments + + real(r8), intent(out) :: solin(pcols) ! Incident solar flux + real(r8), intent(out) :: qrs (pcols,pver) ! Solar heating rate + real(r8), intent(out) :: qrsc(pcols,pver) ! Clearsky solar heating rate + real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux + real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux + real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8), intent(out) :: fsutoa(pcols) ! Upward solar flux at TOA + real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface + + real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux + real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx + real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA + real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7) + real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7) + real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7) + real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7) + real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa + real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns + + real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces + real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces + + real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down + + !---------------------------Local variables----------------------------- + + ! Local and reordered copies of the intent(in) variables + + real(r8) :: pmid(pcols,pver) ! Level pressure (Pascals) + + real(r8) :: cld(pcols,rrtmg_levs-1) ! Fractional cloud cover + real(r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path + real(r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path + real(r8) :: rel(pcols,rrtmg_levs-1) ! Liquid effective drop size (microns) + real(r8) :: rei(pcols,rrtmg_levs-1) ! Ice effective drop size (microns) + + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + real(r8) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad + real(r8) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad + real(r8) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad + real(r8) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad + + real(r8) :: h2ovmr(pcols,rrtmg_levs) ! h2o volume mixing ratio + real(r8) :: o3vmr(pcols,rrtmg_levs) ! o3 volume mixing ratio + real(r8) :: co2vmr(pcols,rrtmg_levs) ! co2 volume mixing ratio + real(r8) :: ch4vmr(pcols,rrtmg_levs) ! ch4 volume mixing ratio + real(r8) :: o2vmr(pcols,rrtmg_levs) ! o2 volume mixing ratio + real(r8) :: n2ovmr(pcols,rrtmg_levs) ! n2o volume mixing ratio + + real(r8) :: tsfc(pcols) ! surface temperature + + integer :: dyofyr ! Set to day of year for Earth/Sun distance calculation in + ! rrtmg_sw, or pass in adjustment directly into adjes + real(r8) :: solvar(nbndsw) ! solar irradiance variability in each band + + integer, parameter :: nsubcsw = ngptsw ! rrtmg_sw g-point (quadrature point) dimension + integer :: permuteseed ! permute seed for sub-column generator + + real(r8) :: diagnostic_od(pcols, pver) ! cloud optical depth - diagnostic temp variable + + real(r8) :: tauc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud optical depth + real(r8) :: ssac_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud single scat. albedo + real(r8) :: asmc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud asymmetry parameter + real(r8) :: fsfc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud forward scattering fraction + + real(r8) :: tau_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer optical depth + real(r8) :: ssa_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer single scat. albedo + real(r8) :: asm_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer asymmetry parameter + + real(r8) :: cld_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud fraction + real(r8) :: rei_stosw(pcols, rrtmg_levs-1) ! stochastic ice particle size + real(r8) :: rel_stosw(pcols, rrtmg_levs-1) ! stochastic liquid particle size + real(r8) :: cicewp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud ice water path + real(r8) :: cliqwp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud liquid wter path + real(r8) :: tauc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud optical depth (optional) + real(r8) :: ssac_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud single scat. albedo (optional) + real(r8) :: asmc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud asymmetry parameter (optional) + real(r8) :: fsfc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud forward scattering fraction (optional) + + real(r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day + + real(r8) :: swuflx(pcols,rrtmg_levs+1) ! Total sky shortwave upward flux (W/m2) + real(r8) :: swdflx(pcols,rrtmg_levs+1) ! Total sky shortwave downward flux (W/m2) + real(r8) :: swhr(pcols,rrtmg_levs) ! Total sky shortwave radiative heating rate (K/d) + real(r8) :: swuflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave upward flux (W/m2) + real(r8) :: swdflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave downward flux (W/m2) + real(r8) :: swhrc(pcols,rrtmg_levs) ! Clear sky shortwave radiative heating rate (K/d) + real(r8) :: swuflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux up + real(r8) :: swdflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux down + + real(r8) :: dirdnuv(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, UV/vis + real(r8) :: difdnuv(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, UV/vis + real(r8) :: dirdnir(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, near-IR + real(r8) :: difdnir(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, near-IR + + ! Added for net near-IR diagnostic + real(r8) :: ninflx(pcols,rrtmg_levs+1) ! Net shortwave flux, near-IR + real(r8) :: ninflxc(pcols,rrtmg_levs+1) ! Net clear sky shortwave flux, near-IR + + ! Other + + integer :: i, k, ns ! indices + + ! Cloud radiative property arrays + real(r8) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth + real(r8) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth + real(r8) :: wcl(pcols,0:pver) ! liquid cloud single scattering albedo + real(r8) :: gcl(pcols,0:pver) ! liquid cloud asymmetry parameter + real(r8) :: fcl(pcols,0:pver) ! liquid cloud forward scattered fraction + real(r8) :: wci(pcols,0:pver) ! ice cloud single scattering albedo + real(r8) :: gci(pcols,0:pver) ! ice cloud asymmetry parameter + real(r8) :: fci(pcols,0:pver) ! ice cloud forward scattered fraction + + ! Aerosol radiative property arrays + real(r8) :: tauxar(pcols,0:pver) ! aerosol extinction optical depth + real(r8) :: wa(pcols,0:pver) ! aerosol single scattering albedo + real(r8) :: ga(pcols,0:pver) ! aerosol assymetry parameter + real(r8) :: fa(pcols,0:pver) ! aerosol forward scattered fraction + + ! CRM + real(r8) :: fus(pcols,pverp) ! Upward flux (added for CRM) + real(r8) :: fds(pcols,pverp) ! Downward flux (added for CRM) + real(r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM) + real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) + +#ifdef AEROFFL +! real(r8), intent(out) :: fds(pcols,pverp) ! Downward flux (added for CRM) +! real(r8), intent(out) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) +!#else +! real(r8) :: fds(pcols,pverp) ! Downward flux (added for CRM) +! real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) + logical, intent(in) :: idrf +#endif + + integer :: kk + + real(r8) :: pmidmb(pcols,rrtmg_levs) ! Level pressure (hPa) + real(r8) :: pintmb(pcols,rrtmg_levs+1) ! Model interface pressure (hPa) + real(r8) :: tlay(pcols,rrtmg_levs) ! mid point temperature + real(r8) :: tlev(pcols,rrtmg_levs+1) ! interface temperature + + !----------------------------------------------------------------------- + ! START OF CALCULATION + !----------------------------------------------------------------------- + + ! Initialize output fields: + + fsds(1:ncol) = 0.0_r8 + + fsnirtoa(1:ncol) = 0.0_r8 + fsnrtoac(1:ncol) = 0.0_r8 + fsnrtoaq(1:ncol) = 0.0_r8 + + fsns(1:ncol) = 0.0_r8 + fsnsc(1:ncol) = 0.0_r8 + fsdsc(1:ncol) = 0.0_r8 + + fsnt(1:ncol) = 0.0_r8 + fsntc(1:ncol) = 0.0_r8 + fsntoa(1:ncol) = 0.0_r8 + fsutoa(1:ncol) = 0.0_r8 + fsntoac(1:ncol) = 0.0_r8 + + solin(1:ncol) = 0.0_r8 + + sols(1:ncol) = 0.0_r8 + soll(1:ncol) = 0.0_r8 + solsd(1:ncol) = 0.0_r8 + solld(1:ncol) = 0.0_r8 + + qrs (1:ncol,1:pver) = 0.0_r8 + qrsc(1:ncol,1:pver) = 0.0_r8 + fns(1:ncol,1:pverp) = 0.0_r8 + fcns(1:ncol,1:pverp) = 0.0_r8 +#ifndef OSLO_AERO + if (single_column.and.scm_crm_mode) then +#endif + fus(1:ncol,1:pverp) = 0.0_r8 + fds(1:ncol,1:pverp) = 0.0_r8 + fusc(:ncol,:pverp) = 0.0_r8 + fdsc(:ncol,:pverp) = 0.0_r8 +#ifndef OSLO_AERO + endif +#endif + + if (associated(su)) su(1:ncol,:,:) = 0.0_r8 + if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 +!#ifdef RFMIPIRF +! su(1:ncol,:,:) = 0.0_r8 +! sd(1:ncol,:,:) = 0.0_r8 +!#endif + + ! If night everywhere, return: + if ( Nday == 0 ) then + return + endif + + ! Rearrange input arrays + call CmpDayNite(E_pmid(:,pverp-rrtmg_levs+1:pver), pmid(:,1:rrtmg_levs-1), & + Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) + call CmpDayNite(E_cld(:,pverp-rrtmg_levs+1:pver), cld(:,1:rrtmg_levs-1), & + Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) + + call CmpDayNite(r_state%pintmb, pintmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) + call CmpDayNite(r_state%pmidmb, pmidmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%h2ovmr, h2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%o3vmr, o3vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%co2vmr, co2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + + call CmpDayNite(E_coszrs, coszrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call CmpDayNite(E_asdir, asdir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call CmpDayNite(E_aldir, aldir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call CmpDayNite(E_asdif, asdif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call CmpDayNite(E_aldif, aldif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + + call CmpDayNite(r_state%tlay, tlay, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%tlev, tlev, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) + call CmpDayNite(r_state%ch4vmr, ch4vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%o2vmr, o2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + call CmpDayNite(r_state%n2ovmr, n2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) + + ! These fields are no longer input by CAM. + cicewp = 0.0_r8 + cliqwp = 0.0_r8 + rel = 0.0_r8 + rei = 0.0_r8 + + ! Aerosol daylight map + ! Also convert to optical properties of rrtmg interface, even though + ! these quantities are later multiplied back together inside rrtmg ! + ! Why does rrtmg use the factored quantities? + ! There are several different ways this factoring could be done. + ! Other ways might allow for better optimization + do ns = 1, nbndsw + do k = 1, rrtmg_levs-1 + kk=(pverp-rrtmg_levs) + k + do i = 1, Nday + if(E_aer_tau_w(IdxDay(i),kk,ns) > 1.e-80_r8) then + asm_aer_sw(i,k,ns) = E_aer_tau_w_g(IdxDay(i),kk,ns)/E_aer_tau_w(IdxDay(i),kk,ns) + else + asm_aer_sw(i,k,ns) = 0._r8 + endif + if(E_aer_tau(IdxDay(i),kk,ns) > 0._r8) then + ssa_aer_sw(i,k,ns) = E_aer_tau_w(IdxDay(i),kk,ns)/E_aer_tau(IdxDay(i),kk,ns) + tau_aer_sw(i,k,ns) = E_aer_tau(IdxDay(i),kk,ns) + else + ssa_aer_sw(i,k,ns) = 1._r8 + tau_aer_sw(i,k,ns) = 0._r8 + endif + enddo + enddo + enddo + + if (scm_crm_mode) then + ! overwrite albedos for CRM + if(have_asdir) asdir = asdirobs(1) + if(have_asdif) asdif = asdifobs(1) + if(have_aldir) aldir = aldirobs(1) + if(have_aldif) aldif = aldifobs(1) + endif + + ! Define solar incident radiation + do i = 1, Nday + solin(i) = sum(sfac(:)*solar_band_irrad(:)) * eccf * coszrs(i) + end do + + ! Calculate cloud optical properties here if using CAM method, or if using one of the + ! methods in RRTMG_SW, then pass in cloud physical properties and zero out cloud optical + ! properties here + + ! Zero optional cloud optical property input arrays tauc_sw, ssac_sw, asmc_sw, + ! if inputting cloud physical properties to RRTMG_SW + !tauc_sw(:,:,:) = 0.0_r8 + !ssac_sw(:,:,:) = 1.0_r8 + !asmc_sw(:,:,:) = 0.0_r8 + !fsfc_sw(:,:,:) = 0.0_r8 + ! + ! Or, calculate and pass in CAM cloud shortwave optical properties to RRTMG_SW + !if (present(old_convert)) print *, 'old_convert',old_convert + !if (present(ancientmethod)) print *, 'ancientmethod',ancientmethod + if (present(old_convert))then + if (old_convert)then ! convert without limits + do i = 1, Nday + do k = 1, rrtmg_levs-1 + kk=(pverp-rrtmg_levs) + k + do ns = 1, nbndsw + if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then + fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) + asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) + else + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + endif + + tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) + if (tauc_sw(ns,i,k) > 0._r8) then + ssac_sw(ns,i,k)=E_cld_tau_w(ns,IdxDay(i),kk)/tauc_sw(ns,i,k) + else + tauc_sw(ns,i,k) = 0._r8 + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + ssac_sw(ns,i,k) = 1._r8 + endif + enddo + enddo + enddo + else + ! eventually, when we are done with archaic versions, This set of code will become the default. + do i = 1, Nday + do k = 1, rrtmg_levs-1 + kk=(pverp-rrtmg_levs) + k + do ns = 1, nbndsw + if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then + fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) + asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) + else + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + endif + + tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) + if (tauc_sw(ns,i,k) > 0._r8) then + ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) + else + tauc_sw(ns,i,k) = 0._r8 + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + ssac_sw(ns,i,k) = 1._r8 + endif + enddo + enddo + enddo + endif + else + do i = 1, Nday + do k = 1, rrtmg_levs-1 + kk=(pverp-rrtmg_levs) + k + do ns = 1, nbndsw + if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then + fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) + asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) + else + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + endif + + tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) + if (tauc_sw(ns,i,k) > 0._r8) then + ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) + else + tauc_sw(ns,i,k) = 0._r8 + fsfc_sw(ns,i,k) = 0._r8 + asmc_sw(ns,i,k) = 0._r8 + ssac_sw(ns,i,k) = 1._r8 + endif + enddo + enddo + enddo + endif + + ! Call mcica sub-column generator for RRTMG_SW + + ! Call sub-column generator for McICA in radiation + call t_startf('mcica_subcol_sw') + + ! Set permute seed (must be offset between LW and SW by at least 140 to insure + ! effective randomization) + permuteseed = 1 + + + call mcica_subcol_sw(lchnk, Nday, rrtmg_levs-1, icld, permuteseed, pmid, & + cld, cicewp, cliqwp, rei, rel, tauc_sw, ssac_sw, asmc_sw, fsfc_sw, & + cld_stosw, cicewp_stosw, cliqwp_stosw, rei_stosw, rel_stosw, & + tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw) + + call t_stopf('mcica_subcol_sw') + + call t_startf('rrtmg_sw') + + ! Call RRTMG_SW for all layers for daylight columns + + + ! Set day of year for Earth/Sun distance calculation in rrtmg_sw, or + ! set to zero and pass E/S adjustment (eccf) directly into array adjes + dyofyr = 0 + + tsfc(:ncol) = tlev(:ncol,rrtmg_levs+1) + + solvar(1:nbndsw) = sfac(1:nbndsw) + + call rrtmg_sw(lchnk, Nday, rrtmg_levs, icld, & + pmidmb, pintmb, tlay, tlev, tsfc, & + h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & + asdir, asdif, aldir, aldif, & + coszrs, eccf, dyofyr, solvar, & + cld_stosw, tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw, & + cicewp_stosw, cliqwp_stosw, rei, rel, & + tau_aer_sw, ssa_aer_sw, asm_aer_sw, & + swuflx, swdflx, swhr, swuflxc, swdflxc, swhrc, & + dirdnuv, dirdnir, difdnuv, difdnir, ninflx, ninflxc, swuflxs, swdflxs) + + ! Flux units are in W/m2 on output from rrtmg_sw and contain output for + ! extra layer above model top with vertical indexing from bottom to top. + ! + ! Heating units are in J/kg/s on output from rrtmg_sw and contain output + ! for extra layer above model top with vertical indexing from bottom to top. + ! + ! Reverse vertical indexing to go from top to bottom for CAM output. + + ! Set the net absorted shortwave flux at TOA (top of extra layer) + fsntoa(1:Nday) = swdflx(1:Nday,rrtmg_levs+1) - swuflx(1:Nday,rrtmg_levs+1) + fsutoa(1:Nday) = swuflx(1:Nday,rrtmg_levs+1) + fsntoac(1:Nday) = swdflxc(1:Nday,rrtmg_levs+1) - swuflxc(1:Nday,rrtmg_levs+1) + + ! Set net near-IR flux at top of the model + fsnirtoa(1:Nday) = ninflx(1:Nday,rrtmg_levs) + fsnrtoaq(1:Nday) = ninflx(1:Nday,rrtmg_levs) + fsnrtoac(1:Nday) = ninflxc(1:Nday,rrtmg_levs) + + ! Set the net absorbed shortwave flux at the model top level + fsnt(1:Nday) = swdflx(1:Nday,rrtmg_levs) - swuflx(1:Nday,rrtmg_levs) + fsntc(1:Nday) = swdflxc(1:Nday,rrtmg_levs) - swuflxc(1:Nday,rrtmg_levs) + + ! Set the downwelling flux at the surface + fsds(1:Nday) = swdflx(1:Nday,1) + fsdsc(1:Nday) = swdflxc(1:Nday,1) + + ! Set the net shortwave flux at the surface + fsns(1:Nday) = swdflx(1:Nday,1) - swuflx(1:Nday,1) + fsnsc(1:Nday) = swdflxc(1:Nday,1) - swuflxc(1:Nday,1) + + ! Set the UV/vis and near-IR direct and dirruse downward shortwave flux at surface + sols(1:Nday) = dirdnuv(1:Nday,1) + soll(1:Nday) = dirdnir(1:Nday,1) + solsd(1:Nday) = difdnuv(1:Nday,1) + solld(1:Nday) = difdnir(1:Nday,1) + + + ! Set the net, up and down fluxes at model interfaces + fns (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - swuflx(1:Nday,rrtmg_levs:1:-1) + fcns(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - swuflxc(1:Nday,rrtmg_levs:1:-1) + fus (1:Nday,pverp-rrtmg_levs+1:pverp) = swuflx(1:Nday,rrtmg_levs:1:-1) + fusc(1:Nday,pverp-rrtmg_levs+1:pverp) = swuflxc(1:Nday,rrtmg_levs:1:-1) + fds (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) + fdsc(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) + + ! Set solar heating, reverse layering + ! Pass shortwave heating to CAM arrays and convert from K/d to J/kg/s + qrs (1:Nday,pverp-rrtmg_levs+1:pver) = swhr (1:Nday,rrtmg_levs-1:1:-1)*cpair*dps + qrsc(1:Nday,pverp-rrtmg_levs+1:pver) = swhrc(1:Nday,rrtmg_levs-1:1:-1)*cpair*dps + + ! Set spectral fluxes, reverse layering + ! order=(/3,1,2/) maps the first index of swuflxs to the third index of su. +!#ifndef RFMIPIRF + if (associated(su)) then +!#endif + su(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swuflxs(:,1:Nday,rrtmg_levs:1:-1), & + (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) +!#ifndef RFMIPIRF + end if +!#endif + +!#ifndef RFMIPIRF + if (associated(sd)) then +!#endif + sd(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swdflxs(:,1:Nday,rrtmg_levs:1:-1), & + (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) +!#ifndef RFMIPIRF + end if +!#endif + + call t_stopf('rrtmg_sw') + + ! Rearrange output arrays. + ! + ! intent(out) + + call ExpDayNite(solin, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(qrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) + call ExpDayNite(qrsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) + call ExpDayNite(fns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fcns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fsns, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsnt, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsntoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsutoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsds, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsnsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsdsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsntc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsntoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(sols, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(soll, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(solsd, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(solld, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsnirtoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsnrtoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + call ExpDayNite(fsnrtoaq, Nday, IdxDay, Nnite, IdxNite, 1, pcols) + +!#ifndef RFMIPIRF + if (associated(su)) then +!#endif + call ExpDayNite(su, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) +!#ifndef RFMIPIRF + end if +!#endif + +!#ifndef RFMIPIRF + if (associated(sd)) then +!#endif + call ExpDayNite(sd, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) +!#ifndef RFMIPIRF + end if +!#endif + + ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) +#ifndef OSLO_AERO + if (single_column .and. scm_crm_mode) then +#endif + ! Following outputs added for CRM + call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call outfld('FUS ', fus, pcols, lchnk) + call outfld('FUSC ', fusc, pcols, lchnk) + call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call outfld('FDS ', fds, pcols, lchnk) + call outfld('FDSC ', fdsc, pcols, lchnk) +#ifndef OSLO_AERO + endif +#endif + +#ifdef AEROFFL + if(idrf) then +! call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) +! call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call outfld('FUSCDRF ', fusc, pcols, lchnk) + call outfld('FDSCDRF ', fdsc, pcols, lchnk) + endif +#endif + +end subroutine rad_rrtmg_sw + +!------------------------------------------------------------------------------- + +subroutine radsw_init() +!----------------------------------------------------------------------- +! +! Purpose: +! Initialize various constants for radiation scheme. +! +!----------------------------------------------------------------------- + use radconstants, only: get_solar_band_fraction_irrad, get_ref_solar_band_irrad + + ! get the reference fractional solar irradiance in each band + call get_solar_band_fraction_irrad(fractional_solar_irradiance) + call get_ref_solar_band_irrad( solar_band_irrad ) + + + ! Initialize rrtmg_sw + call rrtmg_sw_ini + +end subroutine radsw_init + + +!------------------------------------------------------------------------------- + +end module radsw diff --git a/src/physics/cam_oslo/table_manager.F90 b/src/physics/cam_oslo/table_manager.F90 new file mode 100644 index 0000000000..6f91a8459d --- /dev/null +++ b/src/physics/cam_oslo/table_manager.F90 @@ -0,0 +1,95 @@ +module table_manager + + use ptaero_table + use commondefinitions + use aerosoldef !for the mixture ids + + integer, parameter, public :: table_property_dry_radius=1 + integer, parameter, public :: table_property_sigma=2 + integer, parameter :: max_number_of_properties=10 !Max # properties for a mixture + + TYPE(ptaero_table_t), target, dimension(max_number_of_properties*(nmodes+1)) :: property_table + + integer, dimension(0:nmodes,max_number_of_properties) :: property_table_index + integer, save :: last_used_index=0 + +contains + + subroutine initialize_tables() + implicit none + integer :: i + + last_used_index = 0 + property_table_index(:,:) = -1 !Negative index means un-used + + do i=1,SIZE(property_table) + !Construct an empty property table + call construct(property_table(i)) + end do + + end subroutine initialize_tables + + !Registers a look-up table + subroutine register_table(mixture_id, property_id, data2D, data3D, data4D, axis1, axis2, axis3, axis4) + implicit none + integer, intent(in) :: mixture_id + integer, intent(in) :: property_id + real(r8), dimension(:,:), intent(in), optional :: data2D + real(r8), dimension(:,:,:), intent(in), optional :: data3D + real(r8), dimension(:,:,:,:), intent(in), optional :: data4D + real(r8), intent(in), dimension(:),optional :: axis1 + real(r8), intent(in), dimension(:),optional :: axis2 + real(r8), intent(in), dimension(:),optional :: axis3 + real(r8), intent(in), dimension(:),optional :: axis4 + + !Increase the number of tables we are keeping track of.. + last_used_index = last_used_index + 1 + + !Remember the placement of this table + property_table_index(mixture_id, property_id) = last_used_index + + !Need to check for what kind of data the table contains.. + if(present(data2D))then + call initialize(property_table(last_used_index) & !This is the table we are initializing + , mixture_id & !id of the mixture + , property_id & !id of the property + , limits1=axis1 & !axis limits (grid) of first axis + , limits2=axis2 & !axis limits (grid) of second axis + , data2d=data2d & !the 2d-data of the table + ) + else if(present(data3D))then + call initialize(property_table(last_used_index) & !This is the table we are initializing + , mixture_id & !id of the mixture + , property_id & !id of the property + , limits1=axis1 & !axis limits (grid) of first axis + , limits2=axis2 & !axis limits (grid) of second axis + , limits3=axis3 & !axis limits (grid) of third axis + , data3d=data3d & !the 2d-data of the table + ) + else if(present(data4D))then + call initialize(property_table(last_used_index) & !This is the table we are initializing + , mixture_id & !id of the mixture + , property_id & !id of the property + , limits1=axis1 & !axis limits (grid) of first axis + , limits2=axis2 & !axis limits (grid) of second axis + , limits3=axis3 & !axis limits (grid) of third axis + , limits4=axis3 & !axis limits (grid) of third axis + , data4d=data4d & !the 2d-data of the table + ) + end if + + end subroutine register_table + + function get_table_pointer(mixture_id, property_id)RESULT(table_pointer) + integer,intent(in) :: mixture_id + integer,intent(in) :: property_id + TYPE(ptaero_table_t), pointer :: table_pointer + + nullify(table_pointer) + + table_pointer=>property_table(property_table_index(mixture_id, property_id)) + + end function + + +end module table_manager diff --git a/src/physics/camrt/radiation.F90 b/src/physics/camrt/radiation.F90 index 1ca1e074de..63ffa94f3e 100644 --- a/src/physics/camrt/radiation.F90 +++ b/src/physics/camrt/radiation.F90 @@ -861,6 +861,8 @@ subroutine radiation_tend( & real(r8):: p_trop(pcols) logical :: write_output ! switch for outfld calls + + logical, parameter :: cosz_rad_call=.true. !+tht !---------------------------------------------------------------------- lchnk = state%lchnk @@ -902,7 +904,7 @@ subroutine radiation_tend( & ! Cosine solar zenith angle for current time step call get_rlat_all_p(lchnk, ncol, clat) call get_rlon_all_p(lchnk, ncol, clon) - call zenith (calday, clat, clon, coszrs, ncol, dt_avg) + call zenith (calday, clat, clon, coszrs, ncol, dt_avg, cosz_rad_call) !+tht ! Gather night/day column indices. Nday = 0 diff --git a/src/physics/carma/base/ChangeLog b/src/physics/carma/base/ChangeLog new file mode 100644 index 0000000000..fd69d8c860 --- /dev/null +++ b/src/physics/carma/base/ChangeLog @@ -0,0 +1,563 @@ +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Pengfei Yu +Date: Aug 13, 2013 + +One-line Summary: + +Added partial initialization and fixed problems with initialization the dry deposition code. + +Purpose of changes: + +When using fixed initialization, the dry deposition routines were +not getting initialized, so deposition velocities were not calculated. +That has been corrected. Also, the metric scaling was being applied +incorrectly to vd and vf when requested as output from CARMASTATE_Get. +A new option (partialinit) has been added that can be used with +fixed initialization to cause reinitialization of fall velocities and +growth kernels, but not coagulation kernels, which are the most expensive +calculate. This gives a result that is intermediate between full and +fixed initialization. + +=============================================================== +Tag name: +Originator(s): Sean Santos +Date: Dec 27, 2013 + +One-line Summary: + +Support for the NAG Fortran compiler within CAM (nagfor). + +Purpose of changes: + +Made many changes to work with the NAG compiler within CAM. These include +mostly changes to deal with kind in a standard-conforming way (as opposed +to using non-standard intrinsics), and changes to ensure that the code +contains no more than 132 characters per line. + +miess.F90 has more extensive changes; this module used "equivalence" in a +way not allowed by the standard, and so much of the code had to be +re-written to work on complex numbers without associating their components +to reals. + +The Makefile is not currently updated with support for nagfor. + +=============================================================== +Tag name: +Originator(s): Chuck Bardeen +Date: Nov 15, 2013 + +One-line Summary: + +Support for the gfortran compiler. + +Purpose of changes: + +Support was added to the Makefile for the gfortran compiler, and +some compatibility bugs were fixed in the code so that it would +compile and link under gfortran. + +=============================================================== +Tag name: +Originator(s): Chuck Bardeen, Mike Mills +Date: Nov 14, 2013 + +One-line Summary: + +Sulfates wet radius and density includes the Kelvin effect on water. + +Purpose of changes: + +Changed the wetr code to take into account the Kelvin effect on the +water in determining the weight percent, density and particle size. +This is a simpler alternative to the weight percent per bin approach +that MIke has used in other CARMA models. + +NOTE: There was also a fix for a related bug in rhopart.F90, where +the wrong gas concentration was being used for the sulfate weight +percent calculation. + +=============================================================== +Tag name: +Originator(s): Chuck Bardeen +Date: Nov 3, 2013 + +One-line Summary: + +Neutralized sulfates as a function of volume fraction of core mass. + +Purpose of changes: + +Changes to allow for neutralization of sulfates where the neutralization +is a function of the volume fraction of the core mass. This replaces +neutralization by scaling the saturation vapor pressure. NOTE: This +solution is currently not used for ice particles or when particle +heating is being used. + +=============================================================== +Tag name: +Originator(s): Sean Santos +Date: July 15, 2013 + +One-line Summary: + +Set rprat to 1 for all non-fractals. + +Purpose of changes: + +Setting rprat to 1._r8 for I_HEXAGON and I_CYLINDER shapes will prevent +errors due to uninitialized data for the cirrus/dust model. + +=============================================================== +Tag name: +Originator(s): Sean Santos +Date: July 2, 2013 + +One-line Summary: + +Fix build with debug options on and on compilers other than Intel. + +Purpose of changes: + +Fix several compatibility issues with PGI and Lahey. fractal_meanfield_mod +in particular used Intel compiler extensions throughout. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: June 14, 2013 + +One-line Summary: + +Added sulfate heterogeneous nucleation and allow sulfuric acid +vapor pressure to be adjusted for neutralization + +Purpose of changes: + +Add heterogeneous nucleation of sulfate aerosols to the binary +homogeneous nucleation. Also reduced the vapor pressure for +"neutralized" aerosols based upon Marti et al. 1997. Neutralization +is treated very simplistically and is either all or none and just +affects the vapor pressure. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: May 17, 2013 + +One-line Summary: + +Changed way optical properties are handled + +Purpose of changes: + +The optical properties used to be initialized by default to be +used by particle heating; however, the fractal code can take a +long time to calculate the optical properties. So only do the +internal initialization if particle heating is enabled. Added +another interface to the Group to set the optical properties to +allow them to come from an external source. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Pete Colarco +Date: May 13, 2013 + +One-line Summary: + +Fixed bug in nucleation rate statistic + +Purpose of changes: + +Changed how the nucleation rate statistic is calculated to work +around two previous bugs that involved try to calculate the +statistic after the particle count had been updated and not +including the nucleation loss rate in the calculation. + +=============================================================== +Tag name: +Originator(s): Eric Wolf, Charles Bardeen +Date: May 9, 2013 + +One-line Summary: + +Added support for fractal particles. + +Purpose of changes: + +Allows particles to grow fractally, which means that particles are made +up of monomers of a single size that will aggregate together in patterns +that depend on the particles fractal dimension. This will affect growth, +sedimentation, coagulation, deposition and optical properties. + +=============================================================== +Tag name: +Originator(s): Sean Santos +Date: April 24, 2013 + +One-line Summary: Fix problems with different compilers and debug flags. + +Purpose of changes: + +Some cases where the carma_type object had "intent(inout)" were changed to +"intent(in)". This would have been required if those routines had had +explicit interfaces, because intent(in) arguments can only be passed as +arguments that are also intent(in), or as arguments with no explicitly +specified intent. + +Since Fortran 90, imag and aimag are identical generic intrinsics on most +compilers. However, aimag is the name in the Fortran standards, while imag +is a compiler extension. Therefore "imag" has been changed to "aimag" and +comments that are no longer relevant have been removed. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Mike Mills +Date: March 18, 2013 + +One-line Summary: + +Some bug fixes related to sulfates, to evaporation, mie code +and coagulation kernels. + +Purpose of changes: + +The wet radius for sulfates was not being calculated properly, since +it was missing a dry particle density term. The new wet radius will be +roughly twice what it was before. Also made some changes to allow specification +of sulfuric acid in CARMASTATE_CreateFromReference, so that initialization +from a reference profile can be used with sulfate models. Put some limits +on calculations in sulfate utilities for practical temperature ranges. + +Fixed a problem with total evaporation that affected some models. + +Fixed a problem with types in the optical properties calculation when +using Bohren and Huffman. + +Fixed a problem with the way the coagulation due to convection was +being calculated that caused asymmetric coagulation kernels. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: September 7, 2012 + +One-line Summary: + +Fix bug in pheat.F90 when no solute is specified. + +Purpose of changes: + +A check to exclude a calculation in the particle growth code when +no solutes are present was coded incorrectly causing the model +to crash when growth is enabled, core elements exist in the group +and no solutes are defined for the cores. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: January 26, 2011 + +One-line Summary: + +Add capability for clear sky processing when using in-cloud +and gridbox average particles. + +Purpose of changes: + +Allows two sets of microphysical calculations to be done in one +Step call. One is for the fraction of the grid box that is +in-cloud and the other is for the remaining clear sky portion. +The entire mass of particle groups that are "cloud" are only +processed in the in-cloud portion. Other groups can also +condense liquid, but be over the entire gridbox. These would +have "is cloud" as false and will be processed in both the +in-cloud and clear sky portions of the grid box. Sedimentation +is only done once on the gridbox average values, but coagulation +and growth are done twice. + +Two tests have been added for this : + - GROWINTEST = in-cloud test + - GROWCLRTEST = in-cloud & clear sky test + +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Mike Mills +Date: December 1, 2011 + +One-line Summary: + +Bug fixes for sulfate aerosols and some additional diagnostic +information. + +Purpose of changes: + +Fixes problems found while trying to test sulfates aerosols in +WACCM/CARMA, where every cold temperatures are possible. Also +Also producing some additional diagnostics to help diagnose the +sulfate physics. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: November 8, 2011 + +One-line Summary: + +Allow configurable selection of aerosol freezing method and cleanup +error messages. + +Purpose of changes: + +Made nucproc a bit field, so that the aerosol freezing method can +be specified without needing to modify the code, and so that it can +be combined with nucleation of glassy aerosols. Also surpress an +error message from negative temperature unless it is the last +retry. Added a test case (NUC2TEST.exe) to see at what supersaturation +aerosol freezing begins. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Mike Mills +Date: October 9, 2011 + +One-line Summary: + +Fixes to support high (thermospheric) temperatures in the sulfate +code. + +Purpose of changes: + +Modified some of the sulfate code to handle temperatures that +result in 0 wtpct. This was causing WACCM to crash with the +sulfate model. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen, Tianyi Fan +Date: September 3, 2011 + +One-line Summary: + +Added sulfate aerosols. + +Purpose of changes: + +Added support for sulfuric acid and sulfate aerosols. Also fixed +some problems with the way latent and particle heats were applied +when substepping was being used. Made the convergence criteria +more configurable. The sulfate aerosol code is a significantly +modified version of code from that provided by Tianyi Fan. Her +code started with work done by Mike Mills and then was modified +by Jason English, Tianyi Fan and Chuck Bardeen. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: August 19, 2011 + +One-line Summary: + +Bug fixes and enhancements to the particle heating code. + +Purpose of changes: + +Fixed a few bugs found running in the debugger, and changed +dry deposition so that surface friction and aerodynamic resistance +are provided and used per land surface type. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: August 9, 2011 + +One-line Summary: + +Enhancements to the particle heating code. + +Purpose of changes: + +Added band integrals for the planck function to provide a more +accurate estimate of outgoing radiation for particle heating. Also +modified the test case to start the SW band at a non-zero wavelength. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: August 4, 2011 + +One-line Summary: + +Enhancements to the particle heating code. + +Purpose of changes: + +Added the ability to flag overlap bands in for the particle heating +calculation. These are bands which have added energy coming in; however, +the emission should only be done in one of the bands. This is needed +for the CAM radiation bands. Added the Bohren and Huffman mie routine, +to provide a routine that handles a broader array of sizes and refractive +indicies. Also changed the output from particle temperature to the difference +in particle temperature, since that is more relevant to the impact on +growth rates and temperatures may change for other reasons making it hard +to do the difference later. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: July 14, 2011 + +One-line Summary: + +Setup tests to be run as regression tests. + +Purpose of changes: + +Added two new scripts run-all.csh and run-regress.csh. run-regress.csh +runs the tests and then compares the answer to previously generated +results in tests/bench. An error is generated if the results differ. +To make this usable, all of the tests have be modified to have minimal +output to the screen for normal operation. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: July 13, 2011 + +One-line Summary: + +Support for particle heating and some bug fixes + +Purpose of changes: + +Added support for passing radiative intensity into CARMA and +having that affect the particle growth rates and partcile +temperature.This is exercised by carma_pheattest.F90. Changed +initialization, so pkernel is only calcualted once to speed +things up a little. Made area ratio and radius ratio group +properties, so there is more flexibility for setting group +shape. + +=============================================================== +Tag name: +Originator(s): Charles Bardeen +Date: June 8, 2011 + +One-line Summary: + +Support for PGI and g95 compilers + +Purpose of changes: + +Some Fortran compilers have preprocessors that failed to correctly handle +the macros because they recursively tried to replace the name multiple +times. To prevent this, the field names have been changes to have f_XXX +so they don't conflict with the macro name XXX. + +=============================================================== + +Tag name: 3.0.1 +Originator(s): Tianyi Fan, Charles Bardeen +Date: December 1, 2010 + +One-line Summary: + +Add wet deposition to sedimentation. + +Purpose of changes: + +Added support for dry deposition to the sedimentation routine in CARMA. +Surface friction and land fraction are supplied by the parent model. + +=============================================================== + +Tag name: 3.0.0 +Originator(s): Charles Bardeen +Date: August 11, 2010 + +One-line Summary: + +Initial release of the F90 version of CARMA based upon F77 CARMA 2.3 + +Purpose of changes: + +A major revision of CARMA 2.3, with design goals of porting it to +Fortran 90, and designing it to be embedded in other models like CAM +and GEOS. + +Changes for F90: +- All code converted to F90 (wrappers to keep core code similar to F77 code) +- Use modules to replace common blocks +- Dynamic memory allocation +- Thread safe +- Use array operations when possible +- Use implicit none + +Changes for embedded models: +- Single column +- Programmatic interface to define microphysical model +- Initialize from parent model state (mks units) +- Step() can be multithreaded +- Generate optical properties (mie coefficients) +- Scale for cloud fraction +- Detrain particles +- Store information about CARMA needed for parent models (e.g. wet deposition coefficients, diagnostic group, ...) +- Allow a fixed defintion of latent heat, consitent with parent model + +Updated algortihms: +- Aerosol freezing (Koop 2000) +- Water saturation vapor pressure (Murphy & Koop 2005) + +New algorithms: +- Nucleation of glassy aerosols (Murray et al. 2010) +- Ice particle density as a function of size (Heymsfield & Schmitt, 2010) +- Ice fall velocity (Heymsfield & Westbrook, 2010) +- Particle swelling with relative humidity, wet radius (Gerber 1985; Fitzgerald 1975) +- Brownian Diffusion + +New features: +- Allow specification of minimum mass rather than just radius +- Variable density (per bin) within an element +- Determine sedimentation to the surface +- Dynamically allocate ACAP in miess based upon NXM1 + +Performance: +- Only initialize the components needed for the model configuration +- Add retry logic to newstate/microfast, to minimize the number of substeps needed +- Reduce size of data structures used by CARMA +- Reorder some operations for faster array access +- Optional initialization to a fixed reference temperature profile +- Optional explicit sedimentation (substepped) +- Reuse allocated memory in CARMASTATE to reduce memory allocation + +Bugs fixed: +- Mass & energy conservation +- Various bugs in fall velocity calculation +- Scaling problems with rlheat +- Optional Initialize every timestep for maximum accuracy +- Various problems with setting up the model configuration (nucleation tables, scrit, nucgas, ...) +- Improved growth stability and convergence +- Improved stability of aerosol freezing (tabazadeh 2000) +- Evaporation bugs (cmf not getting set, total evaporation ncore=0) +- Modified growth equation for better approximation +- Correct usage of SMALL_PC and FEW_PC + +Algorithms eliminated: +- Horizontal advection +- Hydrostatic approximation +- Eddy diffusion +- Mixed phase particles +- Radiative Transfer + +Known Issues: +- PPM advection code has noisy sedimentation when using hybrid coordinates +- Growth code is not mass or energy conserving, so rlheat and gc are recalculated based upon condensed mass change +- PPM advection code does not return fluxes out the top and bottom of the column, so a kludge was added to get flux out the bottom as column difference +- Estimates for the number of substeps needed (ntsubsteps) are not very accurate +- Full initialization (rather than to reference T) can be very slow, particularly for coagulation +- Parameterizations for latent heats give odd values at low temperatures, use fixed values instead +- Standard fall velocity routine has odd kinks in areas where it transitions between different Reynolds regimes +- Standard shape fall velocity routine is not handling all shapes and aspect ratios correctly +- Mie calculation code can still exceed IACAP estimates even though dynamically allocating ACAP +- Core mass is sometimes larger than total mass, can happen from parent model advection, but perhaps other sources +=============================================================== diff --git a/src/physics/carma/base/actdropl.F90 b/src/physics/carma/base/actdropl.F90 new file mode 100644 index 0000000000..068146df11 --- /dev/null +++ b/src/physics/carma/base/actdropl.F90 @@ -0,0 +1,106 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! droplet activation only. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! To avoid nucleation into an evaporating bin, this subroutine must +!! be called after growp, which evaluates evaporation loss rates . +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine actdropl(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igas !! gas index + integer :: igroup !! group index + integer :: ibin !! bin index + integer :: iepart !! element for condensing group index + integer :: inuc !! nucleating element index + integer :: ienucto !! index of target nucleation element + integer :: ignucto !! index of target nucleation group + integer :: inucto !! index of target nucleation bin + logical :: evapfrom_nucto !! .true. when target droplets are evaporating + + + ! This calculation is only necessary for temperatures greater + ! than -40C. + if( t(iz) .ge. (T0 - 40._f) ) then + + ! Loop over particle groups. + do igroup = 1,NGROUP + + ! Bypass calculation if few particles are present + if( pconmax(iz,igroup) .gt. FEW_PC )then + + igas = inucgas(igroup) ! condensing gas + iepart = ienconc( igroup ) ! particle number density element + + if( igas .ne. 0 )then + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + do inuc = 1,nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + if( ienucto .ne. 0 )then + ignucto = igelem( ienucto ) + else + ignucto = 0 + endif + + ! Only compute nucleation rate for droplet activation + if( inucproc(iepart,ienucto) .eq. I_DROPACT ) then + + ! Loop over particle bins. Loop from largest to smallest for + ! evaluation of index of smallest bin nucleated during time step . + do ibin = NBIN, 1, -1 + + if( ignucto .ne. 0 )then + inucto = inuc2bin(ibin,igroup,ignucto) + else + inucto = 0 + endif + + ! Set to .true. when target droplets are evaporating + if( inucto .ne. 0 )then + evapfrom_nucto = evaplg(inucto,ignucto) .gt. 0._f + else + evapfrom_nucto = .false. + endif + + if( (supsatl(iz,igas) .gt. scrit(iz,ibin,igroup)) .and. & + (.not. evapfrom_nucto) .and. & + (pc(iz,ibin,iepart) .gt. SMALL_PC) )then + + rnuclg(ibin,igroup,ignucto) = 1.e3_f + endif + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPACT + enddo ! inuc = 1,nnuc2elem(iepart) + endif ! (igas = inucgas(igroup)) .ne. 0 + endif ! pconmax(iz,igroup) .gt. FEW_PC + enddo ! igroup = 1,NGROUP + endif ! t(iz) .ge. T0-40. + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/adgaquad_mod.F90 b/src/physics/carma/base/adgaquad_mod.F90 new file mode 100644 index 0000000000..3cc91de56c --- /dev/null +++ b/src/physics/carma/base/adgaquad_mod.F90 @@ -0,0 +1,3573 @@ +!! ****************************************************************** +!! The routines listed in this file "adgaquad_mod.F90" are performing +!! Numerical Integrations using some kind of +!! adaptive Gauss quadrature. +!! They are taken from the Internet (http://www.netlib.org) +!! and parts of different software packages / libraries. +!! ****************************************************************** +!! For any restrictions on the use of the routines, please see +!! the original web site. +!! ****************************************************************** +!! Changes: calls to error handler 'xerror()' replaced by +!! WRITE(7,*) - statements. +!! ****************************************************************** +!! list of routines and the libraries they are taken from: +!! dqag calling routine, bounded integration interval +!! QUADPACK; calls: dqage +!! dqage the integration routine, bounded interval +!! QUADPACK; calls: sd1mach,dqk15,dqk21,dqk31, +!! dqk41,dqk51,dqk61,dqpsrt +!! dqagi calling routine, unbounded (semi-infinite or +!! infinite) integration interval +!! QUADPACK; calls: dqagie +!! dqagie the integration routine, unbounded interval +!! QUADPACK; calls: sd1mach,dqelg,dqk15i,dqpsrt +!! ------------------------------------------------------------------ +!! dqk15 QUADPACK; calls: sd1mach +!! dqk21 QUADPACK; calls: sd1mach +!! dqk31 QUADPACK; calls: sd1mach +!! dqk41 QUADPACK; calls: sd1mach +!! dqk51 QUADPACK; calls: sd1mach +!! dqk61 QUADPACK; calls: sd1mach +!! dqpsrt QUADPACK; calls: none +!! dqk15i QUADPACK; calls: sd1mach +!! dqelg QUADPACK; calls: sd1mach +!! ------------------------------------------------------------------ +!! xerror Error handling routine +!! ALLIANT (/quad); calls: xerrwv +!! xerrwv Error handling routine +!! SODEPACK; calls: none +!! d1mach determine machine parameters (accuracies) +!! BLAS; calls: none +!! ------------------------------------------------------------------ + +module adgaquad_mod + + use carma_precision_mod + use adgaquad_types_mod + + implicit none + + private + + public :: dqag + public :: dqage + public :: dqagi + public :: dqagie + + contains + + !!***begin prologue dqag + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a1 + !!***keywords automatic integrator, general-purpose, + !! integrand examinator, globally adaptive, + !! gauss-kronrod + !!***author piessens,robert,appl. math. & progr. div - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose the routine calculates an approximation result to a given + !! definite integral i = integral of f over (a,b), + !! hopefully satisfying following claim for accuracy + !! abs(i-result)le.max(epsabs,epsrel*abs(i)). + !!***description + !! + !! computation of a definite integral + !! standard fortran subroutine + !! double precision version + !! + !! fx - double precision + !! function subprogam defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the driver program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! epsabs - double precision + !! absolute accoracy requested + !! epsrel - double precision + !! relative accuracy requested + !! if epsabs.le.0 + !! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! the routine will end with ier = 6. + !! + !! key - integer + !! key for choice of local integration rule + !! a gauss-kronrod pair is used with + !! 7 - 15 points if key.lt.2, + !! 10 - 21 points if key = 2, + !! 15 - 31 points if key = 3, + !! 20 - 41 points if key = 4, + !! 25 - 51 points if key = 5, + !! 30 - 61 points if key.gt.5. + !! + !! on return + !! result - double precision + !! approximation to the integral + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed abs(i-result) + !! + !! neval - integer + !! number of integrand evaluations + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine + !! the estimates for result and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! error messages + !! ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yield no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulaties. + !! if the position of a local difficulty can + !! be determined (i.e.singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used which is designed for + !! handling the type of difficulty involved. + !! = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! = 6 the input is invalid, because + !! (epsabs.le.0 and + !! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) + !! or limit.lt.1 or lenw.lt.limit*4. + !! result, abserr, neval, last are set + !! to zero. + !! except when lenw is invalid, iwork(1), + !! work(limit*2+1) and work(limit*3+1) are + !! set to zero, work(1) is set to a and + !! work(limit+1) to b. + !! = 9 failure in sd1mach determining machine parameters + !! + !! dimensioning parameters + !! limit - integer + !! dimensioning parameter for iwork + !! limit determines the maximum number of subintervals + !! in the partition of the given integration interval + !! (a,b), limit.ge.1. + !! if limit.lt.1, the routine will end with ier = 6. + !! + !! lenw - integer + !! dimensioning parameter for work + !! lenw must be at least limit*4. + !! if lenw.lt.limit*4, the routine will end with + !! ier = 6. + !! + !! last - integer + !! on return, last equals the number of subintervals + !! produced in the subdiviosion process, which + !! determines the number of significant elements + !! actually in the work arrays. + !! + !! work arrays + !! iwork - integer + !! vector of dimension at least limit, the first k + !! elements of which contain pointers to the error + !! estimates over the subintervals, such that + !! work(limit*3+iwork(1)),... , work(limit*3+iwork(k)) + !! form a decreasing sequence with k = last if + !! last.le.(limit/2+2), and k = limit+1-last otherwise + !! + !! work - double precision + !! vector of dimension at least lenw + !! on return + !! work(1), ..., work(last) contain the left end + !! points of the subintervals in the partition of + !! (a,b), + !! work(limit+1), ..., work(limit+last) contain the + !! right end points, + !! work(limit*2+1), ..., work(limit*2+last) contain + !! the integral approximations over the subintervals, + !! work(limit*3+1), ..., work(limit*3+last) contain + !! the error estimates. + !! + !!***references (none) + !!***routines called dqage,xerror + !!***end prologue dqag + subroutine dqag(fx,fx_vars,a,b,epsabs,epsrel,key,result,abserr,neval,ier, & + limit,lenw,last,iwork,work) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: epsabs + real(kind=f) :: epsrel + integer :: key + real(kind=f) :: result + real(kind=f) :: abserr + integer :: neval + integer :: ier + integer :: limit + integer :: lenw + integer :: last + integer :: iwork(limit) + real(kind=f) :: work(lenw) + + ! Local declarations + integer :: lvl,l1,l2,l3 + + ! check validity of lenw. + ! + !***first executable statement dqag + ier = 6 + neval = 0 + last = 0 + result = 0.0_f + abserr = 0.0_f + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 + + ! prepare call for dqage. + + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqage(fx,fx_vars,a,b,epsabs,epsrel,key,limit,result,abserr,neval, & + ier,work(1),work(l1),work(l2),work(l3),iwork,last) + + ! call error handler if necessary. + + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) then + write(*,*) "ERROR: abnormal return from dqag" + write(*,*) " ifail=",ier," level=",lvl + endif + return + end subroutine dqag + + + + !!***begin prologue dqage + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a1 + !!***keywords automatic integrator, general-purpose, + !! integrand examinator, globally adaptive, + !! gauss-kronrod + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose the routine calculates an approximation result to a given + !! definite integral i = integral of f over (a,b), + !! hopefully satisfying following claim for accuracy + !! abs(i-reslt).le.max(epsabs,epsrel*abs(i)). + !!***description + !! + !! computation of a definite integral + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the driver program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! epsabs - double precision + !! absolute accuracy requested + !! epsrel - double precision + !! relative accuracy requested + !! if epsabs.le.0 + !! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! the routine will end with ier = 6. + !! + !! key - integer + !! key for choice of local integration rule + !! a gauss-kronrod pair is used with + !! 7 - 15 points if key.lt.2, + !! 10 - 21 points if key = 2, + !! 15 - 31 points if key = 3, + !! 20 - 41 points if key = 4, + !! 25 - 51 points if key = 5, + !! 30 - 61 points if key.gt.5. + !! + !! limit - integer + !! gives an upperbound on the number of subintervals + !! in the partition of (a,b), limit.ge.1. + !! + !! on return + !! result - double precision + !! approximation to the integral + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed abs(i-result) + !! + !! neval - integer + !! number of integrand evaluations + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine + !! the estimates for result and error are + !! less reliable. it is assumed that the + !! requested accuracy has not been achieved. + !! error messages + !! ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value + !! of limit. + !! however, if this yields no improvement it + !! is rather advised to analyze the integrand + !! in order to determine the integration + !! difficulties. if the position of a local + !! difficulty can be determined(e.g. + !! singularity, discontinuity within the + !! interval) one will probably gain from + !! splitting up the interval at this point + !! and calling the integrator on the + !! subranges. if possible, an appropriate + !! special-purpose integrator should be used + !! which is designed for handling the type of + !! difficulty involved. + !! = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! = 6 the input is invalid, because + !! (epsabs.le.0 and + !! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! result, abserr, neval, last, rlist(1) , + !! elist(1) and iord(1) are set to zero. + !! alist(1) and blist(1) are set to a and b + !! respectively. + !! = 9 failure in sd1mach determining machine parameters + !! + !! alist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the left + !! end points of the subintervals in the partition + !! of the given integration range (a,b) + !! + !! blist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the right + !! end points of the subintervals in the partition + !! of the given integration range (a,b) + !! + !! rlist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the + !! integral approximations on the subintervals + !! + !! elist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the moduli of the + !! absolute error estimates on the subintervals + !! + !! iord - integer + !! vector of dimension at least limit, the first k + !! elements of which are pointers to the + !! error estimates over the subintervals, + !! such that elist(iord(1)), ..., + !! elist(iord(k)) form a decreasing sequence, + !! with k = last if last.le.(limit/2+2), and + !! k = limit+1-last otherwise + !! + !! last - integer + !! number of subintervals actually produced in the + !! subdivision process + !! + !!***references (none) + !!***routines called sd1mach,dqk15,dqk21,dqk31, + !! dqk41,dqk51,dqk61,dqpsrt + !!***end prologue dqage + subroutine dqage(fx,fx_vars,a,b,epsabs,epsrel,key,limit,result,abserr, & + neval,ier,alist,blist,rlist,elist,iord,last) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: epsabs + real(kind=f) :: epsrel + integer :: limit + integer :: key + real(kind=f) :: result + real(kind=f) :: abserr + integer :: neval + integer :: ier + real(kind=f) :: alist(limit) + real(kind=f) :: blist(limit) + real(kind=f) :: rlist(limit) + real(kind=f) :: elist(limit) + integer :: iord(limit) + integer :: last + + ! Local declarations + real(kind=f) :: area, area1, area12, area2, a1, a2 + real(kind=f) :: b1, b2, dabs, defabs, defab1, defab2, dmax1, epmach + real(kind=f) :: errbnd,errmax,error1,error2,erro12,errsum,resabs,uflow + integer :: iroff1,iroff2,k,keyf,maxerr,nrmax + + + ! list of major variables + ! ----------------------- + ! + ! alist - list of left end points of all subintervals + ! considered up to now + ! blist - list of right end points of all subintervals + ! considered up to now + ! rlist(i) - approximation to the integral over + ! (alist(i),blist(i)) + ! elist(i) - error estimate applying to rlist(i) + ! maxerr - pointer to the interval with largest + ! error estimate + ! errmax - elist(maxerr) + ! area - sum of the integrals over the subintervals + ! errsum - sum of the errors over the subintervals + ! errbnd - requested accuracy max(epsabs,epsrel* + ! abs(result)) + ! *****1 - variable for the left subinterval + ! *****2 - variable for the right subinterval + ! last - index for subdivision + ! + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqage + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + + ! test on validity of parameters + ! ------------------------------ + ! + ier = 0 + neval = 0 + last = 0 + result = 0.0_f + abserr = 0.0_f + alist(1) = a + blist(1) = b + rlist(1) = 0.0_f + elist(1) = 0.0_f + iord(1) = 0 + if(epsabs.le.0.0_f.and.epsrel.lt.dmax1(0.5e2_f*epmach,0.5e-28_f)) ier = 6 + if(ier.eq.6) go to 999 + + ! first approximation to the integral + ! ----------------------------------- + ! + keyf = key + if(key.le.0) keyf = 1 + if(key.ge.7) keyf = 6 + neval = 0 + if(keyf.eq.1) call dqk15(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + if(keyf.eq.2) call dqk21(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + if(keyf.eq.3) call dqk31(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + if(keyf.eq.4) call dqk41(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + if(keyf.eq.5) call dqk51(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + if(keyf.eq.6) call dqk61(fx,fx_vars,a,b,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + ! + ! test on accuracy. + ! + errbnd = dmax1(epsabs,epsrel*dabs(result)) + if(abserr.le.0.5e2_f*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or.abserr.eq.0.0d+00) go to 60 + ! + ! initialization + ! -------------- + ! + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 + ! + ! main do-loop + ! ------------ + ! + do last = 2,limit + ! + ! bisect the subinterval with the largest error estimate. + ! + a1 = alist(maxerr) + b1 = 0.5_f*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + if(keyf.eq.1) call dqk15(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.2) call dqk21(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.3) call dqk31(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.4) call dqk41(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.5) call dqk51(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.6) call dqk61(fx,fx_vars,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + if(keyf.eq.1) call dqk15(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + if(keyf.eq.2) call dqk21(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + if(keyf.eq.3) call dqk31(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + if(keyf.eq.4) call dqk41(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + if(keyf.eq.5) call dqk51(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + if(keyf.eq.6) call dqk61(fx,fx_vars,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + ! improve previous approximations to integral + ! and error and test for accuracy. + ! + ! neval = neval+1 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 5 + if(dabs(rlist(maxerr)-area12).le.0.1e-4_f*dabs(area12).and.erro12.ge.0.99_f*errmax) iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 + 5 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) + if(errsum.le.errbnd) go to 8 + ! + ! test for roundoff error and eventually set error flag. + ! + if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 + ! + ! set error flag in the case that the number of subintervals + ! equals limit. + ! + if(last.eq.limit) ier = 1 + ! + ! set error flag in the case of bad integrand behaviour + ! at a point of the integration range. + ! + if(dmax1(dabs(a1),dabs(b2)).le.(0.1e1_f+0.1e3_f*epmach)*(dabs(a2)+0.1e4_f*uflow)) ier = 3 + ! + ! append the newly-created intervals to the list. + ! + 8 if(error2.gt.error1) go to 10 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 20 + 10 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + ! + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with the largest error estimate (to be bisected next). + ! + 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + ! ***jump out of do-loop + if(ier.ne.0.or.errsum.le.errbnd) go to 40 + end do + ! + ! compute final result. + ! --------------------- + ! + 40 result = 0.0_f + do k=1,last + result = result+rlist(k) + end do + abserr = errsum + 60 if(keyf.ne.1) neval = (10*keyf+1)*(2*neval+1) + if(keyf.eq.1) neval = 30*neval+15 +999 return + end subroutine dqage + + + !!***begin prologue dqagi + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a3a1,h2a4a1 + !!***keywords automatic integrator, infinite intervals, + !! general-purpose, transformation, extrapolation, + !! globally adaptive + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. -k.u.leuven + !!***purpose the routine calculates an approximation result to a given + !! integral i = integral of f over (bound,+infinity) + !! or i = integral of f over (-infinity,bound) + !! or i = integral of f over (-infinity,+infinity) + !! hopefully satisfying following claim for accuracy + !! abs(i-result).le.max(epsabs,epsrel*abs(i)). + !!***description + !! + !! integration over infinite intervals + !! standard fortran subroutine + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the driver program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! bound - double precision + !! finite bound of integration range + !! (has no meaning if interval is doubly-infinite) + !! + !! inf - integer + !! indicating the kind of integration range involved + !! inf = 1 corresponds to (bound,+infinity), + !! inf = -1 to (-infinity,bound), + !! inf = 2 to (-infinity,+infinity). + !! + !! epsabs - double precision + !! absolute accuracy requested + !! epsrel - double precision + !! relative accuracy requested + !! if epsabs.le.0 + !! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! the routine will end with ier = 6. + !! + !! + !! on return + !! result - double precision + !! approximation to the integral + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed abs(i-result) + !! + !! neval - integer + !! number of integrand evaluations + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! - ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! error messages + !! ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however, if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. if + !! the position of a local difficulty can be + !! determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is assumed that the requested tolerance + !! cannot be achieved, and that the returned + !! result is the best which can be obtained. + !! = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! = 6 the input is invalid, because + !! (epsabs.le.0 and + !! epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) + !! or limit.lt.1 or leniw.lt.limit*4. + !! result, abserr, neval, last are set to + !! zero. exept when limit or leniw is + !! invalid, iwork(1), work(limit*2+1) and + !! work(limit*3+1) are set to zero, work(1) + !! is set to a and work(limit+1) to b. + !! = 9 failure in sd1mach determining machine parameters + !! + !! dimensioning parameters + !! limit - integer + !! dimensioning parameter for iwork + !! limit determines the maximum number of subintervals + !! in the partition of the given integration interval + !! (a,b), limit.ge.1. + !! if limit.lt.1, the routine will end with ier = 6. + !! + !! lenw - integer + !! dimensioning parameter for work + !! lenw must be at least limit*4. + !! if lenw.lt.limit*4, the routine will end + !! with ier = 6. + !! + !! last - integer + !! on return, last equals the number of subintervals + !! produced in the subdivision process, which + !! determines the number of significant elements + !! actually in the work arrays. + !! + !! work arrays + !! iwork - integer + !! vector of dimension at least limit, the first + !! k elements of which contain pointers + !! to the error estimates over the subintervals, + !! such that work(limit*3+iwork(1)),... , + !! work(limit*3+iwork(k)) form a decreasing + !! sequence, with k = last if last.le.(limit/2+2), and + !! k = limit+1-last otherwise + !! + !! work - double precision + !! vector of dimension at least lenw + !! on return + !! work(1), ..., work(last) contain the left + !! end points of the subintervals in the + !! partition of (a,b), + !! work(limit+1), ..., work(limit+last) contain + !! the right end points, + !! work(limit*2+1), ...,work(limit*2+last) contain the + !! integral approximations over the subintervals, + !! work(limit*3+1), ..., work(limit*3) + !! contain the error estimates. + !!***references (none) + !!***routines called dqagie,xerror + !!***end prologue dqagi + !! + subroutine dqagi(fx,fx_vars,bound,inf,epsabs,epsrel,result,abserr,neval, & + ier,limit,lenw,last,iwork,work) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: bound + integer :: inf + real(kind=f) :: epsabs + real(kind=f) :: epsrel + real(kind=f) :: result + real(kind=f) :: abserr + integer :: neval + integer :: ier + integer :: limit + integer :: lenw + integer :: last + integer :: iwork(limit) + real(kind=f) :: work(lenw) + + ! Local declarations + integer lvl,l1,l2,l3 + + ! + ! check validity of limit and lenw. + ! + !***first executable statement dqagi + ier = 6 + neval = 0 + last = 0 + result = 0.0_f + abserr = 0.0_f + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 + ! + ! prepare call for dqagie. + ! + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 + + call dqagie(fx,fx_vars,bound,inf,epsabs,epsrel,limit,result,abserr, & + neval,ier,work(1),work(l1),work(l2),work(l3),iwork,last) + ! + ! call error handler if necessary. + ! + lvl = 0 +10 if(ier.eq.6) lvl = 1 + if(ier.ne.0) then + write(*,*) "ERROR: abnormal return from dqagi" + write(*,*) " ifail=",ier," level=",lvl + endif + return + end subroutine dqagi + + + !!***begin prologue dqagie + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a3a1,h2a4a1 + !!***keywords automatic integrator, infinite intervals, + !! general-purpose, transformation, extrapolation, + !! globally adaptive + !!***author piessens,robert,appl. math & progr. div - k.u.leuven + !! de doncker,elise,appl. math & progr. div - k.u.leuven + !!***purpose the routine calculates an approximation result to a given + !! integral i = integral of f over (bound,+infinity) + !! or i = integral of f over (-infinity,bound) + !! or i = integral of f over (-infinity,+infinity), + !! hopefully satisfying following claim for accuracy + !! abs(i-result).le.max(epsabs,epsrel*abs(i)) + !!***description + !! + !! integration over infinite intervals + !! standard fortran subroutine + !! + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the driver program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! bound - double precision + !! finite bound of integration range + !! (has no meaning if interval is doubly-infinite) + !! + !! inf - double precision + !! indicating the kind of integration range involved + !! inf = 1 corresponds to (bound,+infinity), + !! inf = -1 to (-infinity,bound), + !! inf = 2 to (-infinity,+infinity). + !! + !! epsabs - double precision + !! absolute accuracy requested + !! epsrel - double precision + !! relative accuracy requested + !! if epsabs.le.0 + !! and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! the routine will end with ier = 6. + !! + !! limit - integer + !! gives an upper bound on the number of subintervals + !! in the partition of (a,b), limit.ge.1 + !! + !! on return + !! result - double precision + !! approximation to the integral + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed abs(i-result) + !! + !! neval - integer + !! number of integrand evaluations + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! - ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! error messages + !! ier = 1 maximum number of subdivisions allowed + !! has been achieved. one can allow more + !! subdivisions by increasing the value of + !! limit (and taking the according dimension + !! adjustments into account). however,if + !! this yields no improvement it is advised + !! to analyze the integrand in order to + !! determine the integration difficulties. + !! if the position of a local difficulty can + !! be determined (e.g. singularity, + !! discontinuity within the interval) one + !! will probably gain from splitting up the + !! interval at this point and calling the + !! integrator on the subranges. if possible, + !! an appropriate special-purpose integrator + !! should be used, which is designed for + !! handling the type of difficulty involved. + !! = 2 the occurrence of roundoff error is + !! detected, which prevents the requested + !! tolerance from being achieved. + !! the error may be under-estimated. + !! = 3 extremely bad integrand behaviour occurs + !! at some points of the integration + !! interval. + !! = 4 the algorithm does not converge. + !! roundoff error is detected in the + !! extrapolation table. + !! it is assumed that the requested tolerance + !! cannot be achieved, and that the returned + !! result is the best which can be obtained. + !! = 5 the integral is probably divergent, or + !! slowly convergent. it must be noted that + !! divergence can occur with any other value + !! of ier. + !! = 6 the input is invalid, because + !! (epsabs.le.0 and + !! epsrel.lt.max(50*rel.mach.acc.,0.5d-28), + !! result, abserr, neval, last, rlist(1), + !! elist(1) and iord(1) are set to zero. + !! alist(1) and blist(1) are set to 0 + !! and 1 respectively. + !! = 9 failure in sd1mach determining machine parameters + !! + !! alist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the left + !! end points of the subintervals in the partition + !! of the transformed integration range (0,1). + !! + !! blist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the right + !! end points of the subintervals in the partition + !! of the transformed integration range (0,1). + !! + !! rlist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the integral + !! approximations on the subintervals + !! + !! elist - double precision + !! vector of dimension at least limit, the first + !! last elements of which are the moduli of the + !! absolute error estimates on the subintervals + !! + !! iord - integer + !! vector of dimension limit, the first k + !! elements of which are pointers to the + !! error estimates over the subintervals, + !! such that elist(iord(1)), ..., elist(iord(k)) + !! form a decreasing sequence, with k = last + !! if last.le.(limit/2+2), and k = limit+1-last + !! otherwise + !! + !! last - integer + !! number of subintervals actually produced + !! in the subdivision process + !! + !!***references (none) + !!***routines called sd1mach,dqelg,dqk15i,dqpsrt + !!***end prologue dqagie + subroutine dqagie(fx,fx_vars,bound,inf,epsabs,epsrel,limit,result,abserr,neval,ier,alist,blist,rlist,elist,iord,last) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: bound + integer :: inf + real(kind=f) :: epsabs + real(kind=f) :: epsrel + integer :: limit + real(kind=f) :: result + real(kind=f) :: abserr + integer :: neval + integer :: ier + real(kind=f) :: alist(limit) + real(kind=f) :: blist(limit) + real(kind=f) :: rlist(limit) + real(kind=f) :: elist(limit) + integer :: iord(limit) + integer :: last + + ! Local declartions + real(kind=f) :: abseps, area, area1, area12, area2 + real(kind=f) :: a1, a2, b1, b2, correc + real(kind=f) :: defabs, defab1, defab2 + real(kind=f) :: dmax1, dres, epmach, erlarg, erlast + real(kind=f) :: errbnd, errmax, error1, error2, erro12, errsum + real(kind=f) :: ertest, oflow, resabs, reseps, res3la(3), rlist2(52) + real(kind=f) :: small, uflow, boun + + integer :: id, ierro, iroff1, iroff2, iroff3, jupbnd, k, ksgn + integer :: ktmin, maxerr, nres, nrmax, numrl2 + logical :: extrap, noext + + + ! + ! the dimension of rlist2 is determined by the value of + ! limexp in subroutine dqelg. + ! + ! list of major variables + ! ----------------------- + ! + ! alist - list of left end points of all subintervals + ! considered up to now + ! blist - list of right end points of all subintervals + ! considered up to now + ! rlist(i) - approximation to the integral over + ! (alist(i),blist(i)) + ! rlist2 - array of dimension at least (limexp+2), + ! containing the part of the epsilon table + ! wich is still needed for further computations + ! elist(i) - error estimate applying to rlist(i) + ! maxerr - pointer to the interval with largest error + ! estimate + ! errmax - elist(maxerr) + ! erlast - error on the interval currently subdivided + ! (before that subdivision has taken place) + ! area - sum of the integrals over the subintervals + ! errsum - sum of the errors over the subintervals + ! errbnd - requested accuracy max(epsabs,epsrel* + ! abs(result)) + ! *****1 - variable for the left subinterval + ! *****2 - variable for the right subinterval + ! last - index for subdivision + ! nres - number of calls to the extrapolation routine + ! numrl2 - number of elements currently in rlist2. if an + ! appropriate approximation to the compounded + ! integral has been obtained, it is put in + ! rlist2(numrl2) after numrl2 has been increased + ! by one. + ! small - length of the smallest interval considered up + ! to now, multiplied by 1.5 + ! erlarg - sum of the errors over the intervals larger + ! than the smallest interval considered up to now + ! extrap - logical variable denoting that the routine + ! is attempting to perform extrapolation. i.e. + ! before subdividing the smallest interval we + ! try to decrease the value of erlarg. + ! noext - logical variable denoting that extrapolation + ! is no longer allowed (true-value) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! oflow is the largest positive magnitude. + ! + !***first executable statement dqagie + + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + ! + ! test on validity of parameters + ! ----------------------------- + ! + ier = 0 + neval = 0 + last = 0 + result = 0.0_f + abserr = 0.0_f + alist(1) = 0.0_f + blist(1) = 0.1e1_f + rlist(1) = 0.0_f + elist(1) = 0.0_f + iord(1) = 0 + if(epsabs.le.0.0_f.and.epsrel.lt.dmax1(0.5e2_f*epmach,0.5e-28_f)) ier = 6 + if(ier.eq.6) go to 999 + ! + ! + ! first approximation to the integral + ! ----------------------------------- + ! + ! determine the interval to be mapped onto (0,1). + ! if inf = 2 the integral is computed as i = i1+i2, where + ! i1 = integral of f over (-infinity,0), + ! i2 = integral of f over (0,+infinity). + ! + boun = bound + if(inf.eq.2) boun = 0.0_f + call dqk15i(fx,fx_vars,boun,inf,0.0_f,0.1e1_f,result,abserr,defabs,resabs,ier) + if(ier.eq.9) return + ! + ! test on accuracy + ! + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 + dres = dabs(result) + errbnd = dmax1(epsabs,epsrel*dres) + if(abserr.le.1.0e2_f*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or.abserr.eq.0.0_f) go to 130 + ! + ! initialization + ! -------------- + ! + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + call sd1mach(2,oflow,ier) + if(ier.eq.9) return + + !uflow = d1mach(1) + !oflow = d1mach(2) + rlist2(1) = result + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + abserr = oflow + nrmax = 1 + nres = 0 + ktmin = 0 + numrl2 = 2 + extrap = .false. + noext = .false. + ierro = 0 + iroff1 = 0 + iroff2 = 0 + iroff3 = 0 + ksgn = -1 + if(dres.ge.(0.1e1_f-0.5e2_f*epmach)*defabs) ksgn = 1 + ! + ! main do-loop + ! ------------ + ! + do 90 last = 2,limit + ! + ! bisect the subinterval with nrmax-th largest error estimate. + ! + a1 = alist(maxerr) + b1 = 0.5_f*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + erlast = errmax + call dqk15i(fx,fx_vars,boun,inf,a1,b1,area1,error1,resabs,defab1,ier) + if(ier.eq.9) return + call dqk15i(fx,fx_vars,boun,inf,a2,b2,area2,error2,resabs,defab2,ier) + if(ier.eq.9) return + ! + ! improve previous approximations to integral + ! and error and test for accuracy. + ! + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2)go to 15 + if(dabs(rlist(maxerr)-area12).gt.0.1e-4_f*dabs(area12).or.erro12.lt.0.99_f*errmax) go to 10 + if(extrap) iroff2 = iroff2+1 + if(.not.extrap) iroff1 = iroff1+1 + 10 if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1 + 15 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) + ! + ! test for roundoff error and eventually set error flag. + ! + if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2 + if(iroff2.ge.5) ierro = 3 + ! + ! set error flag in the case that the number of + ! subintervals equals limit. + ! + if(last.eq.limit) ier = 1 + ! + ! set error flag in the case of bad integrand behaviour + ! at some points of the integration range. + ! + if(dmax1(dabs(a1),dabs(b2)).le.(0.1e1_f+0.1e3_f*epmach)*(dabs(a2)+0.1e4_f*uflow)) ier = 4 + ! + ! append the newly-created intervals to the list. + ! + if(error2.gt.error1) go to 20 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 30 + 20 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 + ! + ! call subroutine dqpsrt to maintain the descending ordering + ! in the list of error estimates and select the subinterval + ! with nrmax-th largest error estimate (to be bisected next). + ! + 30 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) + if(errsum.le.errbnd) go to 115 + if(ier.ne.0) go to 100 + if(last.eq.2) go to 80 + if(noext) go to 90 + erlarg = erlarg-erlast + if(dabs(b1-a1).gt.small) erlarg = erlarg+erro12 + if(extrap) go to 40 + ! + ! test whether the interval to be bisected next is the + ! smallest interval. + ! + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + extrap = .true. + nrmax = 2 + 40 if(ierro.eq.3.or.erlarg.le.ertest) go to 60 + ! + ! the smallest interval has the largest error. + ! before bisecting decrease the sum of the errors over the + ! larger intervals (erlarg) and perform extrapolation. + ! + id = nrmax + jupbnd = last + if(last.gt.(2+limit/2)) jupbnd = limit+3-last + do k = id,jupbnd + maxerr = iord(nrmax) + errmax = elist(maxerr) + if(dabs(blist(maxerr)-alist(maxerr)).gt.small) go to 90 + nrmax = nrmax+1 + end do + ! + ! perform extrapolation. + ! + 60 numrl2 = numrl2+1 + rlist2(numrl2) = area + call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres, ier) + if(ier.eq.9) return + ktmin = ktmin+1 + if(ktmin.gt.5.and.abserr.lt.0.1e-2_f*errsum) ier = 5 + if(abseps.ge.abserr) go to 70 + ktmin = 0 + abserr = abseps + result = reseps + correc = erlarg + ertest = dmax1(epsabs,epsrel*dabs(reseps)) + if(abserr.le.ertest) go to 100 + ! + ! prepare bisection of the smallest interval. + ! + 70 if(numrl2.eq.1) noext = .true. + if(ier.eq.5) go to 100 + maxerr = iord(1) + errmax = elist(maxerr) + nrmax = 1 + extrap = .false. + small = small*0.5_f + erlarg = errsum + go to 90 + 80 small = 0.375_f + erlarg = errsum + ertest = errbnd + rlist2(2) = area + 90 continue + ! + ! set final result and error estimate. + ! ------------------------------------ + ! +100 if(abserr.eq.oflow) go to 115 + if((ier+ierro).eq.0) go to 110 + if(ierro.eq.3) abserr = abserr+correc + if(ier.eq.0) ier = 3 + if(result.ne.0.0_f.and.area.ne.0.0_f)go to 105 + if(abserr.gt.errsum)go to 115 + if(area.eq.0.0_f) go to 130 + go to 110 +105 if(abserr/dabs(result).gt.errsum/dabs(area))go to 115 + ! + ! test on divergence + ! +110 if(ksgn.eq.(-1).and.dmax1(dabs(result),dabs(area)).le.defabs*0.1e-1_f) go to 130 + if(0.1e-1_f.gt.(result/area).or.(result/area).gt.0.1e3_f.or.errsum.gt.dabs(area)) ier = 6 + go to 130 + ! + ! compute global integral sum. + ! +115 result = 0.0_f + do k = 1,last + result = result+rlist(k) + end do + abserr = errsum +130 neval = 30*last-15 + if(inf.eq.2) neval = 2*neval + if(ier.gt.2) ier=ier-1 +999 return + end subroutine dqagie + + + !!***begin prologue dqk15 + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 15-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div - k.u.leuven + !!***purpose to compute i = integral of f over (a,b), with error + !! estimate + !! j = integral of abs(f) over (a,b) + !!***description + !! + !! integration rules + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code! + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 15-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the7-point gauss rule(resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should not exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of abs(f-i/(b-a)) + !! over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk15 + !! + subroutine dqk15(fx,fx_vars,a,b,result,abserr,resabs,resasc,ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local Declarations + real(kind=f) :: absc, centr, dabs, dhlgth, dmax2, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(7), fv2(7), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(4), wgk(8), xgk(8) + integer :: j,jtw,jtwm1 + + ! + ! + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 15-point kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 7-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 7-point gauss rule + ! + ! wgk - weights of the 15-point kronrod rule + ! + ! wg - weights of the 7-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.129484966168869693270611432679082_f / + data wg ( 2) / 0.279705391489276667901467771423780_f / + data wg ( 3) / 0.381830050505118944950369775488975_f / + data wg ( 4) / 0.417959183673469387755102040816327_f / + + data xgk ( 1) / 0.991455371120812639206854697526329_f / + data xgk ( 2) / 0.949107912342758524526189684047851_f / + data xgk ( 3) / 0.864864423359769072789712788640926_f / + data xgk ( 4) / 0.741531185599394439863864773280788_f / + data xgk ( 5) / 0.586087235467691130294144838258730_f / + data xgk ( 6) / 0.405845151377397166906606412076961_f / + data xgk ( 7) / 0.207784955007898467600689403773245_f / + data xgk ( 8) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.022935322010529224963732008058970_f / + data wgk ( 2) / 0.063092092629978553290700663189204_f / + data wgk ( 3) / 0.104790010322250183839876322541518_f / + data wgk ( 4) / 0.140653259715525918745189590510238_f / + data wgk ( 5) / 0.169004726639267902826583426598550_f / + data wgk ( 6) / 0.190350578064785409913256402421014_f / + data wgk ( 7) / 0.204432940075298892414161999234649_f / + data wgk ( 8) / 0.209482141084727828012999174891714_f / + + ! + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 7-point gauss formula + ! resk - result of the 15-point kronrod formula + ! reskh - approximation to the mean value of f over (a,b), + ! i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk15 + !epmach = d1mach(4) + !uflow = d1mach(1) + + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 15-point kronrod approximation to + ! the integral, and estimate the absolute error. + ! + fc = fx(centr,fx_vars) + resg = fc*wg(4) + resk = fc*wgk(8) + resabs = dabs(resk) + do j=1,3 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = fx(centr-absc,fx_vars) + fval2 = fx(centr+absc,fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j = 1,4 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = fx(centr-absc,fx_vars) + fval2 = fx(centr+absc,fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(8)*dabs(fc-reskh) + do j=1,7 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0.0_f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk15 + + !! + !!***begin prologue dqk21 + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 21-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose to compute i = integral of f over (a,b), with error + !! estimate + !! j = integral of abs(f) over (a,b) + !!***description + !! + !! integration rules + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the driver program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 21-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the 10-point gauss rule (resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should not exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of abs(f-i/(b-a)) + !! over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk21 + !! + subroutine dqk21(fx,fx_vars,a,b,result,abserr,resabs,resasc, ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declarations + real(kind=f) :: absc, centr, dabs, dhlgth, dmax1, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(10), fv2(10), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(5), wgk(11),xgk(11) + integer :: j,jtw,jtwm1 + + ! + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 21-point kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 10-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 10-point gauss rule + ! + ! wgk - weights of the 21-point kronrod rule + ! + ! wg - weights of the 10-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.066671344308688137593568809893332_f / + data wg ( 2) / 0.149451349150580593145776339657697_f / + data wg ( 3) / 0.219086362515982043995534934228163_f / + data wg ( 4) / 0.269266719309996355091226921569469_f / + data wg ( 5) / 0.295524224714752870173892994651338_f / + + data xgk ( 1) / 0.995657163025808080735527280689003_f / + data xgk ( 2) / 0.973906528517171720077964012084452_f / + data xgk ( 3) / 0.930157491355708226001207180059508_f / + data xgk ( 4) / 0.865063366688984510732096688423493_f / + data xgk ( 5) / 0.780817726586416897063717578345042_f / + data xgk ( 6) / 0.679409568299024406234327365114874_f / + data xgk ( 7) / 0.562757134668604683339000099272694_f / + data xgk ( 8) / 0.433395394129247190799265943165784_f / + data xgk ( 9) / 0.294392862701460198131126603103866_f / + data xgk ( 10) / 0.148874338981631210884826001129720_f / + data xgk ( 11) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.011694638867371874278064396062192_f / + data wgk ( 2) / 0.032558162307964727478818972459390_f / + data wgk ( 3) / 0.054755896574351996031381300244580_f / + data wgk ( 4) / 0.075039674810919952767043140916190_f / + data wgk ( 5) / 0.093125454583697605535065465083366_f / + data wgk ( 6) / 0.109387158802297641899210590325805_f / + data wgk ( 7) / 0.123491976262065851077958109831074_f / + data wgk ( 8) / 0.134709217311473325928054001771707_f / + data wgk ( 9) / 0.142775938577060080797094273138717_f / + data wgk ( 10) / 0.147739104901338491374841515972068_f / + data wgk ( 11) / 0.149445554002916905664936468389821_f / + + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 10-point gauss formula + ! resk - result of the 21-point kronrod formula + ! reskh - approximation to the mean value of f over (a,b), + ! i.e. to i/(b-a) + ! + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk21 + !epmach = d1mach(4) + !uflow = d1mach(1) + + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 21-point kronrod approximation to + ! the integral, and estimate the absolute error. + ! + resg = 0.0_f + fc = fx(centr, fx_vars) + resk = wgk(11)*fc + resabs = dabs(resk) + do j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(11)*dabs(fc-reskh) + do j=1,10 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0.0_f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk21 + + !!***begin prologue dqk31 + !!***date written 800101 (yymmdd) + !!***revision date 130519 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 31-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose to compute i = integral of f over (a,b) with error + !! estimate + !! j = integral of abs(f) over (a,b) + !!***description + !! + !! integration rules + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code! + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 31-point + !! gauss-kronrod rule (resk), obtained by optimal + !! addition of abscissae to the 15-point gauss + !! rule (resg). + !! + !! abserr - double precison + !! estimate of the modulus of the modulus, + !! which should not exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of abs(f-i/(b-a)) + !! over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk31 + subroutine dqk31(fx,fx_vars,a,b,result,abserr,resabs,resasc, ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declarations + real(kind=f) :: absc, centr, dabs, dhlgth, dmax1, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(15), fv2(15), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(8), wgk(16), xgk(16) + integer :: j,jtw,jtwm1 + + ! + ! + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 31-point kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 15-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 15-point gauss rule + ! + ! wgk - weights of the 31-point kronrod rule + ! + ! wg - weights of the 15-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.030753241996117268354628393577204_f / + data wg ( 2) / 0.070366047488108124709267416450667_f / + data wg ( 3) / 0.107159220467171935011869546685869_f / + data wg ( 4) / 0.139570677926154314447804794511028_f / + data wg ( 5) / 0.166269205816993933553200860481209_f / + data wg ( 6) / 0.186161000015562211026800561866423_f / + data wg ( 7) / 0.198431485327111576456118326443839_f / + data wg ( 8) / 0.202578241925561272880620199967519_f / + + data xgk ( 1) / 0.998002298693397060285172840152271_f / + data xgk ( 2) / 0.987992518020485428489565718586613_f / + data xgk ( 3) / 0.967739075679139134257347978784337_f / + data xgk ( 4) / 0.937273392400705904307758947710209_f / + data xgk ( 5) / 0.897264532344081900882509656454496_f / + data xgk ( 6) / 0.848206583410427216200648320774217_f / + data xgk ( 7) / 0.790418501442465932967649294817947_f / + data xgk ( 8) / 0.724417731360170047416186054613938_f / + data xgk ( 9) / 0.650996741297416970533735895313275_f / + data xgk ( 10) / 0.570972172608538847537226737253911_f / + data xgk ( 11) / 0.485081863640239680693655740232351_f / + data xgk ( 12) / 0.394151347077563369897207370981045_f / + data xgk ( 13) / 0.299180007153168812166780024266389_f / + data xgk ( 14) / 0.201194093997434522300628303394596_f / + data xgk ( 15) / 0.101142066918717499027074231447392_f / + data xgk ( 16) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.005377479872923348987792051430128_f / + data wgk ( 2) / 0.015007947329316122538374763075807_f / + data wgk ( 3) / 0.025460847326715320186874001019653_f / + data wgk ( 4) / 0.035346360791375846222037948478360_f / + data wgk ( 5) / 0.044589751324764876608227299373280_f / + data wgk ( 6) / 0.053481524690928087265343147239430_f / + data wgk ( 7) / 0.062009567800670640285139230960803_f / + data wgk ( 8) / 0.069854121318728258709520077099147_f / + data wgk ( 9) / 0.076849680757720378894432777482659_f / + data wgk ( 10) / 0.083080502823133021038289247286104_f / + data wgk ( 11) / 0.088564443056211770647275443693774_f / + data wgk ( 12) / 0.093126598170825321225486872747346_f / + data wgk ( 13) / 0.096642726983623678505179907627589_f / + data wgk ( 14) / 0.099173598721791959332393173484603_f / + data wgk ( 15) / 0.100769845523875595044946662617570_f / + data wgk ( 16) / 0.101330007014791549017374792767493_f / + ! + ! + ! list of major variables + ! ----------------------- + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 15-point gauss formula + ! resk - result of the 31-point kronrod formula + ! reskh - approximation to the mean value of f over (a,b), + ! i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + !***first executable statement dqk31 + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 31-point kronrod approximation to + ! the integral, and estimate the absolute error. + ! + fc = fx(centr, fx_vars) + resg = wg(8)*fc + resk = wgk(16)*fc + resabs = dabs(resk) + do j=1,7 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j = 1,8 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(16)*dabs(fc-reskh) + do j=1,15 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0.0_f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk31 + + + + !!***begin prologue dqk41 + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 41-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose to compute i = integral of f over (a,b), with error + !! estimate + !! j = integral of abs(f) over (a,b) + !!***description + !! + !! integration rules + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 41-point + !! gauss-kronrod rule (resk) obtained by optimal + !! addition of abscissae to the 20-point gauss + !! rule (resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should not exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integal of abs(f-i/(b-a)) + !! over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk41 + !! + subroutine dqk41(fx,fx_vars,a,b,result,abserr,resabs,resasc, ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declarations + real(kind=f) :: absc, centr, dabs, dhlgth, dmax1, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(20), fv2(20), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(10), wgk(21), xgk(21) + integer :: j, jtw, jtwm1 + + ! + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 41-point gauss-kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 20-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 20-point gauss rule + ! + ! wgk - weights of the 41-point gauss-kronrod rule + ! + ! wg - weights of the 20-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.017614007139152118311861962351853_f / + data wg ( 2) / 0.040601429800386941331039952274932_f / + data wg ( 3) / 0.062672048334109063569506535187042_f / + data wg ( 4) / 0.083276741576704748724758143222046_f / + data wg ( 5) / 0.101930119817240435036750135480350_f / + data wg ( 6) / 0.118194531961518417312377377711382_f / + data wg ( 7) / 0.131688638449176626898494499748163_f / + data wg ( 8) / 0.142096109318382051329298325067165_f / + data wg ( 9) / 0.149172986472603746787828737001969_f / + data wg ( 10) / 0.152753387130725850698084331955098_f / + + data xgk ( 1) / 0.998859031588277663838315576545863_f / + data xgk ( 2) / 0.993128599185094924786122388471320_f / + data xgk ( 3) / 0.981507877450250259193342994720217_f / + data xgk ( 4) / 0.963971927277913791267666131197277_f / + data xgk ( 5) / 0.940822633831754753519982722212443_f / + data xgk ( 6) / 0.912234428251325905867752441203298_f / + data xgk ( 7) / 0.878276811252281976077442995113078_f / + data xgk ( 8) / 0.839116971822218823394529061701521_f / + data xgk ( 9) / 0.795041428837551198350638833272788_f / + data xgk ( 10) / 0.746331906460150792614305070355642_f / + data xgk ( 11) / 0.693237656334751384805490711845932_f / + data xgk ( 12) / 0.636053680726515025452836696226286_f / + data xgk ( 13) / 0.575140446819710315342946036586425_f / + data xgk ( 14) / 0.510867001950827098004364050955251_f/ + data xgk ( 15) / 0.443593175238725103199992213492640_f / + data xgk ( 16) / 0.373706088715419560672548177024927_f / + data xgk ( 17) / 0.301627868114913004320555356858592_f / + data xgk ( 18) / 0.227785851141645078080496195368575_f / + data xgk ( 19) / 0.152605465240922675505220241022678_f / + data xgk ( 20) / 0.076526521133497333754640409398838_f / + data xgk ( 21) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.003073583718520531501218293246031_f / + data wgk ( 2) / 0.008600269855642942198661787950102_f / + data wgk ( 3) / 0.014626169256971252983787960308868_f / + data wgk ( 4) / 0.020388373461266523598010231432755_f / + data wgk ( 5) / 0.025882133604951158834505067096153_f / + data wgk ( 6) / 0.031287306777032798958543119323801_f / + data wgk ( 7) / 0.036600169758200798030557240707211_f / + data wgk ( 8) / 0.041668873327973686263788305936895_f / + data wgk ( 9) / 0.046434821867497674720231880926108_f / + data wgk ( 10) / 0.050944573923728691932707670050345_f / + data wgk ( 11) / 0.055195105348285994744832372419777_f / + data wgk ( 12) / 0.059111400880639572374967220648594_f / + data wgk ( 13) / 0.062653237554781168025870122174255_f / + data wgk ( 14) / 0.065834597133618422111563556969398_f / + data wgk ( 15) / 0.068648672928521619345623411885368_f / + data wgk ( 16) / 0.071054423553444068305790361723210_f / + data wgk ( 17) / 0.073030690332786667495189417658913_f / + data wgk ( 18) / 0.074582875400499188986581418362488_f / + data wgk ( 19) / 0.075704497684556674659542775376617_f / + data wgk ( 20) / 0.076377867672080736705502835038061_f / + data wgk ( 21) / 0.076600711917999656445049901530102_f / + + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 20-point gauss formula + ! resk - result of the 41-point kronrod formula + ! reskh - approximation to mean value of f over (a,b), i.e. + ! to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk41 + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 41-point gauss-kronrod approximation to + ! the integral, and estimate the absolute error. + ! + resg = 0.0_f + fc = fx(centr, fx_vars) + resk = wgk(21)*fc + resabs = dabs(resk) + do j=1,10 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j = 1,10 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(21)*dabs(fc-reskh) + do j=1,20 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0._f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk41 + + + !!***begin prologue dqk51 + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 51-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math & progr. div. - k.u.leuven + !!***purpose to compute i = integral of f over (a,b) with error + !! estimate + !! j = integral of abs(f) over (a,b) + !!***description + !! + !! integration rules + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! function subroutine defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 51-point + !! kronrod rule (resk) obtained by optimal addition + !! of abscissae to the 25-point gauss rule (resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should not exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of abs(f-i/(b-a)) + !! over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk51 + !! + subroutine dqk51(fx,fx_vars,a,b,result,abserr,resabs,resasc,ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declarations + real(kind=f) :: absc, centr, dabs, dhlgth, dmax1, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(25), fv2(25), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(13),wgk(26), xgk(26) + integer j,jtw,jtwm1 + + ! + ! the abscissae and weights are given for the interval (-1,1). + ! because of symmetry only the positive abscissae and their + ! corresponding weights are given. + ! + ! xgk - abscissae of the 51-point kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 25-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 25-point gauss rule + ! + ! wgk - weights of the 51-point kronrod rule + ! + ! wg - weights of the 25-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.011393798501026287947902964113235_f / + data wg ( 2) / 0.026354986615032137261901815295299_f / + data wg ( 3) / 0.040939156701306312655623487711646_f / + data wg ( 4) / 0.054904695975835191925936891540473_f / + data wg ( 5) / 0.068038333812356917207187185656708_f / + data wg ( 6) / 0.080140700335001018013234959669111_f / + data wg ( 7) / 0.091028261982963649811497220702892_f / + data wg ( 8) / 0.100535949067050644202206890392686_f / + data wg ( 9) / 0.108519624474263653116093957050117_f / + data wg ( 10) / 0.114858259145711648339325545869556_f / + data wg ( 11) / 0.119455763535784772228178126512901_f / + data wg ( 12) / 0.122242442990310041688959518945852_f / + data wg ( 13) / 0.123176053726715451203902873079050_f / + + data xgk ( 1) / 0.999262104992609834193457486540341_f / + data xgk ( 2) / 0.995556969790498097908784946893902_f / + data xgk ( 3) / 0.988035794534077247637331014577406_f / + data xgk ( 4) / 0.976663921459517511498315386479594_f / + data xgk ( 5) / 0.961614986425842512418130033660167_f / + data xgk ( 6) / 0.942974571228974339414011169658471_f / + data xgk ( 7) / 0.920747115281701561746346084546331_f / + data xgk ( 8) / 0.894991997878275368851042006782805_f / + data xgk ( 9) / 0.865847065293275595448996969588340_f / + data xgk ( 10) / 0.833442628760834001421021108693570_f / + data xgk ( 11) / 0.797873797998500059410410904994307_f / + data xgk ( 12) / 0.759259263037357630577282865204361_f / + data xgk ( 13) / 0.717766406813084388186654079773298_f / + data xgk ( 14) / 0.673566368473468364485120633247622_f / + data xgk ( 15) / 0.626810099010317412788122681624518_f / + data xgk ( 16) / 0.577662930241222967723689841612654_f / + data xgk ( 17) / 0.526325284334719182599623778158010_f / + data xgk ( 18) / 0.473002731445714960522182115009192_f / + data xgk ( 19) / 0.417885382193037748851814394594572_f / + data xgk ( 20) / 0.361172305809387837735821730127641_f / + data xgk ( 21) / 0.303089538931107830167478909980339_f / + data xgk ( 22) / 0.243866883720988432045190362797452_f / + data xgk ( 23) / 0.183718939421048892015969888759528_f / + data xgk ( 24) / 0.122864692610710396387359818808037_f / + data xgk ( 25) / 0.061544483005685078886546392366797_f / + data xgk ( 26) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.001987383892330315926507851882843_f / + data wgk ( 2) / 0.005561932135356713758040236901066_f / + data wgk ( 3) / 0.009473973386174151607207710523655_f / + data wgk ( 4) / 0.013236229195571674813656405846976_f / + data wgk ( 5) / 0.016847817709128298231516667536336_f / + data wgk ( 6) / 0.020435371145882835456568292235939_f / + data wgk ( 7) / 0.024009945606953216220092489164881_f / + data wgk ( 8) / 0.027475317587851737802948455517811_f / + data wgk ( 9) / 0.030792300167387488891109020215229_f / + data wgk ( 10) / 0.034002130274329337836748795229551_f / + data wgk ( 11) / 0.037116271483415543560330625367620_f / + data wgk ( 12) / 0.040083825504032382074839284467076_f / + data wgk ( 13) / 0.042872845020170049476895792439495_f / + data wgk ( 14) / 0.045502913049921788909870584752660_f / + data wgk ( 15) / 0.047982537138836713906392255756915_f / + data wgk ( 16) / 0.050277679080715671963325259433440_f / + data wgk ( 17) / 0.052362885806407475864366712137873_f / + data wgk ( 18) / 0.054251129888545490144543370459876_f / + data wgk ( 19) / 0.055950811220412317308240686382747_f / + data wgk ( 20) / 0.057437116361567832853582693939506_f / + data wgk ( 21) / 0.058689680022394207961974175856788_f / + data wgk ( 22) / 0.059720340324174059979099291932562_f / + data wgk ( 23) / 0.060539455376045862945360267517565_f / + data wgk ( 24) / 0.061128509717053048305859030416293_f / + data wgk ( 25) / 0.061471189871425316661544131965264_f / + ! note: wgk (26) was calculated from the values of wgk(1..25) + data wgk ( 26) / 0.061580818067832935078759824240066_f / + + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc - abscissa + ! fval* - function value + ! resg - result of the 25-point gauss formula + ! resk - result of the 51-point kronrod formula + ! reskh - approximation to the mean value of f over (a,b), + ! i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !***first executable statement dqk51 + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 51-point kronrod approximation to + ! the integral, and estimate the absolute error. + ! + fc = fx(centr, fx_vars) + resg = wg(13)*fc + resk = wgk(26)*fc + resabs = dabs(resk) + do j=1,12 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j = 1,13 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = fx(centr-absc, fx_vars) + fval2 = fx(centr+absc, fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(26)*dabs(fc-reskh) + do j=1,25 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0.0_f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk51 + + !!***begin prologue dqk61 + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a1a2 + !!***keywords 61-point gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose to compute i = integral of f over (a,b) with error + !! estimate + !! j = integral of dabs(f) over (a,b) + !!***description + !! + !! integration rule + !! standard fortran subroutine + !! double precision version + !! + !! + !! parameters + !! on entry + !! fx - double precision + !! function subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code + !! + !! a - double precision + !! lower limit of integration + !! + !! b - double precision + !! upper limit of integration + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 61-point + !! kronrod rule (resk) obtained by optimal addition of + !! abscissae to the 30-point gauss rule (resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed dabs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of dabs(f-i/(b-a)) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk61 + !! + subroutine dqk61(fx,fx_vars,a,b,result,abserr,resabs,resasc, ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declartions + real(kind=f) :: dabsc, centr, dabs, dhlgth, dmax1, dmin1 + real(kind=f) :: epmach, fc, fsum, fval1, fval2, fv1(30), fv2(30), hlgth + real(kind=f) :: resg, resk, reskh, uflow, wg(15) ,wgk(31), xgk(31) + integer :: j, jtw, jtwm1 + + ! + ! the abscissae and weights are given for the + ! interval (-1,1). because of symmetry only the positive + ! abscissae and their corresponding weights are given. + ! + ! xgk - abscissae of the 61-point kronrod rule + ! xgk(2), xgk(4) ... abscissae of the 30-point + ! gauss rule + ! xgk(1), xgk(3) ... optimally added abscissae + ! to the 30-point gauss rule + ! + ! wgk - weights of the 61-point kronrod rule + ! + ! wg - weigths of the 30-point gauss rule + ! + ! + ! gauss quadrature weights and kronron quadrature abscissae and weights + ! as evaluated with 80 decimal digit arithmetic by l. w. fullerton, + ! bell labs, nov. 1981. + ! + data wg ( 1) / 0.007968192496166605615465883474674_f / + data wg ( 2) / 0.018466468311090959142302131912047_f / + data wg ( 3) / 0.028784707883323369349719179611292_f / + data wg ( 4) / 0.038799192569627049596801936446348_f / + data wg ( 5) / 0.048402672830594052902938140422808_f / + data wg ( 6) / 0.057493156217619066481721689402056_f / + data wg ( 7) / 0.065974229882180495128128515115962_f / + data wg ( 8) / 0.073755974737705206268243850022191_f / + data wg ( 9) / 0.080755895229420215354694938460530_f / + data wg ( 10) / 0.086899787201082979802387530715126_f / + data wg ( 11) / 0.092122522237786128717632707087619_f / + data wg ( 12) / 0.096368737174644259639468626351810_f / + data wg ( 13) / 0.099593420586795267062780282103569_f / + data wg ( 14) / 0.101762389748405504596428952168554_f / + data wg ( 15) / 0.102852652893558840341285636705415_f / + + data xgk ( 1) / 0.999484410050490637571325895705811_f / + data xgk ( 2) / 0.996893484074649540271630050918695_f / + data xgk ( 3) / 0.991630996870404594858628366109486_f / + data xgk ( 4) / 0.983668123279747209970032581605663_f / + data xgk ( 5) / 0.973116322501126268374693868423707_f / + data xgk ( 6) / 0.960021864968307512216871025581798_f / + data xgk ( 7) / 0.944374444748559979415831324037439_f / + data xgk ( 8) / 0.926200047429274325879324277080474_f / + data xgk ( 9) / 0.905573307699907798546522558925958_f / + data xgk ( 10) / 0.882560535792052681543116462530226_f / + data xgk ( 11) / 0.857205233546061098958658510658944_f / + data xgk ( 12) / 0.829565762382768397442898119732502_f / + data xgk ( 13) / 0.799727835821839083013668942322683_f / + data xgk ( 14) / 0.767777432104826194917977340974503_f / + data xgk ( 15) / 0.733790062453226804726171131369528_f / + data xgk ( 16) / 0.697850494793315796932292388026640_f / + data xgk ( 17) / 0.660061064126626961370053668149271_f / + data xgk ( 18) / 0.620526182989242861140477556431189_f / + data xgk ( 19) / 0.579345235826361691756024932172540_f / + data xgk ( 20) / 0.536624148142019899264169793311073_f / + data xgk ( 21) / 0.492480467861778574993693061207709_f / + data xgk ( 22) / 0.447033769538089176780609900322854_f / + data xgk ( 23) / 0.400401254830394392535476211542661_f / + data xgk ( 24) / 0.352704725530878113471037207089374_f / + data xgk ( 25) / 0.304073202273625077372677107199257_f / + data xgk ( 26) / 0.254636926167889846439805129817805_f / + data xgk ( 27) / 0.204525116682309891438957671002025_f / + data xgk ( 28) / 0.153869913608583546963794672743256_f / + data xgk ( 29) / 0.102806937966737030147096751318001_f / + data xgk ( 30) / 0.051471842555317695833025213166723_f / + data xgk ( 31) / 0.000000000000000000000000000000000_f / + + data wgk ( 1) / 0.001389013698677007624551591226760_f / + data wgk ( 2) / 0.003890461127099884051267201844516_f / + data wgk ( 3) / 0.006630703915931292173319826369750_f / + data wgk ( 4) / 0.009273279659517763428441146892024_f / + data wgk ( 5) / 0.011823015253496341742232898853251_f / + data wgk ( 6) / 0.014369729507045804812451432443580_f / + data wgk ( 7) / 0.016920889189053272627572289420322_f / + data wgk ( 8) / 0.019414141193942381173408951050128_f / + data wgk ( 9) / 0.021828035821609192297167485738339_f / + data wgk ( 10) / 0.024191162078080601365686370725232_f / + data wgk ( 11) / 0.026509954882333101610601709335075_f / + data wgk ( 12) / 0.028754048765041292843978785354334_f / + data wgk ( 13) / 0.030907257562387762472884252943092_f / + data wgk ( 14) / 0.032981447057483726031814191016854_f / + data wgk ( 15) / 0.034979338028060024137499670731468_f / + data wgk ( 16) / 0.036882364651821229223911065617136_f / + data wgk ( 17) / 0.038678945624727592950348651532281_f / + data wgk ( 18) / 0.040374538951535959111995279752468_f / + data wgk ( 19) / 0.041969810215164246147147541285970_f / + data wgk ( 20) / 0.043452539701356069316831728117073_f / + data wgk ( 21) / 0.044814800133162663192355551616723_f / + data wgk ( 22) / 0.046059238271006988116271735559374_f / + data wgk ( 23) / 0.047185546569299153945261478181099_f / + data wgk ( 24) / 0.048185861757087129140779492298305_f / + data wgk ( 25) / 0.049055434555029778887528165367238_f / + data wgk ( 26) / 0.049795683427074206357811569379942_f / + data wgk ( 27) / 0.050405921402782346840893085653585_f / + data wgk ( 28) / 0.050881795898749606492297473049805_f / + data wgk ( 29) / 0.051221547849258772170656282604944_f / + data wgk ( 30) / 0.051426128537459025933862879215781_f / + data wgk ( 31) / 0.051494729429451567558340433647099_f / + + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! dabsc - abscissa + ! fval* - function value + ! resg - result of the 30-point gauss rule + ! resk - result of the 61-point kronrod rule + ! reskh - approximation to the mean value of f + ! over (a,b), i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! a uflow is the smallest positive magnitude. + ! + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + + centr = 0.5_f*(b+a) + hlgth = 0.5_f*(b-a) + dhlgth = dabs(hlgth) + ! + ! compute the 61-point kronrod approximation to the + ! integral, and estimate the absolute error. + ! + !***first executable statement dqk61 + resg = 0.0_f + fc = fx(centr, fx_vars) + resk = wgk(31)*fc + resabs = dabs(resk) + do j=1,15 + jtw = j*2 + dabsc = hlgth*xgk(jtw) + fval1 = fx(centr-dabsc, fx_vars) + fval2 = fx(centr+dabsc, fx_vars) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + end do + do j=1,15 + jtwm1 = j*2-1 + dabsc = hlgth*xgk(jtwm1) + fval1 = fx(centr-dabsc, fx_vars) + fval2 = fx(centr+dabsc, fx_vars) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(31)*dabs(fc-reskh) + do j=1,30 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0.0_f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk61 + + !! + !!***begin prologue dqpsrt + !!***refer to dqage,dqagie,dqagpe,dqawse + !!***routines called (none) + !!***revision date 130319 (yymmdd) + !!***keywords sequential sorting + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose this routine maintains the descending ordering in the + !! list of the local error estimated resulting from the + !! interval subdivision process. at each call two error + !! estimates are inserted using the sequential search + !! method, top-down for the largest error estimate and + !! bottom-up for the smallest error estimate. + !!***description + !! + !! ordering routine + !! standard fortran subroutine + !! double precision version + !! + !! parameters (meaning at output) + !! limit - integer + !! maximum number of error estimates the list + !! can contain + !! + !! last - integer + !! number of error estimates currently in the list + !! + !! maxerr - integer + !! maxerr points to the nrmax-th largest error + !! estimate currently in the list + !! + !! ermax - double precision + !! nrmax-th largest error estimate + !! ermax = elist(maxerr) + !! + !! elist - double precision + !! vector of dimension last containing + !! the error estimates + !! + !! iord - integer + !! vector of dimension last, the first k elements + !! of which contain pointers to the error + !! estimates, such that + !! elist(iord(1)),..., elist(iord(k)) + !! form a decreasing sequence, with + !! k = last if last.le.(limit/2+2), and + !! k = limit+1-last otherwise + !! + !! nrmax - integer + !! maxerr = iord(nrmax) + !! + !!***end prologue dqpsrt + !! + subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax) + + ! Arguments + integer :: limit + integer :: last + integer :: maxerr + real(kind=f) :: ermax + real(kind=f) :: elist(last) + integer :: iord(last) + integer :: nrmax + + ! Local declarations + real(kind=f) :: errmax, errmin + integer :: i, ibeg, ido, isucc, j, jbnd, jupbn, k + + ! + ! check whether the list contains more than + ! two error estimates. + ! + !***first executable statement dqpsrt + if(last.gt.2) go to 10 + iord(1) = 1 + iord(2) = 2 + go to 90 + ! + ! this part of the routine is only executed if, due to a + ! difficult integrand, subdivision increased the error + ! estimate. in the normal case the insert procedure should + ! start after the nrmax-th largest error estimate. + ! + 10 errmax = elist(maxerr) + if(nrmax.eq.1) go to 30 + ido = nrmax-1 + do i = 1,ido + isucc = iord(nrmax-1) + ! ***jump out of do-loop + if(errmax.le.elist(isucc)) go to 30 + iord(nrmax) = isucc + nrmax = nrmax-1 + end do + ! + ! compute the number of elements in the list to be maintained + ! in descending order. this number depends on the number of + ! subdivisions still allowed. + ! + 30 jupbn = last + if(last.gt.(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) + ! + ! insert errmax by traversing the list top-down, + ! starting comparison from the element elist(iord(nrmax+1)). + ! + jbnd = jupbn-1 + ibeg = nrmax+1 + if(ibeg.gt.jbnd) go to 50 + do i=ibeg,jbnd + isucc = iord(i) + ! ***jump out of do-loop + if(errmax.ge.elist(isucc)) go to 60 + iord(i-1) = isucc + end do + 50 iord(jbnd) = maxerr + iord(jupbn) = last + go to 90 + ! + ! insert errmin by traversing the list bottom-up. + ! + 60 iord(i-1) = maxerr + k = jbnd + do j=i,jbnd + isucc = iord(k) + ! ***jump out of do-loop + if(errmin.lt.elist(isucc)) go to 80 + iord(k+1) = isucc + k = k-1 + end do + iord(i) = last + go to 90 + 80 iord(k+1) = last + ! + ! set maxerr and ermax. + ! + 90 maxerr = iord(nrmax) + ermax = elist(maxerr) + return + end subroutine dqpsrt + + !! + !!***begin prologue dqk15i + !!***date written 800101 (yymmdd) + !!***revision date 130319 (yymmdd) + !!***category no. h2a3a2,h2a4a2 + !!***keywords 15-point transformed gauss-kronrod rules + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math. & progr. div. - k.u.leuven + !!***purpose the original (infinite integration range is mapped + !! onto the interval (0,1) and (a,b) is a part of (0,1). + !! it is the purpose to compute + !! i = integral of transformed integrand over (a,b), + !! j = integral of abs(transformed integrand) over (a,b). + !!***description + !! + !! integration rule + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! on entry + !! fx - double precision + !! fuction subprogram defining the integrand + !! function f(x). the actual name for f needs to be + !! declared e x t e r n a l in the calling program. + !! + !! fx_vars- structure containing variables need for integration + !! specific to fractal meanfield scattering code! + !! + !! boun - double precision + !! finite bound of original integration + !! range (set to zero if inf = +2) + !! + !! inf - integer + !! if inf = -1, the original interval is + !! (-infinity,bound), + !! if inf = +1, the original interval is + !! (bound,+infinity), + !! if inf = +2, the original interval is + !! (-infinity,+infinity) and + !! the integral is computed as the sum of two + !! integrals, one over (-infinity,0) and one over + !! (0,+infinity). + !! + !! a - double precision + !! lower limit for integration over subrange + !! of (0,1) + !! + !! b - double precision + !! upper limit for integration over subrange + !! of (0,1) + !! + !! on return + !! result - double precision + !! approximation to the integral i + !! result is computed by applying the 15-point + !! kronrod rule(resk) obtained by optimal addition + !! of abscissae to the 7-point gauss rule(resg). + !! + !! abserr - double precision + !! estimate of the modulus of the absolute error, + !! which should equal or exceed abs(i-result) + !! + !! resabs - double precision + !! approximation to the integral j + !! + !! resasc - double precision + !! approximation to the integral of + !! abs((transformed integrand)-i/(b-a)) over (a,b) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !!***references (none) + !!***routines called sd1mach + !!***end prologue dqk15i + subroutine dqk15i(fx,fx_vars,boun,inf,a,b,result,abserr,resabs,resasc, ier) + + ! Arguments + interface + function fx(centr, vars) + use carma_precision_mod, only : f + use adgaquad_types_mod + real(kind=f), intent(in) :: centr + type(adgaquad_vars_type), intent(inout) :: vars + real(kind=f) :: fx + end function fx + end interface + type(adgaquad_vars_type) :: fx_vars + real(kind=f) :: boun + integer :: inf + real(kind=f) :: a + real(kind=f) :: b + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: resabs + real(kind=f) :: resasc + integer :: ier + + ! Local declarations + real(kind=f) :: absc, absc1, absc2, centr, dabs, dinf + real(kind=f) :: dmax1, dmin1, epmach, fc, fsum, fval1, fval2, fv1(7) ,fv2(7), hlgth + real(kind=f) :: resg, resk, reskh, tabsc1, tabsc2, uflow, wg(8), wgk(8), xgk(8) + integer :: j + + ! + ! the abscissae and weights are supplied for the interval + ! (-1,1). because of symmetry only the positive abscissae and + ! their corresponding weights are given. + ! + ! xgk - abscissae of the 15-point kronrod rule + ! xgk(2), xgk(4), ... abscissae of the 7-point + ! gauss rule + ! xgk(1), xgk(3), ... abscissae which are optimally + ! added to the 7-point gauss rule + ! + ! wgk - weights of the 15-point kronrod rule + ! + ! wg - weights of the 7-point gauss rule, corresponding + ! to the abscissae xgk(2), xgk(4), ... + ! wg(1), wg(3), ... are set to zero. + ! + data wg(1) / 0.0_f / + data wg(2) / 0.129484966168869693270611432679082_f / + data wg(3) / 0.0_f / + data wg(4) / 0.279705391489276667901467771423780_f / + data wg(5) / 0.0_f / + data wg(6) / 0.381830050505118944950369775488975_f / + data wg(7) / 0.0_f / + data wg(8) / 0.417959183673469387755102040816327_f / + + data xgk(1) / 0.991455371120812639206854697526329_f / + data xgk(2) / 0.949107912342758524526189684047851_f / + data xgk(3) / 0.864864423359769072789712788640926_f / + data xgk(4) / 0.741531185599394439863864773280788_f / + data xgk(5) / 0.586087235467691130294144838258730_f / + data xgk(6) / 0.405845151377397166906606412076961_f / + data xgk(7) / 0.207784955007898467600689403773245_f / + data xgk(8) / 0.000000000000000000000000000000000_f / + + data wgk(1) / 0.022935322010529224963732008058970_f / + data wgk(2) / 0.063092092629978553290700663189204_f / + data wgk(3) / 0.104790010322250183839876322541518_f / + data wgk(4) / 0.140653259715525918745189590510238_f / + data wgk(5) / 0.169004726639267902826583426598550_f / + data wgk(6) / 0.190350578064785409913256402421014_f / + data wgk(7) / 0.204432940075298892414161999234649_f / + data wgk(8) / 0.209482141084727828012999174891714_f / + ! + ! + ! list of major variables + ! ----------------------- + ! + ! centr - mid point of the interval + ! hlgth - half-length of the interval + ! absc* - abscissa + ! tabsc* - transformed abscissa + ! fval* - function value + ! resg - result of the 7-point gauss formula + ! resk - result of the 15-point kronrod formula + ! reskh - approximation to the mean value of the transformed + ! integrand over (a,b), i.e. to i/(b-a) + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! uflow is the smallest positive magnitude. + ! + !*** first executable statement dqk15i + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(1,uflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !uflow = d1mach(1) + dinf = min0(1,inf) + + centr = 0.5_f*(a+b) + hlgth = 0.5_f*(b-a) + tabsc1 = boun+dinf*(0.1e1_f-centr)/centr + fval1 = fx(tabsc1, fx_vars) + if(inf.eq.2) fval1 = fval1+fx(-tabsc1, fx_vars) + fc = (fval1/centr)/centr + ! + ! compute the 15-point kronrod approximation to + ! the integral, and estimate the error. + ! + resg = wg(8)*fc + resk = wgk(8)*fc + resabs = dabs(resk) + do j=1,7 + absc = hlgth*xgk(j) + absc1 = centr-absc + absc2 = centr+absc + tabsc1 = boun+dinf*(0.1d+01-absc1)/absc1 + tabsc2 = boun+dinf*(0.1d+01-absc2)/absc2 + fval1 = fx(tabsc1, fx_vars) + fval2 = fx(tabsc2, fx_vars) + if(inf.eq.2) fval1 = fval1+fx(-tabsc1, fx_vars) + if(inf.eq.2) fval2 = fval2+fx(-tabsc2, fx_vars) + fval1 = (fval1/absc1)/absc1 + fval2 = (fval2/absc2)/absc2 + fv1(j) = fval1 + fv2(j) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(j)*fsum + resabs = resabs+wgk(j)*(dabs(fval1)+dabs(fval2)) + end do + reskh = resk*0.5_f + resasc = wgk(8)*dabs(fc-reskh) + do j=1,7 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + end do + result = resk*hlgth + resasc = resasc*hlgth + resabs = resabs*hlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0_f.and.abserr.ne.0._f) abserr = resasc*dmin1(0.1e1_f,(0.2e3_f*abserr/resasc)**1.5_f) + if(resabs.gt.uflow/(0.5e2_f*epmach)) abserr = dmax1((epmach*0.5e2_f)*resabs,abserr) +999 return + end subroutine dqk15i + + !! + !!***begin prologue dqelg + !!***refer to dqagie,dqagoe,dqagpe,dqagse + !!***routines called sd1mach + !!***revision date 130319 (yymmdd) + !!***keywords epsilon algorithm, convergence acceleration, + !! extrapolation + !!***author piessens,robert,appl. math. & progr. div. - k.u.leuven + !! de doncker,elise,appl. math & progr. div. - k.u.leuven + !!***purpose the routine determines the limit of a given sequence of + !! approximations, by means of the epsilon algorithm of + !! p.wynn. an estimate of the absolute error is also given. + !! the condensed epsilon table is computed. only those + !! elements needed for the computation of the next diagonal + !! are preserved. + !!***description + !! + !! epsilon algorithm + !! standard fortran subroutine + !! double precision version + !! + !! parameters + !! n - integer + !! epstab(n) contains the new element in the + !! first column of the epsilon table. + !! + !! epstab - double precision + !! vector of dimension 52 containing the elements + !! of the two lower diagonals of the triangular + !! epsilon table. the elements are numbered + !! starting at the right-hand corner of the + !! triangle. + !! + !! result - double precision + !! resulting approximation to the integral + !! + !! abserr - double precision + !! estimate of the absolute error computed from + !! result and the 3 previous results + !! + !! res3la - double precision + !! vector of dimension 3 containing the last 3 + !! results + !! + !! nres - integer + !! number of calls to the routine + !! (should be zero at first call) + !! + !! ier - integer + !! ier = 0 normal and reliable termination of the + !! routine. it is assumed that the requested + !! accuracy has been achieved. + !! ier.gt.0 abnormal termination of the routine. the + !! estimates for result and error are less + !! reliable. it is assumed that the requested + !! accuracy has not been achieved. + !! + !!***end prologue dqelg + !! + subroutine dqelg(n,epstab,result,abserr,res3la,nres,ier) + + ! Arguments + integer :: n + real(kind=f) :: epstab(52) + real(kind=f) :: result + real(kind=f) :: abserr + real(kind=f) :: res3la(3) + integer :: nres + integer :: ier + + ! Local declarations + real(kind=f) :: dabs, delta1, delta2, delta3, dmax1 + real(kind=f) :: epmach, epsinf, error, err1, err2, err3, e0, e1, e1abs, e2, e3 + real(kind=f) :: oflow, res, ss, tol1, tol2, tol3 + integer :: i, ib, ib2, ie, indx, k1, k2, k3, limexp, newelm, num + ! + ! list of major variables + ! ----------------------- + ! + ! e0 - the 4 elements on which the computation of a new + ! e1 element in the epsilon table is based + ! e2 + ! e3 e0 + ! e3 e1 new + ! e2 + ! newelm - number of elements to be computed in the new + ! diagonal + ! error - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2) + ! result - the element in the new diagonal with least value + ! of error + ! + ! machine dependent constants + ! --------------------------- + ! + ! epmach is the largest relative spacing. + ! oflow is the largest positive magnitude. + ! limexp is the maximum number of elements the epsilon + ! table can contain. if this number is reached, the upper + ! diagonal of the epsilon table is deleted. + ! + !***first executable statement dqelg + call sd1mach(4,epmach,ier) + if(ier.eq.9) return + call sd1mach(2,oflow,ier) + if(ier.eq.9) return + + !epmach = d1mach(4) + !oflow = d1mach(2) + nres = nres+1 + abserr = oflow + result = epstab(n) + if(n.lt.3) go to 100 + limexp = 50 + epstab(n+2) = epstab(n) + newelm = (n-1)/2 + epstab(n) = oflow + num = n + k1 = n + do 40 i = 1,newelm + k2 = k1-1 + k3 = k1-2 + res = epstab(k1+2) + e0 = epstab(k3) + e1 = epstab(k2) + e2 = res + e1abs = dabs(e1) + delta2 = e2-e1 + err2 = dabs(delta2) + tol2 = dmax1(dabs(e2),e1abs)*epmach + delta3 = e1-e0 + err3 = dabs(delta3) + tol3 = dmax1(e1abs,dabs(e0))*epmach + if(err2.gt.tol2.or.err3.gt.tol3) go to 10 + ! + ! if e0, e1 and e2 are equal to within machine + ! accuracy, convergence is assumed. + ! result = e2 + ! abserr = abs(e1-e0)+abs(e2-e1) + ! + result = res + abserr = err2+err3 + ! ***jump out of do-loop + go to 100 + 10 e3 = epstab(k1) + epstab(k1) = e1 + delta1 = e1-e3 + err1 = dabs(delta1) + tol1 = dmax1(e1abs,dabs(e3))*epmach + ! + ! if two elements are very close to each other, omit + ! a part of the table by adjusting the value of n + ! + if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20 + ss = 0.1e1_f/delta1+0.1e1_f/delta2-0.1e1_f/delta3 + epsinf = dabs(ss*e1) + ! + ! test to detect irregular behaviour in the table, and + ! eventually omit a part of the table adjusting the value + ! of n. + ! + if(epsinf.gt.0.1e-3_f) go to 30 + 20 n = i+i-1 + ! ***jump out of do-loop + go to 50 + ! + ! compute a new element and eventually adjust + ! the value of result. + ! + 30 res = e1+0.1e1_f/ss + epstab(k1) = res + k1 = k1-2 + error = err2+dabs(res-e2)+err3 + if(error.gt.abserr) go to 40 + abserr = error + result = res + 40 continue + ! + ! shift the table. + ! + 50 if(n.eq.limexp) n = 2*(limexp/2)-1 + ib = 1 + if((num/2)*2.eq.num) ib = 2 + ie = newelm+1 + do 60 i=1,ie + ib2 = ib+2 + epstab(ib) = epstab(ib2) + ib = ib2 + 60 continue + if(num.eq.n) go to 80 + indx = num-n+1 + do 70 i = 1,n + epstab(i)= epstab(indx) + indx = indx+1 + 70 continue + 80 if(nres.ge.4) go to 90 + res3la(nres) = result + abserr = oflow + go to 100 + ! + ! compute error estimate + ! + 90 abserr = dabs(result-res3la(3))+dabs(result-res3la(2))+dabs(result-res3la(1)) + res3la(1) = res3la(2) + res3la(2) = res3la(3) + res3la(3) = result +100 abserr = dmax1(abserr,0.5e1_f*epmach*dabs(result)) +999 return + end subroutine dqelg + + !! + !! ********************************************************* + !! taken from BLAS library + !! (http://netlib.bell-labs.com/netlib/blas) + !! ********************************************************* + SUBROUTINE SD1MACH(I,D1MACH_OUT,IER) + INTEGER, INTENT(in) :: I + REAL(kind=f), INTENT(out) :: D1MACH_OUT + INTEGER, INTENT(out) :: IER + ! + ! DOUBLE-PRECISION MACHINE CONSTANTS + ! D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. + ! D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. + ! D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. + ! D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. + ! D1MACH( 5) = LOG10(B) + ! + INTEGER :: SMALL(2) + INTEGER :: LARGE(2) + INTEGER :: RIGHT(2) + INTEGER :: DIVER(2) + INTEGER :: LOG10(2) + INTEGER :: SC, CRAY1(38), J + SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC + REAL(kind=f) :: DMACH(5) + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) + ! THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. + ! R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF + ! D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR + ! MANY MACHINES YET. + ! TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 + ! ON THE NEXT LINE + DATA SC/0/ + ! AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. + ! CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY + ! mail netlib@research.bell-labs.com + ! send old1mach from blas + ! PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. + ! + ! MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. + ! DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / + ! DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / + ! DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / + ! DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / + ! DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ + ! + ! MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING + ! 32-BIT INTEGERS. + ! DATA SMALL(1),SMALL(2) / 8388608, 0 / + ! DATA LARGE(1),LARGE(2) / 2147483647, -1 / + ! DATA RIGHT(1),RIGHT(2) / 612368384, 0 / + ! DATA DIVER(1),DIVER(2) / 620756992, 0 / + ! DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ + ! + ! MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. + ! DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / + ! DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / + ! DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / + ! DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / + ! DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ + ! + ! ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. + IER = 0 + IF (SC .NE. 987) THEN + DMACH(1) = 1.e13_f + IF ( SMALL(1) .EQ. 1117925532 .AND. SMALL(2) .EQ. -448790528) THEN + ! *** IEEE BIG ENDIAN *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2146435071 + LARGE(2) = -1 + RIGHT(1) = 1017118720 + RIGHT(2) = 0 + DIVER(1) = 1018167296 + DIVER(2) = 0 + LOG10(1) = 1070810131 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(2) .EQ. 1117925532 .AND. SMALL(1) .EQ. -448790528) THEN + ! *** IEEE LITTLE ENDIAN *** + SMALL(2) = 1048576 + SMALL(1) = 0 + LARGE(2) = 2146435071 + LARGE(1) = -1 + RIGHT(2) = 1017118720 + RIGHT(1) = 0 + DIVER(2) = 1018167296 + DIVER(1) = 0 + LOG10(2) = 1070810131 + LOG10(1) = 1352628735 + ELSE IF ( SMALL(1) .EQ. -2065213935 .AND. SMALL(2) .EQ. 10752) THEN + ! *** VAX WITH D_FLOATING *** + SMALL(1) = 128 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 9344 + RIGHT(2) = 0 + DIVER(1) = 9472 + DIVER(2) = 0 + LOG10(1) = 546979738 + LOG10(2) = -805796613 + ELSE IF ( SMALL(1) .EQ. 1267827943 .AND. SMALL(2) .EQ. 704643072) THEN + ! *** IBM MAINFRAME *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 856686592 + RIGHT(2) = 0 + DIVER(1) = 873463808 + DIVER(2) = 0 + LOG10(1) = 1091781651 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 1120022684 .AND. SMALL(2) .EQ. -448790528) THEN + ! *** CONVEX C-1 *** + SMALL(1) = 1048576 + SMALL(2) = 0 + LARGE(1) = 2147483647 + LARGE(2) = -1 + RIGHT(1) = 1019215872 + RIGHT(2) = 0 + DIVER(1) = 1020264448 + DIVER(2) = 0 + LOG10(1) = 1072907283 + LOG10(2) = 1352628735 + ELSE IF ( SMALL(1) .EQ. 815547074 .AND. SMALL(2) .EQ. 58688) THEN + ! *** VAX G-FLOATING *** + SMALL(1) = 16 + SMALL(2) = 0 + LARGE(1) = -32769 + LARGE(2) = -1 + RIGHT(1) = 15552 + RIGHT(2) = 0 + DIVER(1) = 15568 + DIVER(2) = 0 + LOG10(1) = 1142112243 + LOG10(2) = 2046775455 + ELSE + DMACH(2) = 1.e27_f + 1 + DMACH(3) = 1.e27_f + LARGE(2) = LARGE(2) - RIGHT(2) + IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN + CRAY1(1) = 67291416 + DO J = 1, 20 + CRAY1(J+1) = CRAY1(J) + CRAY1(J) + END DO + CRAY1(22) = CRAY1(21) + 321322 + DO J = 22, 37 + CRAY1(J+1) = CRAY1(J) + CRAY1(J) + END DO + IF (CRAY1(38) .EQ. SMALL(1)) THEN + ! *** CRAY *** + CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) + SMALL(2) = 0 + CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) + CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) + CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) + RIGHT(2) = 0 + CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) + DIVER(2) = 0 + CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) + CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) + ELSE + IER=9 + END IF + ELSE + IER=9 + END IF + END IF + SC = 987 + END IF + ! SANITY CHECK + IF (DMACH(4) .GE. 1.0D0) IER=9 + IF (I .LT. 1 .OR. I .GT. 5) THEN + IER=9 + END IF + D1MACH_OUT = DMACH(I) + RETURN + END SUBROUTINE SD1MACH + + SUBROUTINE I1MCRY(A, A1, B, C, D) + !*** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** + INTEGER A, A1, B, C, D + A1 = 16777216*B + C + A = 16777216*A1 + D + END SUBROUTINE I1MCRY + + + +end module adgaquad_mod diff --git a/src/physics/carma/base/adgaquad_types_mod.F90 b/src/physics/carma/base/adgaquad_types_mod.F90 new file mode 100644 index 0000000000..a4f9dd7e70 --- /dev/null +++ b/src/physics/carma/base/adgaquad_types_mod.F90 @@ -0,0 +1,39 @@ +module adgaquad_types_mod + use carma_precision_mod + + integer, public, parameter :: nf=50 !! Number of factorials in fact table. + + + !! The the functions that are being integrated may need some extra + !! data. In the F77, these were stored in common blocks. To make the + !! code thread safe, we need to move them into passed parameters. For + !! convenience, we put all of these variables into one structure and + !! pass the entire structure to all functions that could be integrated + !! by these routines. + + type, public :: adgaquad_vars_type + + ! alpha packing coefficient + ! nb number of monomers + ! a monomer size + ! df fractal dimension + ! k absolute value of wavevector = 2*pi/wavelength + + real(kind=f) :: fact(0:nf) + integer :: u1 + integer :: u2 + integer :: u3 + integer :: u4 + integer :: u5 + integer :: u6 + integer :: pbes + real(kind=f) :: kbes + real(kind=f) :: alpha + real(kind=f) :: nb + real(kind=f) :: a + real(kind=f) :: df + real(kind=f) :: k + real(kind=f) :: zed + real(kind=f) :: coeff + end type adgaquad_vars_type +end module \ No newline at end of file diff --git a/src/physics/carma/base/bhmie.F90 b/src/physics/carma/base/bhmie.F90 new file mode 100644 index 0000000000..b2cf8de66c --- /dev/null +++ b/src/physics/carma/base/bhmie.F90 @@ -0,0 +1,182 @@ +!! See Bohren and Huffman, "Absorption and Scattering of Light by +!! Small Particles", 1983, pg 480 (in Appendix A). +!! +!! Subroutine bhmie calculates amplitude scattering matrix +!! elements and efficiencies for extinction, total scattering +!! and backscattering for a given size parameter and +!! relative refractive index. +!! +!! From the main program: +!! refrel = cmplx(refre,refim) / refmed +!! +!! @author Chuck Bardeen +!! @version 2011 +subroutine bhmie(carma, x, refrel, nang, s1, s2, Qext, Qsca, Qback, gfac, rc) + + ! types + use carma_precision_mod + use carma_enums_mod, only : RC_ERROR + use carma_types_mod, only : carma_type + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: x !! radius / wavelength + complex(kind=f), intent(in) :: refrel !! refractive index particle / reference refractive index + integer, intent(in) :: nang !! number of angles in s1 and s2 + complex(kind=f), intent(out) :: s1(2*nang-1) !! CORE RADIUS + complex(kind=f), intent(out) :: s2(2*nang-1) !! REAL PART OF THE CORE INDEX OF REFRACTION + real(kind=f), intent(out) :: Qext !! EFFICIENCY FACTOR FOR EXTINCTION + real(kind=f), intent(out) :: Qsca !! EFFICIENCY FACTOR FOR SCATTERING + real(kind=f), intent(out) :: Qback !! BACK SCATTER CROSS SECTION. + real(kind=f), intent(out) :: gfac !! asymmetry factor + integer, intent(inout) :: rc !! return code, negative indicates failure + + + real(kind=f) :: amu(100), theta(100), pi(100), tau(100), pi0(100), pi1(100) + complex(kind=f) :: y, xi, xi0, xi1, an, bn + complex(kind=f), allocatable :: d(:) + complex(kind=f) :: ccan, ccbn, anmi1, bnmi1 + real(kind=f) :: psi0, psi1, psi, dn, dx, chi0, chi1, apsi0, apsi1, g1, g2 + real(kind=f) :: dang, fn, ffn, apsi, chi, p, t, xstop, ymod + integer :: j, jj, n, nn, rn, nmx, nstop + + + ! Mie x and y values. + dx = x + y = x * refrel + + ! Series terminated after nstop terms + xstop = x + 4._f * x**0.3333_f + 2.0_f + nstop = xstop + + ! Will loop over nang angles. + ymod = int(abs(y)) + nmx = max(xstop, ymod) + 15 + dang = 1.570796327_f / real(nang - 1, kind=f) + allocate(d(nmx)) + + do j = 1, nang + theta(j) = (real(j, kind=f) - 1._f) * dang + amu(j) = cos(theta(j)) + end do + + ! Logarithmic derivative d(j) calculated by downword + ! recurrence beginning with initial value 0.0 + i*0.0 + ! at j = nmx + d(nmx) = cmplx(0.0_f, 0.0_f, kind=f) + nn = nmx-1 +! write(*,*) 'nmx=',nmx,' d(nmx)=',d(nmx), ' nn=',nn + + do n = 1, nn + rn = nmx - n + 1 + d(nmx-n) = (rn/y) - (1._f / (d(nmx - n + 1) + rn / y)) + +! write(*,*) 'n=',n,' rn=',rn,' y=', y,' d(nmx-n)=',d(nmx-n) +! write(*,*) 'rn/y=',rn/y, 'd(nmx-n+1)=',d(nmx-n+1),'(d(nmx-n+1)+rn/y)', & +! (d(nmx-n+1)+rn/y),'1./(d(nmx-n+1)+rn/y)',1./(d(nmx-n+1)+rn/y) + end do + + pi0(1:nang) = 0.0_f + pi1(1:nang) = 1.0_f + + nn = 2 * nang-1 + s1(1:nn) = cmplx(0.0_f, 0.0_f, kind=f) + s2(1:nn) = cmplx(0.0_f, 0.0_f, kind=f) + + ! Riccati-Bessel functions with real argument x + ! calculated by upward recurrence + psi0 = cos(dx) + psi1 = sin(dx) + chi0 = -sin(x) + chi1 = cos(x) + apsi0 = psi0 + apsi1 = psi1 + xi0 = cmplx(apsi0,-chi0, kind=f) + xi1 = cmplx(apsi1,-chi1, kind=f) + Qsca = 0.0_f + g1 = 0.0_f + g2 = 0.0_f + n = 1 + + ! Loop over the terms n in the Mie series + do while (.true.) + dn = n + rn = n + fn = (2._f * rn + 1._f) / (rn * (rn + 1._f)) + ffn = (rn - 1._f) * (rn + 1._f) / rn + psi = (2._f * dn - 1._f) * psi1 / dx - psi0 + apsi = psi + chi = (2._f * rn - 1._f) * chi1 / x - chi0 + xi = cmplx(apsi, -chi, kind=f) +! write(*,*) 'n=', n +! write(*,*) 'd(n)=',d(n),' refrel=',refrel,' rn=',rn, ' x=',x,'apsi=',apsi,' apsi1=',apsi1 + + an = (d(n) / refrel + rn / x) * apsi - apsi1 +! write(*,*) 'an=',an,' xi=',xi,' xi1=',xi1 + + an = an / ((d(n) / refrel + rn / x) * xi - xi1) + bn = (refrel * d(n) + rn / x) * apsi - apsi1 + bn = bn / ((refrel * d(n) + rn / x) * xi - xi1) + ccan = conjg(an) + ccbn = conjg(bn) + g2 = g2 + fn * real(an * ccbn) + + if (n-1 > 0) then + g1 = g1 + ffn * real(anmi1 * ccan + bnmi1 * ccbn) + end if + Qsca = Qsca + (2._f * rn + 1._f) * (abs(an) * abs(an) + abs(bn) * abs(bn)) + + do j = 1, nang + jj = 2 * nang-j + pi(j) = pi1(j) + tau(j) = rn * amu(j) * pi(j) - (rn + 1._f) * pi0(j) + p = (-1._f)**(n-1) +! write(*,*) 'fn=',fn,' an=',an,' bn=',bn,' pi(j)=',pi(j),' tau(j)=',tau(j) + + s1(j) = s1(j) + fn * (an * pi(j) + bn * tau(j)) + t = (-1._f)**n + s2(j) = s2(j) + fn * (an * tau(j) + bn * pi(j)) + + if (j.ne.jj) then + s1(jj)=s1(jj) + fn*(an*pi(j)*p+bn*tau(j)*t) + s2(jj)=s2(jj) + fn*(an*tau(j)*t+bn*pi(j)*p) +! write(*,*) 'j=',j,' s1(j)=',s1(j),' s2(j)=',s2(j) + end if + end do + + psi0 = psi1 + psi1 = psi + apsi1 = psi1 + chi0 = chi1 + chi1 = chi + xi1 = cmplx(apsi1, -chi1, kind=f) + n = n+1 + rn = n + + do j = 1, nang + pi1(j) = ((2._f * rn - 1._f) / (rn - 1._f)) * amu(j) * pi(j) + pi1(j) = pi1(j) -rn * pi0(j) / (rn - 1._f) + pi0(j) = pi(j) + end do + + anmi1 = an + bnmi1 = bn + + if (n - 1 - nstop >= 0) exit + + end do + + Qsca = (2._f / (x * x)) * Qsca + gfac = (4._f / (x * x * Qsca)) * (g1+g2) + Qext = (4._f / (x * x)) * real(s1(1)) + Qback = (4._f / (x * x)) * abs(s1(2 * nang - 1)) * abs(s1(2 * nang - 1)) + +! write(*,*) 'x',x,' s1(1)=',s1(1),' real(s1(1))=',real(s1(1)) +! write(*,*) 'Qsca=',Qsca,' gfac=',gfac,' Qext=',Qext,'Qback=',Qback + + deallocate(d) + + return +end subroutine bhmie diff --git a/src/physics/carma/base/calcrs.F90 b/src/physics/carma/base/calcrs.F90 new file mode 100644 index 0000000000..ae75276a04 --- /dev/null +++ b/src/physics/carma/base/calcrs.F90 @@ -0,0 +1,111 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + + +!!----------------------------------------------------------------------- +!! +!! Purpose: Calculating the surface resistance, using the PBL parameter. +!! +!! Method: Zhang(2001), Atmospheric Environment +!! +!! +!! @author Tianyi Fan +!! @version Nov-2010 +!! + +subroutine calcrs(carma, cstate, ustar, tmp, radi, cc, vfall, rs, landidx, rc) + use carma_precision_mod + use carmastate_mod + use carma_enums_mod + use carma_types_mod + use carma_mod + use carma_constants_mod, only: BK, PI, GRAV +!----------------------------------------------------------------------- + implicit none +!----------------------------------------------------------------------- +! +! Arguments: +! + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(in) :: cstate !! the carma state object + real(kind=f), intent(in) :: ustar !! friction velocity [cm/s] + real(kind=f), intent(in) :: tmp !! temperature [K] + real(kind=f), intent(in) :: radi !! radius of the constitutent [cm] + real(kind=f), intent(in) :: cc !! slip correction factor + real(kind=f), intent(in) :: vfall !! gravitational settling velocity, [cm/s] + real(kind=f), intent(out) :: rs !! surface resistance [s/cm] + integer, intent(in) :: landidx !! landscape index, 1=land, 2=ocean, 3=sea ice + integer, intent(inout) :: rc !! return code, negative indicates failure + + + +! Local variables + real(kind=f) :: ebrn ! Brownian diffusion collection efficiency + real(kind=f) :: eimp ! Impaction collection efficiency + real(kind=f) :: eint ! Interception collection efficiency + real(kind=f) :: db ! Brownian diffusivity + real(kind=f) :: sc ! Schmidt number + real(kind=f) :: st ! Stokes number + real(kind=f) :: rhoadry ! dry air density [g/cm3] + real(kind=f) :: eta ! kinematic viscosity of air [cm2/s] + real(kind=f), parameter :: xkar = 0.4_f ! Von Karman's constant + real(kind=f), parameter :: eps0 = 3._f ! empirical constant for rs, 3.0 in [Zhang, 2001], 1.0 in [Seinfeld and Pandis] + + ! exponent in the eb dependence on sc, 2/3 in [Seinfeld and Pandis, 1998], 1/2 in [Lewis and Schwartz, 2004] + real(kind=f) :: lam + + integer :: ibot + + if (igridv .eq. I_CART) then + ibot = 1 + else + ibot = NZ + end if + + ! Unit conversion + rhoadry = rhoa(ibot) / zmet(ibot) / xmet(ibot) / ymet(ibot) ! [g/cm3] + eta = rmu(ibot) / rhoadry ! rmu, aerodynamic viscosity of air [g/cm/s] + + if (landidx .eq. 1) then + lam = 2._f / 3._f + else + lam = 1._f / 2._f + end if + + ! Surface Resistance = Brownian + Impaction + Interception + + ! ** Brownian diffusion + db = BK * tmp * cc / (6._f * PI * rmu(ibot) * radi) ! [cm2/s] + + sc = eta / db ! [-] + ebrn = sc**(-lam) + + ! ** Impaction + st = vfall * ustar**2 / (GRAV * eta) ! [-] + + ! [Slinn, 1982] + ! eimp = 10. ** (-3._f/st) + + ! [Peters and Eiden, 1992] + eimp = (st / (0.8_f + st))**2 +! eimp = max(eimp, 1.e-10_f) + + ! ** Interception + ! + ! NOTE: Interception is not currently considered for ocean and ice. + if (landidx .eq. 1) then +! eint = 0.3_f * (0.01_f * radi * 1.e-2_f / (radi * 1.e-2_f + 1.e-5_f) + 0.99_f *radi*1.e-2_f / (radi*1.e-2_f + 8.e-4_f)) + eint = 0.3_f * (0.01_f * radi / (radi + 1.e-3_f) + 0.99_f * radi / (radi + 8.e-2_f)) + else + eint = 0._f + end if + + if (ustar > 0._f) then + rs = 1._f / (eps0 * ustar * (ebrn + eimp + eint )) ! [s/cm] + else + rs = 0._f + end if + + return +end subroutine calcrs diff --git a/src/physics/carma/base/carma_constants_mod.F90 b/src/physics/carma/base/carma_constants_mod.F90 new file mode 100644 index 0000000000..5644f68250 --- /dev/null +++ b/src/physics/carma/base/carma_constants_mod.F90 @@ -0,0 +1,123 @@ +module carma_constants_mod + + use carma_precision_mod + + implicit none + + !-- + ! Physical constants + + ! Meter-Kilogram-Second (MKS) convention for units + ! This convention is different from CARMA's original + ! Centimeter-Gram-Second (CGS) convention. Be wary of + ! this conversion to the new convention. + + ! Use the _f for all literal constants, e.g. 1.2e_f. + ! If you omit the _f in the initialization, a compiler may cast this + ! number into single precision and then store it as _f precision. + + !! Define triple-point temperature (K) + real(kind=f), parameter :: T0 = 273.16_f + + ! Define constants for circles and trig + real(kind=f), parameter :: PI = 3.14159265358979_f + real(kind=f), parameter :: DEG2RAD = PI / 180._f + real(kind=f), parameter :: RAD2DEG = 180._f / PI + + !! Acceleration of gravity near Earth surface [ cm/s^2 ] + real(kind=f), parameter :: GRAV = 980.6_f + + !! Define planet equatorial radius [ cm ] + real(kind=f), parameter :: REARTH = 6.37e+8_f + + !! Define avogadro's number [ # particles / mole ] + real(kind=f), parameter :: AVG = 6.02252e+23_f + + !! Define Boltzmann's constant [ erg / deg_K ] + real(kind=f), parameter :: BK = 1.38054e-16_f + + !! Define Loschmidt's number [ mole / cm^3, @ STP ] + real(kind=f), parameter :: ALOS = 2.68719e+19_f + + !! Define molecular weight of dry air [ g / mole ] + real(kind=f), parameter :: WTMOL_AIR = 28.966_f + + !! Define molecular weight of water vaor [ g / mole ] + real(kind=f), parameter :: WTMOL_H2O = 18.016_f + + !! Define reference pressure, e.g. for potential temp calcs [ dyne / cm^2 ] + real(kind=f), parameter :: PREF = 1000.e+3_f + + !! Define conversion factor for mb to cgs [ dyne / cm^2 ] units + real(kind=f), parameter :: RMB2CGS = 1000.e+0_f + + !! Define conversion factor for Pa to cgs [ dyne / cm^2 ] units + real(kind=f), parameter :: RPA2CGS = 10.e+0_f + + !! Define conversion factor for m to cgs [ cm ] units + real(kind=f), parameter :: RM2CGS = 100.0_f + + !! Define universal gas constant [ erg / deg_K / mole ] + real(kind=f), parameter :: RGAS = 8.31430e+07_f + + !! Define gas constant for dry air [ erg / deg_K / mole ] + real(kind=f), parameter :: R_AIR = RGAS / WTMOL_AIR + + !! Define number of seconds per the planet's day [ s / d ] + real(kind=f), parameter :: SCDAY = 86400._f + + !! Define specific heat at constant pres of dry air [ cm^2 / s^2 / deg_K ] + real(kind=f), parameter :: CP = 1.004e7_f + + !! Define ratio of gas constant for dry air and specific heat + real(kind=f), parameter :: RKAPPA = R_AIR / CP + + !! Define mass density of liquid water [ g / cm^3 ] + real(kind=f), parameter :: RHO_W = 1._f + + !! Define mass density of water ice [ g / cm^3 ] + real(kind=f), parameter :: RHO_I = 0.93_f + + !! Latent heat of evaporation for gas [cm^2/s^2] + real(kind=f), parameter :: RLHE_CNST = 2.501e10_f + + !! Latent heat of ice melting for gas [cm^2/s^2] + real(kind=f), parameter :: RLHM_CNST = 3.337e9_f + + !! The dimension of THETD, ELTRMX, CSTHT, PI, TAU, SI2THT. + !! IT must correspond exactly to the second dimension of ELTRMX. + integer, parameter :: IT = 1 + + !! String length of names + integer, parameter :: CARMA_NAME_LEN = 255 + + !! String length of short names + integer, parameter :: CARMA_SHORT_NAME_LEN = 6 + + !! Fill value indicating no value is being returned + integer, parameter :: CAM_FILL = -999 + + + !! Define small particle number concentration + !! [ # / x_units / y_units / z_units ] + real(kind=f), parameter :: SMALL_PC = 1e-50_f +! real(kind=f), parameter :: SMALL_PC = tiny( ONE ) + + !! Define particle number concentration [ # / ? ] + !! used to decide whether to bypass microphysical processes. + !! + !! Set it to SMALL_PC/xmet/ymet/zmet to never bypass the calculations. + + real(kind=f), parameter :: FEW_PC = SMALL_PC * 1e6_f +! real(kind=f), parameter :: FEW_PC = tiny(ONE) * 1e6_f + + !! Define core fraction (for core mass and second moment) used + !! when particle number concentrations are limited to SMALL_PC + real(kind=f), parameter :: FIX_COREF = 0.1_f + + !! Minimum Cloud Fraction + real(kind=f), parameter :: CLDFRC_MIN = 1e-4_f + + !! Incloud Cloud Fraction Threshold for statistics + real(kind=f), parameter :: CLDFRC_INCLOUD = 0.10_f +end module diff --git a/src/physics/carma/base/carma_enums_mod.F90 b/src/physics/carma/base/carma_enums_mod.F90 new file mode 100644 index 0000000000..7cdb093ace --- /dev/null +++ b/src/physics/carma/base/carma_enums_mod.F90 @@ -0,0 +1,143 @@ +!! This module is part of the CARMA module and contains enumerations that are part of +!! the CARMA and CARMASTATE objects. +!! +!! @author Chuck Bardeen +!! @ version July-2009 +module carma_enums_mod + + !-- + ! Index values of CARMA's flags. In a given list, begin with 1 + ! (instead of 0) so that undefined flags will produce an error. + ! + ! For example: + ! if( itype(ielem) .eq. I_INVOLATILE )then + ! + ! If itype(ielem) hasn't been defined (and is still 0), we do not want + ! to execute the statements that follow. + + ! Define values of flag used for vertical transport + ! boundary conditions (ixxxbnd_pc) + integer, public, parameter :: I_FIXED_CONC = 1 !! Fixed Concentration + integer, public, parameter :: I_FLUX_SPEC = 2 !! Flux Specification + + ! Define values of flag used for particle element + ! type specification (itype). + integer, public, parameter :: I_INVOLATILE = 1 !! Involatile particle + integer, public, parameter :: I_VOLATILE = 2 !! Volatile particle + integer, public, parameter :: I_COREMASS = 3 !! Core Mass + integer, public, parameter :: I_VOLCORE = 4 !! Voltile Core + integer, public, parameter :: I_CORE2MOM = 5 !! Core Mass - 2 Moments + + !! Define values of flag used for nucleation process + !! specification (inucproc). + !! + !! NOTE: Some of these can be used in combination, so for aerosol freezing this is treated + !! as a bit mask. When setting for one (or more) of the Aerosol freezing methods, use: + !! IAERFREEZE + I_AF_xxx + I_AF_yyy + ... + integer, public, parameter :: I_AF_TABAZADEH_2000 = 1 !! Aerosol Freezing, Tabazadeh[2000] + integer, public, parameter :: I_AF_KOOP_2000 = 2 !! Aerosol Freezing, Koop[2000] + integer, public, parameter :: I_AF_MOHLER_2010 = 4 !! Aerosol Freezing, Mohler[2010] + integer, public, parameter :: I_AF_MURRAY_2010 = 8 !! Glassy Aerosol Freezing, Murray[2010] + integer, public, parameter :: I_DROPACT = 256 !! Droplet Activation + integer, public, parameter :: I_AERFREEZE = 512 !! Aerosol Freezing + integer, public, parameter :: I_DROPFREEZE = 1024 !! Droplet Freezing + integer, public, parameter :: I_ICEMELT = 2048 !! Ice Melting + integer, public, parameter :: I_HETNUC = 4096 !! Heterogeneous Nucleation + integer, public, parameter :: I_HOMNUC = 8192 !! Binary homogeneous gas-to-particle nucleation + integer, public, parameter :: I_HETNUCSULF = 16384 !! Binary homogeneous gas-to-particle nucleation + + ! Define values of flag used for collection process (icollec) + integer, public, parameter :: I_COLLEC_CONST = 1 !! Constant Collection Efficiency + integer, public, parameter :: I_COLLEC_FUCHS = 2 !! Binwise Maxima of Fuchs' and Langmuir's Efficiencies + integer, public, parameter :: I_COLLEC_DATA = 3 !! Input Data + + ! Define values of flag used for coagulation operation (icoagop) + integer, public, parameter :: I_COAGOP_CONST = 1 !! Constant Coagulation Kernel + integer, public, parameter :: I_COAGOP_CALC = 2 !! Calculate Coagulation Kernel + + ! Define values of flag used for particle shape (ishape) + integer, public, parameter :: I_SPHERE = 1 !! spherical + integer, public, parameter :: I_HEXAGON = 2 !! hexagonal prisms or plates + integer, public, parameter :: I_CYLINDER = 3 !! circular disks, cylinders, or spheroids + + ! Define values of flag used for particle swelling parameterization (irhswell) + integer, public, parameter :: I_NO_SWELLING = 0 !! No swelling + integer, public, parameter :: I_FITZGERALD = 1 !! Fitzgerald + integer, public, parameter :: I_GERBER = 2 !! Gerber + integer, public, parameter :: I_WTPCT_H2SO4 = 3 !! The weight percent method for sulfate aerosol + + ! Define vallues of flag used for particle swelling composition (Fiztgerald) + integer, public, parameter :: I_SWF_NH42SO4 = 1 !! (NH4)2SO4 + integer, public, parameter :: I_SWF_NH4NO3 = 2 !! NH4NO3 + integer, public, parameter :: I_SWF_NANO3 = 3 !! NaNO3 + integer, public, parameter :: I_SWF_NH4CL = 4 !! NH4Cl + integer, public, parameter :: I_SWF_CACL2 = 5 !! CaCl2 + integer, public, parameter :: I_SWF_NABR = 6 !! NaBr + integer, public, parameter :: I_SWF_NACL = 7 !! NaCl + integer, public, parameter :: I_SWF_MGCL2 = 8 !! MgCl2 + integer, public, parameter :: I_SWF_LICL = 9 !! LiCl + + ! Define vallues of flag used for particle swelling composition (Gerber) + integer, public, parameter :: I_SWG_NH42SO4 = 11 !! (NH4)2SO4 + integer, public, parameter :: I_SWG_SEA_SALT = 12 !! Sea Salt + integer, public, parameter :: I_SWG_URBAN = 13 !! Urban + integer, public, parameter :: I_SWG_RURAL = 14 !! Rural + + ! Routines to calculate gas vapor pressures + integer, public, parameter :: I_VAPRTN_H2O_BUCK1981 = 1 !! H2O, Buck[1981] + integer, public, parameter :: I_VAPRTN_H2O_MURPHY2005 = 2 !! H2O, Murphy & Koop [2005] + integer, public, parameter :: I_VAPRTN_H2O_GOFF1946 = 3 !! H2O, Goff & Gratch [1946], used in CAM + integer, public, parameter :: I_VAPRTN_H2SO4_AYERS1980 = 4 !! H2SO4, Ayers [1980] & Kumala [1990] + + ! Routines to calculate fall velocities + integer, public, parameter :: I_FALLRTN_STD = 1 !! Standard CARMA 2.3 routine (spherical only) + integer, public, parameter :: I_FALLRTN_STD_SHAPE = 2 !! Optional CARMA 2.3 routine (supports shapes) + integer, public, parameter :: I_FALLRTN_HEYMSFIELD2010 = 3 !! Heymsfield & Westbrook [2010] (ice only) + + ! Routines to calculate mie optical properties + integer, public, parameter :: I_MIERTN_TOON1981 = 1 !! Shell/Core, Toon & Ackerman [1981] + integer, public, parameter :: I_MIERTN_BOHREN1983 = 2 !! Homogeneous Sphere, Bohren & Huffman [1983] + integer, public, parameter :: I_MIERTN_BOTET1997 = 3 !! Fractal mean-field, Botet et al. [1997] + + ! Gas Composition + integer, public, parameter :: I_GCOMP_H2O = 1 !! Water Vapor + integer, public, parameter :: I_GCOMP_H2SO4 = 2 !! Sulphuric Acid + integer, public, parameter :: I_GCOMP_SO2 = 3 !! Sulfer Dioxide + + ! How is the CARMA group represented in the parent model + integer, public, parameter :: I_CNSTTYPE_PROGNOSTIC = 1 !! Prognostic, advected constituent for each bin + integer, public, parameter :: I_CNSTTYPE_DIAGNOSTIC = 2 !! Diagnostic, bins diagonosed from model state + + ! Return Codes + ! + ! NOTE: Also see error handling macros in globaer.h. + integer, public, parameter :: RC_OK = 0 !! Success + integer, public, parameter :: RC_ERROR = -1 !! Failure + integer, public, parameter :: RC_WARNING = 1 !! Warning + integer, public, parameter :: RC_WARNING_RETRY = 2 !! Warning, Retry Suggested + + + ! Define values of symbols used to specify horizontal & vertical grid type. + ! Grid selection is made by defining each of the variables + ! and to one of the grid types known to the model. + ! + ! Possible values for igridv: + ! I_CART cartesian + ! I_SIG sigma + ! I_HYBRID hybrid + ! + ! Possible values for igridh: + ! I_CART cartesian + ! I_LL longitude_latitude + ! I_LC lambert_conformal + ! I_PS polar_stereographic + ! I_ME mercator + integer, public, parameter :: I_CART = 1 !! Cartesian + integer, public, parameter :: I_SIG = 2 !! Sigma + integer, public, parameter :: I_LL = 3 !! Longitude & Latitude + integer, public, parameter :: I_LC = 4 !! Lambert Conformal + integer, public, parameter :: I_PS = 5 !! Polar Sterographic + integer, public, parameter :: I_ME = 6 !! Mercator + integer, public, parameter :: I_HYBRID = 7 !! Hybrid +end module + diff --git a/src/physics/carma/base/carma_globaer.h b/src/physics/carma/base/carma_globaer.h new file mode 100644 index 0000000000..5d4ca14d27 --- /dev/null +++ b/src/physics/carma/base/carma_globaer.h @@ -0,0 +1,325 @@ +! CARMA Type aliases +! --------------------- +! This file containts shortcut names that map the variable names that +! were traditionally used in the common blocks by the Fortran 77 version +! of CARMA (globeaer.h), to the corresponding structure members in the +! Fortran 90 version of CARMA. This allows the older code to be +! converted to F90 with minimal changes, but without adding any +! processing overhead. +! --------------------------------------------- + +! NOTE: Using macros causes some limitations: +! +! 1) You can not have another #define as a parameter to a macro. This causes +! multiple expansions of the parameter. To prevent this, assign the parameter +! to a varaible and use the variable in the macro. +! +! 2) You can not have comments on the same line as a macro. Put comments on the +! line before the one with the macro. +! +! 3) Not all fortran preprocessors support the CPP's handling of recursion for +! macro names. To work out of the box with the broadest number of fortran +! compilers this requires making the field name different from the macro +! or it will recursively try to replace the macro again (or report an +! error message about recursion. Intel and IBM compilers handle it properly, +! but Portland Group does not. To work around this problem, fields in the +! cstate and carma structure are preceeded by f_ to make their names unique. + +#define NZ cstate%f_NZ +#define NZP1 cstate%f_NZP1 +#define NGAS carma%f_NGAS +#define NBIN carma%f_NBIN +#define NGROUP carma%f_NGROUP +#define NELEM carma%f_NELEM +#define NSOLUTE carma%f_NSOLUTE +#define NWAVE carma%f_NWAVE + +! Model logical units for I/O +#define LUNOPRT carma%f_LUNOPRT + +! Model startup control variables +#define do_print carma%f_do_print + +! Gridding Information +#define igridv cstate%f_igridv +#define igridh cstate%f_igridh +#define xmet cstate%f_xmet +#define ymet cstate%f_ymet +#define zmet cstate%f_zmet +#define zmetl cstate%f_zmetl +#define xc cstate%f_xc +#define yc cstate%f_yc +#define zc cstate%f_zc +#define dx cstate%f_dx +#define dy cstate%f_dy +#define dz cstate%f_dz +#define zl cstate%f_zl +#define lon cstate%f_lon +#define lat cstate%f_lat + +! Element object +#define elemname(ielem) carma%f_element(ielem)%f_name +#define rhoelem(ibin, ielem) carma%f_element(ielem)%f_rho(ibin) +#define igelem(ielem) carma%f_element(ielem)%f_igroup +#define itype(ielem) carma%f_element(ielem)%f_itype +#define icomp(ielem) carma%f_element(ielem)%f_icomposition +#define isolelem(ielem) carma%f_element(ielem)%f_isolute + +! Gas object +#define gasname(igas) carma%f_gas(igas)%f_name +#define gwtmol(igas) carma%f_gas(igas)%f_wtmol +#define ivaprtn(igas) carma%f_gas(igas)%f_ivaprtn +#define igcomp(igas) carma%f_gas(igas)%f_icomposition +#define dgc_threshold(igas) carma%f_gas(igas)%f_dgc_threshold +#define ds_threshold(igas) carma%f_gas(igas)%f_ds_threshold + +! Group object +#define groupname(igroup) carma%f_group(igroup)%f_name +#define nelemg(igroup) carma%f_group(igroup)%f_nelem +#define ncore(igroup) carma%f_group(igroup)%f_ncore +#define ishape(igroup) carma%f_group(igroup)%f_ishape +#define ienconc(igroup) carma%f_group(igroup)%f_ienconc +#define imomelem(igroup) carma%f_group(igroup)%f_imomelem +#define solfac(igroup) carma%f_group(igroup)%f_solface +#define scavcoef(igroup) carma%f_group(igroup)%f_scavcoef +#define if_sec_mom(igroup) carma%f_group(igroup)%f_if_sec_mom +#define is_grp_fractal(igroup) carma%f_group(igroup)%f_is_fractal +#define is_grp_ice(igroup) carma%f_group(igroup)%f_is_ice +#define is_grp_cloud(igroup) carma%f_group(igroup)%f_is_cloud +#define is_grp_sulfate(igroup) carma%f_group(igroup)%f_is_sulfate +#define grp_do_vtran(igroup) carma%f_group(igroup)%f_grp_do_vtran +#define grp_do_drydep(igroup) carma%f_group(igroup)%f_grp_do_drydep +#define irhswell(igroup) carma%f_group(igroup)%f_irhswell +#define irhswcomp(igroup) carma%f_group(igroup)%f_irhswcomp +#define rmrat(igroup) carma%f_group(igroup)%f_rmrat +#define eshape(igroup) carma%f_group(igroup)%f_eshape +#define r(ibin,igroup) carma%f_group(igroup)%f_r(ibin) +#define rmass(ibin,igroup) carma%f_group(igroup)%f_rmass(ibin) +#define vol(ibin,igroup) carma%f_group(igroup)%f_vol(ibin) +#define dr(ibin,igroup) carma%f_group(igroup)%f_dr(ibin) +#define dm(ibin,igroup) carma%f_group(igroup)%f_dm(ibin) +#define rmassup(ibin,igroup) carma%f_group(igroup)%f_rmassup(ibin) +#define rmin(igroup) carma%f_group(igroup)%f_rmin +#define rmassmin(igroup) carma%f_group(igroup)%f_rmassmin +#define rup(ibin,igroup) carma%f_group(igroup)%f_rup(ibin) +#define rlow(ibin,igroup) carma%f_group(igroup)%f_rlow(ibin) +#define icorelem(icore,igroup) carma%f_group(igroup)%f_icorelem(icore) +#define ifallrtn(igroup) carma%f_group(igroup)%f_ifallrtn +#define arat(ibin,igroup) carma%f_group(igroup)%f_arat(ibin) +#define rrat(ibin,igroup) carma%f_group(igroup)%f_rrat(ibin) +#define rprat(ibin,igroup) carma%f_group(igroup)%f_rprat(ibin) +#define qext(iwave,ibin,igroup) carma%f_group(igroup)%f_qext(iwave,ibin) +#define ssa(iwave,ibin,igroup) carma%f_group(igroup)%f_ssa(iwave,ibin) +#define do_mie(igroup) carma%f_group(igroup)%f_do_mie +#define imiertn(igroup) carma%f_group(igroup)%f_imiertn +#define dpc_threshold(igroup) carma%f_group(igroup)%f_dpc_threshold +#define rmon(igroup) carma%f_group(igroup)%f_rmon +#define df(ibin,igroup) carma%f_group(igroup)%f_df(ibin) +#define nmon(ibin,igroup) carma%f_group(igroup)%f_nmon(ibin) +#define falpha(igroup) carma%f_group(igroup)%f_falpha +#define neutral_volfrc(igroup) carma%f_group(igroup)%f_neutral_volfrc + +! Solute object +#define solname(isolute) carma%f_solute(isolute)%f_name +#define sol_ions(isolute) carma%f_solute(isolute)%f_ions +#define solwtmol(isolute) carma%f_solute(isolute)%f_wtmol +#define rhosol(isolute) carma%f_solute(isolute)%f_rho + +! Optical properties +#define wave carma%f_wave +#define dwave carma%f_dwave +#define do_wave_emit carma%f_do_wave_emit + +! Model option & control variables +#define do_clearsky carma%f_do_clearsky +#define do_cnst_rlh carma%f_do_cnst_rlh +#define do_coag carma%f_do_coag +#define do_detrain carma%f_do_detrain +#define do_fixedinit carma%f_do_fixedinit +#define do_grow carma%f_do_grow +#define do_explised carma%f_do_explised +#define do_incloud carma%f_do_incloud +#define do_partialinit carma%f_do_partialinit +#define do_pheat carma%f_do_pheat +#define do_pheatatm carma%f_do_pheatatm +#define do_print_init carma%f_do_print_init +#define do_step carma%f_do_step +#define do_substep carma%f_do_substep +#define do_thermo carma%f_do_thermo +#define do_vdiff carma%f_do_vdiff +#define do_vtran carma%f_do_vtran +#define do_drydep carma%f_do_drydep +#define if_nuc carma%f_if_nuc +#define time cstate%f_time +#define dtime cstate%f_dtime +#define dtime_orig cstate%f_dtime_orig +#define nretries cstate%f_nretries +#define dtmin carma%f_dtmin +#define dtmax carma%f_dtmax +#define conmax carma%f_conmax +#define maxsubsteps carma%f_maxsubsteps +#define minsubsteps carma%f_minsubsteps +#define maxretries carma%f_maxretries +#define ifall carma%f_ifall +#define icoagop carma%f_icoagop +#define icollec carma%f_icollec +#define itbnd_pc carma%f_itbnd_pc +#define ibbnd_pc carma%f_ibbnd_pc +#define inucgas carma%f_inucgas +#define igrowgas carma%f_igrowgas +#define nnuc2elem carma%f_nnuc2elem +#define ievp2elem carma%f_ievp2elem +#define nnucelem carma%f_nnucelem +#define inucproc carma%f_inucproc +#define inuc2elem carma%f_inuc2elem +#define inucelem carma%f_inucelem +#define inuc2bin carma%f_inuc2bin +#define ievp2bin carma%f_ievp2bin +#define nnucbin carma%f_nnucbin +#define inucbin carma%f_inucbin +#define dt_threshold carma%f_dt_threshold +#define igash2o carma%f_igash2o +#define igash2so4 carma%f_igash2so4 +#define igasso2 carma%f_igasso2 +#define tstick carma%f_tstick +#define gsticki carma%f_gsticki +#define gstickl carma%f_gstickl +#define cstick carma%f_cstick + +#define max_nsubstep cstate%f_max_nsubstep +#define max_nretry cstate%f_max_nretry +#define nstep cstate%f_nstep +#define nsubstep cstate%f_nsubstep +#define nretry cstate%f_nretry +#define zsubsteps cstate%f_zsubsteps + +! Particle grid structure +#define diffmass carma%f_diffmass +#define rhop cstate%f_rhop +#define r_wet cstate%f_r_wet +#define rlow_wet cstate%f_rlow_wet +#define rup_wet cstate%f_rup_wet +#define rhop_wet cstate%f_rhop_wet +#define r_ref cstate%f_r_ref +#define rhop_ref cstate%f_rhop_ref + +! Atmospheric structure +#define rhoa cstate%f_rhoa +#define rhoa_wet cstate%f_rhoa_wet +#define t cstate%f_t +#define p cstate%f_p +#define pl cstate%f_pl +#define relhum cstate%f_relhum +#define wtpct cstate%f_wtpct +#define told cstate%f_told +#define rmu cstate%f_rmu +#define thcond cstate%f_thcond +#define thcondnc cstate%f_thcondnc +#define dkz cstate%f_dkz + +! Model primary vars +#define pc cstate%f_pc +#define pcd cstate%f_pcd +#define pc_surf cstate%f_pc_surf +#define gc cstate%f_gc +#define sedimentationflux cstate%f_sedimentationflux +#define cldfrc cstate%f_cldfrc +#define rhcrit cstate%f_rhcrit + +! Model secondary variables +#define pcl cstate%f_pcl +#define gcl cstate%f_gcl +#define d_gc cstate%f_d_gc +#define d_t cstate%f_d_t +#define dpc_sed cstate%f_dpc_sed +#define pconmax cstate%f_pconmax +#define coaglg cstate%f_coaglg +#define coagpe cstate%f_coagpe +#define rnuclg cstate%f_rnuclg +#define rnucpe cstate%f_rnucpe +#define rhompe cstate%f_rhompe +#define pc_nucl cstate%f_pc_nucl +#define growpe cstate%f_growpe +#define evappe cstate%f_evappe +#define coreavg cstate%f_coreavg +#define coresig cstate%f_coresig +#define evdrop cstate%f_evdrop +#define evcore cstate%f_evcore +#define growlg cstate%f_growlg +#define evaplg cstate%f_evaplg +#define gasprod cstate%f_gasprod +#define rlheat cstate%f_rlheat +#define cmf cstate%f_cmf +#define totevap cstate%f_totevap +#define pc_topbnd cstate%f_pc_topbnd +#define pc_botbnd cstate%f_pc_botbnd +#define ftoppart cstate%f_ftoppart +#define fbotpart cstate%f_fbotpart +#define cmf cstate%f_cmf +#define totevap cstate%f_totevap +#define too_small cstate%f_too_small +#define too_big cstate%f_too_big +#define nuc_small cstate%f_nuc_small +#define rlprod cstate%f_rlprod +#define phprod cstate%f_phprod + +! Coagulation kernels and bin pair mapping +#define ck0 carma%f_ck0 +#define grav_e_coll0 carma%f_grav_e_coll0 +#define icoag carma%f_icoag +#define icoagelem carma%f_icoagelem +#define icoagelem_cm carma%f_icoagelem_cm +#define kbin carma%f_kbin + +#define ckernel cstate%f_ckernel +#define pkernel carma%f_pkernel + +#define volx carma%f_volx +#define ilow carma%f_ilow +#define jlow carma%f_jlow +#define iup carma%f_iup +#define jup carma%f_jup +#define npairl carma%f_npairl +#define npairu carma%f_npairu + +! Coagulation group pair mapping +#define iglow carma%f_iglow +#define jglow carma%f_jglow +#define igup carma%f_igup +#define jgup carma%f_jgup + +! Particle fall velocities, transport rates, and coagulation kernels +#define bpm cstate%f_bpm +#define vf cstate%f_vf +#define re cstate%f_re +#define vf_const carma%f_vf_const +#define vd cstate%f_vd + +! Condensational growth parameters +#define diffus cstate%f_diffus +#define rlhe cstate%f_rlhe +#define rlhm cstate%f_rlhm +#define pvapl cstate%f_pvapl +#define pvapi cstate%f_pvapi +#define surfctwa cstate%f_surfctwa +#define surfctiw cstate%f_surfctiw +#define surfctia cstate%f_surfctia +#define akelvin cstate%f_akelvin +#define akelvini cstate%f_akelvini +#define ft cstate%f_ft +#define gro cstate%f_gro +#define gro1 cstate%f_gro1 +#define gro2 cstate%f_gro2 +#define supsatl cstate%f_supsatl +#define supsati cstate%f_supsati +#define supsatlold cstate%f_supsatlold +#define supsatiold cstate%f_supsatiold +#define scrit cstate%f_scrit +#define rlh_nuc carma%f_rlh_nuc +#define radint cstate%f_radint +#define partheat cstate%f_partheat +#define dtpart cstate%f_dtpart +#define pratt carma%f_pratt +#define prat carma%f_prat +#define pden1 carma%f_pden1 +#define palr carma%f_palr diff --git a/src/physics/carma/base/carma_mod.F90 b/src/physics/carma/base/carma_mod.F90 new file mode 100644 index 0000000000..353c6173d2 --- /dev/null +++ b/src/physics/carma/base/carma_mod.F90 @@ -0,0 +1,1492 @@ +!! The CARMA module contains an interface to the Community Aerosol and Radiation +!! Model for Atmospheres (CARMA) bin microphysical model [Turco et al. 1979; +!! Toon et al. 1988]. This implementation has been customized to work within +!! other model frameworks, so although it can be provided with an array of +!! columns, it does not do horizontal transport and just does independent 1-D +!! calculations upon each column. +!! +!! The typical usage for the CARMA and CARMASTATE objects within a model would be: +!!> +!! ! This first section of code is done during the parent model's initialzation, +!! ! and there should be a unique CARMA object created for each thread of +!! ! execution. +!! +!! ! Create the CARMA object. +!! call CARMA_Create(carma, ...) +!! +!! ! Define the microphysical components. +!! call CARMAGROUP_Create(carma, ...) ! One or more calls +!! +!! call CARMAELEMENT_Create(carma, ...) ! One or more calls +!! +!! call CARMASOLUTE_Create(carma, ...) ! Zero or more calls +!! +!! call CARMAGAS_Create(carma, ...) ! Zero or more calls +!! +!! ! Define the relationships for the microphysical processes. +!! call CARMA_AddCoagulation(carma, ...) ! Zero or more calls +!! call CARMA_AddGrowth(carma, ...) ! Zero or more calls +!! call CARMA_AddNucleation(carma, ...) ! Zero or more calls +!! +!! ! Initialize things that are state and timestep independent. +!! call CARMA_Initialize(carma, ...) +!! +!! ... +!! +!! ! This section of code is within the parent model's timing loop. +!! ! +!! ! NOTE: If using OPEN/MP, then each thread will execute one of +!! ! of these loops per column of data. To avoid having to destroy +!! ! the CARMASTATE object, a pool of CARMASTATE objects could be +!! ! created so that there is one per thread and then the +!! ! CARMA_Destroy() could be called after all columns have been +!! ! processed. +!! +!! ! Initialize CARMA for this model state and timestep. +!! call CARMASTATE_Create(cstate, carma, ...) +!! +!! ! Set the model state for each bin and gas. +!! call CARMASTATE_SetBin(cstate, ...) ! One call for each bin +!! call CARMASTATE_SetGas(cstate, ...) ! One call for each gas +!! +!! ! Calculate the new state +!! call CARMASTATE_Step(cstate, ...) +!! +!! ! Get the results to return back to the parent model. +!! call CARMASTATE_GetBin(cstate, ...) ! One call for each Bin +!! call CARMASTATE_GetGas(cstate, ...) ! One call for each gas +!! call CARMASTATE_GetState(cstate, ...) ! Zero or one calls +!! +!! ! (optional) Deallocate arrays that are not needed beyond this timestep. +!! call CARMASTATE_Destroy(cstate) +!! +!! ... +!! +!! ! This section of code is done during the parent model's cleanup. +!! +!! ! Deallocate all arrays. +!! call CARMA_Destroy(carma) +!!< +!! +!! @version Feb-2009 +!! @author Chuck Bardeen, Pete Colarco, Jamie Smith +! +! NOTE: Documentation for this code can be generated automatically using f90doc, +! which is freely available from: +! http://erikdemaine.org/software/f90doc/ +! Comment lines with double comment characters are processed by f90doc, and there are +! some special characters added to the comments to control the documentation process. +! In addition to the special characters mentioned in the f990doc documentation, html +! formatting tags (e.g. , , ...) can also be added to the f90doc +! comments. +module carma_mod + + ! This module maps the parents models constants into the constants need by CARMA. NOTE: CARMA + ! constants are in CGS units, while the parent models are typically in MKS units. + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! CARMA explicitly declares all variables. + implicit none + + ! All CARMA variables and procedures are private except those explicitly declared to be public. + private + + ! Declare the public methods. + public CARMA_AddCoagulation + public CARMA_AddGrowth + public CARMA_AddNucleation + public CARMA_Create + public CARMA_Destroy + public CARMA_Get + public CARMA_Initialize + +contains + + ! These are the methods that provide the interface between the parent model and the CARMA + ! microphysical model. There are many other methods that are not in this file that are + ! used to implement the microphysical calculations needed by the CARMA model. These other + ! methods are in effect private methods of the CARMA module, but are in individual files + ! since that is the way that CARMA has traditionally been structured and where users may + ! want to extend or replace code to affect the microphysics. + + !! Creates the CARMA object and allocates arrays to store configuration information + !! that will follow from the CARMA_AddXXX() methods. When the CARMA object is no longer + !! needed, the CARMA_Destroy() method should be used to clean up any allocations + !! that have happened. If LUNOPRT is specified, then the logical unit should be open and + !! ready for output. The caller is responsible for closing the LUNOPRT logical unit + !! after the CARMA object has been destroyed. + !! + !! @version Feb-2009 + !! @author Chuck Bardeen + subroutine CARMA_Create(carma, NBIN, NELEM, NGROUP, NSOLUTE, NGAS, NWAVE, rc, & + LUNOPRT, wave, dwave, do_wave_emit) + + type(carma_type), intent(out) :: carma !! the carma object + integer, intent(in) :: NBIN !! number of radius bins per group + integer, intent(in) :: NELEM !! total number of elements + integer, intent(in) :: NGROUP !! total number of groups + integer, intent(in) :: NSOLUTE !! total number of solutes + integer, intent(in) :: NGAS !! total number of gases + integer, intent(in) :: NWAVE !! number of wavelengths + integer, intent(out) :: rc !! return code, negative indicates failure + integer, intent(in), optional :: LUNOPRT !! logical unit number for output + real(kind=f), intent(in), optional :: wave(NWAVE) !! wavelength centers (cm) + real(kind=f), intent(in), optional :: dwave(NWAVE) !! wavelength width (cm) + logical, intent(in), optional :: do_wave_emit(NWAVE) !! do emission in band? + + ! Local Varaibles + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Save off the logic unit used for output if one was provided. If one was provided, + ! then assume that CARMA can print output. + if (present(LUNOPRT)) then + carma%f_LUNOPRT = LUNOPRT + carma%f_do_print = .TRUE. + end if + + ! Save the defintion of the number of comonents involved in the microphysics. + carma%f_NGROUP = NGROUP + carma%f_NELEM = NELEM + carma%f_NBIN = NBIN + carma%f_NGAS = NGAS + carma%f_NSOLUTE = NSOLUTE + carma%f_NWAVE = NWAVE + + + ! Allocate tables for the groups. + allocate( & + carma%f_group(NGROUP), & + carma%f_icoag(NGROUP, NGROUP), & + carma%f_inucgas(NGROUP), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating groups, NGROUP=", & + carma%f_NGROUP, ", status=", ier + rc = RC_ERROR + return + endif + + ! Initialize + carma%f_icoag(:, :) = 0 + carma%f_inucgas(:) = 0 + + ! Allocate tables for the elements. + allocate( & + carma%f_element(NELEM), & + carma%f_igrowgas(NELEM), & + carma%f_inuc2elem(NELEM, NELEM), & + carma%f_inucproc(NELEM, NELEM), & + carma%f_ievp2elem(NELEM), & + carma%f_nnuc2elem(NELEM), & + carma%f_nnucelem(NELEM), & + carma%f_inucelem(NELEM,NELEM*NGROUP), & + carma%f_if_nuc(NELEM,NELEM), & + carma%f_rlh_nuc(NELEM, NELEM), & + carma%f_icoagelem(NELEM, NGROUP), & + carma%f_icoagelem_cm(NELEM, NGROUP), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating elements, NELEM=", & + carma%f_NELEM, ", status=", ier + rc = RC_ERROR + return + endif + + ! Initialize + carma%f_igrowgas(:) = 0 + carma%f_inuc2elem(:,:) = 0 + carma%f_inucproc(:,:) = 0 + carma%f_ievp2elem(:) = 0 + carma%f_nnuc2elem(:) = 0 + carma%f_nnucelem(:) = 0 + carma%f_inucelem(:,:) = 0 + carma%f_if_nuc(:,:) = .FALSE. + carma%f_rlh_nuc(:,:) = 0._f + carma%f_icoagelem(:,:) = 0 + carma%f_icoagelem_cm(:,:) = 0 + + + ! Allocate tables for the bins. + allocate( & + carma%f_inuc2bin(NBIN,NGROUP,NGROUP), & + carma%f_ievp2bin(NBIN,NGROUP,NGROUP), & + carma%f_nnucbin(NGROUP,NBIN,NGROUP), & + carma%f_inucbin(NBIN*NGROUP,NGROUP,NBIN,NGROUP), & + carma%f_diffmass(NBIN, NGROUP, NBIN, NGROUP), & + carma%f_volx(NGROUP,NGROUP,NGROUP,NBIN,NBIN), & + carma%f_ilow(NGROUP,NBIN,NBIN*NBIN), & + carma%f_jlow(NGROUP,NBIN,NBIN*NBIN), & + carma%f_iup(NGROUP,NBIN,NBIN*NBIN), & + carma%f_jup(NGROUP,NBIN,NBIN*NBIN), & + carma%f_npairl(NGROUP,NBIN), & + carma%f_npairu(NGROUP,NBIN), & + carma%f_iglow(NGROUP,NBIN,NBIN*NBIN), & + carma%f_jglow(NGROUP,NBIN,NBIN*NBIN), & + carma%f_igup(NGROUP,NBIN,NBIN*NBIN), & + carma%f_jgup(NGROUP,NBIN,NBIN*NBIN), & + carma%f_kbin(NGROUP,NGROUP,NGROUP,NBIN,NBIN), & + carma%f_pkernel(NBIN,NBIN,NGROUP,NGROUP,NGROUP,6), & + carma%f_pratt(3,NBIN,NGROUP), & + carma%f_prat(4,NBIN,NGROUP), & + carma%f_pden1(NBIN,NGROUP), & + carma%f_palr(4,NGROUP), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating bins, NBIN=", & + carma%f_NBIN, ", status=", ier + rc = RC_ERROR + return + endif + + ! Initialize + carma%f_inuc2bin(:,:,:) = 0 + carma%f_ievp2bin(:,:,:) = 0 + carma%f_nnucbin(:,:,:) = 0 + carma%f_inucbin(:,:,:,:) = 0 + carma%f_diffmass(:, :, :, :) = 0._f + carma%f_volx(:,:,:,:,:) = 0._f + carma%f_ilow(:,:,:) = 0 + carma%f_jlow(:,:,:) = 0 + carma%f_iup(:,:,:) = 0 + carma%f_jup(:,:,:) = 0 + carma%f_npairl(:,:) = 0 + carma%f_npairu(:,:) = 0 + carma%f_iglow(:,:,:) = 0 + carma%f_jglow(:,:,:) = 0 + carma%f_igup(:,:,:) = 0 + carma%f_jgup(:,:,:) = 0 + carma%f_kbin(:,:,:,:,:) = 0._f + carma%f_pkernel(:,:,:,:,:,:) = 0._f + carma%f_pratt(:,:,:) = 0._f + carma%f_prat(:,:,:) = 0._f + carma%f_pden1(:,:) = 0._f + carma%f_palr(:,:) = 0._f + + + ! Allocate tables for solutes, if any are needed. + if (NSOLUTE > 0) then + allocate( & + carma%f_solute(NSOLUTE), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating solutes, NSOLUTE=", & + carma%f_NSOLUTE, ", status=", ier + rc = RC_ERROR + return + endif + end if + + + ! Allocate tables for gases, if any are needed. + if (NGAS > 0) then + allocate( & + carma%f_gas(NGAS), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating gases, NGAS=", & + carma%f_NGAS, ", status=", ier + rc = RC_ERROR + return + endif + end if + + + ! Allocate tables for optical properties, if any are needed. + if (NWAVE > 0) then + allocate( & + carma%f_wave(NWAVE), & + carma%f_dwave(NWAVE), & + carma%f_do_wave_emit(NWAVE), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Create: ERROR allocating wavelengths, NWAVE=", & + carma%f_NWAVE, ", status=", ier + rc = RC_ERROR + return + endif + + ! Initialize + carma%f_do_wave_emit(:) = .TRUE. + + if (present(wave)) carma%f_wave(:) = wave(:) + if (present(dwave)) carma%f_dwave(:) = dwave(:) + if (present(do_wave_emit)) carma%f_do_wave_emit(:) = do_wave_emit(:) + end if + + return + end subroutine CARMA_Create + + !! Called after the CARMA object has been created and the microphysics description has been + !! configured. The optional flags control which microphysical processes are enabled and all of + !! them default to FALSE. For a microphysical process to be active it must have been both + !! configured (using a CARMA_AddXXX() method) and enabled here. + !! + !! NOTE: After initialization, the structure of the particle size bins is determined, and + !! the resulting r, dr, rmass and dm can be retrieved with the CARMA_GetGroup() method. + !! + !! @version Feb-2009 + !! @author Chuck Bardeen + subroutine CARMA_Initialize(carma, rc, do_cnst_rlh, do_coag, do_detrain, do_fixedinit, & + do_grow, do_incloud, do_explised, do_print_init, do_substep, do_thermo, do_vdiff, & + do_vtran, do_drydep, vf_const, minsubsteps, maxsubsteps, maxretries, conmax, & + do_pheat, do_pheatatm, dt_threshold, cstick, gsticki, gstickl, tstick, do_clearsky, & + do_partialinit) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(out) :: rc !! return code, negative indicates failure + logical, intent(in), optional :: do_cnst_rlh !! use constant values for latent heats + !! (instead of varying with temperature)? + logical, intent(in), optional :: do_coag !! do coagulation? + logical, intent(in), optional :: do_detrain !! do detrainement? + logical, intent(in), optional :: do_fixedinit !! do initialization from reference atm? + logical, intent(in), optional :: do_grow !! do nucleation, growth and evaporation? + logical, intent(in), optional :: do_incloud !! do incloud growth and coagulation? + logical, intent(in), optional :: do_explised !! do sedimentation with substepping + logical, intent(in), optional :: do_substep !! do substepping + logical, intent(in), optional :: do_print_init !! do prinit initializtion information + logical, intent(in), optional :: do_thermo !! do thermodynamics + logical, intent(in), optional :: do_vdiff !! do Brownian diffusion + logical, intent(in), optional :: do_vtran !! do sedimentation + logical, intent(in), optional :: do_drydep !! do dry deposition + real(kind=f), intent(in), optional :: vf_const !! if specified and non-zero, + !! constant fall velocity for all particles [cm/s] + integer, intent(in), optional :: minsubsteps !! minimum number of substeps, default = 1 + integer, intent(in), optional :: maxsubsteps !! maximum number of substeps, default = 1 + integer, intent(in), optional :: maxretries !! maximum number of substep retries, default = 5 + real(kind=f), intent(in), optional :: conmax !! minimum relative concentration to consider, default = 1e-1 + logical, intent(in), optional :: do_pheat !! do particle heating + logical, intent(in), optional :: do_pheatatm !! do particle heating of atmosphere + real(kind=f), intent(in), optional :: dt_threshold !! convergence criteria for temperature [fraction] + real(kind=f), intent(in), optional :: cstick !! accommodation coefficient - coagulation, default = 1.0 + real(kind=f), intent(in), optional :: gsticki !! accommodation coefficient - growth (ice), default = 0.93 + real(kind=f), intent(in), optional :: gstickl !! accommodation coefficient - growth (liquid), default = 1.0 + real(kind=f), intent(in), optional :: tstick !! accommodation coefficient - temperature, default = 1.0 + logical, intent(in), optional :: do_clearsky !! do clear sky growth and coagulation? + logical, intent(in), optional :: do_partialinit !! do initialization of coagulation from reference atm (requires do_fixedinit)? + + ! Assume success. + rc = RC_OK + + ! Set default values for control flags. + carma%f_do_cnst_rlh = .FALSE. + carma%f_do_coag = .FALSE. + carma%f_do_detrain = .FALSE. + carma%f_do_fixedinit = .FALSE. + carma%f_do_grow = .FALSE. + carma%f_do_incloud = .FALSE. + carma%f_do_explised = .FALSE. + carma%f_do_pheat = .FALSE. + carma%f_do_pheatatm = .FALSE. + carma%f_do_print_init = .FALSE. + carma%f_do_substep = .FALSE. + carma%f_do_thermo = .FALSE. + carma%f_do_vdiff = .FALSE. + carma%f_do_vtran = .FALSE. + carma%f_do_drydep = .FALSE. + carma%f_dt_threshold = 0._f + carma%f_cstick = 1._f + carma%f_gsticki = 0.93_f + carma%f_gstickl = 1._f + carma%f_tstick = 1._f + carma%f_do_clearsky = .FALSE. + carma%f_do_partialinit = .FALSE. + + ! Store off any control flag values that have been supplied. + if (present(do_cnst_rlh)) carma%f_do_cnst_rlh = do_cnst_rlh + if (present(do_coag)) carma%f_do_coag = do_coag + if (present(do_detrain)) carma%f_do_detrain = do_detrain + if (present(do_fixedinit)) carma%f_do_fixedinit = do_fixedinit + if (present(do_grow)) carma%f_do_grow = do_grow + if (present(do_incloud)) carma%f_do_incloud = do_incloud + if (present(do_explised)) carma%f_do_explised = do_explised + if (present(do_pheat)) carma%f_do_pheat = do_pheat + if (present(do_pheatatm)) carma%f_do_pheatatm = do_pheatatm + if (present(do_print_init)) carma%f_do_print_init = (do_print_init .and. carma%f_do_print) + if (present(do_substep)) carma%f_do_substep = do_substep + if (present(do_thermo)) carma%f_do_thermo = do_thermo + if (present(do_vdiff)) carma%f_do_vdiff = do_vdiff + if (present(do_vtran)) carma%f_do_vtran = do_vtran + if (present(do_drydep)) carma%f_do_drydep = do_drydep + if (present(dt_threshold)) carma%f_dt_threshold = dt_threshold + if (present(cstick)) carma%f_cstick = cstick + if (present(gsticki)) carma%f_gsticki = gsticki + if (present(gstickl)) carma%f_gstickl = gstickl + if (present(tstick)) carma%f_tstick = tstick + if (present(do_clearsky)) carma%f_do_clearsky = do_clearsky + if (present(do_partialinit)) carma%f_do_partialinit = do_partialinit + + + ! Setup the bin structure. + call setupbins(carma, rc) + if (rc < 0) return + + ! Substepping + carma%f_minsubsteps = 1 ! minimum number of substeps + carma%f_maxsubsteps = 1 ! maximum number of substeps + carma%f_maxretries = 1 ! maximum number of retries + carma%f_conmax = 1.e-1_f + + if (present(minsubsteps)) carma%f_minsubsteps = minsubsteps + if (present(maxsubsteps)) carma%f_maxsubsteps = maxsubsteps + if (present(maxretries)) carma%f_maxretries = maxretries + if (present(conmax)) carma%f_conmax = conmax + + carma%f_do_step = .TRUE. + + ! Calculate the Optical Properties + ! + ! NOTE: This is only needed by CARMA if particle heating is being used. For + ! fractal particle the optics can be very slow, so only do it if necessary, + if (carma%f_do_pheat) then + call CARMA_InitializeOptics(carma, rc) + if (rc < 0) return + end if + + ! If any of the processes have initialization that can be done without the state + ! information, then perform that now. This will mostly be checking the configuration + ! and setting up any tables based upon the configuration. + if (carma%f_do_vtran .or. carma%f_do_coag) then + call CARMA_InitializeVertical(carma, rc, vf_const) + if (rc < 0) return + end if + + if (carma%f_do_coag) then + call setupcoag(carma, rc) + if (rc < 0) return + end if + + if (carma%f_do_grow) then + call CARMA_InitializeGrowth(carma, rc) + if (rc < 0) return + end if + + if (carma%f_do_thermo) then + call CARMA_InitializeThermo(carma, rc) + if (rc < 0) return + end if + + return + end subroutine CARMA_Initialize + + + subroutine CARMA_InitializeGrowth(carma, rc) + type(carma_type), intent(inout) :: carma + integer, intent(out) :: rc + + ! Local Variables + integer :: i + logical :: bad_grid + integer :: igroup ! group index + integer :: igas ! gas index + integer :: isol ! solute index + integer :: ielem ! element index + integer :: ibin ! bin index + integer :: igfrom + integer :: igto + integer :: ibto + integer :: ieto + integer :: ifrom + integer :: iefrom + integer :: jefrom + integer :: ip + integer :: jcore + integer :: iecore + integer :: im + integer :: jnucelem + integer :: inuc2 + integer :: neto + integer :: jfrom + integer :: j + integer :: nnucb + + ! Define formats + 1 format(a,': ',12i6) + 2 format(/,a,': ',i6) + 3 format(a,a) + 4 format(a,': ',1pe12.3) + 5 format(/,'Particle nucleation mapping arrays (setupnuc):') + 7 format(/,'Warning: nucleation cannot occur from group',i3, & + ' bin',i3,' into group',i3,' ( is zero)') + + + ! Assume success. + rc = RC_OK + + ! Compute radius-dependent terms used in PPM advection scheme + do igroup = 1, carma%f_NGROUP + do i = 2,carma%f_NBIN-1 + carma%f_pratt(1,i,igroup) = carma%f_group(igroup)%f_dm(i) / & + ( carma%f_group(igroup)%f_dm(i-1) + carma%f_group(igroup)%f_dm(i) + carma%f_group(igroup)%f_dm(i+1) ) + carma%f_pratt(2,i,igroup) = ( 2._f*carma%f_group(igroup)%f_dm(i-1) + carma%f_group(igroup)%f_dm(i) ) / & + ( carma%f_group(igroup)%f_dm(i+1) + carma%f_group(igroup)%f_dm(i) ) + carma%f_pratt(3,i,igroup) = ( 2._f*carma%f_group(igroup)%f_dm(i+1) + carma%f_group(igroup)%f_dm(i) ) / & + ( carma%f_group(igroup)%f_dm(i-1) + carma%f_group(igroup)%f_dm(i) ) + enddo + + do i = 2,carma%f_NBIN-2 + carma%f_prat(1,i,igroup) = carma%f_group(igroup)%f_dm(i) / & + ( carma%f_group(igroup)%f_dm(i) + carma%f_group(igroup)%f_dm(i+1) ) + carma%f_prat(2,i,igroup) = 2._f * carma%f_group(igroup)%f_dm(i+1) * carma%f_group(igroup)%f_dm(i) / & + ( carma%f_group(igroup)%f_dm(i) + carma%f_group(igroup)%f_dm(i+1) ) + carma%f_prat(3,i,igroup) = ( carma%f_group(igroup)%f_dm(i-1) + carma%f_group(igroup)%f_dm(i) ) / & + ( 2._f*carma%f_group(igroup)%f_dm(i) + carma%f_group(igroup)%f_dm(i+1) ) + carma%f_prat(4,i,igroup) = ( carma%f_group(igroup)%f_dm(i+2) + carma%f_group(igroup)%f_dm(i+1) ) / & + ( 2._f*carma%f_group(igroup)%f_dm(i+1) + carma%f_group(igroup)%f_dm(i) ) + carma%f_pden1(i,igroup) = carma%f_group(igroup)%f_dm(i-1) + carma%f_group(igroup)%f_dm(i) + & + carma%f_group(igroup)%f_dm(i+1) + carma%f_group(igroup)%f_dm(i+2) + enddo + + if( carma%f_NBIN .gt. 1 )then + carma%f_palr(1,igroup) = & + (carma%f_group(igroup)%f_rmassup(1)-carma%f_group(igroup)%f_rmass(1)) / & + (carma%f_group(igroup)%f_rmass(2)-carma%f_group(igroup)%f_rmass(1)) + carma%f_palr(2,igroup) = & + (carma%f_group(igroup)%f_rmassup(1)/carma%f_group(igroup)%f_rmrat-carma%f_group(igroup)%f_rmass(1)) / & + (carma%f_group(igroup)%f_rmass(2)-carma%f_group(igroup)%f_rmass(1)) + carma%f_palr(3,igroup) = & + (carma%f_group(igroup)%f_rmassup(carma%f_NBIN-1)-carma%f_group(igroup)%f_rmass(carma%f_NBIN-1)) & + / (carma%f_group(igroup)%f_rmass(carma%f_NBIN)-carma%f_group(igroup)%f_rmass(carma%f_NBIN-1)) + carma%f_palr(4,igroup) = & + (carma%f_group(igroup)%f_rmassup(carma%f_NBIN)-carma%f_group(igroup)%f_rmass(carma%f_NBIN-1)) & + / (carma%f_group(igroup)%f_rmass(carma%f_NBIN)-carma%f_group(igroup)%f_rmass(carma%f_NBIN-1)) + endif + end do + + + ! Check the nucleation mapping. + ! + ! NOTE: This code was moved from setupnuc, because it is not dependent on the model's + ! state. A small part of setupnuc which deals with scrit is state specific, and that was + ! left in setupnuc. + + ! Bin mapping for nucleation : nucleation would transfer mass from particles + ! in into target bin in group + ! . The target bin is the smallest bin in the target size grid with + ! mass exceeding that of nucleated particle. + do igfrom = 1,carma%f_NGROUP ! nucleation source group + do igto = 1,carma%f_NGROUP ! nucleation target group + do ifrom = 1,carma%f_NBIN ! nucleation source bin + + carma%f_inuc2bin(ifrom,igfrom,igto) = 0 + + do ibto = carma%f_NBIN,1,-1 ! nucleation target bin + + if( carma%f_group(igto)%f_rmass(ibto) .ge. carma%f_group(igfrom)%f_rmass(ifrom) )then + carma%f_inuc2bin(ifrom,igfrom,igto) = ibto + endif + enddo + enddo + enddo + enddo + + ! Mappings for nucleation sources: + ! + ! is the number of particle elements that nucleate to + ! particle element . + ! + ! are the particle elements that + ! nucleate to particle element , where + ! jefrom = 1,nnucelem(ielem). + ! + ! is true if nucleation transfers mass from element + ! to element . + ! + ! is the number of particle bins that nucleate + ! to particles in bin from group . + ! + ! are the particle bins + ! that nucleate to particles in bin , where + ! jfrom = 1,nnucbin(igfrom,ibin,igto). + ! + ! + ! First, calculate and + ! based on + do iefrom = 1,carma%f_NELEM + do ieto = 1,carma%f_NELEM + carma%f_if_nuc(iefrom,ieto) = .false. + enddo + enddo + + do ielem = 1,carma%f_NELEM + carma%f_nnuc2elem(ielem) = 0 + + do jefrom = 1,carma%f_NGROUP + if( carma%f_inuc2elem(jefrom,ielem) .ne. 0 ) then + carma%f_nnuc2elem(ielem) = carma%f_nnuc2elem(ielem) + 1 + carma%f_if_nuc(ielem,carma%f_inuc2elem(jefrom,ielem)) = .true. + + + ! Also check for cases where neither the source or destinaton don't have cores (e.g. + ! melting ice to water drops). + if ((carma%f_group(carma%f_element(ielem)%f_igroup)%f_ncore .eq. 0) .and. & + (carma%f_group(carma%f_element(carma%f_inuc2elem(jefrom,ielem))%f_igroup)%f_ncore .eq. 0)) then + + ! For particle concentration target elements, only count source elements + ! that are also particle concentrations. + carma%f_nnucelem(carma%f_inuc2elem(jefrom,ielem)) = carma%f_nnucelem(carma%f_inuc2elem(jefrom,ielem)) + 1 + carma%f_inucelem(carma%f_nnucelem(carma%f_inuc2elem(jefrom,ielem)),carma%f_inuc2elem(jefrom,ielem)) = ielem + end if + endif + enddo + enddo + + ! Next, enumerate and count elements that nucleate to cores. + do igroup = 1,carma%f_NGROUP + + ip = carma%f_group(igroup)%f_ienconc ! target particle number concentration element + + do jcore = 1,carma%f_group(igroup)%f_ncore + + iecore = carma%f_group(igroup)%f_icorelem(jcore) ! target core element +! carma%f_nnucelem(iecore) = 0 + + do iefrom = 1,carma%f_NELEM + + if( carma%f_if_nuc(iefrom,iecore) ) then + carma%f_nnucelem(iecore) = carma%f_nnucelem(iecore) + 1 + carma%f_inucelem(carma%f_nnucelem(iecore),iecore) = iefrom + endif + enddo ! iefrom=1,NELEM + enddo ! jcore=1,ncore + enddo ! igroup=1,NGROUP + + + ! Now enumerate and count elements nucleating to particle concentration + ! (itype=I_INVOLATILE and itype=I_VOLATILE) and core second moment + ! (itype=I_COREMASS). Elements with itype = I_VOLATILE are special because all + ! nucleation sources for core elements in same group are also sources + ! for the itype = I_VOLATILE element. + do igroup = 1,carma%f_NGROUP + + ip = carma%f_group(igroup)%f_ienconc ! target particle number concentration element + im = carma%f_group(igroup)%f_imomelem ! target core second moment element + +! carma%f_nnucelem(ip) = 0 +! if( im .ne. 0 )then +! carma%f_nnucelem(im) = 0 +! endif + + do jcore = 1,carma%f_group(igroup)%f_ncore + + iecore = carma%f_group(igroup)%f_icorelem(jcore) ! target core mass element + + do jnucelem = 1,carma%f_nnucelem(iecore) ! elements nucleating to cores + + iefrom = carma%f_inucelem(jnucelem,iecore) ! source + + ! For particle concentration target elements, only count source elements + ! that are also particle concentrations. + carma%f_nnucelem(ip) = carma%f_nnucelem(ip) + 1 + carma%f_inucelem(carma%f_nnucelem(ip),ip) = carma%f_group(carma%f_element(iefrom)%f_igroup)%f_ienconc + + if( im .ne. 0 )then + carma%f_nnucelem(im) = carma%f_nnucelem(im) + 1 + carma%f_inucelem(carma%f_nnucelem(im),im) = iefrom + endif + enddo + enddo ! jcore=1,ncore + enddo ! igroup=1,NGROUP + + + ! Now enumerate and count nucleating bins. + do igroup = 1,carma%f_NGROUP ! target group + do ibin = 1,carma%f_NBIN ! target bin + do igfrom = 1,carma%f_NGROUP ! source group + + carma%f_nnucbin(igfrom,ibin,igroup) = 0 + + do ifrom = 1,carma%f_NBIN ! source bin + + if( carma%f_inuc2bin(ifrom,igfrom,igroup) .eq. ibin ) then + carma%f_nnucbin(igfrom,ibin,igroup) = carma%f_nnucbin(igfrom,ibin,igroup) + 1 + carma%f_inucbin(carma%f_nnucbin(igfrom,ibin,igroup),igfrom,ibin,igroup) = ifrom + endif + enddo + enddo ! igfrom=1,NGROUP + enddo ! ibin=1,NBIN=1,NGROUP + enddo ! igroup=1,NGROUP + + if (carma%f_do_print_init) then + + ! Report nucleation mapping arrays (should be 'write' stmts, of course) + + write(carma%f_LUNOPRT,*) ' ' + write(carma%f_LUNOPRT,*) 'Nucleation mapping arrays (setupnuc):' + write(carma%f_LUNOPRT,*) ' ' + write(carma%f_LUNOPRT,*) 'Elements mapping:' + + do ielem = 1,carma%f_NELEM + write(carma%f_LUNOPRT,*) 'ielem,nnucelem=',ielem,carma%f_nnucelem(ielem) + + if(carma%f_nnucelem(ielem) .gt. 0) then + do jfrom = 1,carma%f_nnucelem(ielem) + write(carma%f_LUNOPRT,*) 'jfrom,inucelem= ',jfrom,carma%f_inucelem(jfrom,ielem) + enddo + endif + enddo + + write(carma%f_LUNOPRT,*) ' ' + write(carma%f_LUNOPRT,*) 'Bin mapping:' + + do igfrom = 1,carma%f_NGROUP + do igroup = 1,carma%f_NGROUP + write(carma%f_LUNOPRT,*) ' ' + write(carma%f_LUNOPRT,*) 'Groups (from, to) = ', igfrom, igroup + + do ibin = 1,carma%f_NBIN + nnucb = carma%f_nnucbin(igfrom,ibin,igroup) + if(nnucb .eq. 0) write(carma%f_LUNOPRT,*) ' None for bin ',ibin + if(nnucb .gt. 0) then + write(carma%f_LUNOPRT,*) ' ibin,nnucbin=',ibin,nnucb + write(carma%f_LUNOPRT,*) ' inucbin=',(carma%f_inucbin(j,igfrom,ibin,igroup),j=1,nnucb) + endif + enddo + enddo + enddo + endif + + + ! Check that values are valid. + do ielem = 1, carma%f_NELEM + + if( carma%f_element(ielem)%f_isolute .gt. carma%f_NSOLUTE )then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - component of isolute > NSOLUTE' + rc = RC_ERROR + return + endif + + if( carma%f_ievp2elem(ielem) .gt. carma%f_NELEM )then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - component of ievp2elem > NELEM' + rc = RC_ERROR + return + endif + + ! Check that is consistent with . + if( carma%f_ievp2elem(ielem) .ne. 0 .and. carma%f_element(ielem)%f_itype .eq. I_COREMASS )then + if( carma%f_element(ielem)%f_isolute .ne. carma%f_element(carma%f_ievp2elem(ielem))%f_isolute)then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - isolute and ievp2elem are inconsistent' + rc = RC_ERROR + return + endif + endif + + ! Check that is consistent with . +! igas = carma%f_inucgas( carma%f_element(ielem)%f_igroup ) +! if( igas .ne. 0 )then +! if( carma%f_element(ielem)%f_itype .eq. I_COREMASS .and. carma%f_element(ielem)%f_isolute .eq. 0 )then +! if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - inucgas ne 0 but isolute eq 0' +! rc = RC_ERROR +! return +! endif +! endif + enddo + + do ielem = 1, carma%f_NELEM + if( carma%f_nnuc2elem(ielem) .gt. 0 ) then + do inuc2 = 1, carma%f_nnuc2elem(ielem) + if( carma%f_inuc2elem(inuc2,ielem) .gt. carma%f_NELEM )then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - component of inuc2elem > NELEM' + rc = RC_ERROR + return + endif + enddo + endif + enddo + + ! Particle grids are incompatible if there is no target bin with enough + ! mass to accomodate nucleated particle. + bad_grid = .false. + + do iefrom = 1,carma%f_NELEM ! source element + + igfrom = carma%f_element(iefrom)%f_igroup + neto = carma%f_nnuc2elem(iefrom) + + if( neto .gt. 0 )then + + do inuc2 = 1,neto + ieto = carma%f_inuc2elem(inuc2,iefrom) + igto = carma%f_element(ieto)%f_igroup + + do ifrom = 1,carma%f_NBIN ! source bin + if( carma%f_inuc2bin(ifrom,igfrom,igto) .eq. 0 )then + if ((carma%f_do_print) .and. (carma%f_do_print_init)) write(carma%f_LUNOPRT,7) igfrom,ifrom,igto + bad_grid = .true. + endif + enddo + enddo + endif + enddo + + if (carma%f_do_print_init) then + + if( bad_grid )then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::Warning - incompatible grids for nucleation' + endif + + ! Report some initialization values! + write(carma%f_LUNOPRT,5) + write(carma%f_LUNOPRT,1) 'inucgas ',(carma%f_inucgas(i),i=1,carma%f_NGROUP) + write(carma%f_LUNOPRT,1) 'inuc2elem',(carma%f_inuc2elem(1,i),i=1,carma%f_NELEM) + write(carma%f_LUNOPRT,1) 'ievp2elem',(carma%f_ievp2elem(i),i=1,carma%f_NELEM) + write(carma%f_LUNOPRT,1) 'isolute ',(carma%f_element(i)%f_isolute,i=1,carma%f_NELEM) + + do isol = 1,carma%f_NSOLUTE + write(carma%f_LUNOPRT,2) 'solute number ',isol + write(carma%f_LUNOPRT,3) 'solute name: ',carma%f_solute(isol)%f_name + write(carma%f_LUNOPRT,4) 'molecular weight',carma%f_solute(isol)%f_wtmol + write(carma%f_LUNOPRT,4) 'mass density ',carma%f_solute(isol)%f_rho + enddo + endif + + + ! Initialize indexes for the gases and check to make sure if H2SO4 is used + ! that it occurs after H2O. This is necessary for supersaturation calculations. + carma%f_igash2o = 0 + carma%f_igash2so4 = 0 + carma%f_igasso2 = 0 + + do igas = 1, carma%f_NGAS + if (carma%f_gas(igas)%f_icomposition == I_GCOMP_H2O) then + carma%f_igash2o = igas + else if (carma%f_gas(igas)%f_icomposition == I_GCOMP_H2SO4) then + carma%f_igash2so4 = igas + else if (carma%f_gas(igas)%f_icomposition == I_GCOMP_SO2) then + carma%f_igasso2 = igas + end if + end do + + if ((carma%f_igash2so4 /= 0) .and. (carma%f_igash2o > carma%f_igash2so4)) then + if (carma%f_do_print) write(carma%f_LUNOPRT,*) 'CARMA_InitializeGrowth::ERROR - H2O gas must come before H2SO4.' + rc = RC_ERROR + return + end if + + return + end subroutine CARMA_InitializeGrowth + + !! Calculate the optical properties for each particle bin at each of + !! the specified wavelengths. The optical properties include the + !! extinction efficiency, the single scattering albedo and the + !! asymmetry factor. + !! + !! NOTE: For these calculations, the particles are assumed to be spheres and + !! Mie code is used to calculate the optical properties. + !! + !! @author Chuck Bardeen + !! @version May-2009 + subroutine CARMA_InitializeOptics(carma, rc) + type(carma_type), intent(inout) :: carma + integer, intent(out) :: rc + + integer :: igroup ! group index + integer :: iwave ! wavelength index + integer :: ibin ! bin index + real(kind=f) :: Qext + real(kind=f) :: Qsca + real(kind=f) :: asym + + + ! Assume success. + rc = RC_OK + + ! Were any wavelengths specified? + do iwave = 1, carma%f_NWAVE + do igroup = 1, carma%f_NGROUP + + ! Should we calculate mie properties for this group? + if (carma%f_group(igroup)%f_do_mie) then + + do ibin = 1, carma%f_NBIN + + ! Assume the particle is homogeneous (no core). + ! + ! NOTE: The miess does not converge over as broad a + ! range of input parameters as bhmie, but it can handle + ! coated spheres. + + call mie(carma, & + carma%f_group(igroup)%f_imiertn, & + carma%f_group(igroup)%f_r(ibin), & + carma%f_wave(iwave), & + carma%f_group(igroup)%f_nmon(ibin), & + carma%f_group(igroup)%f_df(ibin), & + carma%f_group(igroup)%f_rmon, & + carma%f_group(igroup)%f_falpha, & + carma%f_group(igroup)%f_refidx(iwave), & + Qext, & + Qsca, & + asym, & + rc) + + if (rc < RC_OK) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "CARMA_InitializeOptics::& + &Mie failed for (band, wavelength, group, bin)", & + iwave, carma%f_wave(iwave), igroup, ibin + end if + return + end if + + carma%f_group(igroup)%f_qext(iwave, ibin) = Qext + carma%f_group(igroup)%f_ssa(iwave, ibin) = Qsca / Qext + carma%f_group(igroup)%f_asym(iwave, ibin) = asym + + end do + end if + end do + end do + + return + end subroutine CARMA_InitializeOptics + + !! Perform initialization of variables related to thermodynamical calculations that + !! are not dependent on the model state. + !! + !! @author Chuck Bardeen + !! @version May-2009 + subroutine CARMA_InitializeThermo(carma, rc) + type(carma_type), intent(inout) :: carma + integer, intent(out) :: rc + + ! Assume success. + rc = RC_OK + + return + end subroutine CARMA_InitializeThermo + + !! Perform initialization of variables related to vertical transport that are not dependent + !! on the model state. + !! + !! @author Chuck Bardeen + !! @version May-2009 + subroutine CARMA_InitializeVertical(carma, rc, vf_const) + type(carma_type), intent(inout) :: carma + integer, intent(out) :: rc + real(kind=f), intent(in), optional :: vf_const + + ! Assume success. + rc = RC_OK + + ! Was a constant vertical velocity specified? + carma%f_ifall = 1 + carma%f_vf_const = 0._f + + if (present(vf_const)) then + if (vf_const /= 0._f) then + carma%f_ifall = 0 + carma%f_vf_const = vf_const + end if + end if + + ! Specify the boundary conditions for vertical transport. + carma%f_itbnd_pc = I_FIXED_CONC + carma%f_ibbnd_pc = I_FIXED_CONC + + return + end subroutine CARMA_InitializeVertical + + !! The routine should be called when the carma object is no longer needed. It deallocates + !! any memory allocations made by CARMA (during CARMA_Create()), and failure to call this + !!routine could result in memory leaks. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMA_Create + subroutine CARMA_Destroy(carma, rc) + use carmaelement_mod + use carmagas_mod + use carmagroup_mod + use carmasolute_mod + + type(carma_type), intent(inout) :: carma + integer, intent(out) :: rc + + ! Local variables + integer :: ier + integer :: igroup + integer :: ielem + integer :: isolute + integer :: igas + + ! Assume success. + rc = RC_OK + + ! If allocated, deallocate all the variables that were allocated in the Create() method. + if (allocated(carma%f_group)) then + do igroup = 1, carma%f_NGROUP + call CARMAGROUP_Destroy(carma, igroup, rc) + if (rc < 0) return + end do + + deallocate( & + carma%f_group, & + carma%f_icoag, & + carma%f_inucgas, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating groups, status=", ier + rc = RC_ERROR + endif + endif + + if (allocated(carma%f_element)) then + do ielem = 1, carma%f_NELEM + call CARMAELEMENT_Destroy(carma, ielem, rc) + if (rc < RC_OK) return + end do + + deallocate( & + carma%f_element, & + carma%f_igrowgas, & + carma%f_inuc2elem, & + carma%f_inucproc, & + carma%f_ievp2elem, & + carma%f_nnuc2elem, & + carma%f_nnucelem, & + carma%f_inucelem, & + carma%f_if_nuc, & + carma%f_rlh_nuc, & + carma%f_icoagelem, & + carma%f_icoagelem_cm, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating elements, status=", ier + rc = RC_ERROR + endif + endif + + if (allocated(carma%f_inuc2bin)) then + deallocate( & + carma%f_inuc2bin, & + carma%f_ievp2bin, & + carma%f_nnucbin, & + carma%f_inucbin, & + carma%f_diffmass, & + carma%f_volx, & + carma%f_ilow, & + carma%f_jlow, & + carma%f_iup, & + carma%f_jup, & + carma%f_npairl, & + carma%f_npairu, & + carma%f_iglow, & + carma%f_jglow, & + carma%f_igup, & + carma%f_jgup, & + carma%f_kbin, & + carma%f_pkernel, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating bins, status=", ier + rc = RC_ERROR + endif + endif + + if (carma%f_NSOLUTE > 0) then + do isolute = 1, carma%f_NSOLUTE + call CARMASOLUTE_Destroy(carma, isolute, rc) + if (rc < RC_OK) return + end do + + if (allocated(carma%f_solute)) then + deallocate( & + carma%f_solute, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating solutes, status=", ier + rc = RC_ERROR + endif + endif + end if + + if (carma%f_NGAS > 0) then + do igas = 1, carma%f_NGAS + call CARMAGAS_Destroy(carma, igas, rc) + if (rc < RC_OK) return + end do + + if (allocated(carma%f_gas)) then + deallocate( & + carma%f_gas, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating gases, status=", ier + rc = RC_ERROR + endif + endif + end if + + if (carma%f_NWAVE > 0) then + if (allocated(carma%f_wave)) then + deallocate( & + carma%f_wave, & + carma%f_dwave, & + carma%f_do_wave_emit, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_Destroy: ERROR deallocating wavelengths, status=", ier + rc = RC_ERROR + return + endif + endif + endif + + return + end subroutine CARMA_Destroy + + ! Configuration + + !! Add a coagulation process between two groups (igroup1 and igroup2), with the resulting + !! particle being in the destination group (igroup3). If ck0 is specifed, then a constant + !! coagulation kernel will be used. + subroutine CARMA_AddCoagulation(carma, igroup1, igroup2, igroup3, icollec, rc, ck0, grav_e_coll0) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igroup1 !! first source group + integer, intent(in) :: igroup2 !! second source group + integer, intent(in) :: igroup3 !! destination group + integer, intent(in) :: icollec !! collection technique [I_COLLEC_CONST | I_COLLEC_FUCHS | I_COLLEC_DATA] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), intent(in), optional :: ck0 !! if specified, forces a constant coagulation kernel + real(kind=f), intent(in), optional :: grav_e_coll0 !! if icollec is I_COLLEC_CONST + !! the constant gravitational collection efficiency + + ! Assume success. + rc = RC_OK + + ! Make sure the groups exists. + if (igroup1 > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, '(a,i3,a,i3,a)') "CARMA_AddCoagulation:: ERROR - The specifed group (", & + igroup1, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + if (igroup2 > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, '(a,i3,a,i3,a)') "CARMA_AddCoagulation:: ERROR - The specifed group (", & + igroup2, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + if (igroup3 > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, '(a,i3,a,i3,a)') "CARMA_AddCoagulation:: ERROR - The specifed group (", & + igroup3, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + ! Indicate that the groups coagulate together. + carma%f_icoag(igroup1, igroup2) = igroup3 + + ! If ck0 was specified, then we use a fixed coagulation rate of ck0. + if (present(ck0)) then + carma%f_ck0 = ck0 + carma%f_icoagop = I_COAGOP_CONST + else + carma%f_icoagop = I_COAGOP_CALC + end if + + ! What collection technique is specified. + if (icollec > I_COLLEC_DATA) then + if (carma%f_do_print) write(carma%f_LUNOPRT, '(a,i3,a)') "CARMA_AddCoagulation:: ERROR - The specifed collection method (", & + icollec, ") is unknown." + rc = RC_ERROR + return + end if + + if (icollec == I_COLLEC_CONST) then + if (present(grav_e_coll0)) then + carma%f_grav_e_coll0 = grav_e_coll0 + else + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "CARMA_AddCoagulation::& + &ERROR - A constant gravitational collection was requests, & + &but grav_e_coll0 was not provided." + end if + rc = RC_ERROR + return + end if + end if + + carma%f_icollec = icollec + + return + end subroutine CARMA_AddCoagulation + + !! Add a growth process between the element (ielem) and gas (igas) specifed. The element + !! and gas should have already been defined using CARMA_AddElement() and CARMA_AddGas(). + !! + !! NOTE: Each element can only have one volatile component. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMA_AddElement + !! @see CARMA_AddGas + subroutine CARMA_AddGrowth(carma, ielem, igas, rc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: ielem !! the element index + integer, intent(in) :: igas !! the gas index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Assume success. + rc = RC_OK + + ! Make sure the element exists. + if (ielem > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddGrowth:: ERROR - The specifed element (", & + ielem, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough gases allocated. + if (igas > carma%f_NGAS) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddGrowth:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + ! If not already defined, indicate that the element can grow with the specified gas. + if (carma%f_igrowgas(ielem) /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddGrowth:: ERROR - The specifed element (", & + ielem, ") already has gas (", carma%f_igrowgas(ielem), ") condensing on it." + rc = RC_ERROR + return + else + carma%f_igrowgas(ielem) = igas + end if + + return + end subroutine CARMA_AddGrowth + + !! Add a nucleation process that nucleates one element (elemfrom) to another element (elemto) + !! using the specified gas (igas). The elements and gas should have already been defined + !! using CARMA_AddElement() and CARMA_AddGas(). The nucleation scheme is indicated by + !! inucproc, and can be one of: + !! + !! - I_DROPACT + !! - I_AERFREEZE + !! - I_DROPFREEZE + !! - I_ICEMELT + !! - I_HETNUC + !! - I_HOMNUC + !! + !! There are multiple parameterizations for I_AERFREEZE, so when that is selected the + !! particular parameterization needs to be indicated by adding it to I_AERFREEZE. The + !! specific routines are: + !! + !! - I_AF_TABAZADEH_2000 + !! - I_AF_KOOP_2000 + !! - I_AF_MOHLER_2010 + !! - I_AF_MURRAY_2010 + !! + !! One or more of these routines may be selected, but in general one of the first + !! three should be selected and then it can optionally be combined with the glassy + !! aerosols (I_AF_MURRAY_2010). + !! + !! Total evaporation transfers particle mass from the destination element back to the + !! element indicated by ievp2elem. This relationship is not automatically generated, + !! because multiple elements can nucleate to a particular element and therefore the + !! reverse mapping is not unique. + !! + !! NOTE: The gas used for nucleation must be the same for all nucleation defined from + !! elements of the same group. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see I_DROPACT + !! @see I_AERFREEZE + !! @see I_DROPFREEZE + !! @see I_ICEMELT + !! @see I_HETNUC + !! @see I_HOMNUC + !! @see I_AF_TABAZADEH_2000 + !! @see I_AF_KOOP_2000 + !! @see I_AF_MOHLER_2010 + !! @see I_AF_MURRAY_2010 + !! @see CARMA_AddElement + !! @see CARMA_AddGas + subroutine CARMA_AddNucleation(carma, ielemfrom, ielemto, inucproc, & + rlh_nuc, rc, igas, ievp2elem) + + use carmaelement_mod, only : CARMAELEMENT_Get + + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: ielemfrom !! the source element + integer, intent(in) :: ielemto !! the destination element + integer, intent(in) :: inucproc !! the nucleation process + !! [I_DROPACT | I_AERFREEZE | I_ICEMELT | I_HETNUC | I_HOMNUC] + real(kind=f), intent(in) :: rlh_nuc !! the latent heat of nucleation [cm2/s2] + integer, intent(out) :: rc !! return code, negative indicated failure + integer, optional, intent(in) :: igas !! the gas + integer, optional, intent(in) :: ievp2elem !! the element created upon evaporation + + integer :: igroup !! group for source element + + ! Assume success. + rc = RC_OK + + ! Make sure the elements exist. + if (ielemfrom > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddNucleation:: ERROR - The specifed element (", & + ielemfrom, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + if (ielemto > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddNucleation:: ERROR - The specifed element (", & + ielemto, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + if (present(ievp2elem)) then + if (ievp2elem > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddNucleation:: ERROR - The specifed element (", & + ievp2elem, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + end if + + + ! Make sure there are enough gases allocated. + if (present(igas)) then + if (igas > carma%f_NGAS) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMA_AddNucleation:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + end if + + + ! If aerosol freezing is selected, but no I_AF_xxx sub-method is selected, then indicate an error. + if (inucproc == I_AERFREEZE) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "CARMA_AddNucleation::& + &ERROR - I_AERFREEZE was specified without an I_AF_xxx value." + end if + return + end if + + + ! Array maps a particle group to its associated gas for nucleation: + ! Nucleation from group is associated with gas + ! Set to zero if particles are not subject to nucleation. + if (present(igas)) then + call CARMAELEMENT_Get(carma, ielemfrom, rc, igroup=igroup) + + if (rc >= RC_OK) then + carma%f_inucgas(igroup) = igas + end if + end if + + + ! Nucleation transfers particle mass from element to element + ! , where ranges from 0 to the number of elements + ! nucleating from . +! carma%f_nnucelem(ielemto) = carma%f_nnucelem(ielemto) + 1 +! carma%f_inucelem(carma%f_nnucelem(ielemto), ielemto) = ielemfrom + carma%f_nnuc2elem(ielemfrom) = carma%f_nnuc2elem(ielemfrom) + 1 + carma%f_inuc2elem(carma%f_nnuc2elem(ielemfrom), ielemfrom) = ielemto +! carma%f_if_nuc(ielemfrom,carma%f_inuc2elem(carma%f_nnuc2elem(ielemfrom), ielemfrom)) = .true. + + ! specifies what nucleation process nucleates + ! particles from element to element : + ! I_DROPACT: Aerosol activation to droplets + ! I_AERFREEZE: Aerosol homogeneous freezing + ! I_DROPFREEZE: Droplet homogeneous freezing + ! I_GLFREEZE: Glassy Aerosol heteroogeneous freezing + ! I_GLAERFREEZE: Glassy & Aerosol freezing + carma%f_inucproc(ielemfrom, ielemto) = inucproc + + + ! Total evaporation mapping: total evaporation transfers particle mass from + ! element to element . + ! + ! NOTE: This array is not automatically derived from because multiple + ! elements can nucleate to a particular element (reverse mapping is not + ! unique). + if (present(ievp2elem)) carma%f_ievp2elem(ielemto) = ievp2elem + + + ! is the latent heat released by nucleation + ! from element to element [cm^2/s^2]. + carma%f_rlh_nuc(ielemfrom,ielemto) = rlh_nuc + + return + end subroutine + + + ! Query, Control and State I/O + + !! Gets the information about the carma object. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMA_Create + subroutine CARMA_Get(carma, rc, LUNOPRT, NBIN, NELEM, NGAS, NGROUP, NSOLUTE, NWAVE, do_detrain, & + do_drydep, do_fixedinit, do_grow, do_print, do_print_init, do_thermo, wave, dwave, do_wave_emit, & + do_partialinit) + + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(out) :: rc !! return code, negative indicates failure + integer, optional, intent(out) :: NBIN !! number of radius bins per group + integer, optional, intent(out) :: NELEM !! total number of elements + integer, optional, intent(out) :: NGROUP !! total number of groups + integer, optional, intent(out) :: NSOLUTE !! total number of solutes + integer, optional, intent(out) :: NGAS !! total number of gases + integer, optional, intent(out) :: NWAVE !! number of wavelengths + integer, optional, intent(out) :: LUNOPRT !! logical unit number for output + logical, optional, intent(out) :: do_detrain !! do detrainement? + logical, optional, intent(out) :: do_drydep !! do dry deposition? + logical, optional, intent(out) :: do_fixedinit !! do initialization from reference atm? + logical, optional, intent(out) :: do_grow !! do condensational growth? + logical, optional, intent(out) :: do_partialinit !! do initialization of coagulation from reference atm? + logical, optional, intent(out) :: do_print !! do print output? + logical, optional, intent(out) :: do_print_init !! do print initialization output? + logical, optional, intent(out) :: do_thermo !! do thermodynamics? + real(kind=f), optional, intent(out) :: wave(carma%f_NWAVE) !! the wavelengths centers (cm) + real(kind=f), optional, intent(out) :: dwave(carma%f_NWAVE) !! the wavelengths widths (cm) + logical, optional, intent(out) :: do_wave_emit(carma%f_NWAVE) !! do emission in this band? + + ! Assume success. + rc = RC_OK + + if (present(LUNOPRT)) LUNOPRT = carma%f_LUNOPRT + if (present(NBIN)) NBIN = carma%f_NBIN + if (present(NELEM)) NELEM = carma%f_NELEM + if (present(NGAS)) NGAS = carma%f_NGAS + if (present(NGROUP)) NGROUP = carma%f_NGROUP + if (present(NSOLUTE)) NSOLUTE = carma%f_NSOLUTE + if (present(NWAVE)) NWAVE = carma%f_NWAVE + + if (present(do_detrain)) do_detrain = carma%f_do_detrain + if (present(do_drydep)) do_drydep = carma%f_do_drydep + if (present(do_grow)) do_grow = carma%f_do_grow + if (present(do_fixedinit)) do_fixedinit = carma%f_do_fixedinit + if (present(do_partialinit)) do_partialinit = carma%f_do_partialinit + if (present(do_print)) do_print = carma%f_do_print + if (present(do_print_init)) do_print_init = carma%f_do_print_init + if (present(do_thermo)) do_thermo = carma%f_do_thermo + + if (present(wave)) wave(:) = carma%f_wave(:) + if (present(dwave)) dwave(:) = carma%f_dwave(:) + if (present(do_wave_emit)) do_wave_emit(:) = carma%f_do_wave_emit(:) + + return + end subroutine CARMA_Get + +end module diff --git a/src/physics/carma/base/carma_precision_mod.F90 b/src/physics/carma/base/carma_precision_mod.F90 new file mode 100644 index 0000000000..a8835982c7 --- /dev/null +++ b/src/physics/carma/base/carma_precision_mod.F90 @@ -0,0 +1,47 @@ +module carma_precision_mod + + implicit none + +#ifdef SINGLE + + ! For floats commonly referred to as 'real' + ! -at least 6 places of precision past the decimal + ! -must span at least 10**(-37) to 10**(37) + integer, parameter :: f = selected_real_kind(6,37) + real(kind=f), parameter :: powmax = 85._f + +#else + + ! For floats commonly referred to as 'double precision' + ! -at least 15 places of precision past the decimal + ! -must span at least 10**(-307) to 10**(307) + + integer, parameter :: f = selected_real_kind(15,307) + real(kind=f), parameter :: powmax = 706._f + +#endif + + ! Precision control strategy + ! JAS CU-Boulder June 8, 2006 + ! + ! I imagine using these statements bracketed with some CPP statements + ! to control the overall precision of a model. All variables would be + ! declared as real(f). All physical constants would have a + ! a suffix of _f, e.g. 2._f, to force them into the proper precision. + ! + ! I do wonder if it would be more accurate to declare variables as + ! real( kind=f ), but real(f) is how Chivers and Sleightholme + ! declare in their F90 text. + ! + ! Both real(f) and real( kind=f ) seem to work, but I'm more comfortable + ! with real( kind=f ), so I'm using that in all declarations. + + !-- + ! Numerical constants + !! Define 1 in the specified precision. + real(kind=f), parameter :: ONE = 1._f + + !! Define smallest possible number such that ONE + ALMOST_ZERO > ONE + real(kind=f), parameter :: ALMOST_ZERO = epsilon( ONE ) + real(kind=f), parameter :: ALMOST_ONE = ONE - ALMOST_ZERO +end module diff --git a/src/physics/carma/base/carma_types_mod.F90 b/src/physics/carma/base/carma_types_mod.F90 new file mode 100644 index 0000000000..d264e627a8 --- /dev/null +++ b/src/physics/carma/base/carma_types_mod.F90 @@ -0,0 +1,820 @@ +!! This module defines types used in the CARMA module. The types need to be defined here +!! to avoid circular references between different modules (e.g. carma_mod and +!! carmastate_mod). +!! +!! NOTE: All the field members are prefixed by f_. This is done because of the macros that +!! are used to map between the older F77 common block names for variables to the newer F90 +!! structure member names for the fields. This is done in carma_globaer.h to keep the core +!! CARMA code looking similar to the F77 code to make it easier for scientists with CARMA +!! experience to port their code. Some compilers (e.g Portland Group) have preprocessors +!! that will fail to handle the macros in carma_globaer.h properly resulting in recursion +!! errors during compiling. By making the field member name different, the recursion +!! problems should be avoided. +!! +!! @version July-2009 +!! @author Chuck Bardeen +module carma_types_mod + use carma_precision_mod + use carma_constants_mod + + !! The CARMAELEMENT data type represents one of the components of a cloud or aerosol particle. + !! + !! The procedure for adding a variable to the CARMAELEMENT data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the appropriate create or initialization routine. + !! - Deallocate the variable in the approprate finalize and destroy routines. + !! - Add an alias for the variable to carma_globaer.h and associate it with the variable + !! in this typedef. + !! + !! NOTE: While the carmaelement_type is public, routines outside of the CARMA module should not look + !! at or manuipulate fields of this structure directly. There should be CARMAELEMENT_XXX methods + !! to do anything that is needed with this structure, and use of these methods will allow + !! the CARMAELEMENT data type structure to evolve without impacting code in the parent model. + !! The contents of the structure had to be made public, since the CARMA microphysics + !! routines are implemented in separate files outside of this model; however, logically + !! they are part of the model and are the only routines outside of this module that should + !! access fields of this structure directly. + type, public :: carmaelement_type + + ! name Name of the element + ! shortname Short name of the element + ! rho Mass density of particle element [g/cm^3] + ! igroup Group to which the element belongs + ! itype Particle type specification + ! icomposition Particle compound specification + ! isolute Index of solute for the particle element + ! + character(len=CARMA_NAME_LEN) :: f_name + character(len=CARMA_SHORT_NAME_LEN) :: f_shortname + real(kind=f), allocatable, dimension(:) :: f_rho ! (NBIN) + integer :: f_igroup + integer :: f_itype + integer :: f_icomposition + integer :: f_isolute + end type carmaelement_type + + + !! The CARMAGAS data type represents a gas. + !! + !! The procedure for adding a variable to the CARMAGAS data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the appropriate create or initialization routine. + !! - Deallocate the variable in the approprate finalize and destroy routines. + !! - Add an alias for the variable to carma_globaer.h and associate it with the variable + !! in this typedef. + !! + !! NOTE: While the carmagas_type is public, routines outside of the CARMA module should not look + !! at or manuipulate fields of this structure directly. There should be CARMAGAS_XXX methods + !! to do anything that is needed with this structure, and use of these methods will allow + !! the CARMAGAS data type structure to evolve without impacting code in the parent model. + !! The contents of the structure had to be made public, since the CARMA microphysics + !! routines are implemented in separate files outside of this model; however, logically + !! they are part of the model and are the only routines outside of this module that should + !! access fields of this structure directly. + type, public :: carmagas_type + + ! name Name of the gas + ! shortname Short name of the gas + ! wtmol Molecular weight for the gas [g/mol] + ! ivaprtn vapor pressure routine for the gas + ! dgc_threshold convergence criteria for gas concentration [fraction] + ! ds_threshold convergence criteria for gas saturation [fraction] + ! + character(len=CARMA_NAME_LEN) :: f_name + character(len=CARMA_SHORT_NAME_LEN) :: f_shortname + real(kind=f) :: f_wtmol + integer :: f_ivaprtn + integer :: f_icomposition + real(kind=f) :: f_dgc_threshold + real(kind=f) :: f_ds_threshold + end type carmagas_type + + + !! The CARMAGROUP data type represents a cloud or aerosol partcile. + !! + !! The procedure for adding a variable to the CARMAGROUP data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the appropriate create or initialization routine. + !! - Deallocate the variable in the approprate finalize and destroy routines. + !! - Add an alias for the variable to carma_globaer.h and associate it with the variable + !! in this typedef. + !! + !! NOTE: While the carmagroup_type is public, routines outside of the CARMA module should not look + !! at or manuipulate fields of this structure directly. There should be CARMAGROUP_XXX methods + !! to do anything that is needed with this structure, and use of these methods will allow + !! the CARMAGROUP data type structure to evolve without impacting code in the parent model. + !! The contents of the structure had to be made public, since the CARMA microphysics + !! routines are implemented in separate files outside of this model; however, logically + !! they are part of the model and are the only routines outside of this module that should + !! access fields of this structure directly. + type, public :: carmagroup_type + + ! name Name of the particle + ! shortname Short name of the particle + ! cnsttype constituent type [I_CNSTTYPE_PROGNOSTIC | I_CNSTTYPE_DIAGNOSTIC] + ! maxbin the last prognostic bin in the group + ! nelem Number of elements in group + ! ncore Number of core elements (itype = 2) in group + ! ishape Describes particle shape for group + ! ienconc Particle number conc. element for group + ! imomelem Scondary moment element for group + ! icorelem Core elements (itype = 2) in group + ! solfac Solubility factor for wet deposition + ! is_fractal If .true. then particle is fractal + ! is_ice If .true. then ice particle + ! is_cloud If .true. then cloud particle + ! is_sulfate If .true. then sulfate particle + ! do_mie If .true. then do mie calculations + ! do_wetdep If .true. then do wet deposition + ! grp_do_drydep If .true. then do dry deposition + ! grp_do_vtran If .true. then do sedimentation + ! scavcoef Scavenging coefficient for wet deopistion (1/mm) + ! if_sec_mom If .true. then core second moment (itype = 3) used {setupgrow} + ! irhswell Indicates method for swelling particles from RH + ! irhswcomp Indicates composition for swelling particles from RH + ! rmin Radius of particle in first bin [cm] + ! rmassmin Mass of particle in first bin [g] + ! rmrat Ratio of masses of particles in consecutive bins + ! eshape Ratio of particle length / diameter + ! r Radius bins [cm] + ! rmass Mass bins [g] + ! rrat Ratio of maximum diameter to diameter of equivalent sphere + ! rprat Ratio of mobility diameter of a porous particle to diameter of equivlent sphere + ! arat Ratio of projected area to projected area of containing sphere + ! vol Particle volume [cm^3] + ! dr Width of bins in radius space [cm] + ! dm Width of bins in mass space [g] + ! rmassup Upper bin boundary mass [g] + ! rup Upper bin boundary radius [cm] + ! rlow Lower bin boundary radius [cm] + ! refidx refractive index + ! qext extinction efficiency + ! ssa single scattering albedo + ! asym asymmetry factor + ! ifallrtn routine to use to calculate fall velocity [I_FALLRTN_...] + ! imiertn mie routine for optical properties [I_MIERTN_...] + ! dpc_threshold convergence criteria for particle concentration [fraction] + ! rmon monomer radius of fractal particles [cm] + ! df fractal dimension for fractal particles + ! nmon number of monomers per particle + ! falpha fractal packing coefficient + ! neutral_volfrc volume fraction of core mass to neutralize the particle + + character(len=CARMA_NAME_LEN) :: f_name + character(len=CARMA_SHORT_NAME_LEN) :: f_shortname + integer :: f_cnsttype + integer :: f_maxbin + integer :: f_nelem + integer :: f_ncore + integer :: f_ishape + integer :: f_ienconc + integer :: f_imomelem + real(kind=f) :: f_solfac + real(kind=f) :: f_scavcoef + logical :: f_if_sec_mom + logical :: f_is_fractal + logical :: f_is_ice + logical :: f_is_cloud + logical :: f_is_sulfate + logical :: f_do_mie + logical :: f_do_wetdep + logical :: f_grp_do_drydep + logical :: f_grp_do_vtran + integer :: f_irhswell + integer :: f_irhswcomp + integer :: f_ifallrtn + integer :: f_imiertn + real(kind=f) :: f_rmin + real(kind=f) :: f_rmassmin + real(kind=f) :: f_rmrat + real(kind=f) :: f_eshape + real(kind=f), allocatable, dimension(:) :: f_r ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rmass ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_vol ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_dr ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_dm ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rmassup ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rup ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rlow ! (NBIN) + complex(kind=f), allocatable, dimension(:) :: f_refidx ! (NWAVE) + real(kind=f), allocatable, dimension(:,:) :: f_qext ! (NWAVE,NBIN) + real(kind=f), allocatable, dimension(:,:) :: f_ssa ! (NWAVE,NBIN) + real(kind=f), allocatable, dimension(:,:) :: f_asym ! (NWAVE,NBIN) + integer, allocatable, dimension(:) :: f_icorelem ! (NELEM) + real(kind=f), allocatable, dimension(:) :: f_arat ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rrat ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_rprat ! (NBIN) + real(kind=f) :: f_dpc_threshold + real(kind=f) :: f_rmon + real(kind=f), allocatable, dimension(:) :: f_df ! (NBIN) + real(kind=f), allocatable, dimension(:) :: f_nmon ! (NBIN) + real(kind=f) :: f_falpha + real(kind=f) :: f_neutral_volfrc + end type carmagroup_type + + + !! The CARMASOLUTE data type represents a gas. + !! + !! The procedure for adding a variable to the CARMASOLUTE data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the appropriate create or initialization routine. + !! - Deallocate the variable in the approprate finalize and destroy routines. + !! - Add an alias for the variable to carma_globaer.h and associate it with the variable + !! in this typedef. + !! + !! NOTE: While the carmagas_type is public, routines outside of the CARMA module should not look + !! at or manuipulate fields of this structure directly. There should be CARMASOLUTE_XXX methods + !! to do anything that is needed with this structure, and use of these methods will allow + !! the CARMASOLUTE data type structure to evolve without impacting code in the parent model. + !! The contents of the structure had to be made public, since the CARMA microphysics + !! routines are implemented in separate files outside of this model; however, logically + !! they are part of the model and are the only routines outside of this module that should + !! access fields of this structure directly. + type, public :: carmasolute_type + + ! name Name of the solute + ! shortname Short name of the solute + ! ions Number of ions solute dissociates into + ! wtmol Molecular weight of solute + ! rho Mass density of solute + ! + character(len=CARMA_NAME_LEN) :: f_name + character(len=CARMA_SHORT_NAME_LEN) :: f_shortname + integer :: f_ions + real(kind=f) :: f_wtmol + real(kind=f) :: f_rho + end type carmasolute_type + + + !! The CARMA data type replaces the common blocks that were used in the F77 version of + !! CARMA. This allows the code to be written to allow for multiple threads to call CARMA + !! routines simulataneously. This thread safety is necessary for to run CARMA under OPEN/MP. + !! + !! The procedure for adding a variable to the CARMA data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the appropriate create or initialization routine. + !! - Deallocate the variable in the approprate finalize and destroy routines. + !! - Add an alias for the variable to carma_globaer.h and associate it with the variable + !! in this typedef. + !! + !! NOTE: While the carmatype is public, routines outside of the CARMA module should not look + !! at or manuipulate fields of this structure directly. There should be CARMA_XXX methods + !! to do anything that is needed with this structure, and use of these methods will allow + !! the CARMA data type structure to evolve without impacting code in the parent model. + !! The contents of the structure had to be made public, since the CARMA microphysics + !! rountines are implemented in separate files outside of this model; however, logically + !! they are part of the model and are the only routines outside of this module that should + !! access fields of this structure directly. + type, public :: carma_type + + ! Model Dimensions + ! + ! NGROUP number of particle groups + ! NELEM number of particle components (elements) + ! NBIN number of size bins per element + ! NGAS number of gases (may be 0) + ! NSOLUTE number of solutes (may be 0) + ! NWAVE number of wavelength bands (may be 0) + ! + integer :: f_NGROUP + integer :: f_NELEM + integer :: f_NBIN + integer :: f_NGAS + integer :: f_NSOLUTE + integer :: f_NWAVE + + ! Output logical unit numbers + ! + ! NOTE: CARMA will not directly access files or keep track of file names. It is the + ! parent model's responsibility to provide the logical unit number to be used for + ! model output. + ! + integer :: f_LUNOPRT ! output print file + + ! Model startup control variables + ! + ! do_print .t. if print output is desired + ! + logical :: f_do_print + + + ! Configuration Objects + ! + ! These are all other objects that are parts of the CARMA model. This is + ! an attempt to break up the large common block that has historically been + ! the structure of CARMA so the code is easier to understand and to + ! maintain. + ! + ! element Particle component + ! gas Gas + ! group Particle + ! solute Element solute + ! + ! NOTE: In the future, it may make sense to create objects that represent + ! the CARMA processes. This would encapsulate all the variables related to + ! a particular process into one structure. Candidate processes include: + ! transport, growth, nucleation, coagulation, ... + ! + type(carmaelement_type), allocatable, dimension(:) :: f_element ! (NELEM) + type(carmagas_type), allocatable, dimension(:) :: f_gas ! (NGAS) + type(carmagroup_type), allocatable, dimension(:) :: f_group ! (NGROUP) + type(carmasolute_type), allocatable, dimension(:) :: f_solute ! (NSOLUTE) + + + + ! Model option & control variables + ! + ! conmax Minumum relative concentration to consider in varstep {prestep} + ! icoag Coagulation mapping array {setupcoag} + ! icoagelem Coagulation element mapping array {setupcoag} + ! icoagelem_cm Coagulation element mapping array for second mom {setupcoag} + ! ifall Fall velocity options {setupvfall} + ! icoagop Coagulation kernel options {setupckern} + ! icollec Gravitational collection options {setupckern} + ! itbnd_pc Top boundary condition flag for particles {init} + ! ibbnd_pc Bottom boundary condition flag for particles {init} + ! do_vdiff If .true. then do Brownian diffusion {init} + ! do_coag If .true. then do coagulation {init} + ! do_detrain If .true. then do detrainment {init} + ! do_drydep If .true. then do dry deposition {init} + ! do_fixedinitIf .true. then do initialize from reference atm {init} + ! do_grow If .true. then do condensational growth and evap. {init} + ! do_clearsky If .true. then do clear sky growth and coagulation {init} + ! do_incloud If .true. then do incloud growth and coagulation {init} + ! do_explised If .true. then do sedimentation with substepping {init} + ! do_partialinit If .true. then do initialize coagulation from reference atm {init} + ! do_pheat If .true. then do particle heating for growth rates {init} + ! do_pheatatm If .true. then do particle heating on atmosphere {init} + ! do_print_init If .true. then do print initializtion info {init} + ! do_step if .true. then varstepping succeeded {init} + ! do_substep if .true. then use substepping {init} + ! do_thermo if .true. then do solve thermodynamic equation {init} + ! do_vdiff If .true. then do Brownian diffusion {init} + ! do_vtran If .true. then do vertical transport {init} + ! do_cnst_rlh If .true. then uses constants for rlhe and rlhm {setupgrow} + ! igrowgas Gas that condenses into a particle element {setupgrow} + ! inucgas Gas that nucleates a particle group {setupnuc} + ! if_nuc Nucleation conditional array {setupaer} + ! inucproc Nucleation conditional array {setupaer} + ! nnuc2elem Number of elements that nucleate to element {setupnuc} + ! inuc2elem Nucleation transfers particles into element inuc2elem {setupnuc} + ! ievp2elem Total evap. transfers particles into group ievp2elem {setupnuc} + ! ievp2bin Total evap. transfers particles into bin ievp2bin {setupnuc} + ! inuc2bin Nucleation transfers particles into bin inuc2bin {setupnuc} + ! maxsubsteps Maximum number of time substeps allowed + ! minsubsteps Maximum number of time substeps allowed + ! maxretries Maximum number of substepping retries allowed + ! igash2o gas index for H2O + ! igash2so4 gas index for H2SO4 + ! igasso2 gas index for SO2 + ! dt_threshold convergence criteria for temperature [fraction] + ! cstick accommodation coefficient - coagulation + ! gsticki accommodation coefficient - growth (ice), default = 0.93 + ! gstickl accommodation coefficient - growth (liquid), default = 1.0 + ! tstick accommodation coefficient - temperature, default = 1.0 + ! + logical :: f_do_vdiff + logical :: f_do_drydep + logical :: f_do_coag + logical :: f_do_detrain + logical :: f_do_fixedinit + logical :: f_do_grow + logical :: f_do_clearsky + logical :: f_do_incloud + logical :: f_do_vtran + logical :: f_do_explised + logical :: f_do_partialinit + logical :: f_do_pheat + logical :: f_do_pheatatm + logical :: f_do_print_init + logical :: f_do_step + logical :: f_do_substep + logical :: f_do_thermo + logical :: f_do_cnst_rlh + logical, allocatable, dimension(:,:) :: f_if_nuc !(NELEM,NELEM) + real(kind=f) :: f_conmax + integer :: f_igash2o + integer :: f_igash2so4 + integer :: f_igasso2 + integer :: f_maxsubsteps + integer :: f_minsubsteps + integer :: f_maxretries + integer :: f_ifall + integer :: f_icoagop + integer :: f_icollec + integer :: f_itbnd_pc + integer :: f_ibbnd_pc + integer, allocatable, dimension(:) :: f_inucgas ! NGROUP + integer, allocatable, dimension(:) :: f_igrowgas ! NELEM + integer, allocatable, dimension(:) :: f_nnuc2elem ! NELEM + integer, allocatable, dimension(:) :: f_ievp2elem ! NELEM + integer, allocatable, dimension(:) :: f_nnucelem ! NELEM + integer, allocatable, dimension(:,:) :: f_icoag ! (NGROUP,NGROUP) + integer, allocatable, dimension(:,:) :: f_inucproc ! (NELEM,NELEM) + integer, allocatable, dimension(:,:) :: f_inuc2elem ! (NELEM,NELEM) + integer, allocatable, dimension(:,:) :: f_icoagelem ! (NELEM,NGROUP) + integer, allocatable, dimension(:,:) :: f_icoagelem_cm ! (NELEM,NGROUP) + integer, allocatable, dimension(:,:) :: f_inucelem ! (NELEM,NELEM*NGROUP) + integer, allocatable, dimension(:,:,:) :: f_inuc2bin ! (NBIN,NGROUP,NGROUP) + integer, allocatable, dimension(:,:,:) :: f_ievp2bin ! (NBIN,NGROUP,NGROUP) + integer, allocatable, dimension(:,:,:) :: f_nnucbin ! (NGROUP,NBIN,NGROUP) + integer, allocatable, dimension(:,:,:,:) :: f_inucbin ! (NBIN*NGROUP,NGROUP,NBIN,NGROUP) + real(kind=f) :: f_dt_threshold + real(kind=f) :: f_tstick + real(kind=f) :: f_gsticki + real(kind=f) :: f_gstickl + real(kind=f) :: f_cstick + + + ! Particle bin structure + ! + ! diffmass Difference between values + ! + real(kind=f), allocatable, dimension(:,:,:,:) :: f_diffmass ! (NBIN,NGROUP,NBIN,NGROUP) + + ! Coagulation kernels and bin pair mapping + ! + ! ck0 Constant coagulation kernel {setupaer} + ! grav_e_coll0 Constant value for collection effic. {setupaer} + ! volx Coagulation subdivision variable {setupcoag} + ! ilow Bin pairs for coagulation production {setupcoag} + ! jlow Bin pairs for coagulation production {setupcoag} + ! iup Bin pairs for coagulation production {setupcoag} + ! jup Bin pairs for coagulation production {setupcoag} + ! npairl Bin pair indices {setupcoag} + ! npairu Bin pair indices {setupcoag} + ! kbin lower bin for coagulation {setupcoag} + ! pkernel Coagulation production variables {setupcoag} + ! + real(kind=f) :: f_ck0 + real(kind=f) :: f_grav_e_coll0 + real(kind=f), allocatable, dimension(:,:,:,:,:) :: f_volx ! (NGROUP,NGROUP,NGROUP,NBIN,NBIN) + integer, allocatable, dimension(:,:,:) :: f_ilow ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_jlow ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_iup ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_jup ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:) :: f_npairl ! (NGROUP,NBIN) + integer, allocatable, dimension(:,:) :: f_npairu ! (NGROUP,NBIN) + integer, allocatable, dimension(:,:,:,:,:) :: f_kbin ! (NGROUP,NGROUP,NGROUP,NBIN,NBIN) + real(kind=f), allocatable, dimension(:,:,:,:,:,:) :: f_pkernel ! (NBIN,NBIN,NGROUP,NGROUP,NGROUP,6) + + ! Coagulation group pair mapping + ! + ! iglow Group pairs for coagulation production {setupcoag} + ! jglow Group pairs for coagulation production {setupcoag} + ! igup Group pairs for coagulation production {setupcoag} + ! jgup Group pairs for coagulation production {setupcoag} + ! + integer, allocatable, dimension(:,:,:) :: f_iglow ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_jglow ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_igup ! (NGROUP,NBIN,NBIN*NBIN) + integer, allocatable, dimension(:,:,:) :: f_jgup ! (NGROUP,NBIN,NBIN*NBIN) + + ! Particle fall velocities + ! + ! vf_const Constant vertical fall velocity when ifall=0 {setupaer} + ! + real(kind=f) :: f_vf_const + + + ! Condensational growth parameters + ! + ! NOTE: Some of these variables are used for storing intermediate values in + ! the calculations. They may no longer be necessary, when the code is + ! implemented as F90 and values as passed as parameters between subroutines. + ! + ! rlh_nuc Latent heat released by nucleation [cm^2/s^2] {setupaer} + ! pratt Terms in PPM advection scheme for condensation {setupgkern} + ! prat + ! pden1 + ! palr + real(kind=f), allocatable, dimension(:,:) :: f_rlh_nuc ! (NELEM,NELEM) + real(kind=f), allocatable, dimension(:,:,:) :: f_pratt ! (3,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_prat ! (4,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_pden1 ! (NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_palr ! (4,NGROUP) + + ! Optical Properties + ! wave Bin-center wavelengths [cm] + ! dwave width of radiation bands [cm] + ! do_wave_emit If true, emission should be calculated the band + ! + real(kind=f), allocatable, dimension(:) :: f_wave ! (NWAVE) + real(kind=f), allocatable, dimension(:) :: f_dwave ! (NWAVE) + logical, allocatable, dimension(:) :: f_do_wave_emit ! (NWAVE) + end type carma_type + + + !! The cstate data type replaces portions of the common blocks that were used + !! in the F77 version of CARMA. This allows the code to be written to allow for + !! multiple threads to call CARMA routines simulataneously. This thread safety is + !! necessary for to run CARMA under OPEN/MP. + !! + !! The procedure for adding a variable to the cstate data type is: + !! - Add the variable as a scalar or allocatable in the type definition. + !! - If the new variable is dynamic, + !! - Allocate the variable in the create routine. + !! - Deallocate the variable in the destroy routines. + !! - Add an alias for the variable to cstate.h and associate it with the + !! variable in this typedef. + !! + !! NOTE: While the carmastate_type is public, routines outside of the CARMA module + !! should not look at or manuipulate fields of this structure directly. There should + !! be CARMASTATE_XXX methods to do anything that is needed with this structure, and + !! use of these methods will allow the cstate data type structure to evolve without + !! impacting code in the parent model. The contents of the structure had to be made + !! public, since the CARMA microphysics rountines are implemented in separate files + !! outside of this model; however, logically they are part of the model and are the + !! only routines outside of this module that should access fields of this structure + !! directly. + type, public :: carmastate_type + + ! Parent CARMA object + type(carma_type), pointer :: f_carma + + ! Model Dimensions + ! + ! NZ number of grid points in the column + ! NZP1 NZ+1 + ! NGROUP number of particle groups + ! NELEM number of particle components (elements) + ! NBIN number of size bins per element + ! NGAS number of gases (may be 0) + ! + integer :: f_NZ + integer :: f_NZP1 + + ! Model option & control variables + ! + ! time Simulation time at end of current timestep [s] + ! dtime Substep Timestep size [s] + ! dtime_orig Original Timestep size [s] + ! nretries Number of substepping retries attempted + real(kind=f) :: f_time + real(kind=f) :: f_dtime + real(kind=f) :: f_dtime_orig + real(kind=f) :: f_nretries + + ! max_nretry Maximum number of retries in a step + ! nstep Total number of steps taken + ! nsubstep Total number of substeps taken + ! nretry Total number of retries taken + integer :: f_max_nsubstep + real(kind=f) :: f_max_nretry + real(kind=f) :: f_nstep + integer :: f_nsubstep + real(kind=f) :: f_nretry + + real(kind=f), allocatable, dimension(:) :: f_zsubsteps ! (NZ) + + + ! Model Grid + ! + ! igridv flag to specify desired vertical grid coord system {initatm} + ! igridh flag to specify desired horizontal grid coord system {initatm} + ! xmet Horizontal ds/dx (ds is metric distance) {initatm} + ! ymet Horizontal ds/dy (ds is metric distance) {initatm} + ! zmet Vertical ds/dz (ds is metric distance) {initatm} + ! zmetl Vertical ds/dz at edges (ds is metric distance) {initatm} + ! xc Horizontal position at center of box {initatm} + ! yc Horizontal position at center of box {initatm} + ! zc Altitude at layer mid-point {initatm} + ! dx Horizontal grid spacing {initatm} + ! dy Horizontal grid spacing {initatm} + ! dz Thickness of vertical layers {initatm} + ! zl Altitude at top of layer {initatm} + ! lon Longitude [deg] at xc, yc {initatm} + ! lat Latitude [deg] at xc, yc {initatm} + ! + integer :: f_igridv + integer :: f_igridh + real(kind=f), allocatable, dimension(:) :: f_xmet ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_ymet ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_zmet ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_zmetl ! (NZP1) + real(kind=f), allocatable, dimension(:) :: f_xc ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_yc ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_zc ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_dx ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_dy ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_dz ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_zl ! (NZP1) + real(kind=f) :: f_lon + real(kind=f) :: f_lat + + ! Particle bin structure + ! + ! rhop Mass density of particle groups [g/cm^3] + ! r_wet Wet particle radius from RH swelling [cm] {setupvfall} + ! rlow_wet Wet particle radius (lower bound) from RH swelling [cm] {setupvfall} + ! rup_wet Wet particle radius (upper bound) from RH swelling [cm] {setupvfall} + ! rhop_wet Wet Mass density of particle groups [g/cm^3] + ! r_ref Reference wet particle radius from RH swelling [cm] {setupvfall} + ! rhop_ref Reference wet Mass density of particle groups [g/cm^3] + ! + real(kind=f), allocatable, dimension(:,:,:) :: f_rhop ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_rhop_wet ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_r_wet ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_rlow_wet ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_rup_wet ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_r_ref ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_rhop_ref ! (NZ,NBIN,NGROUP) + + ! Primary model state variables + ! + ! pc Particle concentration [/x_units/y_units/z_units] {initaer} + ! pcd Detrained particle concentration [/x_units/y_units/z_units] {initaer} + ! pc_surf Particles on surface [/cm2] {initaer} + ! sedimentationflux Particles sedimented to surface [/cm2/s] {initaer} + ! gc Gas concentration [g/x_units/y_units/z_units] {initgas} + ! cldfrc Cloud fraction [fraction] + ! rhcrit Relative humidity for onset of liquid clouds [fraction] + ! + real(kind=f), allocatable, dimension(:,:,:) :: f_pc ! (NZ,NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:,:) :: f_pcd ! (NZ,NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_pc_surf ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_sedimentationflux ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_gc ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:) :: f_cldfrc ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_rhcrit ! (NZ) + + ! Secondary model variables + ! + ! NOTE: Some of these variables are used for storing intermediate values in + ! the calculations. They may no longer be necessary, when the code is + ! implemented as F90 and values as passed as parameters between subroutines. + ! + ! pcl Particle concentration at beginning of time-step + ! pconmax Maximum particle concentration for each grid point + ! gcl Gas concentration at beginning of time-step + ! d_gc Change in gas concentration due to transport + ! d_t Change in temperature due to transport + ! dpc_sed Change in particle concentration due to sedimentation + ! coaglg Total particle loss rate due to coagulation for group + ! coagpe Particle production due to coagulation + ! rnuclg Total particle loss rate due to nucleation for group + ! rnucpe Particle production due to nucleation + ! rhompe Particle production due to homogeneous nucleation + ! pc_nucl Particles produced due to nucleation (for the whole step, not just the substep) + ! growlg Total particle loss rate due to growth for group + ! growle Partial particle loss rate due to growth for element + ! growpe Particle production due to growth + ! evaplg Total particle loss rate due to evaporation for group + ! evapls Partial particle loss rate due to evaporation for element + ! evappe Particle production due to evaporation + ! coreavg Average total core mass in bin + ! coresig logarithm^2 of std dev of core distribution + ! evdrop Particle production of droplet number + ! evcore Particle production of core elements + ! gasprod Gas production term + ! rlheat Latent heating rate (per step) [deg_K/s] + ! ftoppart Downward particle flux across top boundary of model + ! fbotpart Upward flux particle across bottom boundary of model + ! pc_topbnd Particle concentration assumed just above the top boundary + ! pc_botbnd Particle concentration assumed just below the bottom boundary + ! cmf Core mass fraction in a droplet + ! totevap .true. if droplets are totally evaporating to CN + ! too_small .true. if cores are smaller than smallest CN + ! too_big .true. if cores are larger than largest CN + ! nuc_small .true. if cores are smaller than smallest nucleated CN + ! rlprod Latent heat production (per substep) (K/s) + ! + real(kind=f), allocatable, dimension(:,:,:) :: f_pcl ! (NZ,NBIN,NELEM + real(kind=f), allocatable, dimension(:,:) :: f_gcl ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_d_gc ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:) :: f_d_t ! (NZ) + real(kind=f), allocatable, dimension(:,:) :: f_dpc_sed ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_pconmax ! (NZ,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_coaglg ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_coagpe ! (NZ,NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:,:) :: f_rnuclg ! (NBIN,NGROUP,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_rnucpe ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_rhompe ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:,:) :: f_pc_nucl ! (NZ,NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_growpe ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_evappe ! (NBIN,NELEM) + real(kind=f) :: f_coreavg + real(kind=f) :: f_coresig + real(kind=f) :: f_evdrop + real(kind=f), allocatable, dimension(:) :: f_evcore ! (NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_growlg ! (NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_evaplg ! (NBIN,NGROUP) + real(kind=f), allocatable, dimension(:) :: f_gasprod ! (NGAS) + real(kind=f), allocatable, dimension(:) :: f_rlheat ! (NZ) + real(kind=f), allocatable, dimension(:,:) :: f_ftoppart ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_fbotpart ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_pc_topbnd ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_pc_botbnd ! (NBIN,NELEM) + real(kind=f), allocatable, dimension(:,:) :: f_cmf ! (NBIN,NGROUP) + logical, allocatable, dimension(:,:) :: f_totevap ! (NBIN,NGROUP) + logical :: f_too_small + logical :: f_too_big + logical :: f_nuc_small + real(kind=f) :: f_rlprod + + ! Coagulation kernels and bin pair mapping + ! + ! ckernel Coagulation kernels [cm^3/s] {setupckern} + ! + real(kind=f), allocatable, dimension(:,:,:,:,:) :: f_ckernel ! (NZ,NBIN,NBIN,NGROUP,NGROUP) + + ! Particle fall velocities and diffusivities + ! + ! bpm Corrects for non-sphericity and non-continuum effects {setupvfall} + ! vf Fall velocities at layer endge {setupvfall} + ! re Reynolds' number based on {setupvfall} + ! dkz Vert Brownian diffusion coef at layer boundary [z_units^2/s] {setupbdif} + ! vd Particle dry deposition velocity [z_units/s] {setupvdry} + ! + real(kind=f), allocatable, dimension(:,:,:) :: f_bpm ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_vf ! (NZP1,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_re ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_dkz ! (NZP1,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_vd ! (NBIN,NGROUP) + + ! Atmospheric Structure + ! + ! rhoa Air density at layer mid-pt [g/x_units/y_units/z_units] {initatm} + ! rhoa_wet Wet Air density averaged over grid box [g/x_units/y_units/z_units] {initatm} + ! t Air temperature at layer mid-pt [deg_K] {initatm} + ! p Atmospheric pressure at layer mid-pt [dyne/cm^2] {initatm} + ! pl Atmospheric pressure at layer edge [dyne/cm^2] {initatm} + ! rmu Air viscosity at layer mid-pt [g/cm/s] {initatm} + ! thcond Thermal conductivity of dry air [erg/cm/sec/deg_K] {initatm} + ! thcondnc Adjusted thermal conductivity of dry air [erg/cm/sec/deg_K] {initatm} + ! told Temperature at beginning of time-step + ! relhum Hacked in relative humidity from hostmodel + ! wtpct Sulfate weight percent + ! + real(kind=f), allocatable, dimension(:) :: f_rhoa ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_rhoa_wet ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_t ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_p ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_pl ! (NZP1) + real(kind=f), allocatable, dimension(:) :: f_rmu ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_thcond ! (NZ) + real(kind=f), allocatable, dimension(:,:,:) :: f_thcondnc ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:) :: f_told ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_relhum ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_wtpct ! (NZ) + + ! Condensational growth parameters + ! + ! NOTE: Some of these variables are used for storing intermediate values in + ! the calculations. They may no longer be necessary, when the code is + ! implemented as F90 and values as passed as parameters between subroutines. + ! + ! diffus Diffusivity of gas in air [cm^2/s] {setupgrow} + ! rlhe Latent heat of evaporation for gas [cm^2/s^2] {setupgrow} + ! rlhm Latent heat of ice melting for gas [cm^2/s^2] {setupgrow} + ! pvapl Saturation vapor pressure over water [dyne/cm^2] {vaporp} + ! pvapi Saturation vapor pressure over ice [dyne/cm^2] {vaporp} + ! surfctwa Surface tension of water-air interface {setupgkern} + ! surfctiw Surface tension of water-ice interface {setupgkern} + ! surfctia Surface tension of ice-air interface {setupgkern} + ! akelvin Exponential arg. in curvature term for growth {setupgkern} + ! akelvini Curvature term for ice {setupgkern} + ! ft Ventilation factor {setupgkern} + ! gro Growth kernel [UNITS?] {setupgkern} + ! gro1 Growth kernel conduction term [UNITS?] {setupgkern} + ! gro2 Growth kernel radiation term [UNITS?] {setupgkern} + ! supsatl Supersaturation of vapor w.r.t. liquid water [dimless] + ! supsati Supersaturation of vapor w.r.t. ice [dimless] + ! supsatlold Supersaturation (liquid) before time-step {prestep} + ! supsatiold Supersaturation (ice) before time-step {prestep} + ! scrit Critical supersaturation for nucleation [dimless] {setupnuc} + ! radint Incoming radiative intensity [erg/cm2/sr/s/um] + ! partheat Diffusional heating from particles (step) [K/s] + ! dtpart Delta particle temperature [K] + ! phprod Particle heating production (substep) [K/s] + ! + real(kind=f), allocatable, dimension(:,:) :: f_diffus ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_rlhe ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_rlhm ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_pvapl ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_pvapi ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:) :: f_surfctwa ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_surfctiw ! (NZ) + real(kind=f), allocatable, dimension(:) :: f_surfctia ! (NZ) + real(kind=f), allocatable, dimension(:,:) :: f_akelvin ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_akelvini ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:,:) :: f_ft ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_gro ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:,:) :: f_gro1 ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_gro2 ! (NZ,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_supsatl ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_supsati ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_supsatlold ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:) :: f_supsatiold ! (NZ,NGAS) + real(kind=f), allocatable, dimension(:,:,:) :: f_scrit ! (NZ,NBIN,NGROUP) + real(kind=f), allocatable, dimension(:,:) :: f_radint ! (NZ,NWAVE) + real(kind=f), allocatable, dimension(:) :: f_partheat ! (NZ) + real(kind=f), allocatable, dimension(:,:,:) :: f_dtpart ! (NZ,NBIN,NGROUP) + real(kind=f) :: f_phprod + end type carmastate_type +end module \ No newline at end of file diff --git a/src/physics/carma/base/carmaelement_mod.F90 b/src/physics/carma/base/carmaelement_mod.F90 new file mode 100644 index 0000000000..b1ef11f034 --- /dev/null +++ b/src/physics/carma/base/carmaelement_mod.F90 @@ -0,0 +1,267 @@ +!! The CARMAELEMENT module contains configuration information about a particle +!! element used by CARMA. +!! +!! @version March-2010 +!! @author Chuck Bardeen +module CARMAELEMENT_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! CARMA explicitly declares all variables. + implicit none + + ! All CARMA variables and procedures are private except those explicitly declared to be public. + private + + ! Declare the public methods. + public CARMAELEMENT_Create + public CARMAELEMENT_Destroy + public CARMAELEMENT_Get + public CARMAELEMENT_Print + +contains + + !! Defines a gas used by CARMA for nucleation and growth of cloud and + !! aerosol particles. + !! + !! NOTE: The element density can be specifeid per bin using rhobin; however, + !! if only the bulk density is provided (rho) then the same value will be used + !! for all bins. The bulk density allows for backward compatability and ease of + !! configuration. If rhobin is provided, then rho is ignored. + !! + !! @author Chuck Bardeen + !! @version March-2010 + !! + !! @see CARMA_AddGas + !! @see CARMAELEMENT_Destroy + subroutine CARMAELEMENT_Create(carma, ielement, igroup, name, rho, itype, icomposition, rc, & + shortname, isolute, rhobin, arat) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: ielement !! the element index + integer, intent(in) :: igroup !! Group to which the element belongs + character(*), intent(in) :: name !! the element name, maximum of 255 characters + real(kind=f), intent(in) :: rho !! bulk mass density of particle element [g/cm^3] + integer, intent(in) :: itype !! Particle type specification + integer, intent(in) :: icomposition !! Particle compound specification + integer, intent(out) :: rc !! return code, negative indicates failure + character(*), optional, intent(in) :: shortname !! the element shortname, maximum of 6 characters + integer, optional, intent(in) :: isolute !! Index of solute for the particle element + real(kind=f), optional, intent(in) :: rhobin(carma%f_NBIN) !! mass density per bin of particle element [g/cm^3] + real(kind=f), optional, intent(in) :: arat(carma%f_NBIN) !! projected area ratio + + ! Local variables + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough elements allocated. + if (ielement > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Create:: ERROR - The specifed element (", & + ielement, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough groups allocated. + if (igroup > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Create:: ERROR - The specifed group (", & + igroup, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + allocate( & + carma%f_element(ielement)%f_rho(carma%f_NBIN), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Add: ERROR allocating, status=", ier + rc = RC_ERROR + return + end if + + ! Save off the settings. + carma%f_element(ielement)%f_igroup = igroup + carma%f_element(ielement)%f_name = name + carma%f_element(ielement)%f_rho(:) = rho + carma%f_element(ielement)%f_itype = itype + carma%f_element(ielement)%f_icomposition = icomposition + + + ! Defaults for optional parameters + carma%f_element(ielement)%f_shortname = "" + carma%f_element(ielement)%f_isolute = 0 + + ! Set optional parameters. + if (present(shortname)) carma%f_element(ielement)%f_shortname = shortname + if (present(isolute)) then + + ! Make sure there are enough solutes allocated. + if (isolute > carma%f_NSOLUTE) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Create:: ERROR - The specifed solute (", & + isolute, ") is larger than the number of solutes (", carma%f_NSOLUTE, ")." + rc = RC_ERROR + return + end if + + carma%f_element(ielement)%f_isolute = isolute + end if + if (present(rhobin)) carma%f_element(ielement)%f_rho(:) = rhobin(:) + + ! If the area ratio is specfied (usually along with rhobin), then set this + ! for the group. + if (present(arat)) carma%f_group(igroup)%f_arat(:) = arat(:) + + ! Keep track of the fact that another element has been added to the group. + carma%f_group(igroup)%f_nelem = carma%f_group(igroup)%f_nelem + 1 + + return + end subroutine CARMAELEMENT_Create + + + !! Deallocates the memory associated with a CARMAELEMENT object. + !! + !! @author Chuck Bardeen + !! @version March-2010 + !! + !! @see CARMAELEMENT_Create + subroutine CARMAELEMENT_Destroy(carma, ielement, rc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: ielement !! the element index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough elements allocated. + if (ielement > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Destroy:: ERROR - The specifed element (", & + ielement, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + if (allocated(carma%f_element(ielement)%f_rho)) then + deallocate( & + carma%f_element(ielement)%f_rho, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Destroy: ERROR deallocating, status=", ier + rc = RC_ERROR + return + endif + endif + + return + end subroutine CARMAELEMENT_Destroy + + + !! Gets information about a particle element. + !! + !! The group name and other properties are available after a call to + !! CARMAELEMENT_Create(). + !! + !! @author Chuck Bardeen + !! @version March-2010 + !! + !! @see CARMAELEMENT_Create + !! @see CARMA_GetElement + subroutine CARMAELEMENT_Get(carma, ielement, rc, igroup, name, shortname, rho, itype, icomposition, isolute) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: ielement !! the element index + integer, intent(out) :: rc !! return code, negative indicates failure + integer, optional, intent(out) :: igroup !! Group to which the element belongs + character(len=*), optional, intent(out) :: name !! the element name + character(len=*), optional, intent(out) :: shortname !! the element short name + real(kind=f), optional, intent(out) :: rho(carma%f_NBIN) !! Mass density of particle element [g/cm^3] + integer, optional, intent(out) :: itype !! Particle type specification + integer, optional, intent(out) :: icomposition !! Particle compound specification + integer, optional, intent(out) :: isolute !! Index of solute for the particle element + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough elements allocated. + if (ielement > carma%f_NELEM) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAELEMENT_Get:: ERROR - The specifed element (", & + ielement, ") is larger than the number of elements (", carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Return any requested properties of the group. + if (present(igroup)) igroup = carma%f_element(ielement)%f_igroup + if (present(name)) name = carma%f_element(ielement)%f_name + if (present(shortname)) shortname = carma%f_element(ielement)%f_shortname + if (present(rho)) rho(:) = carma%f_element(ielement)%f_rho(:) + if (present(itype)) itype = carma%f_element(ielement)%f_itype + if (present(icomposition)) icomposition = carma%f_element(ielement)%f_icomposition + if (present(isolute)) isolute = carma%f_element(ielement)%f_isolute + + return + end subroutine CARMAELEMENT_Get + + + !! Prints information about an element. + !! + !! @author Chuck Bardeen + !! @version March-2010 + !! + !! @see CARMAELEMENT_Get + subroutine CARMAELEMENT_Print(carma, ielement, rc) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: ielement !! the element index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + character(len=CARMA_NAME_LEN) :: name ! name + character(len=CARMA_SHORT_NAME_LEN) :: shortname ! shortname + real(kind=f) :: rho(carma%f_NBIN) ! density (g/cm3) + integer :: igroup ! Group to which the element belongs + integer :: itype ! Particle type specification + integer :: icomposition ! Particle compound specification + integer :: isolute ! Index of solute for the particle element + + ! Assume success. + rc = RC_OK + + ! Test out the Get method. + if (carma%f_do_print) then + call CARMAELEMENT_Get(carma, ielement, rc, name=name, shortname=shortname, igroup=igroup, & + itype=itype, icomposition=icomposition, rho=rho, isolute=isolute) + if (rc < 0) return + + + write(carma%f_LUNOPRT,*) " name : ", trim(name) + write(carma%f_LUNOPRT,*) " igroup : ", igroup + write(carma%f_LUNOPRT,*) " shortname : ", trim(shortname) + write(carma%f_LUNOPRT,*) " rho : ", rho, " (g/cm3)" + + select case(itype) + case (I_INVOLATILE) + write(carma%f_LUNOPRT,*) " itype : involatile" + case (I_VOLATILE) + write(carma%f_LUNOPRT,*) " itype : volatile" + case (I_COREMASS) + write(carma%f_LUNOPRT,*) " itype : core mass" + case (I_VOLCORE) + write(carma%f_LUNOPRT,*) " itype : volatile core" + case (I_CORE2MOM) + write(carma%f_LUNOPRT,*) " itype : core mass - second moment" + case default + write(carma%f_LUNOPRT,*) " itype : unknown, ", itype + end select + + write(carma%f_LUNOPRT,*) " icomposition : ", icomposition + write(carma%f_LUNOPRT,*) " isolute : ", isolute + end if + + return + end subroutine CARMAELEMENT_Print +end module diff --git a/src/physics/carma/base/carmagas_mod.F90 b/src/physics/carma/base/carmagas_mod.F90 new file mode 100644 index 0000000000..e446db01ad --- /dev/null +++ b/src/physics/carma/base/carmagas_mod.F90 @@ -0,0 +1,208 @@ +!! The CARMAGAS module contains configuration information about a gas used by CARMA. +!! +!! @version May-2009 +!! @author Chuck Bardeen +module carmagas_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! CARMA explicitly declares all variables. + implicit none + + ! All CARMA variables and procedures are private except those explicitly declared to be public. + private + + ! Declare the public methods. + public CARMAGAS_Create + public CARMAGAS_Destroy + public CARMAGAS_Get + public CARMAGAS_Print + +contains + + !! Defines a gas used by CARMA for nucleation and growth of cloud and + !! aerosol particles. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMA_AddGas + !! @see CARMAGAS_Destroy + subroutine CARMAGAS_Create(carma, igas, name, wtmol, ivaprtn, icomposition, & + rc, shortname, dgc_threshold, ds_threshold) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igas !! the gas index + character(*), intent(in) :: name !! the gas name, maximum of 255 characters + real(kind=f), intent(in) :: wtmol !! the gas molecular weight [g/mol] + integer, intent(in) :: ivaprtn !! vapor pressure routine for this gas + integer, intent(in) :: icomposition !! gas compound specification + integer, intent(out) :: rc !! return code, negative indicates failure + character(*), optional, intent(in) :: shortname !! the gas shortname, maximum of 6 characters + real(kind=f), optional, intent(in) :: dgc_threshold !! convergence criteria for gas concentration + !! [0 : off; > 0 : percentage change] + real(kind=f), optional, intent(in) :: ds_threshold !! convergence criteria for gas saturation + !! [0 : off; > 0 : percentage change; < 0 : amount past 0 crossing] + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough gases allocated. + if (igas > carma%f_NGAS) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGAS_GetCreate:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + ! Save off the settings. + carma%f_gas(igas)%f_name = name + carma%f_gas(igas)%f_wtmol = wtmol + carma%f_gas(igas)%f_ivaprtn = ivaprtn + carma%f_gas(igas)%f_icomposition = icomposition + + + ! Defaults for optional parameters + carma%f_gas(igas)%f_shortname = "" + carma%f_gas(igas)%f_dgc_threshold = 0._f + carma%f_gas(igas)%f_ds_threshold = 0._f + + ! Set optional parameters. + if (present(shortname)) carma%f_gas(igas)%f_shortname = shortname + if (present(dgc_threshold)) carma%f_gas(igas)%f_dgc_threshold = dgc_threshold + if (present(ds_threshold)) carma%f_gas(igas)%f_ds_threshold = ds_threshold + + return + end subroutine CARMAGAS_Create + + + !! Deallocates the memory associated with a CARMAGAS object. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGAS_Create + subroutine CARMAGAS_Destroy(carma, igas, rc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igas !! the gas index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough gases allocated. + if (igas > carma%f_NGAS) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGAS_Destroy:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + return + end subroutine CARMAGAS_Destroy + + + !! Gets information about a gas. + !! + !! The group name and other properties are available after a call to + !! CARMAGAS_Create(). + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGAS_Create + !! @see CARMA_GetGas + subroutine CARMAGAS_Get(carma, igas, rc, name, shortname, wtmol, ivaprtn, icomposition, dgc_threshold, ds_threshold) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: igas !! the gas index + integer, intent(out) :: rc !! return code, negative indicates failure + character(len=*), optional, intent(out) :: name !! the gas name + character(len=*), optional, intent(out) :: shortname !! the gas short name + real(kind=f), optional, intent(out) :: wtmol !! the gas molecular weight [g/mol] + integer, optional, intent(out) :: ivaprtn !! vapor pressure routine for this gas + integer, optional, intent(out) :: icomposition !! gas compound specification + real(kind=f), optional, intent(out) :: dgc_threshold !! convergence criteria for gas concentration [fraction] + real(kind=f), optional, intent(out) :: ds_threshold !! convergence criteria for gas saturation [fraction] + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough gases allocated. + if (igas > carma%f_NGAS) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGAS_Get:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + ! Return any requested properties of the group. + if (present(name)) name = carma%f_gas(igas)%f_name + if (present(shortname)) shortname = carma%f_gas(igas)%f_shortname + if (present(wtmol)) wtmol = carma%f_gas(igas)%f_wtmol + if (present(ivaprtn)) ivaprtn = carma%f_gas(igas)%f_ivaprtn + if (present(icomposition)) icomposition = carma%f_gas(igas)%f_icomposition + if (present(dgc_threshold)) dgc_threshold = carma%f_gas(igas)%f_dgc_threshold + if (present(ds_threshold)) ds_threshold = carma%f_gas(igas)%f_ds_threshold + + return + end subroutine CARMAGAS_Get + + + !! Prints information about a gas. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGAS_Get + subroutine CARMAGAS_Print(carma, igas, rc) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: igas !! the gas index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + character(len=CARMA_NAME_LEN) :: name !! name + character(len=CARMA_SHORT_NAME_LEN) :: shortname !! shortname + real(kind=f) :: wtmol !! molecular weight (g/mol) + integer :: ivaprtn !! vapor pressure routine for this gas + integer :: icomposition !! gas compound specification + real(kind=f) :: dgc_threshold !! convergence criteria for gas concentration [fraction] + real(kind=f) :: ds_threshold !! convergence criteria for gas saturation [fraction] + + ! Assume success. + rc = RC_OK + + ! Test out the Get method. + if (carma%f_do_print) then + call CARMAGAS_Get(carma, igas, rc, name=name, shortname=shortname, wtmol=wtmol, & + ivaprtn=ivaprtn, icomposition=icomposition) + if (rc < RC_OK) return + + + write(carma%f_LUNOPRT,*) " name : ", trim(name) + write(carma%f_LUNOPRT,*) " shortname : ", trim(shortname) + write(carma%f_LUNOPRT,*) " wtmol : ", wtmol, " (g/mol)" + write(carma%f_LUNOPRT,*) " dgc_threshold : ", dgc_threshold + write(carma%f_LUNOPRT,*) " ds_threshold : ", ds_threshold + + select case(ivaprtn) + case (I_VAPRTN_H2O_BUCK1981) + write(carma%f_LUNOPRT,*) " ivaprtn : Buck [1981]" + case (I_VAPRTN_H2O_MURPHY2005) + write(carma%f_LUNOPRT,*) " ivaprtn : Murphy & Koop [2005]" + case default + write(carma%f_LUNOPRT,*) " ivaprtn : unknown, ", ivaprtn + end select + + select case(icomposition) + case (I_GCOMP_H2O) + write(carma%f_LUNOPRT,*) " icomposition : H2O" + case default + write(carma%f_LUNOPRT,*) " icomposition : unknown, ", icomposition + end select + end if + + return + end subroutine CARMAGAS_Print +end module diff --git a/src/physics/carma/base/carmagroup_mod.F90 b/src/physics/carma/base/carmagroup_mod.F90 new file mode 100644 index 0000000000..b1e4f77d13 --- /dev/null +++ b/src/physics/carma/base/carmagroup_mod.F90 @@ -0,0 +1,731 @@ +!! The CARMAGROUP module contains configuration information about a CARMA partcile. +!! +!! NOTE: Because of the way Fortran handles pointers and allocations, it is much +!! simpiler to have these methods directly access the group array that is in the +!! CARMA object rather than having this as its own objects. Some compilers (like +!! IBM on AIX do not by default automatically deallocate automatically created +!! derived types that contain allocations. This can result in memory leaks that +!! are difficult to find. +!! +!! These calls are written like they are part of CARMA, but they are called +!! CARMAGROUP and kept by themselves in their own file to make it easier to keep +!! track of what is required when adding an attribute to a group. +!! +!! @version July-2009 +!! @author Chuck Bardeen +module carmagroup_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! CARMA explicitly declares all variables. + implicit none + + ! All CARMA variables and procedures are private except those explicitly declared to be public. + private + + ! Declare the public methods. + public CARMAGROUP_Create + public CARMAGROUP_Destroy + public CARMAGROUP_Get + public CARMAGROUP_Print + +contains + + subroutine CARMAGROUP_Create(carma, igroup, name, rmin, rmrat, ishape, eshape, is_ice, rc, is_fractal, & + irhswell, irhswcomp, refidx, do_mie, do_wetdep, do_drydep, do_vtran, solfac, scavcoef, shortname, & + cnsttype, maxbin, ifallrtn, is_cloud, rmassmin, imiertn, is_sulfate, dpc_threshold, rmon, df, falpha, & + neutral_volfrc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igroup !! the group index + character(*), intent(in) :: name !! the group name, maximum of 255 characters + real(kind=f), intent(in) :: rmin !! the minimum radius, can be specified [cm] + real(kind=f), intent(in) :: rmrat !! the volume ratio between bins + integer, intent(in) :: ishape !! the type of the particle shape + !! [I_SPHERE | I_HEXAGON | I_CYLINDER] + real(kind=f), intent(in) :: eshape !! the aspect ratio of the particle shape (length/diameter) + logical, intent(in) :: is_ice !! is this an ice particle? + integer, intent(out) :: rc !! return code, negative indicates failure + logical, optional, intent(in) :: is_fractal !! is this a fractal particle? + integer, optional, intent(in) :: irhswell !! the parameterization for particle swelling + !! from relative humidity [I_FITZGERALD | I_GERBER] + integer, optional, intent(in) :: irhswcomp !! the composition for particle swelling + !! from relative humidity [I_FITZGERALD | I_GERBER] + complex(kind=f), optional, intent(in) :: refidx(carma%f_NWAVE) !! refractive index for the particle + logical, optional, intent(in) :: do_mie !! do mie calculations? + logical, optional, intent(in) :: do_wetdep !! do wet deposition for this particle? + logical, optional, intent(in) :: do_drydep !! do dry deposition for this particle? + logical, optional, intent(in) :: do_vtran !! do sedimentation for this particle? + real(kind=f), intent(in), optional :: solfac !! the solubility factor for wet deposition + real(kind=f), intent(in), optional :: scavcoef !! the scavenging coefficient for wet deposition + character(*), optional, intent(in) :: shortname !! the group shortname, maximum of 6 characters + integer, optional, intent(in) :: cnsttype !! constituent type in parent model + !! [I_CNSTTYPE_PROGNOSTIC | I_CNSTTYPE_DIAGNOSTIC] + integer, optional, intent(in) :: maxbin !! bin number of the last prognostic bin + !! the remaining bins are diagnostic + integer, optional, intent(in) :: ifallrtn !! fall velocity routine [I_FALLRTN_STD + !! | I_FALLRTN_STD_SHAPE | I_FALLRTN_HEYMSFIELD2010 + !! | I_FALLRTN_ACKERMAN_DROP | I_FALLRTN_ACKERMAN_ICE] + logical, optional, intent(in) :: is_cloud !! is this a cloud particle? + real(kind=f), optional, intent(in) :: rmassmin !! the minimum mass, when used overrides rmin[g] + integer, optional, intent(in) :: imiertn !! mie routine [I_MIERTN_TOON1981 | I_MIERTN_BOHREN1983 + !! | I_MIERTN_BOTET1997] + logical, optional, intent(in) :: is_sulfate !! is this a sulfate particle? + real(kind=f), optional, intent(in) :: dpc_threshold !! convergence criteria for particle concentration + !! [fraction] + real(kind=f), optional, intent(in) :: rmon !! monomer radius for fractal particles [cm] + real(kind=f), optional, intent(in) :: df(carma%f_NBIN) !! fractal dimension + real(kind=f), optional, intent(in) :: falpha !! fractal packing coefficient + real(kind=f), optional, intent(in) :: neutral_volfrc !! volume fraction of core mass for neutralization + + ! Local variables + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough groups allocated. + if (igroup > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Add:: ERROR - The specifed group (", & + igroup, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + allocate( & + carma%f_group(igroup)%f_r(carma%f_NBIN), & + carma%f_group(igroup)%f_rmass(carma%f_NBIN), & + carma%f_group(igroup)%f_vol(carma%f_NBIN), & + carma%f_group(igroup)%f_dr(carma%f_NBIN), & + carma%f_group(igroup)%f_dm(carma%f_NBIN), & + carma%f_group(igroup)%f_rmassup(carma%f_NBIN), & + carma%f_group(igroup)%f_rup(carma%f_NBIN), & + carma%f_group(igroup)%f_rlow(carma%f_NBIN), & + carma%f_group(igroup)%f_icorelem(carma%f_NELEM), & + carma%f_group(igroup)%f_arat(carma%f_NBIN), & + carma%f_group(igroup)%f_rrat(carma%f_NBIN), & + carma%f_group(igroup)%f_rprat(carma%f_NBIN), & + carma%f_group(igroup)%f_df(carma%f_NBIN), & + carma%f_group(igroup)%f_nmon(carma%f_NBIN), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Add: ERROR allocating, status=", ier + rc = RC_ERROR + return + end if + + ! Initialize + carma%f_group(igroup)%f_r(:) = 0._f + carma%f_group(igroup)%f_rmass(:) = 0._f + carma%f_group(igroup)%f_vol(:) = 0._f + carma%f_group(igroup)%f_dr(:) = 0._f + carma%f_group(igroup)%f_dm(:) = 0._f + carma%f_group(igroup)%f_rmassup(:) = 0._f + carma%f_group(igroup)%f_rup(:) = 0._f + carma%f_group(igroup)%f_rlow(:) = 0._f + carma%f_group(igroup)%f_icorelem(:) = 0 + carma%f_group(igroup)%f_ifallrtn = I_FALLRTN_STD + carma%f_group(igroup)%f_imiertn = I_MIERTN_TOON1981 + carma%f_group(igroup)%f_is_fractal = .false. + carma%f_group(igroup)%f_is_cloud = .false. + carma%f_group(igroup)%f_is_sulfate = .false. + carma%f_group(igroup)%f_dpc_threshold = 0._f + carma%f_group(igroup)%f_rmon = 0._f + carma%f_group(igroup)%f_df(:) = 3.0_f + carma%f_group(igroup)%f_nmon(:) = 1.0_f + carma%f_group(igroup)%f_falpha = 1.0_f + carma%f_group(igroup)%f_neutral_volfrc = 0.0_f + + ! Any optical properties? + if (carma%f_NWAVE > 0) then + allocate( & + carma%f_group(igroup)%f_refidx(carma%f_NWAVE), & + carma%f_group(igroup)%f_qext(carma%f_NWAVE,carma%f_NBIN), & + carma%f_group(igroup)%f_ssa(carma%f_NWAVE,carma%f_NBIN), & + carma%f_group(igroup)%f_asym(carma%f_NWAVE,carma%f_NBIN), & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Add: ERROR allocating, status=", ier + rc = RC_ERROR + return + endif + + ! Initialize + carma%f_group(igroup)%f_refidx(:) = (0._f, 0._f) + carma%f_group(igroup)%f_qext(:,:) = 0._f + carma%f_group(igroup)%f_ssa(:,:) = 0._f + carma%f_group(igroup)%f_asym(:,:) = 0._f + end if + + + ! Save off the settings. + carma%f_group(igroup)%f_name = name + carma%f_group(igroup)%f_rmin = rmin + carma%f_group(igroup)%f_rmrat = rmrat + carma%f_group(igroup)%f_ishape = ishape + carma%f_group(igroup)%f_eshape = eshape + carma%f_group(igroup)%f_is_ice = is_ice + + + ! Defaults for optional parameters + carma%f_group(igroup)%f_irhswell = 0 + carma%f_group(igroup)%f_do_mie = .false. + carma%f_group(igroup)%f_do_wetdep = .false. + carma%f_group(igroup)%f_grp_do_drydep = .false. + carma%f_group(igroup)%f_grp_do_vtran = .true. + carma%f_group(igroup)%f_solfac = 0.3_f + carma%f_group(igroup)%f_scavcoef = 0.1_f + carma%f_group(igroup)%f_shortname = "" + carma%f_group(igroup)%f_cnsttype = I_CNSTTYPE_PROGNOSTIC + carma%f_group(igroup)%f_maxbin = carma%f_NBIN + carma%f_group(igroup)%f_rmassmin = 0.0_f + + ! Set optional parameters. + if (present(irhswell)) carma%f_group(igroup)%f_irhswell = irhswell + if (present(irhswcomp)) carma%f_group(igroup)%f_irhswcomp = irhswcomp + if (present(refidx)) carma%f_group(igroup)%f_refidx(:) = refidx(:) + if (present(do_mie)) carma%f_group(igroup)%f_do_mie = do_mie + if (present(do_wetdep)) carma%f_group(igroup)%f_do_wetdep = do_wetdep + if (present(do_drydep)) carma%f_group(igroup)%f_grp_do_drydep = do_drydep + if (present(do_vtran)) carma%f_group(igroup)%f_grp_do_vtran = do_vtran + if (present(solfac)) carma%f_group(igroup)%f_solfac = solfac + if (present(scavcoef)) carma%f_group(igroup)%f_scavcoef = scavcoef + if (present(shortname)) carma%f_group(igroup)%f_shortname = shortname + if (present(cnsttype)) carma%f_group(igroup)%f_cnsttype = cnsttype + if (present(maxbin)) carma%f_group(igroup)%f_maxbin = maxbin + if (present(ifallrtn)) carma%f_group(igroup)%f_ifallrtn = ifallrtn + if (present(is_cloud)) carma%f_group(igroup)%f_is_cloud = is_cloud + if (present(is_fractal)) carma%f_group(igroup)%f_is_fractal = is_fractal + if (present(rmassmin)) carma%f_group(igroup)%f_rmassmin = rmassmin + if (present(imiertn)) carma%f_group(igroup)%f_imiertn = imiertn + if (present(is_sulfate)) carma%f_group(igroup)%f_is_sulfate = is_sulfate + if (present(dpc_threshold)) carma%f_group(igroup)%f_dpc_threshold = dpc_threshold + if (present(rmon)) carma%f_group(igroup)%f_rmon = rmon + if (present(df)) carma%f_group(igroup)%f_df(:) = df(:) + if (present(falpha)) carma%f_group(igroup)%f_falpha = falpha + if (present(neutral_volfrc)) carma%f_group(igroup)%f_neutral_volfrc = neutral_volfrc + + ! Initialize other properties. + carma%f_group(igroup)%f_nelem = 0 + carma%f_group(igroup)%f_if_sec_mom = .FALSE. + carma%f_group(igroup)%f_ncore = 0 + carma%f_group(igroup)%f_ienconc = 0 + carma%f_group(igroup)%f_imomelem = 0 + + + ! The area ratio is the ratio of the area of the shape to the area of the + ! circumscribing circle. The radius ratio is the ratio between the radius + ! of the longest dimension and the radius of the enclosing sphere. + if (ishape .eq. I_HEXAGON) then + carma%f_group(igroup)%f_arat(:) = 3._f * sqrt(3._f) / 2._f / PI + carma%f_group(igroup)%f_rrat(:) = ((4._f * PI / 9._f / sqrt(3._f)) ** (1._f / 3._f)) * eshape**(-1._f / 3._f) + else if (ishape .eq. I_CYLINDER) then + carma%f_group(igroup)%f_arat(:) = 1.0_f + carma%f_group(igroup)%f_rrat(:) = ((2._f / 3._f) ** (1._f / 3._f)) * eshape**(-1._f / 3._f) + else + + ! Default to a sphere. + ! + ! NOTE: Should add code here to handle oblate and prolate spheroids. + carma%f_group(igroup)%f_arat(:) = 1.0_f + carma%f_group(igroup)%f_rrat(:) = 1.0_f + end if + + carma%f_group(igroup)%f_rprat(:) = 1.0_f + + !! Dry fractal aggregate aerosols composed of nmon identical spheres of radius rmon + !! can be treated by enabling the switch is_fractal = .true. Optical properties of dry + !! fractal aggregates can be computed using option imiertn = I_MIERTN_FRACTAL. + !! To use either of these options, the user must define the fractal dimension, df(NBIN), + !! monomer size (rmon), and packing coefficient (falpha) when creating the CARMA group. + !! + !! For aerosol particles fractal dimensions (df) are typically near 2.0, but can vary as a function + !! of size/number of monomers contained withing. The packing coefficient (falpha) is expected to be near + !! unity. falpha > 1 implies a more tightly packed fractal aggregate and vice-versa. + !! + !! If the user desires to use fractal optical properties calculation (I_MIERTN_BOTET1997), then + !! the user must also have fractal microphysics enabled (is_fractal = .true.). However, note that + !! if fractal microphysics are enabled, the user is free to select a standard Mie optical property calculation. + !! + ! + ! Check consistency for fractal optical property calculation + if ((carma%f_group(igroup)%f_imiertn == I_MIERTN_BOTET1997) .and. & + .not. carma%f_group(igroup)%f_is_fractal) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "CARMAGROUP_Create:& + &ERROR, fractal optics selected without fractal microphysics enabled." + end if + rc = RC_ERROR + return + end if + + ! Check input consistency for fractal physics + if (carma%f_group(igroup)%f_is_fractal .or. & + (carma%f_group(igroup)%f_imiertn == I_MIERTN_BOTET1997)) then + if (.not. (present(rmon) .and. present(df) .and. present(falpha))) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "CARMAGROUP_Create:& + &ERROR, for fractal physics must set rmon,df,falpha" + end if + rc = RC_ERROR + return + end if + end if + + return + end subroutine CARMAGROUP_Create + + + !! Deallocates the memory associated with a CARMAGROUP object. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGROUP_Create + subroutine CARMAGROUP_Destroy(carma, igroup, rc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igroup !! the group index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough groups allocated. + if (igroup > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Destroy:: ERROR - The specifed group (", & + igroup, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + if (allocated(carma%f_group(igroup)%f_refidx)) then + deallocate( & + carma%f_group(igroup)%f_refidx, & + carma%f_group(igroup)%f_qext, & + carma%f_group(igroup)%f_ssa, & + carma%f_group(igroup)%f_asym, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Destroy: ERROR deallocating, status=", ier + rc = RC_ERROR + return + endif + endif + + ! Allocate dynamic data. + if (allocated(carma%f_group(igroup)%f_r)) then + deallocate( & + carma%f_group(igroup)%f_r, & + carma%f_group(igroup)%f_rmass, & + carma%f_group(igroup)%f_vol, & + carma%f_group(igroup)%f_dr, & + carma%f_group(igroup)%f_dm, & + carma%f_group(igroup)%f_rmassup, & + carma%f_group(igroup)%f_rup, & + carma%f_group(igroup)%f_rlow, & + carma%f_group(igroup)%f_icorelem, & + carma%f_group(igroup)%f_arat, & + carma%f_group(igroup)%f_rrat, & + carma%f_group(igroup)%f_rprat, & + carma%f_group(igroup)%f_df, & + carma%f_group(igroup)%f_nmon, & + stat=ier) + if(ier /= 0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Destroy: ERROR deallocating, status=", ier + rc = RC_ERROR + return + endif + endif + + return + end subroutine CARMAGROUP_Destroy + + + !! Gets information about a group. + !! + !! The group name and most other properties are available after a call to + !! CARMAGROUP_Create(). After a call to CARMA_Initialize(), the bin + !! dimensions and optical properties can be retrieved. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGROUP_Create + !! @see CARMA_GetGroup + !! @see CARMA_Initialize + subroutine CARMAGROUP_Get(carma, igroup, rc, name, shortname, rmin, rmrat, ishape, eshape, is_ice, is_fractal, & + irhswell, irhswcomp, cnsttype, r, rlow, rup, dr, rmass, dm, vol, qext, ssa, asym, do_mie, & + do_wetdep, do_drydep, do_vtran, solfac, scavcoef, ienconc, refidx, ncore, icorelem, maxbin, & + ifallrtn, is_cloud, rmassmin, arat, rrat, rprat, imiertn, is_sulfate, dpc_threshold, rmon, df, & + nmon, falpha, neutral_volfrc) + + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: igroup !! the group index + integer, intent(out) :: rc !! return code, negative indicates failure + character(len=*), optional, intent(out) :: name !! the group name + character(len=*), optional, intent(out) :: shortname !! the group short name + real(kind=f), optional, intent(out) :: rmin !! the minimum radius [cm] + real(kind=f), optional, intent(out) :: rmrat !! the volume ratio between bins + integer, optional, intent(out) :: ishape !! the type of the particle shape + real(kind=f), optional, intent(out) :: eshape !! the aspect ratio of the particle shape + logical, optional, intent(out) :: is_ice !! is this an ice particle? + logical, optional, intent(out) :: is_fractal !! is this a fractal? + integer, optional, intent(out) :: irhswell !! the parameterization for particle swelling + !! from relative humidity + integer, optional, intent(out) :: irhswcomp !! the composition for particle swelling + !! from relative humidity + integer, optional, intent(out) :: cnsttype !! constituent type in the parent model + real(kind=f), intent(out), optional :: r(carma%f_NBIN) !! the bin radius [cm] + real(kind=f), intent(out), optional :: rlow(carma%f_NBIN) !! the bin radius lower bound [cm] + real(kind=f), intent(out), optional :: rup(carma%f_NBIN) !! the bin radius upper bound [cm] + real(kind=f), intent(out), optional :: dr(carma%f_NBIN) !! the bin width in radius space [cm] + real(kind=f), intent(out), optional :: rmass(carma%f_NBIN) !! the bin mass [g] + real(kind=f), intent(out), optional :: dm(carma%f_NBIN) !! the bin width in mass space [g] + real(kind=f), intent(out), optional :: vol(carma%f_NBIN) !! the bin volume [cm3] + real(kind=f), intent(out), optional :: arat(carma%f_NBIN) !! the projected area ratio + !! (area / area enclosing sphere) + real(kind=f), intent(out), optional :: rrat(carma%f_NBIN) !! the radius ratio + !! (maximum dimension / radius of enclosing sphere) + real(kind=f), intent(out), optional :: rprat(carma%f_NBIN) !! the porusity radius ratio + !! (scaled porosity radius / equiv. sphere) + complex(kind=f), intent(out), optional :: refidx(carma%f_NWAVE) !! the refractive index at each wavelength + real(kind=f), intent(out), optional :: qext(carma%f_NWAVE,carma%f_NBIN) !! extinction efficiency + real(kind=f), intent(out), optional :: ssa(carma%f_NWAVE,carma%f_NBIN) !! single scattering albedo + real(kind=f), intent(out), optional :: asym(carma%f_NWAVE,carma%f_NBIN) !! asymmetry factor + logical, optional, intent(out) :: do_mie !! do mie calculations? + logical, optional, intent(out) :: do_wetdep !! do wet deposition for this particle? + logical, optional, intent(out) :: do_drydep !! do dry deposition for this particle? + logical, optional, intent(out) :: do_vtran !! do sedimentation for this particle? + real(kind=f), intent(out), optional :: solfac !! the solubility factor for wet deposition + real(kind=f), intent(out), optional :: scavcoef !! the scavenging coefficient for wet deposition + integer, intent(out), optional :: ienconc !! Particle number conc. element for group + integer, intent(out), optional :: ncore !! Number of core mass elements for group + integer, intent(out), optional :: icorelem(carma%f_NELEM) !! Element index of core mass elements for group + integer, optional, intent(out) :: maxbin !! the last prognostic bin in the group + integer, optional, intent(out) :: ifallrtn !! fall velocity routine [I_FALLRTN_STD + !! | I_FALLRTN_STD_SHAPE | I_FALLRTN_HEYMSFIELD2010 + !! | I_FALLRTN_ACKERMAN_DROP + !! | I_FALLRTN_ACKERMAN_ICE] + logical, optional, intent(out) :: is_cloud !! is this a cloud particle? + real(kind=f), optional, intent(out) :: rmassmin !! the minimum mass [g] + integer, optional, intent(out) :: imiertn !! mie routine [I_MIERTN_TOON1981 + !! | I_MIERTN_BOHREN1983 | I_MIERTN_BOTET1997] + logical, optional, intent(out) :: is_sulfate !! is this a sulfate particle? + real(kind=f), optional, intent(out) :: dpc_threshold !! convergence criteria for particle concentration + !! [fraction] + real(kind=f), optional, intent(out) :: rmon !! monomer radius for fractal particles + real(kind=f), optional, intent(out) :: df(carma%f_NBIN) !! fractal dimension + real(kind=f), optional, intent(out) :: nmon(carma%f_NBIN) !! number of monomers per + real(kind=f), optional, intent(out) :: falpha !! fractal packing coefficient + real(kind=f), optional, intent(out) :: neutral_volfrc !! volume fraction of core mass for neutralization + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough groups allocated. + if (igroup > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Get:: ERROR - The specifed group (", & + igroup, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + ! Return any requested properties of the group. + if (present(name)) name = carma%f_group(igroup)%f_name + if (present(shortname)) shortname = carma%f_group(igroup)%f_shortname + if (present(rmin)) rmin = carma%f_group(igroup)%f_rmin + if (present(rmrat)) rmrat = carma%f_group(igroup)%f_rmrat + if (present(ishape)) ishape = carma%f_group(igroup)%f_ishape + if (present(eshape)) eshape = carma%f_group(igroup)%f_eshape + if (present(is_ice)) is_ice = carma%f_group(igroup)%f_is_ice + if (present(is_fractal)) is_fractal = carma%f_group(igroup)%f_is_fractal + if (present(irhswell)) irhswell = carma%f_group(igroup)%f_irhswell + if (present(irhswcomp)) irhswcomp = carma%f_group(igroup)%f_irhswcomp + if (present(cnsttype)) cnsttype = carma%f_group(igroup)%f_cnsttype + if (present(r)) r(:) = carma%f_group(igroup)%f_r(:) + if (present(rlow)) rlow(:) = carma%f_group(igroup)%f_rlow(:) + if (present(rup)) rup(:) = carma%f_group(igroup)%f_rup(:) + if (present(dr)) dr(:) = carma%f_group(igroup)%f_dr(:) + if (present(rmass)) rmass(:) = carma%f_group(igroup)%f_rmass(:) + if (present(rrat)) rrat(:) = carma%f_group(igroup)%f_rrat(:) + if (present(arat)) arat(:) = carma%f_group(igroup)%f_arat(:) + if (present(rprat)) rprat(:) = carma%f_group(igroup)%f_rprat(:) + if (present(dm)) dm(:) = carma%f_group(igroup)%f_dm(:) + if (present(vol)) vol(:) = carma%f_group(igroup)%f_vol(:) + if (present(do_mie)) do_mie = carma%f_group(igroup)%f_do_mie + if (present(do_wetdep)) do_wetdep = carma%f_group(igroup)%f_do_wetdep + if (present(do_drydep)) do_drydep = carma%f_group(igroup)%f_grp_do_drydep + if (present(do_vtran)) do_vtran = carma%f_group(igroup)%f_grp_do_vtran + if (present(solfac)) solfac = carma%f_group(igroup)%f_solfac + if (present(scavcoef)) scavcoef = carma%f_group(igroup)%f_scavcoef + if (present(ienconc)) ienconc = carma%f_group(igroup)%f_ienconc + if (present(ncore)) ncore = carma%f_group(igroup)%f_ncore + if (present(icorelem)) icorelem = carma%f_group(igroup)%f_icorelem(:) + if (present(maxbin)) maxbin = carma%f_group(igroup)%f_maxbin + if (present(ifallrtn)) ifallrtn = carma%f_group(igroup)%f_ifallrtn + if (present(is_cloud)) is_cloud = carma%f_group(igroup)%f_is_cloud + if (present(rmassmin)) rmassmin = carma%f_group(igroup)%f_rmassmin + if (present(imiertn)) imiertn = carma%f_group(igroup)%f_imiertn + if (present(is_sulfate)) is_sulfate = carma%f_group(igroup)%f_is_sulfate + if (present(dpc_threshold)) dpc_threshold = carma%f_group(igroup)%f_dpc_threshold + if (present(rmon)) rmon = carma%f_group(igroup)%f_rmon + if (present(df)) df(:) = carma%f_group(igroup)%f_df(:) + if (present(nmon)) nmon(:) = carma%f_group(igroup)%f_nmon(:) + if (present(falpha)) falpha = carma%f_group(igroup)%f_falpha + if (present(neutral_volfrc)) neutral_volfrc = carma%f_group(igroup)%f_neutral_volfrc + + if (carma%f_NWAVE == 0) then + if (present(refidx) .or. present(qext) .or. present(ssa) .or. present(asym)) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Get: ERROR no optical properties defined." + rc = RC_ERROR + return + end if + else + if (present(refidx)) refidx(:) = carma%f_group(igroup)%f_refidx(:) + if (present(qext)) qext(:,:) = carma%f_group(igroup)%f_qext(:,:) + if (present(ssa)) ssa(:,:) = carma%f_group(igroup)%f_ssa(:,:) + if (present(asym)) asym(:,:) = carma%f_group(igroup)%f_asym(:,:) + end if + + return + end subroutine CARMAGROUP_Get + + + + !! Prints information about a group. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMAGROUP_Get + subroutine CARMAGROUP_Print(carma, igroup, rc) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: igroup !! the group index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + integer :: i + character(len=CARMA_NAME_LEN) :: name ! name + character(len=CARMA_SHORT_NAME_LEN) :: shortname ! shortname + real(kind=f) :: rmin ! the minimum radius [cm] + real(kind=f) :: rmrat ! the volume ratio between bins + integer :: ishape ! the type of the particle shape + real(kind=f) :: eshape ! the aspect ratio of the particle shape + logical :: is_ice ! is this an ice particle? + logical :: is_fractal ! is this a fractal? + integer :: irhswell ! the parameterization for particle swelling + ! from relative humidity + integer :: irhswcomp ! the composition for particle swelling + ! from relative humidity + integer :: cnsttype ! constituent type in the parent model + real(kind=f) :: r(carma%f_NBIN) ! the bin radius [m] + real(kind=f) :: dr(carma%f_NBIN) ! the bin width in radius space [m] + real(kind=f) :: rmass(carma%f_NBIN) ! the bin mass [kg] + real(kind=f) :: dm(carma%f_NBIN) ! the bin width in mass space [kg] + real(kind=f) :: vol(carma%f_NBIN) ! the bin volume [m3] + integer :: ifallrtn ! fall velocity routine [I_FALLRTN_STD + ! | I_FALLRTN_STD_SHAPE | I_FALLRTN_HEYMSFIELD2010 + ! | I_FALLRTN_ACKERMAN_DROP | I_FALLRTN_ACKERMAN_ICE] + logical :: is_cloud ! is this a cloud particle? + real(kind=f) :: rmassmin ! the minimum mass [g] + logical :: do_mie ! do mie calculations? + logical :: do_wetdep ! do wet deposition for this particle? + logical :: do_drydep ! do dry deposition for this particle? + logical :: do_vtran ! do sedimentation for this particle? + integer :: imiertn ! mie scattering routine + logical :: is_sulfate ! is this a sulfate particle? + real(kind=f) :: dpc_threshold ! convergence criteria for particle concentration + ! [fraction] + real(kind=f) :: neutral_volfrc ! volume fraction of core mass for neutralization + + ! Assume success. + rc = RC_OK + + ! Test out the Get method. + if (carma%f_do_print) then + call CARMAGROUP_Get(carma, igroup, rc, name=name, shortname=shortname, & + rmin=rmin, rmrat=rmrat, ishape=ishape, eshape=eshape, & + is_ice=is_ice, is_fractal=is_fractal, is_cloud=is_cloud, & + irhswell=irhswell, irhswcomp=irhswcomp, cnsttype=cnsttype, & + r=r, dr=dr, rmass=rmass, dm=dm, vol=vol, ifallrtn=ifallrtn, & + rmassmin=rmassmin, do_mie=do_mie, do_wetdep=do_wetdep, & + do_drydep=do_drydep, do_vtran=do_vtran, imiertn=imiertn, & + neutral_volfrc=neutral_volfrc) + if (rc < 0) return + + + write(carma%f_LUNOPRT,*) " name : ", trim(name) + write(carma%f_LUNOPRT,*) " shortname : ", trim(shortname) + write(carma%f_LUNOPRT,*) " rmin : ", rmin, " (cm)" + write(carma%f_LUNOPRT,*) " rmassmin : ", rmassmin, " (g)" + write(carma%f_LUNOPRT,*) " rmrat : ", rmrat + write(carma%f_LUNOPRT,*) " dpc_threshold : ", dpc_threshold + + select case(ishape) + case (I_SPHERE) + write(carma%f_LUNOPRT,*) " ishape : spherical" + case (I_HEXAGON) + write(carma%f_LUNOPRT,*) " ishape : hexagonal" + case (I_CYLINDER) + write(carma%f_LUNOPRT,*) " ishape : cylindrical" + case default + write(carma%f_LUNOPRT,*) " ishape : unknown, ", ishape + end select + + write(carma%f_LUNOPRT,*) " eshape : ", eshape + write(carma%f_LUNOPRT,*) " is_ice : ", is_ice + write(carma%f_LUNOPRT,*) " is_fractal : ", is_fractal + write(carma%f_LUNOPRT,*) " is_cloud : ", is_cloud + write(carma%f_LUNOPRT,*) " is_sulfate : ", is_sulfate + + write(carma%f_LUNOPRT,*) " do_drydep : ", do_drydep + write(carma%f_LUNOPRT,*) " do_mie : ", do_mie + write(carma%f_LUNOPRT,*) " do_vtran : ", do_vtran + write(carma%f_LUNOPRT,*) " do_wetdep : ", do_wetdep + write(carma%f_LUNOPRT,*) " neutral_volfrc: ", neutral_volfrc + + select case(irhswell) + case (0) + write(carma%f_LUNOPRT,*) " irhswell : none" + case (I_FITZGERALD) + write(carma%f_LUNOPRT,*) " irhswell : Fitzgerald" + case (I_GERBER) + write(carma%f_LUNOPRT,*) " irhswell : Gerber" + case default + write(carma%f_LUNOPRT,*) " irhswell : unknown, ", irhswell + end select + + select case(irhswcomp) + case (0) + write(carma%f_LUNOPRT,*) " irhswcomp : none" + + case (I_SWF_NH42SO4) + write(carma%f_LUNOPRT,*) " irhswcomp : (NH4)2SO4 (Fitzgerald)" + case (I_SWF_NH4NO3) + write(carma%f_LUNOPRT,*) " irhswcomp : NH4NO3 (Fitzgerald)" + case (I_SWF_NANO3) + write(carma%f_LUNOPRT,*) " irhswcomp : NaNO3 (Fitzgerald)" + case (I_SWF_NH4CL) + write(carma%f_LUNOPRT,*) " irhswcomp : NH4Cl (Fitzgerald)" + case (I_SWF_CACL2) + write(carma%f_LUNOPRT,*) " irhswcomp : CaCl2 (Fitzgerald)" + case (I_SWF_NABR) + write(carma%f_LUNOPRT,*) " irhswcomp : NaBr (Fitzgerald)" + case (I_SWF_NACL) + write(carma%f_LUNOPRT,*) " irhswcomp : NaCl (Fitzgerald)" + case (I_SWF_MGCL2) + write(carma%f_LUNOPRT,*) " irhswcomp : MgCl2 (Fitzgerald)" + case (I_SWF_LICL) + write(carma%f_LUNOPRT,*) " irhswcomp : LiCl (Fitzgerald)" + + case (I_SWG_NH42SO4) + write(carma%f_LUNOPRT,*) " irhswcomp : (NH4)2SO4 (Gerber)" + case (I_SWG_RURAL) + write(carma%f_LUNOPRT,*) " irhswcomp : Rural (Gerber)" + case (I_SWG_SEA_SALT) + write(carma%f_LUNOPRT,*) " irhswcomp : Sea Salt (Gerber)" + case (I_SWG_URBAN) + write(carma%f_LUNOPRT,*) " irhswcomp : Urban (Gerber)" + + case default + write(carma%f_LUNOPRT,*) " irhswell : unknown, ", irhswcomp + end select + + select case(cnsttype) + case (0) + write(carma%f_LUNOPRT,*) " cnsttype : none" + case (I_CNSTTYPE_PROGNOSTIC) + write(carma%f_LUNOPRT,*) " cnsttype : prognostic" + case (I_CNSTTYPE_DIAGNOSTIC) + write(carma%f_LUNOPRT,*) " cnsttype : diagnostic" + case default + write(carma%f_LUNOPRT,*) " cnsttype : unknown, ", cnsttype + end select + + select case(ifallrtn) + case (I_FALLRTN_STD) + write(carma%f_LUNOPRT,*) " ifallrtn : standard" + case (I_FALLRTN_STD_SHAPE) + write(carma%f_LUNOPRT,*) " ifallrtn : standard (shape)" + case (I_FALLRTN_HEYMSFIELD2010) + write(carma%f_LUNOPRT,*) " ifallrtn : Heymsfield & Westbrook, 2010" + case default + write(carma%f_LUNOPRT,*) " ifallrtn : unknown, ", ifallrtn + end select + + select case(imiertn) + case (I_MIERTN_TOON1981) + write(carma%f_LUNOPRT,*) " imiertn : Toon & Ackerman, 1981" + case (I_MIERTN_BOHREN1983) + write(carma%f_LUNOPRT,*) " imiertn : Bohren & Huffman, 1983" + case (I_MIERTN_BOTET1997) + write(carma%f_LUNOPRT,*) " imiertn : Botet, Rannou & Cabane, 1997" + case default + write(carma%f_LUNOPRT,*) " imiertn : unknown, ", imiertn + end select + + write(carma%f_LUNOPRT,*) + write(carma%f_LUNOPRT,"(' ', a4, 5a12)") "bin", "r", "dr", "rmass", "dm", "vol" + write(carma%f_LUNOPRT,"(' ', a4, 5a12)") "", "(cm)", "(cm)", "(g)", "(g)", "(cm3)" + + do i = 1, carma%f_NBIN + write(carma%f_LUNOPRT, "(' ', i4, 5g12.3)") i, r(i), dr(i), rmass(i), dm(i), vol(i) + end do + end if + + return + end subroutine CARMAGROUP_Print + + !! Sets information about a group. + !! + !! Group optical properties may not be set by the CARMA initialization and + !! may instead be specified by an outside source (e.g. read in from a file). + !! + !! @author Chuck Bardeen + !! @version May-2013 + !! + !! @see CARMAGROUP_Create + !! @see CARMA_GetGroup + !! @see CARMA_Initialize + subroutine CARMAGROUP_Set(carma, igroup, rc, qext, ssa, asym) + + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: igroup !! the group index + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), intent(in), optional :: qext(carma%f_NWAVE,carma%f_NBIN) !! extinction efficiency + real(kind=f), intent(in), optional :: ssa(carma%f_NWAVE,carma%f_NBIN) !! single scattering albedo + real(kind=f), intent(in), optional :: asym(carma%f_NWAVE,carma%f_NBIN) !! asymmetry factor + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough groups allocated. + if (igroup > carma%f_NGROUP) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Set:: ERROR - The specifed group (", & + igroup, ") is larger than the number of groups (", carma%f_NGROUP, ")." + rc = RC_ERROR + return + end if + + ! Set any requested properties of the group. + if (carma%f_NWAVE == 0) then + if (present(qext) .or. present(ssa) .or. present(asym)) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMAGROUP_Get: ERROR no optical properties defined." + rc = RC_ERROR + return + end if + else + if (present(qext)) carma%f_group(igroup)%f_qext(:,:) = qext(:,:) + if (present(ssa)) carma%f_group(igroup)%f_ssa(:,:) = ssa(:,:) + if (present(asym)) carma%f_group(igroup)%f_asym(:,:) = asym(:,:) + end if + + return + end subroutine CARMAGROUP_Set + +end module diff --git a/src/physics/carma/base/carmasolute_mod.F90 b/src/physics/carma/base/carmasolute_mod.F90 new file mode 100644 index 0000000000..17274f579b --- /dev/null +++ b/src/physics/carma/base/carmasolute_mod.F90 @@ -0,0 +1,176 @@ +!! The CARMASOLUTE module contains configuration information about a solute used by CARMA. +!! +!! @version May-2009 +!! @author Chuck Bardeen +module carmasolute_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! CARMA explicitly declares all variables. + implicit none + + ! All CARMA variables and procedures are private except those explicitly declared to be public. + private + + ! Declare the public methods. + public CARMASOLUTE_Create + public CARMASOLUTE_Destroy + public CARMASOLUTE_Get + public CARMASOLUTE_Print + +contains + + !! Defines a solute used by CARMA for nucleation and growth of cloud and + !! aerosol particles. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMA_AddGas + !! @see CARMASOLUTE_Destroy + subroutine CARMASOLUTE_Create(carma, isolute, name, ions, wtmol, rho, rc, shortname) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: isolute !! the solute index + character(*), intent(in) :: name !! the solute name, maximum of 255 characters + integer, intent(in) :: ions !! Number of ions solute dissociates into + real(kind=f), intent(in) :: wtmol !! the solute molecular weight [g/mol] + real(kind=f), intent(in) :: rho !! Mass density of solute + integer, intent(out) :: rc !! return code, negative indicates failure + character(*), optional, intent(in) :: shortname !! the solute shortname, maximum of 6 characters + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough solutes allocated. + if (isolute > carma%f_NSOLUTE) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMASOLUTE_Create:: ERROR - The specifed solute (", & + isolute, ") is larger than the number of solutes (", carma%f_NSOLUTE, ")." + rc = RC_ERROR + return + end if + + ! Save off the settings. + carma%f_solute(isolute)%f_name = name + carma%f_solute(isolute)%f_ions = ions + carma%f_solute(isolute)%f_wtmol = wtmol + carma%f_solute(isolute)%f_rho = rho + + + ! Defaults for optional parameters + carma%f_solute(isolute)%f_shortname = "" + + ! Set optional parameters. + if (present(shortname)) carma%f_solute(isolute)%f_shortname = shortname + + return + end subroutine CARMASOLUTE_Create + + + !! Deallocates the memory associated with a CARMASOLUTE object. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMASOLUTE_Create + subroutine CARMASOLUTE_Destroy(carma, isolute, rc) + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(in) :: isolute !! the solute index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough solutes allocated. + if (isolute > carma%f_NSOLUTE) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMASOLUTE_Destroy:: ERROR - The specifed solute (", & + isolute, ") is larger than the number of solutes (", carma%f_NSOLUTE, ")." + rc = RC_ERROR + return + end if + + return + end subroutine CARMASOLUTE_Destroy + + + !! Gets information about a solute. + !! + !! The group name and other properties are available after a call to + !! CARMASOLUTE_Create(). + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMASOLUTE_Create + !! @see CARMA_GetGas + subroutine CARMASOLUTE_Get(carma, isolute, rc, name, shortname, ions, wtmol, rho) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: isolute !! the solute index + integer, intent(out) :: rc !! return code, negative indicates failure + character(len=*), optional, intent(out) :: name !! the solute name + character(len=*), optional, intent(out) :: shortname !! the solute short name + integer, optional, intent(out) :: ions !! Number of ions solute dissociates into + real(kind=f), optional, intent(out) :: wtmol !! the solute molecular weight [g/mol] + real(kind=f), optional, intent(out) :: rho !! Mass density of solute + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough solutes allocated. + if (isolute > carma%f_NSOLUTE) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "CARMASOLUTE_Get:: ERROR - The specifed solute (", & + isolute, ") is larger than the number of solutes (", carma%f_NSOLUTE, ")." + rc = RC_ERROR + return + end if + + ! Return any requested properties of the group. + if (present(name)) name = carma%f_solute(isolute)%f_name + if (present(shortname)) shortname = carma%f_solute(isolute)%f_shortname + if (present(ions)) ions = carma%f_solute(isolute)%f_ions + if (present(wtmol)) wtmol = carma%f_solute(isolute)%f_wtmol + if (present(rho)) rho = carma%f_solute(isolute)%f_rho + + return + end subroutine CARMASOLUTE_Get + + + !! Prints information about a solute. + !! + !! @author Chuck Bardeen + !! @version May-2009 + !! + !! @see CARMASOLUTE_Get + subroutine CARMASOLUTE_Print(carma, isolute, rc) + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: isolute !! the solute index + integer, intent(out) :: rc !! return code, negative indicates failure + + ! Local variables + character(len=CARMA_NAME_LEN) :: name !! name + character(len=CARMA_SHORT_NAME_LEN) :: shortname !! shortname + integer :: ions !! Number of ions solute dissociates into + real(kind=f) :: wtmol !! the solute molecular weight [g/mol] + real(kind=f) :: rho !! Mass density of solute + + ! Assume success. + rc = RC_OK + + ! Test out the Get method. + if (carma%f_do_print) then + call CARMASOLUTE_Get(carma, isolute, rc, name=name, shortname=shortname, ions=ions, wtmol=wtmol, rho=rho) + if (rc < 0) return + + + write(carma%f_LUNOPRT,*) " name : ", trim(name) + write(carma%f_LUNOPRT,*) " shortname : ", trim(shortname) + write(carma%f_LUNOPRT,*) " ions : ", ions + write(carma%f_LUNOPRT,*) " wtmol : ", wtmol, " (g/mol)" + write(carma%f_LUNOPRT,*) " rho : ", rho, " (g/cm3)" + end if + + return + end subroutine CARMASOLUTE_Print +end module diff --git a/src/physics/carma/base/carmastate_mod.F90 b/src/physics/carma/base/carmastate_mod.F90 new file mode 100644 index 0000000000..0ce0a4438b --- /dev/null +++ b/src/physics/carma/base/carmastate_mod.F90 @@ -0,0 +1,1672 @@ +!! The CARMA state module contains the atmospheric data for use with the CARMA +!! module. This implementation has been customized to work within other model +!! frameworks. CARMA adds a lot of extra state information (atmospheric +!! properties, fall velocities, coagulation kernels, growth kernels, ...) and +!! thus has a large memory footprint. Because only one column will be operated +!! upon at a time per thread, only one cstate object needs to be instantiated +!! at a time and each cstate object only represents one column. This keeps +!! the memory requirements of CARMA to a minimum. +!! +!! @version Feb-2009 +!! @author Chuck Bardeen, Pete Colarco, Jamie Smith +! +! NOTE: Documentation for this code can be generated automatically using f90doc, +! which is freely available from: +! http://erikdemaine.org/software/f90doc/ +! Comment lines with double comment characters are processed by f90doc, and there are +! some special characters added to the comments to control the documentation process. +! In addition to the special characters mentioned in the f990doc documentation, html +! formatting tags (e.g. , , ...) can also be added to the f90doc +! comments. +module carmastate_mod + + ! This module maps the parents models constants into the constants need by CARMA. + ! NOTE: CARMA constants are in CGS units, while the parent models are typically in + ! MKS units. + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + + ! cstate explicitly declares all variables. + implicit none + + ! All cstate variables and procedures are private except those explicitly + ! declared to be public. + private + + ! Declare the public methods. + public CARMASTATE_Create + public CARMASTATE_CreateFromReference + public CARMASTATE_Destroy + public CARMASTATE_Get + public CARMASTATE_GetBin + public CARMASTATE_GetDetrain + public CARMASTATE_GetGas + public CARMASTATE_GetState + public CARMASTATE_SetBin + public CARMASTATE_SetDetrain + public CARMASTATE_SetGas + public CARMASTATE_SetState + public CARMASTATE_Step + +contains + + ! These are the methods that provide the interface between the parent model and + ! the atmospheric state data of the CARMA microphysical model. There are many other + ! methods that are not in this file that are used to implement the microphysical + ! calculations needed by the CARMA model. These other methods are in effect private + ! methods of the CARMA module, but are in individual files since that is the way that + ! CARMA has traditionally been structured and where users may want to extend or + ! replace code to affect the microphysics. + + !! Create the CARMASTATE object, which contains information about the + !! atmospheric state. Internally, CARMA uses CGS units, but this interface uses + !! MKS units which are more commonly used in parent models. The units and grid + !! orientation depend on the grid type: + !! + !! - igridh + !! - I_CART : Cartesian coordinates, units in [m] + !! - I_LL : Lat/Lon coordinates, units in [degrees] + !! + !! - igridv + !! - I_CART : Cartesian coordinates, units in [m], bottom at NZ=1 + !! - I_SIG : Sigma coordinates, unitless [P/P0], top at NZ=1 + !! - I_HYBRID : Hybrid coordinates, unitless [~P/P0], top at NZ=1 + !! + !! NOTE: The supplied CARMA object should already have been created, configured, + !! and initialized. + !! + !! NOTE: The relative humidity is optional, but needs to be supplied if particles + !! are subject to swelling based upon relative humidity. The specific humdity can + !! can be specified instead. If both are specified, then the realtive humidity is + !! used. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_Create + !! @see CARMA_Initialize + !! @see CARMASTATE_Destroy + subroutine CARMASTATE_Create(cstate, carma_ptr, time, dtime, NZ, igridv, igridh, & + lat, lon, xc, dx, yc, dy, zc, zl, p, pl, t, rc, qh2o, relhum, told, radint) + type(carmastate_type), intent(inout) :: cstate !! the carma state object + type(carma_type), pointer, intent(in) :: carma_ptr !! (in) the carma object + real(kind=f), intent(in) :: time !! the model time [s] + real(kind=f), intent(in) :: dtime !! the timestep size [s] + integer, intent(in) :: NZ !! the number of vertical grid points + integer, intent(in) :: igridv !! vertical grid type + integer, intent(in) :: igridh !! horizontal grid type + real(kind=f), intent(in) :: lat !! latitude at center [degrees north] + real(kind=f), intent(in) :: lon !! longitude at center [degrees east] + real(kind=f), intent(in) :: xc(NZ) !! x at center + real(kind=f), intent(in) :: dx(NZ) !! ix width + real(kind=f), intent(in) :: yc(NZ) !! y at center + real(kind=f), intent(in) :: dy(NZ) !! y width + real(kind=f), intent(in) :: zc(NZ) !! z at center + real(kind=f), intent(in) :: zl(NZ+1) !! z at edge + real(kind=f), intent(in) :: p(NZ) !! pressure at center [Pa] + real(kind=f), intent(in) :: pl(NZ+1) !! presssure at edge [Pa] + real(kind=f), intent(in) :: t(NZ) !! temperature at center [K] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), intent(in) , optional :: qh2o(NZ) !! specific humidity at center [mmr] + real(kind=f), intent(in) , optional :: relhum(NZ) !! relative humidity at center [fraction] + real(kind=f), intent(in) , optional :: told(NZ) !! previous temperature at center [K] + real(kind=f), intent(in) , optional :: radint(NZ,carma_ptr%f_NWAVE) !! radiative intensity [W/m2/sr/cm] + + integer :: iz + real(kind=f) :: rvap + real(kind=f) :: pvap_liq + real(kind=f) :: pvap_ice + real(kind=f) :: gc_cgs + + ! Assume success. + rc = RC_OK + + ! Save the defintion of the number of comonents involved in the microphysics. + cstate%f_carma => carma_ptr + + ! Save the model timing. + cstate%f_time = time + cstate%f_dtime_orig = dtime + cstate%f_dtime = dtime + cstate%f_nretries = 0 + + ! Save the grid dimensions. + cstate%f_NZ = NZ + cstate%f_NZP1 = NZ+1 + + ! Save the grid definition. + cstate%f_igridv = igridv + cstate%f_igridh = igridh + + ! Store away the grid location information. + cstate%f_lat = lat + cstate%f_lon = lon + + ! Allocate all the dynamic variables related to state. + call CARMASTATE_Allocate(cstate, rc) + if (rc < 0) return + + cstate%f_xc(:) = xc(:) + cstate%f_dx(:) = dx(:) + cstate%f_yc(:) = yc(:) + cstate%f_dy(:) = dy(:) + cstate%f_zc(:) = zc(:) + cstate%f_zl(:) = zl(:) + + ! Store away the grid state, doing any necessary unit conversions from MKS to CGS. + cstate%f_p(:) = p(:) * RPA2CGS + cstate%f_pl(:) = pl(:) * RPA2CGS + cstate%f_t(:) = t(:) + + cstate%f_pcd(:,:,:) = 0._f + + if (carma_ptr%f_do_substep) then + if (present(told)) then + cstate%f_told(:) = told + else + if (carma_ptr%f_do_print) write(carma_ptr%f_LUNOPRT,*) "CARMASTATE_Create: Error - Need to specify told when substepping." + rc = RC_ERROR + + return + end if + end if + + ! Calculate the metrics, ... + ! if Cartesian coordinates were specifed, then the units need to be converted + ! from MKS to CGS. + if (cstate%f_igridh == I_CART) then + cstate%f_xc = cstate%f_xc * RM2CGS + cstate%f_dx = cstate%f_dx * RM2CGS + cstate%f_yc = cstate%f_yc * RM2CGS + cstate%f_dy = cstate%f_dy * RM2CGS + end if + + if (cstate%f_igridv == I_CART) then + cstate%f_zc = cstate%f_zc * RM2CGS + cstate%f_zl = cstate%f_zl * RM2CGS + end if + + ! Initialize the state of the atmosphere. + call setupatm(carma_ptr, cstate, carma_ptr%f_do_fixedinit, rc) + if (rc < 0) return + + ! Set the realtive humidity. If necessary, it will be calculated from + ! the specific humidity. + if (present(relhum)) then + cstate%f_relhum(:) = relhum(:) + else if (present(qh2o)) then + + ! Define gas constant for this gas + rvap = RGAS/WTMOL_H2O + + ! Calculate relative humidity + do iz = 1, NZ + call vaporp_h2o_murphy2005(carma_ptr, cstate, iz, rc, pvap_liq, pvap_ice) + if (rc < 0) return + + gc_cgs = qh2o(iz)*cstate%f_rhoa_wet(iz) / (cstate%f_zmet(iz)*cstate%f_xmet(iz)*cstate%f_ymet(iz)) + cstate%f_relhum(iz) = ( gc_cgs * rvap * t(iz)) / pvap_liq + enddo + end if + + ! Need for vertical transport. + ! + ! NOTE: How should these be set? Optional parameters? + if (carma_ptr%f_do_vtran) then + cstate%f_ftoppart(:,:) = 0._f + cstate%f_fbotpart(:,:) = 0._f + cstate%f_pc_topbnd(:,:) = 0._f + cstate%f_pc_botbnd(:,:) = 0._f + end if + + ! Radiative intensity for particle heating. + ! + ! W/m2/sr/cm -> erg/s/cm2/sr/cm + if (carma_ptr%f_do_grow) then + if (present(radint)) cstate%f_radint(:,:) = radint(:,:) * 1e7_f / 1e4_f + end if + + return + end subroutine CARMASTATE_Create + + + !! Create the CARMASTATE object, which contains information about the + !! atmospheric state. + !! + !! This call is similar to CARMASTATE_Create, but differs in that all the + !! initialization happens here based on the the fixed state information provided rather + !! than occurring in CARMASTATE_Step. + !! + !! This call should be done before CARMASTATE_Create when do_fixedinit has been + !! specified. The temperatures and pressures specified here should be the reference + !! state used for all columns, not an actual column from the model. + !! + !! A water vapor profile is optional, but is used whenever either qh2o (preferred) + !! or relhum have been provided. If this is not provided, then initialization will + !! be done on a dry profile. If particle swelling occurs, initialization will be + !! done on the wet radius; however, most of the initialized values will not get + !! recalculated as the wet radius changes. + !! + !! CARMASTATE_Create should still be called again after this call with the actual + !! column of state information from the model. The initialization will be done once + !! from the reference state, but the microphysical calculations will be done on the + !! model state. Multiple CARMASTATE_Create ... CARMASTATE_Step calls can be done + !! before a CARMASTATE_Destroy. This reduces the amount of memory allocations and + !! when used with do_fixedinit, reduces the amount of time spent initializing. + !! + !! @author Chuck Bardeen + !! @version June-2010 + !! @see CARMA_Create + !! @see CARMA_Initialize + !! @see CARMASTATE_Destroy + subroutine CARMASTATE_CreateFromReference(cstate, carma_ptr, time, dtime, NZ, igridv, igridh, & + lat, lon, xc, dx, yc, dy, zc, zl, p, pl, t, rc, qh2o, relhum, qh2so4) + type(carmastate_type), intent(inout) :: cstate !! the carma state object + type(carma_type), pointer, intent(in) :: carma_ptr !! (in) the carma object + real(kind=f), intent(in) :: time !! the model time [s] + real(kind=f), intent(in) :: dtime !! the timestep size [s] + integer, intent(in) :: NZ !! the number of vertical grid points + integer, intent(in) :: igridv !! vertical grid type + integer, intent(in) :: igridh !! horizontal grid type + real(kind=f), intent(in) :: lat !! latitude at center [degrees north] + real(kind=f), intent(in) :: lon !! longitude at center [degrees east] + real(kind=f), intent(in) :: xc(NZ) !! x at center + real(kind=f), intent(in) :: dx(NZ) !! ix width + real(kind=f), intent(in) :: yc(NZ) !! y at center + real(kind=f), intent(in) :: dy(NZ) !! y width + real(kind=f), intent(in) :: zc(NZ) !! z at center + real(kind=f), intent(in) :: zl(NZ+1) !! z at edge + real(kind=f), intent(in) :: p(NZ) !! pressure at center [Pa] + real(kind=f), intent(in) :: pl(NZ+1) !! presssure at edge [Pa] + real(kind=f), intent(in) :: t(NZ) !! temperature at center [K] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), intent(in) , optional :: qh2o(NZ) !! specific humidity at center [mmr] + real(kind=f), intent(in) , optional :: relhum(NZ) !! relative humidity at center [fraction] + real(kind=f), intent(in) , optional :: qh2so4(NZ) !! H2SO4 mass mixing ratio at center [mmr] + + integer :: iz + integer :: igas + real(kind=f) :: rvap + real(kind=f) :: pvap_liq + real(kind=f) :: pvap_ice + real(kind=f) :: gc_cgs + + ! Assume success. + rc = RC_OK + + ! Save the defintion of the number of comonents involved in the microphysics. + cstate%f_carma => carma_ptr + + ! Save the model timing. + cstate%f_time = time + cstate%f_dtime_orig = dtime + cstate%f_dtime = dtime + cstate%f_nretries = 0 + + ! Save the grid dimensions. + cstate%f_NZ = NZ + cstate%f_NZP1 = NZ+1 + + ! Save the grid definition. + cstate%f_igridv = igridv + cstate%f_igridh = igridh + + ! Store away the grid location information. + cstate%f_lat = lat + cstate%f_lon = lon + + ! Allocate all the dynamic variables related to state. + call CARMASTATE_Allocate(cstate, rc) + if (rc < 0) return + + cstate%f_xc(:) = xc(:) + cstate%f_dx(:) = dx(:) + cstate%f_yc(:) = yc(:) + cstate%f_dy(:) = dy(:) + cstate%f_zc(:) = zc(:) + cstate%f_zl(:) = zl(:) + + ! Store away the grid state, doing any necessary unit conversions from MKS to CGS. + cstate%f_p(:) = p(:) * RPA2CGS + cstate%f_pl(:) = pl(:) * RPA2CGS + cstate%f_t(:) = t(:) + + cstate%f_pcd(:,:,:) = 0._f + + ! Calculate the metrics, ... + ! if Cartesian coordinates were specifed, then the units need to be converted + ! from MKS to CGS. + if (cstate%f_igridh == I_CART) then + cstate%f_xc = cstate%f_xc * RM2CGS + cstate%f_dx = cstate%f_dx * RM2CGS + cstate%f_yc = cstate%f_yc * RM2CGS + cstate%f_dy = cstate%f_dy * RM2CGS + end if + + if (cstate%f_igridv == I_CART) then + cstate%f_zc = cstate%f_zc * RM2CGS + cstate%f_zl = cstate%f_zl * RM2CGS + end if + + ! Initialize the state of the atmosphere. + call setupatm(carma_ptr, cstate, .false., rc) + if (rc < 0) return + + ! If the model uses a gas, then set the relative and + ! specific humidities. + if (carma_ptr%f_igash2o /= 0) then + + if (present(qh2o)) then + cstate%f_gc(:, carma_ptr%f_igash2o) = qh2o(:) * cstate%f_rhoa_wet(:) + + ! Define gas constant for this gas + rvap = RGAS/WTMOL_H2O + + ! Calculate relative humidity + do iz = 1, NZ + call vaporp_h2o_murphy2005(carma_ptr, cstate, iz, rc, pvap_liq, pvap_ice) + if (rc < 0) return + + gc_cgs = qh2o(iz) * cstate%f_rhoa_wet(iz) / (cstate%f_zmet(iz)*cstate%f_xmet(iz)*cstate%f_ymet(iz)) + cstate%f_relhum(iz) = (gc_cgs * rvap * t(iz)) / pvap_liq + enddo + + else if (present(relhum)) then + cstate%f_relhum(:) = relhum + + ! Define gas constant for this gas + rvap = RGAS/WTMOL_H2O + + ! Calculate specific humidity + do iz = 1, NZ + call vaporp_h2o_murphy2005(carma_ptr, cstate, iz, rc, pvap_liq, pvap_ice) + if (rc < 0) return + + gc_cgs = (rvap * t(iz)) / (pvap_liq * relhum(iz)) + cstate%f_gc(iz, carma_ptr%f_igash2o) = gc_cgs * & + (cstate%f_zmet(iz)*cstate%f_xmet(iz)*cstate%f_ymet(iz)) / & + cstate%f_rhoa_wet(iz) + enddo + end if + end if + + ! If the model uses sulfuric acid, then set that gas concentration. + if (carma_ptr%f_igash2so4 /= 0) then + if (present(qh2so4)) then + cstate%f_gc(:, carma_ptr%f_igash2so4) = qh2so4(:) * cstate%f_rhoa_wet(:) + end if + end if + + ! Determine the gas supersaturations. + do iz = 1, cstate%f_NZ + do igas = 1, cstate%f_carma%f_NGAS + call supersat(cstate%f_carma, cstate, iz, igas, rc) + if (rc < 0) return + end do + end do + + ! Need for vertical transport. + ! + ! NOTE: How should these be set? Optional parameters? + if (carma_ptr%f_do_vtran) then + cstate%f_ftoppart(:,:) = 0._f + cstate%f_fbotpart(:,:) = 0._f + cstate%f_pc_topbnd(:,:) = 0._f + cstate%f_pc_botbnd(:,:) = 0._f + end if + + + ! Now do the initialization that is normally done in CARMASTATE_Step. However + ! here it is done using the reference atmosphere. + + ! Determine the particle densities. + call rhopart(cstate%f_carma, cstate, rc) + if (rc < 0) return + + ! Save off the wet radius and wet density as reference values to be used + ! later to scale process rates based upon changes to the wet radius and + ! wet density when particle swelling is used. + cstate%f_r_ref(:,:,:) = cstate%f_r_wet(:,:,:) + cstate%f_rhop_ref(:,:,:) = cstate%f_rhop_wet(:,:,:) + + ! If configured for fixed initialization, then we will lose some accuracy + ! in the calculation of the fall velocities, growth kernels, ... and in return + ! will gain a significant performance by not having to initialize as often. + + ! Initialize the vertical transport. + if (cstate%f_carma%f_do_vtran .or. cstate%f_carma%f_do_coag .or. cstate%f_carma%f_do_grow) then + call setupvf(cstate%f_carma, cstate, rc) + + if (cstate%f_carma%f_do_vdiff) then + call setupbdif(cstate%f_carma, cstate, rc) + end if + end if + + ! Intialize the nucleation, growth and evaporation. + if (cstate%f_carma%f_do_grow) then + call setupgrow(cstate%f_carma, cstate, rc) + if (rc < 0) return + + call setupgkern(cstate%f_carma, cstate, rc) + if (rc < 0) return + + call setupnuc(cstate%f_carma, cstate, rc) + if (rc < 0) return + end if + + ! Initialize the coagulation. + if (cstate%f_carma%f_do_coag) then + call setupckern(cstate%f_carma, cstate, rc) + if (rc < 0) return + end if + + return + end subroutine CARMASTATE_CreateFromReference + + + subroutine CARMASTATE_Allocate(cstate, rc) + type(carmastate_type), intent(inout) :: cstate + integer, intent(out) :: rc + + ! Local Variables + integer :: ier + integer :: NZ + integer :: NZP1 + integer :: NGROUP + integer :: NELEM + integer :: NBIN + integer :: NGAS + integer :: NWAVE + + ! Assume success. + rc = RC_OK + + ! Check to see if the arrays are already allocated. If so, just reuse the + ! existing allocations. + + ! Allocate the variables needed for setupatm. + if (.not. (allocated(cstate%f_xmet))) then + + NZ = cstate%f_NZ + NZP1 = cstate%f_NZP1 + NGROUP = cstate%f_carma%f_NGROUP + NELEM = cstate%f_carma%f_NELEM + NBIN = cstate%f_carma%f_NBIN + NGAS = cstate%f_carma%f_NGAS + NWAVE = cstate%f_carma%f_NWAVE + + allocate( & + cstate%f_xmet(NZ), & + cstate%f_ymet(NZ), & + cstate%f_zmet(NZ), & + cstate%f_zmetl(NZP1), & + cstate%f_xc(NZ), & + cstate%f_yc(NZ), & + cstate%f_zc(NZ), & + cstate%f_dx(NZ), & + cstate%f_dy(NZ), & + cstate%f_dz(NZ), & + cstate%f_zl(NZP1), & + cstate%f_pc(NZ,NBIN,NELEM), & + cstate%f_pcd(NZ,NBIN,NELEM), & + cstate%f_pc_surf(NBIN,NELEM), & + cstate%f_sedimentationflux(NBIN,NELEM), & + cstate%f_gc(NZ,NGAS), & + cstate%f_cldfrc(NZ), & + cstate%f_rhcrit(NZ), & + cstate%f_rhop(NZ,NBIN,NGROUP), & + cstate%f_r_wet(NZ,NBIN,NGROUP), & + cstate%f_rlow_wet(NZ,NBIN,NGROUP), & + cstate%f_rup_wet(NZ,NBIN,NGROUP), & + cstate%f_rhop_wet(NZ,NBIN,NGROUP), & + cstate%f_r_ref(NZ,NBIN,NGROUP), & + cstate%f_rhop_ref(NZ,NBIN,NGROUP), & + cstate%f_rhoa(NZ), & + cstate%f_rhoa_wet(NZ), & + cstate%f_t(NZ), & + cstate%f_p(NZ), & + cstate%f_pl(NZP1), & + cstate%f_relhum(NZ), & + cstate%f_wtpct(NZ), & + cstate%f_rmu(NZ), & + cstate%f_thcond(NZ), & + cstate%f_thcondnc(NZ,NBIN,NGROUP), & + cstate%f_dpc_sed(NBIN,NELEM), & + cstate%f_pconmax(NZ,NGROUP), & + cstate%f_pcl(NZ,NBIN,NELEM), & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + &ERROR allocating atmosphere arrays, status=", ier + end if + rc = RC_ERROR + return + end if + + cstate%f_relhum(:) = 0._f + cstate%f_pc(:,:,:) = 0._f + cstate%f_pcd(:,:,:) = 0._f + cstate%f_pc_surf(:,:) = 0._f + cstate%f_sedimentationflux(:,:) = 0._f + cstate%f_cldfrc(:) = 1._f + cstate%f_rhcrit(:) = 1._f + + ! Allocate the last fields if they are needed for substepping. + if (cstate%f_carma%f_do_substep) then + allocate( & + cstate%f_gcl(NZ,NGAS), & + cstate%f_d_gc(NZ,NGAS), & + cstate%f_told(NZ), & + cstate%f_d_t(NZ), & + cstate%f_zsubsteps(NZ), & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + &ERROR allocating stepping arrays, status=", ier + end if + rc = RC_ERROR + return + endif + + ! Initialize + cstate%f_gcl(:,:) = 0._f + cstate%f_d_gc(:,:) = 0._f + cstate%f_told(:) = 0._f + cstate%f_d_t(:) = 0._f + cstate%f_zsubsteps(:) = 0._f + + ! When substepping is enabled, we want to initialize these statistics once for + ! the life of the object. + cstate%f_max_nsubstep = 0 + cstate%f_max_nretry = 0._f + cstate%f_nstep = 0._f + cstate%f_nsubstep = 0 + cstate%f_nretry = 0._f + endif + + + ! Allocate the variables needed for setupvf. + ! + ! NOTE: Coagulation and dry deposition also need bpm, vf and re. + if (cstate%f_carma%f_do_vtran .or. cstate%f_carma%f_do_coag .or. & + cstate%f_carma%f_do_grow .or. cstate%f_carma%f_do_drydep) then + allocate( & + cstate%f_bpm(NZ,NBIN,NGROUP), & + cstate%f_vf(NZP1,NBIN,NGROUP), & + cstate%f_re(NZ,NBIN,NGROUP), & + cstate%f_dkz(NZP1,NBIN,NGROUP), & + cstate%f_ftoppart(NBIN,NELEM), & + cstate%f_fbotpart(NBIN,NELEM), & + cstate%f_pc_topbnd(NBIN,NELEM), & + cstate%f_pc_botbnd(NBIN,NELEM), & + cstate%f_vd(NBIN, NGROUP), & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + &ERROR allocating vertical transport arrays, status=", ier + end if + rc = RC_ERROR + return + endif + + ! Initialize + cstate%f_bpm(:,:,:) = 0._f + cstate%f_vf(:,:,:) = 0._f + cstate%f_re(:,:,:) = 0._f + cstate%f_dkz(:,:,:) = 0._f + cstate%f_ftoppart(:,:) = 0._f + cstate%f_fbotpart(:,:) = 0._f + cstate%f_pc_topbnd(:,:) = 0._f + cstate%f_pc_botbnd(:,:) = 0._f + cstate%f_vd(:, :) = 0._f + end if + + + + if (cstate%f_carma%f_NGAS > 0) then + allocate( & + cstate%f_pvapl(NZ,NGAS), & + cstate%f_pvapi(NZ,NGAS), & + cstate%f_supsatl(NZ,NGAS), & + cstate%f_supsati(NZ,NGAS), & + cstate%f_supsatlold(NZ,NGAS), & + cstate%f_supsatiold(NZ,NGAS), & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + ERROR allocating gas arrays, status=", ier + end if + rc = RC_ERROR + return + endif + end if + + + if (cstate%f_carma%f_do_grow) then + allocate( & + cstate%f_diffus(NZ,NGAS), & + cstate%f_rlhe(NZ,NGAS), & + cstate%f_rlhm(NZ,NGAS), & + cstate%f_surfctwa(NZ), & + cstate%f_surfctiw(NZ), & + cstate%f_surfctia(NZ), & + cstate%f_akelvin(NZ,NGAS), & + cstate%f_akelvini(NZ,NGAS), & + cstate%f_ft(NZ,NBIN,NGROUP), & + cstate%f_gro(NZ,NBIN,NGROUP), & + cstate%f_gro1(NZ,NBIN,NGROUP), & + cstate%f_gro2(NZ,NGROUP), & + cstate%f_scrit(NZ,NBIN,NGROUP), & + cstate%f_rnuclg(NBIN,NGROUP,NGROUP),& + cstate%f_rhompe(NBIN,NELEM), & + cstate%f_rnucpe(NBIN,NELEM), & + cstate%f_pc_nucl(NZ,NBIN,NELEM), & + cstate%f_growpe(NBIN,NELEM), & + cstate%f_evappe(NBIN,NELEM), & + cstate%f_evcore(NELEM), & + cstate%f_growlg(NBIN,NGROUP), & + cstate%f_evaplg(NBIN,NGROUP), & + cstate%f_gasprod(NGAS), & + cstate%f_rlheat(NZ), & + cstate%f_radint(NZ,NWAVE), & + cstate%f_partheat(NZ), & + cstate%f_dtpart(NZ,NBIN,NGROUP), & + cstate%f_cmf(NBIN,NGROUP), & + cstate%f_totevap(NBIN,NGROUP), & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + &ERROR allocating growth arrays, status=", ier + end if + rc = RC_ERROR + return + endif + + cstate%f_radint(:,:) = 0._f + end if + + if (cstate%f_carma%f_do_coag) then + allocate( & + cstate%f_coaglg(NZ,NBIN,NGROUP), & + cstate%f_coagpe(NZ,NBIN,NELEM), & + cstate%f_ckernel(NZ,NBIN,NBIN,NGROUP,NGROUP), & + stat = ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Allocate::& + &ERROR allocating coag arrays, status=", ier + end if + rc = RC_ERROR + return + end if + + ! Initialize + cstate%f_coaglg(:,:,:) = 0._f + cstate%f_coagpe(:,:,:) = 0._f + cstate%f_ckernel(:,:,:,:,:) = 0._f + end if + end if + + return + end subroutine CARMASTATE_Allocate + + + !! The routine should be called when the carma state object is no longer needed. + !! It deallocates any memory allocations made by CARMA during CARMASTATE_Create(), + !! and failure to call this routine could result in memory leaks. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMASTATE_Create + subroutine CARMASTATE_Destroy(cstate, rc) + type(carmastate_type), intent(inout) :: cstate + integer, intent(out) :: rc + + ! Local variables + integer :: ier + + ! Assume success. + rc = RC_OK + + ! Check to see if the arrays are already allocated. If so, deallocate them. + + ! Allocate the variables needed for setupatm. + if (allocated(cstate%f_xmet)) then + + deallocate( & + cstate%f_xmet, & + cstate%f_ymet, & + cstate%f_zmet, & + cstate%f_zmetl, & + cstate%f_xc, & + cstate%f_yc, & + cstate%f_zc, & + cstate%f_dx, & + cstate%f_dy, & + cstate%f_dz, & + cstate%f_zl, & + cstate%f_pc, & + cstate%f_pcd, & + cstate%f_pc_surf, & + cstate%f_sedimentationflux, & + cstate%f_gc, & + cstate%f_cldfrc, & + cstate%f_rhcrit, & + cstate%f_rhop, & + cstate%f_r_wet, & + cstate%f_rlow_wet, & + cstate%f_rup_wet, & + cstate%f_rhop_wet, & + cstate%f_r_ref, & + cstate%f_rhop_ref, & + cstate%f_rhoa, & + cstate%f_rhoa_wet, & + cstate%f_t, & + cstate%f_p, & + cstate%f_pl, & + cstate%f_relhum, & + cstate%f_wtpct, & + cstate%f_rmu, & + cstate%f_thcond, & + cstate%f_thcondnc, & + cstate%f_dpc_sed, & + cstate%f_pconmax, & + cstate%f_pcl, & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating atmosphere arrays, status=", ier + end if + rc = RC_ERROR + return + end if + + ! Allocate the last fields if they are needed for substepping stepping. + if (allocated(cstate%f_gcl)) then + deallocate( & + cstate%f_gcl, & + cstate%f_d_gc, & + cstate%f_told, & + cstate%f_d_t, & + cstate%f_zsubsteps, & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating stepping arrays, status=", ier + end if + rc = RC_ERROR + return + endif + endif + + ! Allocate the variables needed for setupvf. + ! + ! NOTE: Coagulation also needs bpm, vf and re. + if (allocated(cstate%f_bpm)) then + deallocate( & + cstate%f_bpm, & + cstate%f_vf, & + cstate%f_re, & + cstate%f_dkz, & + cstate%f_ftoppart, & + cstate%f_fbotpart, & + cstate%f_pc_topbnd, & + cstate%f_pc_botbnd, & + cstate%f_vd, & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating vertical transport arrays, status=", ier + end if + rc = RC_ERROR + return + endif + end if + + if (allocated(cstate%f_diffus)) then + deallocate( & + cstate%f_diffus, & + cstate%f_rlhe, & + cstate%f_rlhm, & + cstate%f_surfctwa, & + cstate%f_surfctiw, & + cstate%f_surfctia, & + cstate%f_akelvin, & + cstate%f_akelvini, & + cstate%f_ft, & + cstate%f_gro, & + cstate%f_gro1, & + cstate%f_gro2, & + cstate%f_scrit, & + cstate%f_rnuclg,& + cstate%f_rnucpe, & + cstate%f_rhompe, & + cstate%f_pc_nucl, & + cstate%f_growpe, & + cstate%f_evappe, & + cstate%f_evcore, & + cstate%f_growlg, & + cstate%f_evaplg, & + cstate%f_gasprod, & + cstate%f_rlheat, & + cstate%f_radint, & + cstate%f_partheat, & + cstate%f_dtpart, & + cstate%f_cmf, & + cstate%f_totevap, & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating growth arrays, status=", ier + end if + rc = RC_ERROR + return + endif + end if + + if (allocated(cstate%f_pvapl)) then + deallocate( & + cstate%f_pvapl, & + cstate%f_pvapi, & + cstate%f_supsatl, & + cstate%f_supsati, & + cstate%f_supsatlold, & + cstate%f_supsatiold, & + stat=ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating gas arrays, status=", ier + end if + rc = RC_ERROR + return + endif + end if + + if (allocated(cstate%f_coaglg)) then + deallocate( & + cstate%f_coaglg, & + cstate%f_coagpe, & + cstate%f_ckernel, & + stat = ier) + if (ier /= 0) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Destroy::& + &ERROR deallocating coag arrays, status=", ier + end if + rc = RC_ERROR + return + end if + end if + end if + + return + end subroutine CARMASTATE_Destroy + + + !! The routine performs the main CARMA processing for one timestep of + !! the parent model. The state variables should have all been set before + !! calling CARMASTATE_Step(). When this routine returns, the state will + !! have been updated to reflect the changes from the CARMA microphysics. + !! If tendencies are desired, then the difference between the final and + !! initial state will need to be computed by the caller. + !! + !! NIOTE: xxxfv, xxxram and xxxfrac need to be specified for dry deposition. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + subroutine CARMASTATE_Step(cstate, rc, cldfrc, rhcrit, lndfv, ocnfv, icefv, lndram, ocnram, iceram, lndfrac, ocnfrac, icefrac) + type(carmastate_type), intent(inout) :: cstate + integer, intent(out) :: rc + real(kind=f), intent(in), optional :: cldfrc(cstate%f_NZ) !! cloud fraction [fraction] + real(kind=f), intent(in), optional :: rhcrit(cstate%f_NZ) !! relative humidity for onset of liquid clouds [fraction] + real(kind=f), intent(in), optional :: lndfv !! the surface friction velocity over land [m/s] + real(kind=f), intent(in), optional :: ocnfv !! the surface friction velocity over ocean [m/s] + real(kind=f), intent(in), optional :: icefv !! the surface friction velocity over ice [m/s] + real(kind=f), intent(in), optional :: lndram !! the aerodynamic resistance over land [s/m] + real(kind=f), intent(in), optional :: ocnram !! the aerodynamic resistance over ocean [s/m] + real(kind=f), intent(in), optional :: iceram !! the aerodynamic resistance over ice [s/m] + real(kind=f), intent(in), optional :: lndfrac !! land fraction + real(kind=f), intent(in), optional :: ocnfrac !! ocn fraction + real(kind=f), intent(in), optional :: icefrac !! ice fraction + + + integer :: iz ! vertical index + integer :: igas ! gas index + integer :: ielem + integer :: ibin + integer :: igroup + logical :: swelling ! Do any groups undergo partcile swelling? + integer :: i1, i2, j1, j2 + + ! Assume success. + rc = RC_OK + + ! Store the cloud fraction if specified + cstate%f_cldfrc(:) = 1._f + cstate%f_rhcrit(:) = 1._f + + if (present(cldfrc)) cstate%f_cldfrc(:) = cldfrc(:) + if (present(rhcrit)) cstate%f_rhcrit(:) = rhcrit(:) + + ! Determine the gas supersaturations. + do iz = 1, cstate%f_NZ + do igas = 1, cstate%f_carma%f_NGAS + call supersat(cstate%f_carma, cstate, iz, igas, rc) + if (rc < 0) return + end do + end do + + ! Determine the particle densities. + call rhopart(cstate%f_carma, cstate, rc) + if (rc < 0) return + + + ! We have to hold off initialization until now, because the particle density + ! (rhop) can not be determined until the particle masses are known (i.e. after + ! CARMASTATE_SetBin), because rhop is used to determine the fall velocity. + ! + ! NOTE: If configured for fixed initialization, then we will lose some accuracy + ! in the calculation of the fall velocities, growth kernels, ... and in return + ! will gain a significant performance by not having to initialize as often. + ! + ! NOTE: If configured for partial initialized in conjunction with fixed + ! initialization, then do the fall velocity (and growth) initialization which + ! is relatively quick, but skip the recalculation of the coagulation kernels + ! which is relatively expensive. This could be useful for particles that have + ! a wet radius that is different from the dry radius or where there are large + ! changes from the average conditions (temperature, water vapor, ...) used in + ! the fixed initialization. + if ((.not. cstate%f_carma%f_do_fixedinit) .or. & + (cstate%f_carma%f_do_partialinit)) then + + ! Initialize the vertical transport. + if (cstate%f_carma%f_do_vtran .or. cstate%f_carma%f_do_coag .or. cstate%f_carma%f_do_grow) then + call setupvf(cstate%f_carma, cstate, rc) + + if (cstate%f_carma%f_do_vdiff) then + call setupbdif(cstate%f_carma, cstate, rc) + end if + end if + + ! Initialize the nucleation, growth and evaporation. + if (cstate%f_carma%f_do_grow) then + call setupgrow(cstate%f_carma, cstate, rc) + if (rc < RC_OK) return + + call setupgkern(cstate%f_carma, cstate, rc) + if (rc < RC_OK) return + + call setupnuc(cstate%f_carma, cstate, rc) + if (rc < RC_OK) return + end if + + ! Initialize the coagulation. + if (cstate%f_carma%f_do_coag .and. & + (.not. cstate%f_carma%f_do_fixedinit)) then + call setupckern(cstate%f_carma, cstate, rc) + if (rc < RC_OK) return + end if + end if + + ! Initialize the dry deposition + ! + ! NOTE: This is tied to the surface fields that vary from column to column, + ! so it needs to get calculated here whether using fixed or full initialization. + if (cstate%f_carma%f_do_drydep) then + if (present(lndfv) .and. present(lndram) .and. present(lndfrac) .and. & + present(ocnfv) .and. present(ocnram) .and. present(ocnfrac) .and. & + present(icefv) .and. present(iceram) .and. present(icefrac)) then + + ! NOTE: Need to convert surfric and ram from mks to cgs units. + call setupvdry(cstate%f_carma, cstate, & + lndfv * 100._f, ocnfv * 100._f, icefv * 100._f, & + lndram / 100._f, ocnram / 100._f, iceram / 100._f, & + lndfrac, ocnfrac, icefrac, rc) + if (rc < RC_OK) return + else + write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_Step: & + &do_drydep requires that the optional inputs xxxfv, xxxram & + &and xxxfrac be provided." + rc = RC_ERROR + return + end if + end if + + ! Calculate the impact of microphysics upon the state. + call step(cstate%f_carma, cstate, rc) + + return + end subroutine CARMASTATE_Step + + + ! Query, Control and State I/O + + !! Gets the mass mixing ratio for the gas (igas). After a call to CARMA_Step(), + !! the new mass mixing ratio of the gas can be retrieved. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddGas + !! @see CARMA_GetGas + !! @see CARMA_Step + !! @see CARMASTATE_SetGas + subroutine CARMASTATE_Get(cstate, rc, max_nsubstep, max_nretry, nstep, nsubstep, nretry, zsubsteps, lat, lon) + type(carmastate_type), intent(in) :: cstate !! the carma state object + integer, intent(out) :: rc !! return code, negative indicates failure + integer, optional, intent(out) :: max_nsubstep !! maximum number of substeps in a step + real(kind=f), optional, intent(out) :: max_nretry !! maximum number of retries in a step + real(kind=f), optional, intent(out) :: nstep !! total number of steps taken + integer, optional, intent(out) :: nsubstep !! total number of substeps taken + real(kind=f), optional, intent(out) :: nretry !! total number of retries taken + real(kind=f), optional, intent(out) :: zsubsteps(cstate%f_NZ) !! number of substeps taken per vertical grid point + real(kind=f), optional, intent(out) :: lat !! grid center latitude [deg] + real(kind=f), optional, intent(out) :: lon !! grid center longitude [deg] + + ! Assume success. + rc = RC_OK + + if (present(max_nsubstep)) max_nsubstep = cstate%f_max_nsubstep + if (present(max_nretry)) max_nretry = cstate%f_max_nretry + if (present(nstep)) nstep = cstate%f_nstep + if (present(nsubstep)) nsubstep = cstate%f_nsubstep + if (present(nretry)) nretry = cstate%f_nretry + if (present(zsubsteps)) zsubsteps = cstate%f_zsubsteps + if (present(lat)) lat = cstate%f_lat + if (present(lon)) lon = cstate%f_lon + + return + end subroutine CARMASTATE_Get + + + !! Gets the mass of the bins (ibin) for each particle element (ielem). After the + !! CARMA_Step() call, new particle concentrations are determined. The number density + !! and the nucleation rate are only calculated if the element is the number density + !! element for the group. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddElement + !! @see CARMA_AddGroup + !! @see CARMA_Step + !! @see CARMASTATE_SetBin + subroutine CARMASTATE_GetBin(cstate, ielem, ibin, mmr, rc, & + nmr, numberDensity, nucleationRate, r_wet, rhop_wet, & + surface, sedimentationflux, vf, vd, dtpart) + type(carmastate_type), intent(in) :: cstate !! the carma state object + integer, intent(in) :: ielem !! the element index + integer, intent(in) :: ibin !! the bin index + real(kind=f), intent(out) :: mmr(cstate%f_NZ) !! the bin mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code negative indicates failure + real(kind=f), optional, intent(out) :: nmr(cstate%f_NZ) !! number mixing ratio [#/kg] + real(kind=f), optional, intent(out) :: numberDensity(cstate%f_NZ) !! number density [#/cm3] + real(kind=f), optional, intent(out) :: nucleationRate(cstate%f_NZ) !! nucleation rate [1/cm3/s] + real(kind=f), optional, intent(out) :: r_wet(cstate%f_NZ) !! wet particle radius [cm] + real(kind=f), optional, intent(out) :: rhop_wet(cstate%f_NZ) !! wet particle density [g/cm3] + real(kind=f), optional, intent(out) :: surface !! particle mass on the surface [kg/m2] + real(kind=f), optional, intent(out) :: sedimentationflux !! particle sedimentation mass flux to surface [kg/m2/s] + real(kind=f), optional, intent(out) :: vf(cstate%f_NZ+1) !! fall velocity [cm/s] + real(kind=f), optional, intent(out) :: vd !! deposition velocity [cm/s] + real(kind=f), optional, intent(out) :: dtpart(cstate%f_NZ) !! delta particle temperature [K] + + integer :: ienconc !! index of element that is the particle concentration for the group + integer :: igroup ! Group containing this bin + + ! Assume success. + rc = RC_OK + + ! Determine the particle group for the bin. + igroup = cstate%f_carma%f_element(ielem)%f_igroup + + ! Make sure there are enough elements allocated. + if (ielem > cstate%f_carma%f_NELEM) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetBin:: ERROR - The specifed element (", & + ielem, ") is larger than the number of elements (", cstate%f_carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough bins allocated. + if (ibin > cstate%f_carma%f_NBIN) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMA_SetBin:: ERROR - The specifed bin (", & + ibin, ") is larger than the number of bins (", cstate%f_carma%f_NBIN, ")." + rc = RC_ERROR + return + end if + + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the particles in g/x/y/z. + mmr(:) = cstate%f_pc(:, ibin, ielem) / cstate%f_rhoa_wet(:) + + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + mmr(:) = mmr(:) * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + mmr(:) = mmr(:) / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + + ! If the number of particles in the group is less than the minimum value represented + ! by CARMA, then return and mmr of 0.0 for all elements. + ienconc = cstate%f_carma%f_group(igroup)%f_ienconc +! where (cstate%f_pc(:, ibin, ienconc) <= SMALL_PC) mmr(:) = 0.0_f + + + ! Do they also want the mass concentration of particles at the surface? + if (present(surface)) then + + ! Convert from g/cm2 to kg/m2 + surface = cstate%f_pc_surf(ibin, ielem) * 1e4_f / 1e3_f + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + surface = surface * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + surface = surface / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + end if + + ! Do they also want the mass flux of particles that sediment to the surface? + if (present(sedimentationflux)) then + + ! Convert from g/cm2 to kg/m2 + sedimentationflux = cstate%f_sedimentationflux(ibin, ielem) * 1e4_f / 1e3_f + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + sedimentationflux = sedimentationflux * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + sedimentationflux = sedimentationflux / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + end if + + ! If this is the partcile # element, then determine some other statistics. + if (ienconc == ielem) then + if (present(nmr)) nmr(:) = (cstate%f_pc(:, ibin, ielem) / cstate%f_rhoa_wet(:)) * 1000._f + if (present(numberDensity)) numberDensity(:) = cstate%f_pc(:, ibin, ielem) / & + (cstate%f_xmet(:)*cstate%f_ymet(:)*cstate%f_zmet(:)) + if (present(r_wet)) r_wet(:) = cstate%f_r_wet(:, ibin, igroup) + if (present(rhop_wet)) rhop_wet(:) = cstate%f_rhop_wet(:, ibin, igroup) + + if (cstate%f_carma%f_do_vtran) then + if (present(vf)) vf(:) = cstate%f_vf(:, ibin, igroup) * cstate%f_zmetl(:) + else + if (present(vf)) vf(:) = CAM_FILL + end if + + if (cstate%f_carma%f_do_drydep) then + if (present(vd)) then + if (cstate%f_igridv .eq. I_CART) then + vd = cstate%f_vd(ibin, igroup) * cstate%f_zmetl(1) + else + vd = cstate%f_vd(ibin, igroup) * cstate%f_zmetl(cstate%f_NZP1) + end if + end if + else + if (present(vd)) vd = CAM_FILL + end if + + if (cstate%f_carma%f_do_grow) then + if (present(nucleationRate)) nucleationRate(:) = cstate%f_pc_nucl(:, ibin, ielem) / & + (cstate%f_xmet(:)*cstate%f_ymet(:)*cstate%f_zmet(:)) / cstate%f_dtime + else + if (present(nucleationRate)) nucleationRate(:) = CAM_FILL + end if + + if (cstate%f_carma%f_do_pheat) then + if (present(dtpart)) dtpart(:) = cstate%f_dtpart(:, ibin, igroup) + else + if (present(dtpart)) dtpart(:) = CAM_FILL + end if + else + if (present(nmr)) nmr(:) = CAM_FILL + if (present(numberDensity)) numberDensity(:) = CAM_FILL + if (present(nucleationRate)) nucleationRate(:) = CAM_FILL + if (present(r_wet)) r_wet(:) = CAM_FILL + if (present(rhop_wet)) rhop_wet(:) = CAM_FILL + if (present(dtpart)) dtpart(:) = CAM_FILL + if (present(vf)) vf(:) = CAM_FILL + if (present(vd)) vd = CAM_FILL + end if + + return + end subroutine CARMASTATE_GetBin + + + !! Gets the mass of the detrained condensate for the bins (ibin) for each particle + !! element (ielem) in the grid. + !! + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddElement + !! @see CARMA_AddGroup + !! @see CARMA_Step + !! @see CARMASTATE_SetDetrain + subroutine CARMASTATE_GetDetrain(cstate, ielem, ibin, mmr, rc, nmr, numberDensity, r_wet, rhop_wet) + type(carmastate_type), intent(in) :: cstate !! the carma state object + integer, intent(in) :: ielem !! the element index + integer, intent(in) :: ibin !! the bin index + real(kind=f), intent(out) :: mmr(cstate%f_NZ) !! the bin mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code negative indicates failure + real(kind=f), optional, intent(out) :: nmr(cstate%f_NZ) !! number mixing ratio [#/kg] + real(kind=f), optional, intent(out) :: numberDensity(cstate%f_NZ) !! number density [#/cm3] + real(kind=f), optional, intent(out) :: r_wet(cstate%f_NZ) !! wet particle radius [cm] + real(kind=f), optional, intent(out) :: rhop_wet(cstate%f_NZ) !! wet particle density [g/cm3] + + integer :: ienconc !! index of element that is the particle concentration for the group + integer :: igroup ! Group containing this bin + + ! Assume success. + rc = RC_OK + + ! Determine the particle group for the bin. + igroup = cstate%f_carma%f_element(ielem)%f_igroup + + ! Make sure there are enough elements allocated. + if (ielem > cstate%f_carma%f_NELEM) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetDetrain:: ERROR - The specifed element (", & + ielem, ") is larger than the number of elements (", cstate%f_carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough bins allocated. + if (ibin > cstate%f_carma%f_NBIN) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMA_SetDetrainin:: ERROR - The specifed bin (", & + ibin, ") is larger than the number of bins (", cstate%f_carma%f_NBIN, ")." + rc = RC_ERROR + return + end if + + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the particles in g/x/y/z. + mmr(:) = cstate%f_pcd(:, ibin, ielem) / cstate%f_rhoa_wet(:) + + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + mmr(:) = mmr(:) * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + mmr(:) = mmr(:) / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + + ! If this is the partcile # element, then determine some other statistics. + ienconc = cstate%f_carma%f_group(igroup)%f_ienconc + if (ienconc == ielem) then + if (present(nmr)) nmr(:) = (cstate%f_pcd(:, ibin, ielem) / cstate%f_rhoa_wet(:)) * 1000._f + if (present(numberDensity)) numberDensity(:) = cstate%f_pcd(:, ibin, ielem) / & + (cstate%f_xmet(:)*cstate%f_ymet(:)*cstate%f_zmet(:)) + if (present(r_wet)) r_wet(:) = cstate%f_r_wet(:, ibin, igroup) + if (present(rhop_wet)) rhop_wet(:) = cstate%f_rhop_wet(:, ibin, igroup) + else + if (present(nmr)) nmr(:) = CAM_FILL + if (present(numberDensity)) numberDensity(:) = CAM_FILL + end if + + return + end subroutine CARMASTATE_GetDetrain + + + !! Gets the mass mixing ratio for the gas (igas). After a call to CARMA_Step(), + !! the new mass mixing ratio of the gas can be retrieved. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddGas + !! @see CARMA_GetGas + !! @see CARMA_Step + !! @see CARMASTATE_SetGas + subroutine CARMASTATE_GetGas(cstate, igas, mmr, rc, satice, satliq, eqice, eqliq, wtpct) + type(carmastate_type), intent(in) :: cstate !! the carma state object + integer, intent(in) :: igas !! the gas index + real(kind=f), intent(out) :: mmr(cstate%f_NZ) !! the gas mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), optional, intent(out) :: satice(cstate%f_NZ) !! the gas saturation wrt ice + real(kind=f), optional, intent(out) :: satliq(cstate%f_NZ) !! the gas saturation wrt liquid + real(kind=f), optional, intent(out) :: eqice(cstate%f_NZ) !! the gas vapor pressure wrt ice + real(kind=f), optional, intent(out) :: eqliq(cstate%f_NZ) !! the gas vapor pressure wrt liquid + real(kind=f), optional, intent(out) :: wtpct(cstate%f_NZ) !! weight percent aerosol composition + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough gases allocated. + if (igas > cstate%f_carma%f_NGAS) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_GetGas:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", cstate%f_carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the gas in g/x/y/z. + mmr(:) = cstate%f_gc(:, igas) / cstate%f_rhoa_wet(:) + + if (present(satice)) satice(:) = cstate%f_supsati(:, igas) + 1._f + if (present(satliq)) satliq(:) = cstate%f_supsatl(:, igas) + 1._f + if (present(eqice)) eqice(:) = cstate%f_pvapi(:, igas) / cstate%f_p(:) + if (present(eqliq)) eqliq(:) = cstate%f_pvapl(:, igas) / cstate%f_p(:) + if (present(wtpct)) wtpct(:) = cstate%f_wtpct(:) + + return + end subroutine CARMASTATE_GetGas + + + !! Gets information about the state of the atmosphere. After the CARMA_Step() call, + !! a new atmospheric state is determined. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_Step + !! @see CARMASTATE_Create + subroutine CARMASTATE_GetState(cstate, rc, t, p, rhoa_wet, rlheat) + type(carmastate_type), intent(in) :: cstate !! the carma state object + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), optional, intent(out) :: t(cstate%f_NZ) !! the air temperature [K] + real(kind=f), optional, intent(out) :: p(cstate%f_NZ) !! the air pressure [Pa] + real(kind=f), optional, intent(out) :: rhoa_wet(cstate%f_NZ) !! air density [kg m-3] + real(kind=f), optional, intent(out) :: rlheat(cstate%f_NZ) !! latent heat [K/s] + + ! Assume success. + rc = RC_OK + + ! Return the temperature, pressure, and/or density. + if (present(t)) t(:) = cstate%f_t(:) + + ! DYNE -> Pa + if (present(p)) p(:) = cstate%f_p(:) / RPA2CGS + + ! Convert rhoa from the scaled units to mks. + if (present(rhoa_wet)) rhoa_wet(:) = (cstate%f_rhoa_wet(:) / & + (cstate%f_zmet(:)*cstate%f_xmet(:)*cstate%f_ymet(:))) * 1e6_f / 1e3_f + + if (present(rlheat)) rlheat(:) = cstate%f_rlheat(:) + + return + end subroutine CARMASTATE_GetState + + + !! Sets the mass of the bins (ibin) for each particle element (ielem) in the grid. + !! This call should be made after CARMASTATE_Create() and before CARMA_Step(). + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddBin + !! @see CARMA_Step + !! @see CARMASTATE_GetBin + subroutine CARMASTATE_SetBin(cstate, ielem, ibin, mmr, rc, surface) + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: ielem !! the element index + integer, intent(in) :: ibin !! the bin index + real(kind=f), intent(in) :: mmr(cstate%f_NZ) !! the bin mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), optional, intent(in) :: surface !! particles mass on the surface [kg/m2] + + integer :: igroup ! Group containing this bin + + ! Assume success. + rc = RC_OK + + ! Determine the particle group for the bin. + igroup = cstate%f_carma%f_element(ielem)%f_igroup + + ! Make sure there are enough elements allocated. + if (ielem > cstate%f_carma%f_NELEM) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetBin:: ERROR - The specifed element (", & + ielem, ") is larger than the number of elements (", cstate%f_carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough bins allocated. + if (ibin > cstate%f_carma%f_NBIN) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetBin:: ERROR - The specifed bin (", & + ibin, ") is larger than the number of bins (", cstate%f_carma%f_NBIN, ")." + rc = RC_ERROR + return + end if + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the particles in g/x/y/z. + cstate%f_pc(:, ibin, ielem) = mmr(:) * cstate%f_rhoa_wet(:) + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + cstate%f_pc(:, ibin, ielem) = cstate%f_pc(:, ibin, ielem) / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + cstate%f_pc(:, ibin, ielem) = cstate%f_pc(:, ibin, ielem) * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + + ! If they specified an initial mass of particles on the surface, then use that + ! value. + if (present(surface)) then + + ! Convert from g/cm2 to kg/m2 + cstate%f_pc_surf(ibin, ielem) = surface / 1e4_f * 1e3_f + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + cstate%f_pc_surf(ibin, ielem) = cstate%f_pc_surf(ibin, ielem) / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + cstate%f_pc_surf(ibin, ielem) = cstate%f_pc_surf(ibin, ielem) * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + else + cstate%f_pc_surf(ibin, ielem) = 0.0_f + end if + + return + end subroutine CARMASTATE_SetBin + + + !! Sets the mass of the detrained condensate for the bins (ibin) for each particle + !! element (ielem) in the grid. This call should be made after CARMASTATE_Create() + !! and before CARMA_Step(). + !! + !! @author Chuck Bardeen + !! @version May-2010 + !! @see CARMA_AddBin + !! @see CARMA_Step + !! @see CARMASTATE_GetDetrain + subroutine CARMASTATE_SetDetrain(cstate, ielem, ibin, mmr, rc) + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: ielem !! the element index + integer, intent(in) :: ibin !! the bin index + real(kind=f), intent(in) :: mmr(cstate%f_NZ) !! the bin mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code, negative indicates failure + + integer :: igroup ! Group containing this bin + + ! Assume success. + rc = RC_OK + + ! Determine the particle group for the bin. + igroup = cstate%f_carma%f_element(ielem)%f_igroup + + ! Make sure there are enough elements allocated. + if (ielem > cstate%f_carma%f_NELEM) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetDetrain:: ERROR - The specifed element (", & + ielem, ") is larger than the number of elements (", cstate%f_carma%f_NELEM, ")." + rc = RC_ERROR + return + end if + + ! Make sure there are enough bins allocated. + if (ibin > cstate%f_carma%f_NBIN) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetDetrain:: ERROR - The specifed bin (", & + ibin, ") is larger than the number of bins (", cstate%f_carma%f_NBIN, ")." + rc = RC_ERROR + return + end if + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the particles in g/x/y/z. + cstate%f_pcd(:, ibin, ielem) = mmr(:) * cstate%f_rhoa_wet(:) + + ! Handle the special cases for different types of elements ... + if ((cstate%f_carma%f_element(ielem)%f_itype == I_INVOLATILE) .or. & + (cstate%f_carma%f_element(ielem)%f_itype == I_VOLATILE)) then + cstate%f_pcd(:, ibin, ielem) = cstate%f_pcd(:, ibin, ielem) / cstate%f_carma%f_group(igroup)%f_rmass(ibin) + else if (cstate%f_carma%f_element(ielem)%f_itype == I_CORE2MOM) then + cstate%f_pcd(:, ibin, ielem) = cstate%f_pcd(:, ibin, ielem) * cstate%f_carma%f_group(igroup)%f_rmass(ibin) + end if + + return + end subroutine CARMASTATE_SetDetrain + + + + !! Sets the mass of the gas (igas) in the grid. This call should be made after + !! CARMASTATE_Create() and before CARMA_Step(). + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_AddGas + !! @see CARMA_GetGas + !! @see CARMA_InitializeStep + !! @see CARMA_Step + subroutine CARMASTATE_SetGas(cstate, igas, mmr, rc, mmr_old, satice_old, satliq_old) + type(carmastate_type), intent(inout) :: cstate !! the carma object + integer, intent(in) :: igas !! the gas index + real(kind=f), intent(in) :: mmr(cstate%f_NZ) !! the gas mass mixing ratio [kg/kg] + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), intent(in), optional :: mmr_old(cstate%f_NZ) !! the previous gas mass mixing ratio [kg/kg] + real(kind=f), intent(inout), optional :: satice_old(cstate%f_NZ) !! the previous gas saturation wrt ice, calculates if -1 + real(kind=f), intent(inout), optional :: satliq_old(cstate%f_NZ) !! the previous gas saturation wrt liquid, calculates if -1 + + real(kind=f) :: tnew(cstate%f_NZ) + integer :: iz + logical :: calculateOld + + ! Assume success. + rc = RC_OK + + ! Make sure there are enough gases allocated. + if (igas > cstate%f_carma%f_NGAS) then + if (cstate%f_carma%f_do_print) write(cstate%f_carma%f_LUNOPRT, *) "CARMASTATE_SetGas:: ERROR - The specifed gas (", & + igas, ") is larger than the number of gases (", cstate%f_carma%f_NGAS, ")." + rc = RC_ERROR + return + end if + + if (cstate%f_carma%f_do_substep) then + if (.not. present(mmr_old)) then + if (cstate%f_carma%f_do_print) then + write(cstate%f_carma%f_LUNOPRT,*) "CARMASTATE_SetGas: & + &Error - Need to specify mmr_old, satic_old, satliq_old when substepping." + end if + rc = RC_ERROR + + return + + else + cstate%f_gcl(:, igas) = mmr_old(:) * cstate%f_rhoa_wet(:) * cstate%f_t(:) / cstate%f_told(:) + + ! A value of -1 for the saturation ratio means that it needs to be calculated from the old temperature + ! and the old gc. + ! + ! NOTE: This is typically just a problem for the first step, so we just need to get close. + calculateOld = .false. + if (present(satice_old) .and. present(satliq_old)) then + if (any(satice_old(:) == -1._f) .or. any(satliq_old(:) == -1._f)) calculateOld = .true. + else + calculateOld = .true. + end if + + if (calculateOld) then + + ! This is a bit of a hack, because of the way CARMA has the vapor pressure and saturation + ! routines implemented. + + ! Temporarily set the temperature and gc of to the old state + + tnew(:) = cstate%f_t(:) + cstate%f_t(:) = cstate%f_told(:) + + cstate%f_gc(:, igas) = mmr_old(:) * cstate%f_rhoa_wet(:) + + do iz = 1, cstate%f_NZ + call supersat(cstate%f_carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + + if (present(satice_old)) then + if (satice_old(iz) == -1._f) then + cstate%f_supsatiold(iz, igas) = cstate%f_supsati(iz, igas) + else + cstate%f_supsatiold(iz, igas) = satice_old(iz) - 1._f + endif + else + cstate%f_supsatiold(iz, igas) = cstate%f_supsati(iz, igas) + end if + + if (present(satliq_old)) then + if (satliq_old(iz) == -1._f) then + cstate%f_supsatlold(iz, igas) = cstate%f_supsatl(iz, igas) + else + cstate%f_supsatlold(iz, igas) = satliq_old(iz) - 1._f + endif + else + cstate%f_supsatlold(iz, igas) = cstate%f_supsatl(iz, igas) + end if + end do + + cstate%f_t(:) = tnew(:) + + else + cstate%f_supsatiold(:, igas) = satice_old(:) - 1._f + cstate%f_supsatlold(:, igas) = satliq_old(:) - 1._f + end if + end if + end if + + ! Use the specified mass mixing ratio and the air density to determine the mass + ! of the gas in g/x/y/z. + cstate%f_gc(:, igas) = mmr(:) * cstate%f_rhoa_wet(:) + + return + end subroutine CARMASTATE_SetGas + + + !! Sets information about the state of the atmosphere. + !! + !! @author Chuck Bardeen + !! @version Feb-2009 + !! @see CARMA_Step + !! @see CARMASTATE_Create + subroutine CARMASTATE_SetState(cstate, rc, t, rhoa_wet) + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(out) :: rc !! return code, negative indicates failure + real(kind=f), optional, intent(in) :: t(cstate%f_NZ) !! the air temperature [K] + real(kind=f), optional, intent(in) :: rhoa_wet(cstate%f_NZ) !! air density [kg m-3] + + ! Assume success. + rc = RC_OK + + ! Return the temperature or density. + if (present(t)) cstate%f_t(:) = t(:) + + ! Convert rhoa from mks to the scaled units. + if (present(rhoa_wet)) cstate%f_rhoa_wet(:) = (rhoa_wet(:) * & + (cstate%f_zmet(:)*cstate%f_xmet(:)*cstate%f_ymet(:))) / 1e6_f * 1e3_f + + return + end subroutine CARMASTATE_SetState +end module diff --git a/src/physics/carma/base/coagl.F90 b/src/physics/carma/base/coagl.F90 new file mode 100644 index 0000000000..4362a3f527 --- /dev/null +++ b/src/physics/carma/base/coagl.F90 @@ -0,0 +1,105 @@ +#include "carma_globaer.h" + +!! This routine calculates coagulation loss rates . +!! See [Jacobson, et al., Atmos. Env., 28, 1327, 1994] for details +!! on the coagulation algorithm. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! @author Eric Jensen +!! @version Oct-1995 +subroutine coagl(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: ig + integer :: jg + integer :: je + integer :: igrp + integer :: iz + integer :: i + integer :: j + + + ! Loop over particle groups for which coagulation loss is being + ! calculated. + do ig = 1,NGROUP + + ! Loop over particle groups that particle in group ig might + ! collide with. + do jg = 1,NGROUP + + ! Element corresponding to particle number concentration + je = ienconc(jg) + + ! Particle resulting from coagulation between groups and goes + ! to group + igrp = icoag(ig,jg) + + ! Resulting particle is in same group as particle under consideration -- + ! partial loss (muliplies ). + if( igrp .eq. ig )then + + ! Loop over the column + do iz = 1, NZ + + if( pconmax(iz,jg) .gt. FEW_PC .and. & + pconmax(iz,ig) .gt. FEW_PC )then + + do i = 1, NBIN-1 + do j = 1, NBIN + + coaglg(iz,i,ig) = coaglg(iz,i,ig) & + + ckernel(iz,i,j,ig,jg) * & + pcl(iz,j,je) * volx(igrp,ig,jg,i,j) + enddo + enddo + endif + enddo ! iz + + ! Resulting particle is in a different group -- complete loss (no ). + else if( igrp .ne. ig .and. igrp .ne. 0 )then + + ! Loop over the column + do iz = 1, NZ + + ! Bypass calculation if few particles present + + if( pconmax(iz,jg) .gt. FEW_PC .and. & + pconmax(iz,ig) .gt. FEW_PC )then + + do i = 1, NBIN + do j = 1, NBIN + + coaglg(iz,i,ig) = coaglg(iz,i,ig) & + + ckernel(iz,i,j,ig,jg) * & + pcl(iz,j,je) + + enddo + enddo + endif ! pconmax(ig) * pconmax(jg) > FEW_PC ** 2 + enddo ! iz + endif ! igrp .eq. ig ? + enddo ! jg + enddo ! ig + + ! Boundary condition: Particles from bin are only lost by + ! coagulating into other elements. (This is taken care of by -1 + ! limit above) + + ! Return to caller with particle loss rates due to coagulation evaluated. + return +end diff --git a/src/physics/carma/base/coagp.F90 b/src/physics/carma/base/coagp.F90 new file mode 100644 index 0000000000..a21eff9367 --- /dev/null +++ b/src/physics/carma/base/coagp.F90 @@ -0,0 +1,266 @@ +#include "carma_globaer.h" + +!! This routine calculates coagulation production terms . +!! See [Jacobson, et al., Atmos. Env., 28, 1327, 1994] for details +!! on the coagulation algorithm. +!! +!! @author Eric Jensen +!! @version Oct-1995 +subroutine coagp(carma, cstate, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: iz + integer :: igrp + integer :: i_pkern + integer :: iquad + integer :: ig + integer :: jg + integer :: i + integer :: j + integer :: iefrom + integer :: iefrom_cm + integer :: je + integer :: je_cm + integer :: ic + integer :: iecore + real(kind=f) :: totmass + real(kind=f) :: rmasscore + real(kind=f) :: fracmass + real(kind=f) :: elemass + real(kind=f) :: rmi + real(kind=f) :: rmj + + + ! Definition of i,j,k,n used in comments: colision between i and j bins + ! yields particle between bins k and k+1. Production in bin n is calculated. + + + ! Determine group that particles are produced in + igrp = igelem(ielem) + + ! Particle number production + ! + ! Coagulation between particle in group bin with particle in + ! group bin results in particle with mass between bins k and k+1. + ! First, loop over group-bin quads resulting in production in + ! bin = k+1. The set of quads is + ! defined in setupcoag. + + do iquad = 1, npairu(igrp,ibin) + + ig = igup(igrp,ibin,iquad) ! source group + jg = jgup(igrp,ibin,iquad) ! source group + i = iup(igrp,ibin,iquad) ! source bin + j = jup(igrp,ibin,iquad) ! source bin + + iefrom = icoagelem(ielem,ig) ! source element for particle + + if( if_sec_mom(igrp) )then + iefrom_cm = icoagelem_cm(ielem,ig) ! core mass moment source element + endif + + ! If = 0 then there is no contribution to production + if( iefrom .ne. 0 ) then + + je = ienconc(jg) ! source element for particle + + if( if_sec_mom(igrp) )then + je_cm = icoagelem_cm(ielem,jg) ! core mass moment source element + endif + + ! If ielem is core mass type and is a CN type and is different + ! from , then we must multiply production by mass + ! per particle () of element . (this is for all source + ! elements except particle number concentration in a multicomponent CN group). + do iz = 1, NZ + + ! Bypass calculation if few source particles present + if( pconmax(iz,ig) .gt. FEW_PC .and. & + pconmax(iz,jg) .gt. FEW_PC )then + + rmi = 1._f + i_pkern = 1 + + if( itype(ielem) .eq. I_COREMASS .or. & + itype(ielem) .eq. I_VOLCORE )then ! core mass + + i_pkern = 3 ! Use different kernel for core mass prod. + + if( ( itype(ienconc(ig)) .eq. I_INVOLATILE .or. & + itype(ienconc(ig)) .eq. I_VOLATILE ) & + .and. ig .ne. igrp ) then + + ! CN source and ig different from igrp + + if( ncore(ig) .eq. 0 )then ! No cores in source group + + if(icomp(ienconc(ig)) .eq. icomp(ielem)) then + rmi = rmass(i,ig) + else + rmi = 0._f + endif + + elseif( itype(iefrom) .eq. I_INVOLATILE .or. & + itype(iefrom) .eq. I_VOLATILE ) then + + ! Source element is number concentration elem of mixed CN group + totmass = pc(iz,i,iefrom) * rmass(i,ig) + rmasscore = pc(iz,i,icorelem(1,ig)) + + do ic = 2,ncore(ig) + iecore = icorelem(ic,ig) + rmasscore = rmasscore + pc(iz,i,iecore) + enddo + + fracmass = 1._f - rmasscore/totmass + elemass = fracmass * rmass(i,ig) + rmi = elemass + endif + endif ! ig is a CCN and not igrp + + elseif( itype(ielem) .eq. I_CORE2MOM )then ! core mass^2 + + i_pkern = 5 ! Use different kernel for core mass^2 production + rmj = 1._f + + if( itype(ienconc(ig)) .eq. I_INVOLATILE ) then + rmi = rmass(i,ig) + rmj = rmass(j,jg) + endif + + endif ! itype(ielem) is a coremass or core2mom + + ! For each spatial grid point, sum up coagulation production + ! contributions from each quad. + if( itype(ielem) .ne. I_CORE2MOM )then + coagpe(iz,ibin,ielem) = coagpe(iz,ibin,ielem) + & + pc(iz,i,iefrom)*pcl(iz,j,je)*rmi * & + ckernel(iz,i,j,ig,jg) * & + pkernel(i,j,ig,jg,igrp,i_pkern) + else + coagpe(iz,ibin,ielem) = coagpe(iz,ibin,ielem) + & + ( pc(iz,i,iefrom)*pcl(iz,j,je)*rmi**2 + & + pc(iz,i,iefrom_cm)*rmi* & + pcl(iz,j,je_cm)*rmj ) * & + ckernel(iz,i,j,ig,jg) * & + pkernel(i,j,ig,jg,igrp,i_pkern) + endif + endif ! end of ( pconmax .gt. FEW_PC ) + enddo ! iz = 1, NZ + endif ! iefrom .ne. 0 + enddo ! iquad + + ! Next, loop over group-bin quads for production in bin = k from + ! bin due to collision between bins and . + ! Production will only occur if either k != or igrp != + do iquad = 1, npairl(igrp,ibin) + + ig = iglow(igrp,ibin,iquad) + jg = jglow(igrp,ibin,iquad) + i = ilow(igrp,ibin,iquad) + j = jlow(igrp,ibin,iquad) + + iefrom = icoagelem(ielem,ig) ! source element for particle + + if( if_sec_mom(igrp) )then + iefrom_cm = icoagelem_cm(ielem,ig) ! core mass moment source element + endif + + if( iefrom .ne. 0 ) then + + je = ienconc(jg) ! source element for particle + + if( if_sec_mom(igrp) )then + je_cm = icoagelem_cm(ielem,jg) ! core mass moment source element + endif + + do iz = 1, NZ + + ! Bypass calculation if few particles present + if( pconmax(iz,ig) .gt. FEW_PC .and. & + pconmax(iz,jg) .gt. FEW_PC )then + + rmi = 1._f + i_pkern = 2 + + if( itype(ielem) .eq. I_COREMASS .or. & + itype(ielem) .eq. I_VOLCORE )then ! core mass + + i_pkern = 4 ! Use different kernel for core mass production + + if( ( itype(ienconc(ig)) .eq. I_INVOLATILE .or. & + itype(ienconc(ig)) .eq. I_VOLATILE ) & + .and. ig .ne. igrp ) then + + ! CN source and ig different from igrp + + if( ncore(ig) .eq. 0 )then ! No cores in source group + rmi = rmass(i,ig) + + elseif( itype(iefrom) .eq. I_INVOLATILE .or. & + itype(iefrom) .eq. I_VOLATILE ) then + + ! Source element is number concentration elem of mixed CN group + + totmass = pc(iz,i,iefrom) * rmass(i,ig) + rmasscore = pc(iz,i,icorelem(1,ig)) + do ic = 2,ncore(ig) + iecore = icorelem(ic,ig) + rmasscore = rmasscore + pc(iz,i,iecore) + enddo + fracmass = 1._f - rmasscore/totmass + elemass = fracmass * rmass(i,ig) + rmi = elemass + + endif ! pure CN group or CN group w/ cores + + endif ! src group is CN and different from the target group + + elseif( itype(ielem) .eq. I_CORE2MOM )then ! core mass^2 + + i_pkern = 6 ! Use different kernel for core mass^2 production + rmj = 1._f + if( itype(ienconc(ig)) .eq. I_INVOLATILE ) then + rmi = rmass(i,ig) + rmj = rmass(j,jg) + endif + endif ! itype(ielem) + + if( itype(ielem) .ne. I_CORE2MOM )then + coagpe(iz,ibin,ielem) = coagpe(iz,ibin,ielem) + & + pc(iz,i,iefrom)*pcl(iz,j,je)*rmi * & + ckernel(iz,i,j,ig,jg) * & + pkernel(i,j,ig,jg,igrp,i_pkern) + else + coagpe(iz,ibin,ielem) = coagpe(iz,ibin,ielem) + & + ( pc(iz,i,iefrom)*pcl(iz,j,je)*rmi**2 + & + pc(iz,i,iefrom_cm)*rmi* & + pcl(iz,j,je_cm)*rmj ) * & + ckernel(iz,i,j,ig,jg) * & + pkernel(i,j,ig,jg,igrp,i_pkern) + endif + endif ! end of ( pconmax .gt. FEW_PC ) + enddo ! iz = 1, NZ + endif ! end of (iefrom .ne. 0) + enddo ! iquad + + ! Return to caller with coagulation production terms evaluated. + + return +end diff --git a/src/physics/carma/base/csolve.F90 b/src/physics/carma/base/csolve.F90 new file mode 100644 index 0000000000..c287742f4e --- /dev/null +++ b/src/physics/carma/base/csolve.F90 @@ -0,0 +1,61 @@ +#include "carma_globaer.h" + +!! This routine calculates new particle concentrations from coagulation +!! microphysical processes. +!! +!! The basic form from which the solution is derived is: +!! +!! ( new_value - old_value ) / dtime = source_term - loss_rate*new_value +!! +!! This routine derived from psolve.f code, in which particle concentrations +!! due to coagulation were formerly included, before the relatively slow +!! coagulation calcs were separated from the other microphysical processes +!! so that time splitting could be applied to these fast & slow calcs. +!! +!! @author Bill McKie +!! @version Sep-1997 +subroutine csolve(carma, cstate, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: igroup + real(kind=f) :: xyzmet(NZ) + real(kind=f) :: ppd(NZ) + real(kind=f) :: pls(NZ) + + + ! Define current group & particle number concentration element indices + igroup = igelem(ielem) ! particle group + + ! Metric scaling factor + xyzmet = xmet(:) * ymet(:) * zmet(:) + + ! Compute total production rate due to coagulation + ppd = coagpe(:,ibin,ielem) / xyzmet(:) + + ! Compute total loss rate due to coagulation + pls = coaglg(:,ibin,igroup) / xyzmet(:) + + ! Update net particle number concentration during current timestep + ! due to production and loss rates for coagulation + pc(:,ibin,ielem) = ( pc(:,ibin,ielem) & + + dtime * ppd(:) ) & + / ( ONE + pls(:) * dtime ) + + return +end diff --git a/src/physics/carma/base/detrain.F90 b/src/physics/carma/base/detrain.F90 new file mode 100644 index 0000000000..129152ce1c --- /dev/null +++ b/src/physics/carma/base/detrain.F90 @@ -0,0 +1,51 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine moves condensate from the detrained bins (pcd) to the +!! particle bins. +!! +!! @author Chuck Bardeen +!! @version May 2010 +subroutine detrain(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: iz ! z index + integer :: ibin ! bin index + integer :: ielem ! element index + + rc = RC_OK + + ! Add the detrained condensate to the particle bins. + ! + ! NOTE: For now, do this all prior to the fast microphysics, but eventually it may + ! be better to move it into microfast and substep the detrained condensate. + pc(:,:,:) = pc(:,:,:) + pcd(:,:,:) + pcd(:,:,:) = 0._f + + ! Prevent particle concentrations from dropping below SMALL_PC + do iz = 1, NZ + do ibin = 1, NBIN + do ielem = 1, NELEM + call smallconc(carma, cstate, iz, ibin, ielem, rc) + end do + end do + end do + + ! Return to caller with new particle number concentrations. + return +end diff --git a/src/physics/carma/base/downgevapply.F90 b/src/physics/carma/base/downgevapply.F90 new file mode 100644 index 0000000000..83dbb27381 --- /dev/null +++ b/src/physics/carma/base/downgevapply.F90 @@ -0,0 +1,52 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine applies evaporation and nucleation production terms to +!! particle concentrations. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine downgevapply(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ibin !! bin index + integer :: ielem !! element index + + + ! Visit each radius bin for each element to compute particle production + ! due to evaporation and element transfer processes for which the source + ! element number is greater than the target element number + do ielem = 1,NELEM + do ibin = 1,NBIN + + pc(iz,ibin,ielem) = pc(iz,ibin,ielem) + & + dtime * ( evappe(ibin,ielem) + & + rnucpe(ibin,ielem) ) + + ! Prevent particle concentrations from dropping below SMALL_PC + call smallconc(carma, cstate, iz, ibin, ielem, rc) + + enddo + enddo + + + ! Return to caller with evaporation and down-grid element transfer + ! production terms applied to particle concentrations. + return +end diff --git a/src/physics/carma/base/downgxfer.F90 b/src/physics/carma/base/downgxfer.F90 new file mode 100644 index 0000000000..fedcfb500a --- /dev/null +++ b/src/physics/carma/base/downgxfer.F90 @@ -0,0 +1,146 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to particle +!! element transfer processes for which the source element number is larger +!! than the target element number. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine downgxfer(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: iepart + integer :: ibin !! bin index + integer :: ielem !! element index + integer :: i + integer :: jefrom + integer :: iefrom + integer :: igfrom + integer :: ipow_from + integer :: ipow_to + integer :: ipow + integer :: jfrom + integer :: ifrom + integer :: ic + integer :: iecore + real(kind=f) :: elemass + real(kind=f) :: totmass + real(kind=f) :: rmasscore + real(kind=f) :: fracmass + real(kind=f) :: rnucprod + + + ! Calculate nucleation source terms for which the source element + ! number is greater than the target element number + + ! Set nucleation production rates to zero to avoid double-application + ! of rates calculated in upgxfer.f + rnucpe(:,:) = 0._f + + ! Loop over particle elements and bins + do ielem = 1, NELEM + do ibin = 1, NBIN + + ! Define group & particle # concentration indices for current element + igroup = igelem(ielem) ! target particle group + iepart = ienconc(igroup) ! target particle number concentration element + + ! First calculate production terms due to nucleation . + + ! Loop over elements that nucleate to element . + do jefrom = 1,nnucelem(ielem) + + iefrom = inucelem(jefrom,ielem) ! source particle element + + ! Only calculate production rates here if is less than + ! . Otherwise, production is calculated in upgxfer.f + if( ielem .lt. iefrom ) then + igfrom = igelem(iefrom) ! source particle group + + ! is the power to which the source particle mass must be taken + ! to match the type of the target element. This ugliness could be + ! handled much more slickly in setupnuc() + if( itype(iefrom) .eq. I_INVOLATILE .or. itype(iefrom) .eq. I_VOLATILE )then + ipow_from = 0 + elseif ( itype(iefrom) .eq. I_COREMASS .or. itype(iefrom) .eq. I_VOLCORE )then + ipow_from = 1 + else + ipow_from = 2 + endif + + if( itype(ielem) .eq. I_INVOLATILE .or. itype(ielem) .eq. I_VOLATILE )then + ipow_to = 0 + elseif ( itype(ielem) .eq. I_COREMASS .or. itype(ielem) .eq. I_VOLCORE )then + ipow_to = 1 + else + ipow_to = 2 + endif + + ipow = ipow_to - ipow_from + + ! Loop over bins that nucleate to bin . + do jfrom = 1,nnucbin(igfrom,ibin,igroup) + + ifrom = inucbin(jfrom,igfrom,ibin,igroup) ! bin of source + + ! Bypass calculation if few source particles are present + if( pconmax(iz,igfrom) .gt. FEW_PC )then + if( rnuclg(ifrom,igfrom,igroup) .gt. 0._f )then + + ! First calculate mass associated with the source element + ! (this is for all source elements except particle number + ! concentration in a multicomponent particle group). + if( ncore(igfrom) .eq. 0 .or. itype(iefrom) .gt. I_VOLATILE )then + elemass = rmass(ifrom,igfrom) + else + totmass = pc(iz,ifrom,iefrom) * rmass(ifrom,igfrom) + rmasscore = pc(iz,ifrom,icorelem(1,igfrom)) + + do ic = 2,ncore(igfrom) + iecore = icorelem(ic,igfrom) + rmasscore = rmasscore + pc(iz,ifrom,iecore) + enddo + + fracmass = 1._f - rmasscore/totmass + elemass = fracmass * rmass(ifrom,igfrom) + endif + + rnucprod = rnuclg(ifrom,igfrom,igroup) * & + pc(iz,ifrom,iefrom) * elemass**ipow + + rnucpe(ibin,ielem) = rnucpe(ibin,ielem) + rnucprod + + ! Calculate latent heat associated with nucleation to + ! from +! rlprod = rlprod + rnucprod * rlh_nuc(iefrom,ielem) / & +! (CP * rhoa(iz)) * elemass + + endif ! (rnuclg > 0.) + endif ! (pconmax > FEW_PC) + enddo ! (jfrom = 1,nnucbin) + endif ! (ielem < iefrom) + enddo ! (jefrom = 1,nnucelem) + enddo ! (ibin = 1, NBIN) + enddo ! (ielem = 1, NELEM) + + ! Return to caller with down-grid production terms evaluated. + return +end diff --git a/src/physics/carma/base/evap_ingrp.F90 b/src/physics/carma/base/evap_ingrp.F90 new file mode 100644 index 0000000000..a9fda41df9 --- /dev/null +++ b/src/physics/carma/base/evap_ingrp.F90 @@ -0,0 +1,53 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms of droplets +!! evaporating within a particle group. +!! +!! Distinct evaporation of cores has not been treated. +!! +!! @author Andy Ackerman +!! @version Aug-2001 +subroutine evap_ingrp(carma,cstate,iz,ibin,ig,ip,rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ig !! group index + integer, intent(in) :: ip + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ie + integer :: isub + + + ! For a single group, the core mass fraction is 0. + cmf(ibin,ig) = 0.0_f + + ! The smallest bin cannot be a source to smaller bins in same group + if( ibin .eq. 1 )then + return + endif + + ! Evaluate evaporation source term for all elements in group + do isub = 1, nelemg(ig) + ie = ip + isub - 1 + evappe(ibin-1,ie) = evappe(ibin-1,ie) + & + pc(iz,ibin,ie)*evaplg(ibin,ig) + enddo + + return +end diff --git a/src/physics/carma/base/evap_mono.F90 b/src/physics/carma/base/evap_mono.F90 new file mode 100644 index 0000000000..bf08e8b9fa --- /dev/null +++ b/src/physics/carma/base/evap_mono.F90 @@ -0,0 +1,109 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to total +!! evaporation from bin group into a monodisperse +!! distribution. +!! +!! Distinct evaporation of cores has not been treated. +!! +!! @author Andy Ackerman +!! @version Aug-2001 +subroutine evap_mono(carma,cstate,iz,ibin,ig,iavg,ieto,igto,rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ig !! group index + integer, intent(in) :: iavg + integer, intent(in) :: ieto + integer, intent(in) :: igto + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ic + integer :: iecore + integer :: ie2cn + integer :: jbin + logical :: conserve_mass + real(kind=f) :: factor + real(kind=f) :: fracmass + + + ! Define option to conserve mass or number when a choice must be made + ! during monodisperse total evaporation beyond CN grid -- should be done in setupaer() + conserve_mass = .true. + + ! Set automatic flag for total evaporation used in gasexchange() + totevap(ibin,ig) = .true. + + ! Possibly put all of core mass into largest, smallest, or + ! smallest nucelated CN bin + if( too_big .or. too_small .or. nuc_small )then + + if( too_big )then + jbin = NBIN + elseif( too_small )then + jbin = 1 + else + jbin = 1 + endif + + if( conserve_mass )then + factor = coreavg/rmass(jbin,igto) + else + factor = ONE + endif + + ! First the CN number concentration element + evappe(jbin,ieto) = evappe(jbin,ieto) + factor*evdrop + + ! Now the CN cores + do ic = 2, ncore(ig) + iecore = icorelem(ic,ig) + ie2cn = ievp2elem(iecore) + evappe(jbin,ie2cn) = evappe(jbin,ie2cn) + & + factor*evcore(ic)*rmass(jbin,igto) + enddo + else + + ! Partition core mass between two CN bins, conserving total core mass + ! and number. The number will be subdivided into bins and -1. + if( iavg .le. 1 .or. iavg .gt. NBIN )then + if (do_print) write(LUNOPRT, *) "evap_mono: bad iavg = , ", iavg + rc = RC_ERROR + return + endif + + fracmass = ( rmass(iavg,igto) - coreavg ) / diffmass(iavg,igto,iavg-1,igto) +! fracmass = max( 0._f, min( ONE, fracmass ) ) + + ! First the CN number concentration element + evappe(iavg-1,ieto) = evappe(iavg-1,ieto) + evdrop*fracmass + evappe(iavg,ieto) = evappe(iavg,ieto) + evdrop*( ONE - fracmass ) + + ! Now the cores + do ic = 2, ncore(ig) + iecore = icorelem(ic,ig) + ie2cn = ievp2elem(iecore) + evappe(iavg-1,ie2cn) = evappe(iavg-1,ie2cn) + & + rmass(iavg-1,igto)*evcore(ic)*fracmass + evappe(iavg,ie2cn) = evappe(iavg,ie2cn) + & + rmass(iavg,igto)*evcore(ic)*( ONE - fracmass ) + enddo + endif + + return +end diff --git a/src/physics/carma/base/evap_poly.F90 b/src/physics/carma/base/evap_poly.F90 new file mode 100644 index 0000000000..1eb7117a7b --- /dev/null +++ b/src/physics/carma/base/evap_poly.F90 @@ -0,0 +1,141 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to +!! total evaporation into a polydisperse CN distribution by assuming +!! that the pdf of core mass is log-normal skewed by mass raised to +!! the -3/2 power (which guarantees average core mass from pdf is the +!! same as average core mass). +!! +!! Distinct evaporation of cores has not been treated. +!! +!! @author Andy Ackerman +!! @version Aug-2001 +subroutine evap_poly(carma,cstate,iz,ibin,ig,iavg,ieto,igto,rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ig !! group index + integer, intent(in) :: iavg + integer, intent(in) :: ieto + integer, intent(in) :: igto + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ic + integer :: ito + integer :: kount_s + integer :: kount_l + integer :: iecore + integer :: ie2cn + real(kind=f) :: prob(NBIN) + real(kind=f) :: rn_norms + real(kind=f) :: rn_norml + real(kind=f) :: rm_norms + real(kind=f) :: rm_norml + real(kind=f) :: expon + real(kind=f) :: rmassto + real(kind=f) :: dmto + real(kind=f) :: weightl + real(kind=f) :: weights + + + ! Treat total evaporation from a polydisperse core mass distribution: + ! assume a log-normal CN size distribution and conserve number and mass as + ! described by Turco (NASA Technical Paper 1362). + ! + ! Set automatic flag for total evaporation used in gasexchange() + totevap(ibin,ig) = .true. + + ! Calculate number and mass + ! normalization factors for cores smaller and larger than . + rn_norms = 0._f + rn_norml = 0._f + rm_norms = 0._f + rm_norml = 0._f + kount_s = 0 + kount_l = 0 + + do ito = 1, NBIN + + rmassto = rmass(ito,igto) + dmto = dm(ito,igto) + + ! is probability that core mass is in CN bin . + if( coreavg .gt. 0._f .and. coresig .gt. 0._f )then + expon = -log( rmassto/coreavg )**2 / ( 2.*coresig ) + expon = max(-POWMAX, expon) + else + expon = 0._f + endif + + prob(ito) = rmassto**(-1.5_f) * exp( expon ) + + if( ito .lt. iavg )then + rn_norms = rn_norms + prob(ito)*dmto + rm_norms = rm_norms + prob(ito)*dmto*rmassto + kount_s = kount_s + 1 + else + rn_norml = rn_norml + prob(ito)*dmto + rm_norml = rm_norml + prob(ito)*dmto*rmassto + kount_l = kount_l + 1 + endif + enddo + + ! Calculate mass weighting factors for small and + ! large cores. + if( kount_s .eq. 0 )then + weightl = ONE + elseif( kount_l .eq. 0 )then + weightl = 0._f + else + rm_norms = rm_norms/rn_norms + rm_norml = rm_norml/rn_norml + weightl = (coreavg - rm_norms) / (rm_norml - rm_norms) + if( weightl .gt. ALMOST_ONE )then + weightl = ONE + elseif( weightl .lt. ALMOST_ZERO )then + weightl = 0._f + endif + endif + + weights = ONE - weightl + + ! Renormalize probability distribution function and evaluate the CN + ! evaporation source term . + do ito = 1, NBIN + +! if( ito .le. iavg )then + if( ito .lt. iavg )then ! Kevin M + prob(ito) = prob(ito)*weights/rn_norms + else + prob(ito) = prob(ito)*weightl/rn_norml + endif + + ! First the CN number concentration element + evappe(ito,ieto) = evappe(ito,ieto) + evdrop*prob(ito)*dm(ito,igto) + + ! Now the CN core elements + do ic = 2, ncore(ig) + iecore = icorelem(ic,ig) + ie2cn = ievp2elem(iecore) + evappe(ito,ie2cn) = evappe(ito,ie2cn) + & + rmass(ito,igto)*evcore(ic)*prob(ito)*dm(ito,igto) + enddo + enddo + + return +end diff --git a/src/physics/carma/base/evapp.F90 b/src/physics/carma/base/evapp.F90 new file mode 100644 index 0000000000..64bad71d7f --- /dev/null +++ b/src/physics/carma/base/evapp.F90 @@ -0,0 +1,199 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to evaporation . +!! +!! @author Andy Ackerman +!! @version Aug-2001 +subroutine evapp(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ibin !! bin index + integer :: ielem !! element index + integer :: ig !! source group index + integer :: ip !! source number concentration element + integer :: ic + integer :: ic1 !! element of first core mass in group + integer :: iecore + integer :: ieto + integer :: igto + integer :: iavg + logical :: evap_total + real(kind=f) :: sig_mono + real(kind=f) :: coretot + real(kind=f) :: coremom + real(kind=f) :: smf + integer :: nbin + + + ! Define criterion for monodisperse core mass distributions + sig_mono = sqrt( ALMOST_ZERO ) + + ! Loop over source groups (from which evaporation is being treated) + do ig = 1, NGROUP + + ip = ienconc(ig) + + ! No evaporation unless particles are volatile + if( itype(ip) .eq. I_VOLATILE )then + + ! Make sure that these always get intializaed, since they can + ! cause problems in other parts of the code if they aren't. + totevap(:,ig) = .false. + cmf(:,ig) = 0._f + + if (pconmax(iz, ig) > FEW_PC) then + + ic1 = icorelem(1,ig) + + ! Loop over source bins and calculate temporary evaporation source + ! for droplets in next smaller bin assuming no total evaporation + do ibin = 1, NBIN + evdrop = pc(iz,ibin,ip)*evaplg(ibin,ig) + + ! Check for evaporation of a sufficient number of droplets +! if( evdrop .gt. 0._f .and. pc(iz,ibin,ip) .gt. SMALL_PC )then + if( evdrop .gt. 0._f )then + + ! No cores: transfer droplets within group + if( ic1 .eq. 0 )then + call evap_ingrp(carma,cstate,iz,ibin,ig,ip,rc) + else + + ! First core is not involatile (therefore none are) + ! -- this is a hack until enforced/checked in setupbins() -- + ! transfer droplets within group + ! + if( itype(ic1) .ne. I_COREMASS )then + call evap_ingrp(carma,cstate,iz,ibin,ig,ip,rc) + else + + ! Have cores: calculate the amount of the source term + ! by number associated with total evaporation of secondary cores + coretot = pc(iz,ibin,ic1) + do ic = 2, ncore(ig) + iecore = icorelem(ic,ig) + if( itype(iecore) .eq. I_COREMASS )then + coretot = coretot + pc(iz,ibin,iecore) + endif + enddo + do ic = 2, ncore(ig) + iecore = icorelem(ic,ig) + if( itype(iecore) .eq. I_COREMASS )then + evcore(ic) = evdrop*pc(iz,ibin,iecore)/coretot + endif + enddo + + ! Calculate average particle core mass and fraction + coreavg = coretot / pc(iz,ibin,ip) + coreavg = min( rmass(ibin,ig), coreavg ) + cmf(ibin,ig) = coreavg / rmass(ibin,ig) + ! cmf(ibin,ig) = max( 0., min( ONE, cmf(ibin,ig) ) ) + + ! Get target number concentration element and group for total evaporation + ! and evaluate logical flags regarding position on CN bin and index of + ! target CN bin + ieto = ievp2elem(ic1) + + ! To treat internal mixtures, it is possible for the condensate to + ! totally evaporate and have core mass, but for there not to be another + ! group to which the core mass should go. So allow no evp2elem, but + ! always use the in group evaporation. + if (ieto == 0) then + nuc_small = .false. + else + igto = igelem(ieto) + + too_small = coreavg .lt. rmass(1,igto) + nbin = NBIN + too_big = coreavg .gt. rmass(nbin,igto) + + if( .not. (too_small .or. too_big) )then + iavg = log( coreavg / rmassmin(igto) ) / & + log( rmrat(igto) ) + 2 + iavg = min( iavg, NBIN ) + endif + + ! Only consider size of evaporating cores relative to nuc_small + ! when treating core second moment for this particle group + if( if_sec_mom(ig) )then + nuc_small = coreavg .lt. rmass(1,igto) + else + nuc_small = .false. + endif + end if + + ! Want total evaporation when + ! cores smaller than smallest nucleated + ! OR evaporating droplets are in bin 1 + ! OR droplets will be created with core mass fraction > 1 + evap_total = nuc_small .or. ibin .eq. 1 .or. & + rmrat(ig)*cmf(ibin,ig) .gt. ONE + + ! No core second moment: evaporate to monodisperse CN cores or within group.! + if( .not. if_sec_mom(ig) )then + + if( evap_total .and. (ieto /= 0) )then + call evap_mono(carma,cstate,iz,ibin,ig,iavg,ieto,igto,rc) + else + call evap_ingrp(carma,cstate,iz,ibin,ig,ip,rc) + endif + + ! Have core second moments: evaporate to mono- or polydisperse CN cores + ! or within group. First calculate average core second moment , + ! second moment fraction , and square of the logarithm of the geometric + ! standard deviation of the assumed core mass distribution . + else + + coremom = pc(iz,ibin,imomelem(ig)) / pc(iz,ibin,ip) + smf = coremom / rmass(ibin,ig)**2 + coresig = log( smf / cmf(ibin,ig)**2 ) + + ! Want total evaporation for above reasons + ! OR droplets will be created with core moment fraction > 1 + evap_total = evap_total .or. rmrat(ig)**2*smf .gt. ONE + + if( evap_total .and. (ieto /= 0) )then + + ! Want monodisperse total evaporation when + ! cores smaller than smallest nucleated + ! OR evaporating core distribution is narrow + ! Otherwise want polydisperse total evaporation + if( nuc_small .or. coresig .le. sig_mono )then + call evap_mono(carma,cstate,iz,ibin,ig,iavg,ieto,igto,rc) + else + call evap_poly(carma,cstate,iz,ibin,ig,iavg,ieto,igto,rc) + endif + + ! Droplet evaporation within group + else + call evap_ingrp(carma,cstate,iz,ibin,ig,ip,rc) + endif + endif ! if_sec_mom(ig) + endif ! itype(ic1) + endif ! ic1=0 + endif ! evaplg > 0 + enddo ! ibin=1,NBIN + endif ! enough particles + endif ! volatile particles + enddo ! ig=1,NGROUP + + ! Return to caller with evaporation production terms evaluated. + return +end diff --git a/src/physics/carma/base/fractal_meanfield_mod.F90 b/src/physics/carma/base/fractal_meanfield_mod.F90 new file mode 100644 index 0000000000..5139fcd0fc --- /dev/null +++ b/src/physics/carma/base/fractal_meanfield_mod.F90 @@ -0,0 +1,1475 @@ +!! This module (fractal_meanfield_mod.F90) contains the main routines +!! necessary to calculate the solution of the mean field approximation +!! for a dry fractal particle composed of identical spherical monomers. +!! This is used to generate optical properties for these paticles in CARMA. +!! +!! See Botet et al. 1997 "Mean-field approximation of Mie +!! scattering by fractal aggregates of identical spheres." +!! Applied Optics 36(33) 8791-8797 +!! +!! Original code from P. Rannou and R. Botet. +!! Translated to F90 and ported into CARMA by E. Wolf +!! +!! master: fractal_meanfield calling: cmie,ludcmpc,lubksbc,dqagi +!! +!! calculating the monomer Mie scattering +!! - SUBROUTINE cmie() calling: intmie() +!! - SUBROUTINE intmie() calling: intmie() +!! +!! calculating the matrix elements +!! - FUNCTION funa() calling: dqag,fpl +!! - FUNCTION fpl() calling: plgndr +!! - FUNCTION plgndr() +!! - FUNCTION funb_n() +!! - FUNCTION funs_n() calling: dq2agi,xfreal_n,xfimag_n +!! - FUNCTION xfreal_n() calling: besseljy,phi +!! - FUNCTION xfimag_n() calling: besseljy,phi +!! - FUNCTION BESSELJY() +!! +!! Routines to calculate the scattered wave +!! of monomer: +!! - FUNCTION fpi() calling: plgndr() +!! - FUNCTION ftau() calling: plgndr() +!! of agglomerate/cluster: +!! - FUNCTION fp1() +!! +!! Routines related to the probability distribution: +!! - FUNCTION anorm() calling: dqdagi,fdval +!! - FUNCTION fdval() +!! - FUNCTION phi() calling: fdval +!! - FUNCTION fco() calling: fdval +!! +!! @author P. Rannou, R. Botet, Eric Wolf +!! version March 2013 +module fractal_meanfield_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carma_mod + + use adgaquad_types_mod + use adgaquad_mod + use lusolvec_mod + + implicit none + + private + + public :: fractal_meanfield + + ! Private module varibles: Moved from COMMON blocks + integer, parameter :: nmi=40 + integer, parameter :: n2m = 2*nmi + + contains + + !! + !! Generate optical properties for CARMA fractal particles. + !! + !! See Botet et al. 1997 "Mean-field approximation of Mie + !! scattering by fractal aggregates of identical spheres." + !! Applied Optics 36(33) 8791-8797 + !! + !! @author P.Rannou, R.Botet, Eric Wolf + !! @version March 2013 + subroutine fractal_meanfield(carma, xl_in, xk_in, xn_in, nb_in, alpha_in, & + df_in, rmon,xv, ang, Qext, Qsca, gfac, rc) + + ! some of these may be included in carma object + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f),intent(in) :: xl_in !! Wavelength [microns] + real(kind=f),intent(in) :: xk_in !! imaginary index of refraction + real(kind=f),intent(in) :: xn_in !! real index of refraction + real(kind=f),intent(in) :: nb_in !! number of monomers + real(kind=f),intent(in) :: alpha_in !! Packing coefficient + real(kind=f),intent(in) :: df_in !! Fractal dimension + real(kind=f),intent(in) :: rmon !! monomer size [microns] + real(kind=f),intent(in) :: xv !! set to 1 + real(kind=f),intent(in) :: ang !! angle set to zero + real(kind=f),intent(out) :: Qext !! EFFICIENCY FACTOR FOR EXTINCTION + real(kind=f),intent(out) :: Qsca !! EFFICIENCY FACTOR FOR SCATTERING + real(kind=f),intent(out) :: gfac !! asymmetry factor + integer,intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer, parameter :: nth = 10001 + integer, parameter :: maxsub = 50000 + integer, parameter :: lenw = 200000 + integer :: nstop ! index with the last mie-coefficient + integer :: n1stop + integer :: pp,tt,mm + real(kind=f) :: krg,rg ! Particle structure + real(kind=f) :: sigmas,sigmae,nc1 + real(kind=f) :: sigext ! extinction cross section + real(kind=f) :: sigsca ! scattering cross section + real(kind=f) :: sigabs ! absorption cross section + real(kind=f) :: totg ! asymmetry parameter + real(kind=f) :: sigext2,sigext3 + real(kind=f) :: rems ! radius of equivalent mass sphere + real(kind=f) :: gems ! geometric cross-section of equivalent mass sphere + real(kind=f) :: dthetar,angler,weight + real(kind=f) :: sumsca + real(kind=f) :: lbd,beta ! optical characteristics + real(kind=f) :: sstest(0:nf) + real(kind=f) :: setest(0:nf) + real(kind=f) :: xl(39) ! place holder for wavelength + real(kind=f) :: xn(39) ! place holder for real index of refraction + real(kind=f) :: xk(39) ! place holder for imaginary index of refraction + real(kind=f) :: val + real(kind=f) :: funca(nmi,nmi,0:n2m) ! for storage of funa(nu,n;p) + complex(kind=f) :: res ! for storage of funs_n + complex(kind=f) :: funcs(0:n2m) + real(kind=f) :: s11(0:nth-1) + real(kind=f) :: s11_n(0:nth-1) + real(kind=f) :: xint(0:nth-1) + real(kind=f) :: wom + real(kind=f) :: pol(0:nth-1) + complex(kind=f) :: s01,s02 + complex(kind=f) :: s1(0:nth-1) + complex(kind=f) :: s2(0:nth-1) + complex(kind=f) :: ajt + complex(kind=f) :: an(nf) + complex(kind=f) :: bn(nf) + complex(kind=f) :: ni,i,id,onec,zeroc + complex(kind=f) :: d1(nmi) + complex(kind=f) :: d2(nmi) + complex(kind=f) :: Ap1(nmi,nmi) + complex(kind=f) :: Bp1(nmi,nmi) + complex(kind=f) :: dvec(n2m) ! For matrix eqn of order 2N + complex(kind=f) :: cvec(n2m) + complex(kind=f) :: EpABC(n2m,n2m) + integer :: luindx(n2m) ! For LU decomposition + real(kind=f) :: dlu + integer :: ifail + integer :: iwork(maxsub) + integer :: neval,nsubin + real(kind=f) :: work(lenw) + + ! Previously these were implicitly defined + real(kind=f) :: angle, pi, rn, ri + real(kind=f) :: deltas, deltae, xfact + real(kind=f) :: bound, errrel, p1, dp1 + real(kind=f) :: errabs, total + integer :: n2stop, n3stop, ntheta, ii, kk, nn, jj, iy, ir, q, interv + real(kind=f) :: a0, c0, a1, c1, a2, c2 + real(kind=f) :: qabs + + ! Previously these were globals, which wouldn't be thread safe. + type(adgaquad_vars_type) :: fx_vars + + ! Set the return code to default to okay. + rc = RC_OK + + ! *** Set from input arguments + fx_vars%nb = nb_in + fx_vars%df = df_in + fx_vars%alpha = alpha_in + xl(1) = xl_in + xk(1) = xk_in + xn(1) = xn_in + + ! *** Complex constants 1, 1, identity(1,1), zero(0,0) : + i = cmplx(0._f,1._f,kind=f) + onec = cmplx(1._f,0._f,kind=f) + id = cmplx(1._f,1._f,kind=f) + zeroc = cmplx(0._f,0._f,kind=f) + + ! Other initializations + funca(:,:,:) = 0.0_f + fx_vars%a = rmon *1.e-2_f ! a = r_monomer in m + beta=ang*(3.1415926_f / 180._f) ! =0 when ang=0 + Ap1(:,:) = zeroc + Bp1(:,:) = zeroc + sstest(:) = 0.0_f + setest(:) = 0.0_f + + ! **************************************************************** + ! *** Definition and calculation of factorials 0 - nf + ! *** (nf set in adgaqaud_types_mod.F90) + ! *** and storage [ real*8 fact() (double prec.) ] + ! **************************************************************** + + fx_vars%fact(0)=1._f ! factorials fact(n)=n! + do ii=1,nf + fx_vars%fact(ii) = fx_vars%fact(ii-1)*ii*1._f + end do + + pi=4._f*atan(1._f) ! 3.1415926535 + fx_vars%coeff=anorm(carma,fx_vars,rc) + if (rc < 0) return + + ! **************************************************************** + ! anorm() integrated INT_0^inf[ x**(df-1.)*exp(-x**df/2._f) dx ] + ! and occupied + ! anorm := 4 pi * INT_0^inf[ x**(df-1.)*exp(-x**df/2._f) dx ] + ! == geometric scalingfactor Eq.(10) in [Botet et al, 1995] + ! c := 0.5 + ! **************************************************************** + + kk=1 + ni=xn(kk)*1._f+i*xk(kk)*xv*1._f ! ni := complex index of refraction of monomer + ! (xv := 1 ; input parameter in file "calpha") + lbd=xl(kk)*1.e-6_f ! lbd := wavelength in m + ! (in matrix medium / material !) + fx_vars%k=2._f*pi/lbd ! k := abs.val. of wavevector in m^-1 + ! (in matrix medium / material !) + + ! *** ****************************************************************** + ! *** Calculation of Mie coefficients for monomer scattering + ! *** up to a maximum order of nf=50 + ! *** ****************************************************************** + + do ii=1,nf + an(ii) = zeroc + bn(ii) = zeroc + end do + + rn=xn(kk) ! Re(relative_n_complex,monomer) + ri=xk(kk)*xv ! Im(relative_n_complex,monomer) + ! xv should be set to 1 (sse above) + ! a = monomer sphere radius + ! lbd = wavelength in matrix medium + + ! Call Mie routine + call cmie(lbd,rn,ri,fx_vars%a,an,bn,nstop) + + do ii=1,nf + if (an(ii).ne.0._f) nstop=ii + end do + + ! nstop is now the index with the last mie-coefficient + ! (highest index i) an(i) not equal zero. + ! since all the an were set to zero before calling + ! cmie(), nstop is the termination index used in cmie() + ! or in intmie(). Usually, a termination index + ! nstop = INT( 2 + x + 4 x^(1/3) ) is used; in intmie(), + ! however, a value of + ! nstop := MAX( INT(...), |m*x| )+15 is used !??? + + sigmas=0._f + sigmae=0._f + + do nn=1,nstop + nc1=abs(an(nn))**2._f+abs(bn(nn))**2._f + nc1=nc1*(2._f*nn+1._f) + sigmas=sigmas+nc1*(2._f*3.14159265_f)/(fx_vars%k**2._f) + nc1=real(an(nn)+bn(nn)) + nc1=nc1*(2._f*nn+1._f) + sigmae=sigmae+nc1*(2._f*3.14159265_f)/(fx_vars%k**2._f) + sstest(nn)=sigmas + setest(nn)=sigmae + deltas=abs(sstest(nn-1)-sstest(nn))/sstest(nn) + deltae=abs(setest(nn-1)-setest(nn))/setest(nn) + if(deltas.gt.1.e-6_f) n2stop=nn + if(deltae.gt.1.e-6_f) n3stop=nn + end do + + n1stop=n2stop + if (n3stop.gt.n2stop) n1stop=n3stop + ! The order of the set of linear equations is chosen + ! as the number of mie coefficients where the sum yielding + ! the monomer ext./scatt. cross sections do not change more + ! than 1.D-3 compared to the values with one summand less. + + rg=fx_vars%alpha*fx_vars%nb**(1._f/fx_vars%df)*fx_vars%a ! rg := radius of gyration + krg=fx_vars%k*rg + ntheta=7800 !180-int(krg**.5*28*log10(dxk(kk))) + if (ntheta*0.5_f .eq. (ntheta/2)*1._f) ntheta=ntheta+1 + + ! *** ****************************************************************** + ! *** FIRST PART: Solution of self consistent mean field equation, + ! *** i.e. the set of linear equations (SLE) defining the + ! *** mean field coefficients d^1_1,n and d^2_1,n + ! *** according to Eq.(12) of (Botet 1997) + ! *** To do so, + ! *** - matrix elements A^1,nu_1,n and B^1,nu_1,n + ! *** are calculated with Eq.(13), using Eqns.(14)-(16) + ! *** - the set of lin. Eqns. is solved yielding the d's + ! *** ****************************************************************** + ! *** Eq.(12) of Botet et al 1997 defines a matrix eqn. of order 2N : + ! *** (since N=n1stop, 2N = 2 * n1stop = order of SLE) + ! *** + ! *** EpABC * dvec = cvec with + ! *** + ! *** dvec and cvec being the 2N-vectors + ! *** + ! *** ( d^(1)_1,1 ) ( a_1 ) + ! *** ( d^(1)_1,2 ) ( a_2 ) + ! *** ( ... ) ( ... ) + ! *** ( d^(1)_1,n ) ( a_n ) + ! *** dvec := ( d^(2)_1,1 ) and cvec := ( b_1 ) and further + ! *** ( d^(2)_1,2 ) ( b_2 ) + ! *** ( ... ) ( ... ) + ! *** ( d^(2)_1,n ) ( b_n ) + ! *** + ! *** + ! *** EpABC := 1 + AB * C where AB, 1, C are the 2N*2N - matrices + ! *** + ! *** ( a_1 0 0 ... ... 0 ) + ! *** ( 0 a_2 0 ... ... 0 ) + ! *** AB := ( 0 0 ... 0 0 0 ... 0 ) 1 := 2N*2N unity matrix + ! *** ( 0 0 ... a_n 0 0 ... 0 ) + ! *** ( 0 0 ... 0 b_1 0 ... 0 ) + ! *** ( ... ... ... 0 ) + ! *** ( ... ... 0 b_n-1 0 ) + ! *** ( 0 0 ... ... 0 0 b_n) + ! *** + ! *** and ( A B ) + ! *** C := ( ) where A and B are the two N*N matrices + ! *** ( B A ) given by Eq.(13), + ! *** including the factor (N_monomers - 1): + ! *** + ! *** A_n,nu := (N_m-1) * A_(1,n)^(1,nu) and + ! *** B_n,nu := (N_m-1) * B_(1,n)^(1,nu) + ! *** + ! *** (A_(1,n... and B_(1,n... according to Eq.(13) of Botet 1997) + ! *** ****************************************************************** + + n2stop = 2 * n1stop ! n2stop = order of SLE + + ! *** ****************************************************************** + ! *** Error handling moved from xfreal_n, xfimag_n. Calculations fail + ! *** in integration package when n2stop > 48. n2stop is related to the + ! *** number of complex mie scattering coefficients used in teh calculation + ! *** which is in turn related to the size parameter of monomers. + ! *** If nstop>48 end calculation here instead of continuing. + + if (n2stop.gt.48) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "fractal_meanfield_mod::n2stop greater & + &than 48. Size parameter (2*pi*rmon/lambda): ", & + 2._f*3.14159265_f*fx_vars%a/lbd, "Monomer Size parameter & + &must be less than ~17." + end if + rc = RC_ERROR + return + endif + + + ! *** ****************************************************************** + do ii=1,n1stop + cvec(ii) = an(ii) ! right hand side vector + cvec(n1stop+ii) = bn(ii) + dvec(ii) = zeroc ! solution vector d + dvec(n1stop+ii) = zeroc + end do + + do pp=0,n2stop !variable p + res = funs_n(carma,fx_vars,pp,rc) ! Eq.(16) S_p(k R_g) + if (rc < 0) return + funcs(pp) = res + end do + + ! Calculate terms A and B + + ! *** loops over indices nu,n,p : + do ii=1,n1stop !variable n + do jj=1,n1stop !variable nu + mm = IABS(ii-jj) + tt = ii+jj + + ! *** ****************************************************************** + ! calculation of A_(1,n)^(1,nu) according to Eq.(13) + ! *** ****************************************************************** + do pp=mm,tt + + funca(jj,ii,pp) = funa(carma,fx_vars,jj,ii,pp,rc) ! Eq.(14) a(nu,n;p)a + if (rc < 0) return + + Ap1(ii,jj) = Ap1(ii,jj) + & + ( onec * (ii*(ii+1)+jj*(jj+1)-pp*(pp+1)) ) & + * funca(jj,ii,pp) * funcs(pp) + end do ! loop over pp (variable p) + + ! scaling factors of eq.(13), factor (N_mon-1) from eq.(12) + Ap1(ii,jj) = Ap1(ii,jj) * (2._f*jj+1._f)/(jj*(jj*1._f+1._f)) + Ap1(ii,jj) = Ap1(ii,jj) * (fx_vars%nb-1._f) / (ii*(ii*1._f+1._f)) + + ! *** ****************************************************************** + ! calculation of B_(1,n)^(1,nu) according to Eq.(13) + ! *** ****************************************************************** + do pp=mm,tt + Bp1(ii,jj) = Bp1(ii,jj) + funb_n(jj,ii,pp,funca) * funcs(pp) + end do ! loop over pp (variable p) + + ! scaling factors of eq.(13), factor (N_mon-1) from eq.(12) + Bp1(ii,jj) = Bp1(ii,jj) * (2._f*jj+1._f)/(jj*(jj*1._f+1._f)) + Bp1(ii,jj) = Bp1(ii,jj) * (fx_vars%nb-1._f) * 2._f/(ii*(ii*1._f+1._f)) + end do ! loop over jj=1,n1stop (variable nu) + end do ! loop over ii=1,n1stop (variable n) + + ! *** ****************************************************************** + ! End of Calculation of terms A and B + + ! *** ****************************************************************** + ! *** Setup and solution of matrix equation of order 2N ( = n2stop ) + ! *** constituted by eq.(12) + ! *** ****************************************************************** + ! *** matrix product (AB * C) (definitions see above) + do ii=1,n1stop + do jj=1,n1stop + EpABC(ii,jj) = an(ii) * Ap1(ii,jj) + EpABC(ii,jj+n1stop) = an(ii) * Bp1(ii,jj) + EpABC(ii+n1stop,jj) = bn(ii) * Bp1(ii,jj) + EpABC(ii+n1stop,jj+n1stop) = bn(ii) * Ap1(ii,jj) + end do + end do + + ! *** ****************************************************************** + ! *** add 2N*2N unity matrix + do ii=1,n1stop + EpABC(ii,ii) = EpABC(ii,ii) + onec + EpABC(ii+n1stop,ii+n1stop) = EpABC(ii+n1stop,ii+n1stop) + onec + end do + + ! ====================================================================== + ! *** solve matrix equation using external routines (LU decomposition) + CALL LUDCMPC(EpABC,n2stop,n2m,luindx,dlu) + CALL LUBKSBC(EpABC,n2stop,n2m,luindx,cvec) + do ii=1,n1stop + d1(ii) = cvec(ii) + d2(ii) = cvec(ii+n1stop) + end do + + ! *** ****************************************************************** + ! *** SECOND PART: Recomposition of the total wave scattered by + ! *** the entire agglomerate/cluster by adding the + ! *** waves scattered by each monomer taking into + ! *** account the respective phase of the single waves. + ! *** ****************************************************************** + + ! *** ****************************************************************** + ! ---------------------------------------------------------------------- + ! 1) Calculate the amplitude functions |S1^j(th)| et |S2^j(th)| + ! of one monomer of the agglomerate/cluster: + ! ( see e.g. Bohren, Huffman (1983) p.112, Eq.(4.74) with the + ! substitutions a_n -> d^1_1,n and b_n -> d^2_1,n + ! or Rannou (1999) Eq.(1)-(6) ) + ! ---------------------------------------------------------------------- + ! *** ****************************************************************** + + do iy=0,ntheta-1,1 ! loop over angles + angle=iy*180._f/(ntheta-1) + s1(iy)=0._f + s2(iy)=0._f + wom=cos(angle*3.1415926353_f/180._f) + + do ir=1,n1stop ! loop over Mie - indices + xfact=2._f*(2._f*ir+1._f)/(ir*1._f*(ir*1._f+1._f)) + ajt=d1(ir)*fpi(ir,wom,fx_vars)+d2(ir)*tau(ir,wom,fx_vars) + s1(iy)=s1(iy)+xfact*ajt + ajt=d1(ir)*tau(ir,wom,fx_vars)+d2(ir)*fpi(ir,wom,fx_vars) + s2(iy)=s2(iy)+xfact*ajt + end do + + s11(iy)=abs(s1(iy))**2._f+abs(s2(iy))**2._f + pol(iy)=abs(s1(iy))**2._f-abs(s2(iy))**2._f + pol(iy)=pol(iy)/(abs(s1(iy))**2_f+abs(s2(iy))**2._f) + ! *** S_11(theta) = 1/2 * ( |S_1|^2 + |S_2|^2 ) + ! *** above, s1(theta) = 2 * S_1(theta) + ! *** =>S_11(theta) = 1/2 * ( |1/2*s1|^2 + |1/2*s2|^2 ) + ! = 1/8 * ( |s1|^2 + |s2|^2 ) + s11_n(iy)=.125_f*(abs(s1(iy))**2._f+abs(s2(iy))**2._f) + end do + + s01=s1(0) + s02=s2(0) + + ! *** Extinction cross section sigext( d^1_1,n , d^2_1,n ) *** + sigext=0._f + do ir=1,n1stop ! loop (sum) over Mie-indices + sigext=sigext+(2._f*ir+1._f)*REAL(d1(ir)+d2(ir)) + end do + sigext = fx_vars%nb * 2._f*pi/fx_vars%k**2._f * sigext ! Eq.(27) + + ! *** Alternatively (in a test, all values agreed with rel.acc. 1e-6), + ! *** Extinction cross section sigext( S(0 deg) ) (optical theorem) *** + ! *** (see e.g. Bohren, Huffman (1983), Eq. (4.76)) + ! *** S(0)=S_1(0)=S_2(0); sigma_ext = 4 pi / k^2 * Re(S(0)) + ! *** above, s1(theta) = 2 * S_1(theta) (factor 2 in 'xfact') + ! sigext2 = nb * 4._f*pi/k**2._f * 0.5_f*REAL(s01) + ! sigext3 = nb * 4._f*pi/k**2._f * 0.5_f*REAL(s02) + ! *** ****************************************************************** + + ! *** ****************************************************************** + ! ---------------------------------------------------------------------- + ! 2) Calculate the phase integral in Eq.(26) with P(r) already + ! substituted ( compare Eq.(10) and (Botet 1995) ) : + ! INT(0;infinity)[ sin(2XuZ) u^(d-2) f_co(u) du ] + ! taking into account the different phases of the single + ! scattered waves. + ! ---------------------------------------------------------------------- + ! *** ****************************************************************** + do q=0,ntheta-1,1 + angle=q*180._f/(ntheta-1) + if (angle .eq. 0._f) angle=0.001_f + if (angle .eq. 180._f) angle=179.999_f + fx_vars%zed=sin(angle*3.1415928353_f/180._f/2._f) + + bound=0._f + interv=1 + errrel=1e-5_f + p1=0._f + dp1=0._f + + !====================================================================== + !--- Version using the QUADPACK - routine : + !---------------------------------------------------------------------- + ifail = 0 + CALL dqagi(fp1,fx_vars,bound,interv,errabs,errrel,p1,dp1,neval,ifail,maxsub,lenw,nsubin,iwork,work) + if(ifail.ne.0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "fractal_meanfield_mod::ifail=",ifail," returned by dqagi()!" + rc = RC_ERROR + return + endif + !====================================================================== + + p1=2._f*pi * (fx_vars%nb-1._f) / (fx_vars%coeff*fx_vars%zed*krg)*p1 + 1._f + xint(q)=p1 + end do + + ! *** now, xint(theta) contains the square bracket terms in + ! *** Botet (1997) Eq.(26) or Rannou (1999) Eq.(1) + + ! *** ****************************************************************** + ! ---------------------------------------------------------------------- + ! 3) Calculation of the phase function, calculation of the optical + ! properties (asymmetrie factor g, scatt. cross section sigma_s) + ! by angular integration: INT_0^180[ ... d_theta ] + ! ---------------------------------------------------------------------- + ! *** ****************************************************************** + + total=0._f + totg=0._f + + do q=1,ntheta-2,2 + angle=(q-1)*180._f/(ntheta-1) ! angle in deg + a0=fx_vars%nb*xint(q-1)*s11(q-1)*sin(angle*3.1415926353_f/180._f) + c0=cos(angle*3.1415926353_f/180._f) + + angle=q*180._f/(ntheta-1) + a1=fx_vars%nb*xint(q)*s11(q)*sin(angle*3.1415926353_f/180._f) + c1=cos(angle*3.1415926353_f/180._f) + + angle=(q+1)*180._f/(ntheta-1) + a2=fx_vars%nb*xint(q+1)*s11(q+1)*sin(angle*3.1415926353_f/180._f) + c2=cos(angle*3.1415926353_f/180._f) + + total=total+2._f/6._f*3.1415926353_f/(ntheta-1)*(a0+4._f*a1+a2) + totg=totg+2._f/6._f*3.1415926353_f/(ntheta-1)*(a0*c0+4._f*a1*c1+a2*c2) + end do + totg=totg/total + + ! *** ****************************************************************** + ! *** angular integration of I(theta) according to + ! *** Botet (1997) Eq.(26) or Rannou (1999) Eq.(1) + ! *** I(theta) = N 2pi/k^2 * S(theta) * [ phase integral ] + ! *** with + ! *** S(theta) = s11_n(i) + ! *** [ phase i. ] = xint(i) + ! *** Perfom integration using the following rule: + ! *** Integral_0^pi[ I(theta) sin(theta) d_theta ] + ! *** + ! *** = Sum_q=1^ntheta-1{ Integral_th_(i-1)^th_i [ + ! *** + ! *** 1/2(I(th_(i-1))+I(th_i)) * sin(th) d_th ] } + ! *** + ! *** = sin(delta_theta/2) * Sum_q=1^ntheta-1{ + ! *** + ! *** ( I(th_(i-1)) + I(th_i) ) * sin(th_middle) } + ! *** + ! *** ****************************************************************** + + !dthetad = 180._f / (ntheta-1) ! angular interval in deg + dthetar = pi / (ntheta-1) ! angular interval in rad + sumsca = 0._f + do q=1,ntheta-1,1 + angler = (DBLE(q)-.5_f)*dthetar ! middle of interval in rad + weight = SIN(angler) ! integration weight + val = s11_n(q-1)*xint(q-1) + s11_n(q)*xint(q) + sumsca = sumsca + val*weight + end do + + sumsca = sin(.5_f*dthetar) * sumsca ! interval width factor + ! *** Scattering cross section + sigsca = 2._f * pi / fx_vars%k**2._f * DBLE(fx_vars%nb) * sumsca + ! Warning! sigabs is well computed using this approximation + sigabs=fx_vars%nb*(sigmae-sigmas) + ! sigext=sigabs+sigsca is better than the mean-field value + ! previously defined. This is used hereafter. (P.Rannou) + + ! *** Radius of equivalent mass sphere + rems = fx_vars%a * fx_vars%nb**(1._f/3._f) + + ! *** reference area in definition of efficiencies is the geometrical + ! *** cross section of equivalent mass sphere + gems = pi * rems**2._f + + ! *** Extinction and scattering efficiencies: + qsca = sigsca / gems + qabs = sigabs / gems + qext = qabs + qsca + + gfac = totg + + end subroutine fractal_meanfield + + !! + !! Mie-scattering routine calling interface + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + subroutine cmie(lambda,xn,xk,rad,an,bn,nstop) + + ! Arguments + real(kind=f), intent(in) :: lambda !! wavelength (microns) + real(kind=f), intent(in) :: xn !! real index of refraction + real(kind=f), intent(in) :: xk !! imaginary index of refraction + real(kind=f), intent(in) :: rad !! monomer radius (meters) + complex(kind=f), intent(out) :: an(50) !! Mie wave coefficient an + complex(kind=f), intent(out) :: bn(50) !! Mie wave coefficient bn + integer, intent(out) :: nstop !! index of last mie-coefficent + + ! Local declarations + integer, parameter :: nang = 451 ! number of angles + complex(kind=f) :: refrel ! complex index of refraction + real(kind=f) :: theta(10000) + real(kind=f) :: x,dang + + refrel=cmplx(xn,xk,kind=f) + x=2._f*3.14159265_f*rad/lambda ! size parameter of monomer + dang=1.570796327_f/real(nang-1,kind=f) + + call intmie(x,refrel,nang,an,bn,nstop) + + return + end subroutine cmie + + !! + !! Mie scattering calculations + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + SUBROUTINE intmie(x,refrel,nang,an,bn,nstop) + + ! Arguments + real(kind=f), intent(in) :: x !! size parameter of monomer + complex(kind=f), intent(in) :: refrel !! complex index of refraction + integer, intent(in) :: nang !! number of angles + complex(kind=f), intent(out) :: an(nf) !! Mie wave coefficient an + complex(kind=f), intent(out) :: bn(nf) !! Mie wave coefficient an + integer, intent(out) :: nstop !! index of last mie-coefficent + + ! Local declarations + real(kind=f) :: amu(10000),pi(10000) + real(kind=f) :: pi0(10000),pi1(10000) + complex(kind=f) :: d(3000),y,xi,xi0,xi1 + complex(kind=f) :: s1(2000),s2(2000) + real(kind=f) psi0,psi1,psi,dn,dx + integer :: nmx,nn,n,j + real(kind=f) :: rn, xstop, dang, ymod, chi0, chi1, apsi0, apsi1, fn, chi, apsi + + dx=x + y=x*refrel + + xstop=x+4._f*x**.3333_f+2._f + nstop=xstop + ymod=abs(y) + nmx=dmax1(xstop,ymod)+15 + dang=1.570796327_f/real(nang-1,kind=f) + + ! Initializations + pi0(:) = 0._f + pi1(:) = 0._f + s1(:) = cmplx(0._f,0._f,kind=f) + s2(:) = cmplx(0._f,0._f,kind=f) + amu(:) = 0.0_f + pi(:) = 0.0_f + + d(:) = cmplx(0._f,0._f,kind=f) + nn=nmx-1 + + do n=1,nn + rn=nmx-n+1 + d(nmx-n)=(rn/y)-(1._f/(d(nmx-n+1)+rn/y)) + end do + + do j=1,nang + pi0(j)=0._f ! Legendre functions + pi1(j)=1._f + end do + + nn=2*nang-1 + + do j=1,nn + s1(j)=cmplx(0._f,0._f,kind=f) + s2(j)=cmplx(0._f,0._f,kind=f) + end do + + psi0=cos(dx) ! Initialize Bessel functions + psi1=sin(dx) + chi0=-sin(x) + chi1=cos(x) + + apsi0=psi0 + apsi1=psi1 + + xi0=cmplx(apsi0,-chi0,kind=f) + xi1=cmplx(apsi1,-chi1,kind=f) + + n=1 + + ! ************* iterate over index n ************* +200 dn=n + rn=n + fn=(2._f*rn+1._f)/(rn*(rn+1._f)) + + psi=(2._f*dn-1._f)*psi1/dx-psi0 ! calculate Bessel functions + chi=(2._f*rn-1._f)*chi1/x-chi0 + apsi=psi + xi=cmplx(apsi,-chi,kind=f) + + an(n)=(d(n)/refrel+rn/x)*apsi-apsi1 + an(n)=an(n)/((d(n)/refrel+rn/x)*xi-xi1) + bn(n)=(refrel*d(n)+rn/x)*apsi-apsi1 + bn(n)=bn(n)/((refrel*d(n)+rn/x)*xi-xi1) + + psi0=psi1 + psi1=psi + apsi1=psi1 + + chi0=chi1 + chi1=chi + xi1=cmplx(apsi1,-chi1,kind=f) + + n=n+1 + rn=n + + do 999 j=1,nang + pi1(j)=((2._f*rn-1._f)/(rn-1._f))*amu(j)*pi(j) + pi1(j)=pi1(j)-rn*pi0(j)/(rn-1._f) +999 pi0(j)=pi(j) + + if (n-1-nstop) 200,300,300 +300 continue + + return + END SUBROUTINE intmie + + !! + !! + !! CALLS: FUNCTION dqag/dqdag/DADAPT_() Integration + !! FUNCTION fpl() Integrand + !! + !! Integral in eq. 14, Botet et al. 1997 + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + function funa(carma,fx_vars,nu,n,p,rc) + type(carma_type), intent(in) :: carma !! the carma object + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + integer, intent(in) :: n !! indices + integer, intent(in) :: nu !! indices + integer, intent(in) :: p !! indices + integer, intent(inout) :: rc !! return code + real(kind=f) :: funa !! + + ! Local declarations + integer, parameter :: maxsub=1000 + real(kind=f) :: r,xa,xb,era,erl + integer :: interv + integer :: ifail + integer, parameter :: lenw=4000 ! .ge. 4*maxsub + integer :: iwork(maxsub),neval,nsubin ! nsubin=last + real(kind=f) :: work(lenw) + real(kind=f) :: bound, rres, rerr + + ! Set return code assuming success. + rc = RC_OK + + ! Initializations + funa=0._f + fx_vars%u1=n + fx_vars%u2=1 + fx_vars%u3=nu + fx_vars%u4=1 + fx_vars%u5=p + fx_vars%u6=0 + xa=-1._f + xb=1._f + bound=0._f + interv=1 + era=0._f + erl=1.e-4_f + rres=0._f + rerr=0._f + + !====================================================================== + !--- Version using the QUADPACK - routine : + !---------------------------------------------------------------------- + ifail = 0 + + call dqag(fpl,fx_vars,xa,xb,era,erl,3,rres,rerr,neval,ifail,maxsub,lenw,nsubin,iwork,work) + + if (ifail.ne.0) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "funa::ifail=",ifail, & + " returned by dqag() during call of funa(",nu,",",n,",",p,")" + end if + rc = RC_ERROR + return + endif + + rres=rres-2._f ! ceci est un artifice pour eviter que + ! la routine se plante quand la fonction + ! est paire (res=0.;err=1.d-3 impossible + ! a atteindre!! j'ai fpl'=fpl+1....d'ou + ! int(fpl)=int(fpl')-2. integr de -1 a 1! + + r = (2._f*p+1._f)/2._f + funa = r * rres + + return + END FUNCTION funa + + !! + !! CALLS: FUNCTION plgndr() Legendre-Functions + !! + !! Used in funa. Integrand of eq. 14, Botet et al. 1997 + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION fpl(x, fx_vars) + + ! Arguments + real(kind=f),intent(in) :: x !! + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local declarations + real(kind=f) :: fpl + integer :: m,n,mu,nu,p,pmu + real(kind=f) :: c1,c2,c3 + + c1=plgndr(fx_vars%u1,fx_vars%u2,x,fx_vars) + c2=plgndr(fx_vars%u3,fx_vars%u4,x,fx_vars) + c3=plgndr(fx_vars%u5,fx_vars%u6,x,fx_vars) + + fpl=c1*c2*c3+1._f !this is a trick! + + return + END FUNCTION fpl + + !! + !! Adapted from FUNCTION plgndr() in: Press, Teukolsky, Vetterling, Flannery + !! "Numerical Recipes in ???" (e.g. Num.Rec.in C, 2nd Ed., Cambridge Univ.Press, 1992, page 254) + !! + !! Calculate Legendre Polynomials, used in eq. 14 Botet et al. 1997 + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION plgndr(l,m,x,fx_vars) + + ! Arguments + integer, intent(in) :: l !! indices + integer, intent(in) :: m !! indices + real(kind=f), intent(in) :: x !! return result + type(adgaquad_vars_type), intent(in) :: fx_vars !! variables for functions being integrated + + ! Local declarations + real(kind=f) :: plgndr + integer ::lbl + real(kind=f) :: pll, pmm, somx2, pmmp1 + integer :: i, ll + real(kind=f) :: fact1 + integer :: mstar + + mstar=m + + lbl=0 + plgndr=0._f + + if (mstar.lt.0)then + mstar=-m + lbl=1 + endif + + if (mstar.gt.l) then + pll=0._f + plgndr=0._f + return ! si m>l, Pl,m=0 ! + endif + + pmm=1._f + + if(mstar.gt.0) then + somx2=sqrt((1._f-x)*(1._f+x)) + fact1=1._f + do i=1,mstar + pmm=+pmm*fact1*somx2 !cghmt - en + !! + fact1=fact1+2._f + end do + endif + + if(l.eq.mstar) then + plgndr=pmm + else + pmmp1=x*(2*mstar+1)*pmm + + if(l.eq.mstar+1) then + plgndr=pmmp1 + else + do ll=mstar+2,l + pll=(x*(2*ll-1)*pmmp1-(ll+mstar-1)*pmm)/(ll-mstar) + pmm=pmmp1 + pmmp1=pll + end do + plgndr=pll + endif + endif + + if (lbl.eq.1) then + plgndr=(-1)**mstar*(fx_vars%fact(l-mstar)/fx_vars%fact(l+mstar))*plgndr + mstar=-m !restitution du parametre m!!!!! + endif + + return + END FUNCTION plgndr + + !! + !! replaces funb(nu,n,p) in original code, + !! saving n*n re-calculations of funa(nu,n,p). + !! + !! Calculates eq. 15, Botet et al. 1997 + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION funb_n(nu,n,p,funca) + + ! Arguments + integer, intent(in) :: nu !! indices + integer, intent(in) :: n !! indices + integer, intent(in) :: p !! indices + real(kind=f), intent(in) :: funca(nmi,nmi,0:n2m) !! return result + + ! Local Declarations + real(kind=f) :: funb_n + integer :: i, l, j + real(kind=f) :: var + + funb_n = 0._f + i = int((p*1._f-1._f-abs(n*1._f-nu*1._f))*1._f/2._f) + !print*,nu,n,p,i + + do l=0,i + j = p-2*l-1 + + ! omit j = -1 (when nu=n and p=l=i=0) + IF (j .GE. 0) THEN + + var = funca(nu,n,j) ! in main, a(nu,n,p) was stored in + ! funca(nu,n;p) + funb_n = funb_n + var + ENDIF + + end do + funb_n = (2._f*p+1._f) * funb_n + return + END FUNCTION funb_n + + !! Replaces funs(pp,k) in original code + !! + !! CALLS: + !! FUNCTION dqagi/dq2agi/DADAPT_() Integration + !! FUNCTION xfreal_n() Integrand + !! FUNCTION xfimag_n() Integrand + !! + !! Calculates eq. 16 , Botet et al. 1997 + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version Mar 2013 + function funs_n(carma,fx_vars,pp,rc) + + ! Arguments + type(carma_type), intent(in) :: carma !! the carma object + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + integer, intent(in) :: pp !! indices + integer, intent(inout) :: rc !! return code + + ! Local Declarations + integer, parameter :: maxsub=50000 + complex(kind=f) :: rcomplex,funs_n + real(kind=f) :: rres,ires,rerr,ierr,afun + real(kind=f) :: xa,xb + integer :: ifail + integer, parameter :: lenw=200000 ! .ge. 4*maxsub + integer :: iwork(maxsub),neval,nsubin ! nsubin=last + real(kind=f) :: work(lenw) + real(kind=f) :: rg, bound, errabs, errrel + integer :: interv + + rc = RC_OK + + rg=fx_vars%alpha*fx_vars%nb**(1._f/fx_vars%df)*fx_vars%a + + afun=(2._f*3.1415926_f)/(fx_vars%k**3._f) + + + fx_vars%pbes=pp + fx_vars%kbes=fx_vars%k + + bound=0._f + interv=1 + + errabs=0._f + errrel=1.e-3_f + + rres=0._f + !trres=0._f + rerr=0._f + !trerr=0._f + xa=0._f + xb=5._f*fx_vars%k*rg + + !====================================================================== + !--- Version using the QUADPACK - routine : + !---------------------------------------------------------------------- + ifail = 0 + CALL dqagi(xfreal_n,fx_vars,bound,interv,errabs,errrel,rres,rerr,neval,ifail,maxsub,lenw,nsubin,iwork,work) + if (ifail.ne.0) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "funs_n::ifail=",ifail, & + " returned by dqag() during call of funs(",pp, & + ") while integrating xfreal_n()" + end if + rc = RC_ERROR + return + endif + + bound=0._f + interv=1 + + ires=0._f + ierr=0._f + xa=0._f + xb=5._f*fx_vars%k*rg + + !====================================================================== + !--- Version using the QUADPACK - routine : + !---------------------------------------------------------------------- + ifail = 0 + CALL dqagi(xfimag_n,fx_vars,bound,interv,errabs,errrel,ires,ierr,neval,ifail,maxsub,lenw,nsubin,iwork,work) + if(ifail.ne.0) then + if (carma%f_do_print) then + write(carma%f_LUNOPRT, *) "funs_n::ifail=",ifail, & + " returned by dqagi() during call of funs(",pp, & + ") while integrating xfimag_n()" + end if + rc = RC_ERROR + return + endif + + rcomplex = cmplx(1._f,0._f,kind=f)*rres + cmplx(0._f,1._f,kind=f)*ires + + funs_n = afun * rcomplex + + continue + return + END FUNCTION funs_n + + !! + !! replaces xfreel(xx) in original code + !! CALLS: FUNCTION BESSELJY() Spherical Bessel functions + !! FUNCTION phi() Probability distrib. + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version Mar 2013 + FUNCTION xfreal_n(xx, fx_vars) + + ! Arguments + real(kind=f), intent(in) :: xx + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local Declarations + complex(kind=f) :: z,xj(0:nf),xjp(0:nf),xy(0:nf),xyp(0:nf) + complex(kind=f) :: jsol,ysol,hsol,hpsol + real(kind=f) :: x,r,xfreal_n + integer :: ifail,p,pc + real(kind=f) :: rg + + ifail = 0 + rg = fx_vars%alpha*fx_vars%nb**(1._f/fx_vars%df)*fx_vars%a + x = xx + if (x.GT.3000._f) x=3000._f + z = x*cmplx(1._f,0._f,kind=f) + + pc = fx_vars%pbes + if( fx_vars%pbes .eq. 0 ) pc = fx_vars%pbes + 1 + + CALL BESSELJY(z,pc,xj,xjp,xy,xyp,ifail) + + r=x/fx_vars%kbes + + xfreal_n = real( z*z*xj(fx_vars%pbes)*xj(fx_vars%pbes) * phi(r,fx_vars) ) + + return + END FUNCTION xfreal_n + + !! + !! replaces xfima(xx) in original code + !! CALLS: FUNCTION BESSELJY() Spherical Bessel functions + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version Mar 2013 + FUNCTION xfimag_n(xx, fx_vars) + + ! Arguments + real(kind=f), intent(in) :: xx + type(adgaquad_vars_type), intent(inout) :: fx_vars !! variables for functions being integrated + + ! Local Declarations + complex(kind=f) :: z,xj(0:nf),xjp(0:nf),xy(0:nf),xyp(0:nf) + real(kind=f) :: x,r,xfimag_n + integer :: ifail,p,pc + real(kind=f) :: rg + + rg = fx_vars%alpha*fx_vars%nb**(1._f/fx_vars%df)*fx_vars%a + x = xx + if (x.gt.3000._f) x=3000._f + ifail = 0 + z = x*cmplx(1._f,0._f,kind=f) + + pc = fx_vars%pbes + if( fx_vars%pbes .eq. 0 ) pc = fx_vars%pbes + 1 + + CALL BESSELJY(z,pc,xj,xjp,xy,xyp,ifail) + + r=x/fx_vars%kbes + + xfimag_n = real( z*z*xj(fx_vars%pbes)*xy(fx_vars%pbes) * phi(r,fx_vars) ) + + return + END FUNCTION xfimag_n + + + !! Spherical Bessel functions j_n(z) and y_n(z) of complex + !! argument to desired accuracy, + !! and their derivatives, up to a maximal order n=LMAX. + !! j_n(z) = SQRT(pi/2 / z) * J_(n + 1/2)(z) + !! y_n(z) = SQRT(pi/2 / z) * Y_(n + 1/2)(z) + !! Adapted from: + !! I.J.Thompson, A.R.Barnett + !! "Modified Bessel Funkctions I_v(z) and K_v(z) + !! of Real Order and Complex Argument, to Selected + !! Accuracy" + !! COMP.PHYS.COMMUN. 47 (1987) 245-57 + !! (Source code printed on page 249) + !! ****************************************************************** + !! INPUTS: + !! X argument z, dble cmplx + !! z in the upper half plane, Im(z) > -3 + !! LMAX largest desired order of Bessel functions, int + !! j_n,y_n,j_n',y_n' are calculated for n=0 to n=LMAX + !! Dimension of arrays xj,xjp,xy,xyp at least (0:LMAX) + !! XJ(M) Spher. Bessel function j_m(z), dble cmplx + !! XJP(M) Derivative of Spher. Bessel function d/dz [ j_m(z) ], + !! dble cmplx + !! XY(M) Spher. Bessel function y_m(z), dble cmplx + !! XYP(M) Derivative of Spher. Bessel function d/dz [ y_m(z) ], + !! dble cmplx + !! IFAIL error flag, int + !! = 0 if all results are satisfactory + !! = -1 for arguments out of range + !! = > 0 for results ok up to and including the + !! function of order LMAX-IFAIL + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version Mar 2013 + SUBROUTINE BESSELJY (X, LMAX, XJ, XJP, XY, XYP, IFAIL) + + ! Arguments + complex(kind=f), intent(in) :: X + integer, intent(in) :: LMAX + complex(kind=f), intent(out) :: XJ(0:LMAX) + complex(kind=f), intent(out) :: XJP(0:LMAX) + complex(kind=f), intent(out) :: XY(0:LMAX) + complex(kind=f), intent(out) :: XYP(0:LMAX) + integer, intent(out) :: IFAIL + + ! Local Declarations + INTEGER, PARAMETER :: LIMIT = 20000 + REAL(kind=f),parameter :: ZERO = 0._f + REAL(kind=f),parameter :: ONE = 1._f + REAL(kind=f),parameter :: ACCUR = 1e-12_f + REAL(kind=f),parameter :: TM30 = 1e-30_f + COMPLEX(kind=f), parameter :: CI = (0._f, 1._f) + complex(kind=f) :: XI, W, PL, B, D, FF, DEL, C, XJ0, XH1, XH1P, XTEMP + integer :: L + + IF (ABS(X).LT.ACCUR .OR. AIMAG(X) .LT. -3.d0) THEN + IFAIL=-1 + GOTO 5 + END IF + + ! *** Lentz - Algorithmus (?) : + XI = ONE/X + W = XI + XI + PL = LMAX * XI + FF = PL + XI + B = FF + FF + XI + D = ZERO + C = FF + DO 1 L=1,LIMIT + D = B - D + C = B - ONE/C + IF(ABS(D).LT. TM30) D = TM30 + IF(ABS(C).LT. TM30) C = TM30 + D = ONE / D + DEL = D * C + FF = FF * DEL + B = B + W +1 IF(ABS(DEL-ONE).LT.ACCUR) GOTO 2 + IFAIL = -2 + GOTO 5 + +2 XJ(LMAX) = TM30 + XJP(LMAX) = FF * XJ(LMAX) + + ! *** Abwaertsrekursion + DO 3 L = LMAX-1,0,-1 + XJ(L) = PL * XJ(L+1) + XJP(L+1) + XJP(L) = PL * XJ(L) - XJ(L+1) +3 PL = PL - XI + + ! *** Calculate the l=0 Besselfunktionen + XJ0 = XI * SIN(X) + XY(0) = - XI * COS(X) + XH1 = EXP(CI * X) * XI * (-CI) + XH1P = XH1 * (CI - XI) + B = XH1P + + ! *** Rescale XJ, XJP, converting to spherical Bessels + ! *** Recur XH1,XH1P as sperical Bessels + W = ONE / XJ(0) + PL = XI + DO 4 L = 0,LMAX + XJ(L) = XJ0 * (W*XJ(L)) + XJP(L) = XJ0 * (W*XJP(L)) - XI * XJ(L) + IF (L.EQ.0) GOTO 4 + XTEMP = XH1 + XH1 = (PL-XI) * XTEMP - XH1P + PL = PL + XI + XH1P = - PL * XH1 + XTEMP + XY(L) = CI * (XJ(L) - XH1) ! y_n = i * ( j_n - h^1_n ) + XYP(L) = CI * (XJP(L) - XH1P) ! und dito fuer Ableitungen +4 CONTINUE + XYP(0) = CI * (XJP(0) - B) + RETURN + +5 WRITE(*,10) IFAIL +10 FORMAT( 'ERROR in SUBR BESSELJY() : IFAIL = ', I4) + RETURN + END SUBROUTINE BESSELJY + + !! + !! Angular function pi_l( x=cos(theta) ) + !! e.g. Bohren,Huffman (1983) + !! pp.94 ff Eq.(4.46)-(4.49) + !! p.112 + !! CALLS: FUNCTION plgndr() Legendre-Functions + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version Mar 2013 + FUNCTION fpi(l,x,fx_vars) + + ! Arguments + integer, intent(in) :: l + real(kind=f), intent(in) :: x + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local declarations + real(kind=f) :: fpi + real(kind=f) :: y + real(kind=f) :: flag + + y=x + if (x.eq.1._f) y=1._f-1.e-6_f + ! alternatively, one could use Bohren,Huffman + ! p.112: pi_n(1)=tau_n(1)= 1/2 * n * (n+1) !!! + flag=plgndr(l,1,y,fx_vars) + fpi=(1._f-y**2._f)**(-0.5_f)*flag + return + END FUNCTION fpi + + !! + !! Angular function tau_l( x=cos(theta) ) + !! e.g. Bohren,Huffman (1983) + !! pp.94 ff Eq.(4.46)-(4.49) + !! p.112 + !! CALLS: FUNCTION plgndr() Legendre-Functions + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION tau(l,x,fx_vars) + + ! Arguments + integer, intent(in) :: l + real(kind=f), intent(in) :: x + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local Declarations + real(kind=f) :: fp + real(kind=f) :: tau + real(kind=f) :: flag + real(kind=f) :: y + + y=x + if (x.eq.1._f) y=1._f-1.e-6_f + ! alternatively, one could use Bohren,Huffman + ! p.112: pi_n(1)=tau_n(1)= 1/2 * n * (n+1) !!! + flag=plgndr(l,0,y,fx_vars) + fp=fpi(l,y,fx_vars) + tau=-y*fp+l*(l*1._f+1._f)*flag + return + END FUNCTION tau + + !! + !! + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + function fp1(u, fx_vars) + + ! Arguments + real(kind=f), intent(in) :: u !! + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + real(kind=f) :: fp1 !! returns + + ! Local Declarations + real(kind=f) :: krg,s1,s2,s3,rg + + rg=fx_vars%alpha*fx_vars%a*fx_vars%nb**(1._f/fx_vars%df) + krg=fx_vars%k*rg + s1=sin(2._f*krg*fx_vars%zed*u) + s2=u**(fx_vars%df-2._f) + s3=fco(u, fx_vars) + fp1=s1*s2*s3 + + return + END FUNCTION fp1 + + !! + !! CALLS: FUNCTION dqagi/dqdagi/DADAPT_() Integration + !! FUNCTION fdval() Integrand + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION anorm(carma, fx_vars, rc) + + ! arguments + type(carma_type), intent(in) :: carma !! the carma object + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + integer, intent(inout) :: rc !! return code + + ! Local Declarations + real(kind=f) :: anorm + integer :: interv + integer, parameter :: maxsub=50000 + integer :: ifail + integer, parameter :: lenw=200000 ! .ge. 4*maxsub + integer :: iwork(maxsub),neval,nsubin ! nsubin=last + real(kind=f) :: work(lenw) + real(kind=f) :: bound,errrel,errabs,b,db,c + + rc = RC_OK + + bound=0._f + interv=1 + errrel=1.e-3_f + errabs=0._f + b=0._f + db=0._f + + !====================================================================== + !--- Version using the QUADPACK - routine : + !---------------------------------------------------------------------- + ifail = 0 + CALL dqagi(fdval,fx_vars,bound,interv,errabs,errrel,b,db,neval,ifail,maxsub,lenw,nsubin,iwork,work) + if(ifail.ne.0) then + if (carma%f_do_print) write(carma%f_LUNOPRT, *) "anorm::ifail=",ifail," returned by dqagi() during call of anorm" + rc = RC_ERROR + return + endif + + c=0.5_f + anorm=b*4._f*3.1415926_f + return + END FUNCTION anorm + + !! + !! Probability distribution of monomer location within cluster + !! CALLS: FUNCTION fdval() + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION phi(x,fx_vars) + + ! Arguments + real(kind=f), intent(in) :: x + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local Declarations + real(kind=f) :: fval,pref,phi, rg, z + + rg=fx_vars%alpha*fx_vars%nb**(1._f/fx_vars%df)*fx_vars%a + z=x/rg + pref=(x/rg)**(fx_vars%df-3._f)/(fx_vars%coeff*rg**3._f) + fval=z**(1._f-fx_vars%df)*fdval(z, fx_vars) + phi=pref*fval + continue + return + END FUNCTION phi + + !! + !! Probability distribution of monomer location within cluster + !! CALLS: FUNCTION fdval() + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION fco(z, fx_vars) + + ! Arguments + real(kind=f), intent(in) :: z + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Local Declarations + real(kind=f) :: fco + real(kind=f) :: fval + + fval=z**(1._f-fx_vars%df)*fdval(z, fx_vars) + fco=fval + continue + return + END FUNCTION fco + + !! + !! @author P. Rannou, R. Botet, Eric Wolf + !! @version March 2013 + FUNCTION fdval(x, fx_vars) + + type(adgaquad_vars_type), intent(inout) :: fx_vars !! varaibles for functions being integrated + + ! Arguments + real(kind=f), intent(in) :: x + + ! Local Declarations + real(kind=f) :: fdval + + fdval=x**(fx_vars%df-1._f)*exp(-x**fx_vars%df/2._f) + return + END FUNCTION fdval + +end module + + diff --git a/src/physics/carma/base/freezaerl_koop2000.F90 b/src/physics/carma/base/freezaerl_koop2000.F90 new file mode 100644 index 0000000000..c26ac320c6 --- /dev/null +++ b/src/physics/carma/base/freezaerl_koop2000.F90 @@ -0,0 +1,209 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! aerosol freezing only. +!! +!! The parameterization described by Koop et al., Nature 406, 611-614, 2000 +!! is used. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! To avoid nucleation into an evaporating bin, this subroutine must +!! be called after growp, which evaluates evaporation loss rates . +!! +!! @author Eric Jensen, Chuck Bardeen +!! @version Dec-2003, Apr-2010 +subroutine freezaerl_koop2000(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f), parameter :: prenuc = 2.075e33_f * RHO_W / RHO_I + real(kind=f), parameter :: kt0 = 1.6e0_f + real(kind=f), parameter :: dkt0dp = -8.8e0_f + real(kind=f), parameter :: kti = 0.22e0_f + real(kind=f), parameter :: dktidp = -0.17e0_f + + logical :: evapfrom_nucto + integer :: igas ! gas index + integer :: igroup ! group index + integer :: ibin ! bin index + integer :: iepart ! element for condensing group index + integer :: inuc ! nucleating element index + integer :: isol ! solute index of freezing particle + integer :: ienucto ! index of target nucleation element + integer :: ignucto ! index of target nucleation group + integer :: inucto ! index of target nucleation bin + real(kind=f) :: sifreeze + real(kind=f) :: aw + real(kind=f) :: CONTL + real(kind=f) :: CONTH + real(kind=f) :: H2SO4m + real(kind=f) :: WT + real(kind=f) :: volrat + real(kind=f) :: ssi + real(kind=f) :: ssl + real(kind=f) :: rjj + real(kind=f) :: rlogj + real(kind=f) :: daw + real(kind=f) :: riv + real(kind=f) :: vw0 + real(kind=f) :: awi + real(kind=f) :: rsi + real(kind=f) :: dmy + real(kind=f) :: rlnt + real(kind=f) :: td + real(kind=f) :: pp + real(kind=f) :: pp2 + real(kind=f) :: pp3 + real(kind=f) :: vi + real(kind=f) :: fkelv + real(kind=f) :: fkelvi + + + rc = RC_OK + + ! Aerosol freezing limited to T < 240K + if (t(iz) <= 240._f) then + + ! Loop over particle groups. + do igroup = 1,NGROUP + + igas = inucgas(igroup) + iepart = ienconc(igroup) + isol = isolelem(iepart) + + if (igas .ne. 0) then + + ! Bypass calculation if few particles are present + if (pconmax(iz,igroup) .gt. FEW_PC) then + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + do inuc = 1, nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + if (ienucto /= 0) then + ignucto = igelem( ienucto ) + + ! Only compute nucleation rate for aerosol freezing + ! + ! NOTE: If heterogeneous nucleation of glassy aerosols is being used + ! as a nucleation mechanism, then both the heterogeneous nucleation and + ! the homogeneous freezing need to be considered. + if ((iand(inucproc(iepart,ienucto), I_AF_KOOP_2000) /= 0)) then + + ! Loop over particle bins. + do ibin = 1, NBIN + + ssi = supsati(iz,igas) + ssl = supsatl(iz,igas) + + ! Calculate approximate critical saturation needed for homogeneous freezing + ! of sulfate aerosols (see Jensen and Toon, GRL, 1994). + sifreeze = 0.3_f + + ! Homogeneous freezing of sulfate aerosols should only occur if SL < Scrit + ! and SI > . + if (ssi > sifreeze) then + + ! Koop et al. nucleation rate parameterization + td = t(iz) + rlnt = log(td) + ! eqn 2, potential difference [J mol-1] + dmy = 210368._f + 131.438_f * td - (3.32373e6_f / td) - 41729.1_f * rlnt + rsi = RGAS / 1.e7_f ! gas constant [J mol-1 K-1] + ! Notes (p: ambient vs. at pressure) ? + awi = exp(dmy / (rsi * td)) + + ! eqn 4 + vw0 = -230.76_f - 0.1478_f * td + (4099.2_f / td) + 48.8341_f * rlnt + ! eqn 5 + vi = 19.43_f - 2.2e-3_f * td + 1.08e-5_f * td * td + + pp = 1.e-10_f * p(iz) ! pressure [GPa] + pp2 = pp * pp * 0.5_f + pp3 = pp2 * pp / 3._f + riv = vw0 * (pp - kt0 * pp2 - dkt0dp * pp3) - vi * (pp - kti * pp2 - dktidp * pp3) ! eqn 3 + + riv = riv * 1.e3_f ! [GPa cm3 mol-1] to [Pa m3 mol-1] + + ! NOTE: The wieght percent can become negative from this parameterization, + ! which is not physicsal. With small supersaturations, the water activity + ! becomes postive (>1.013) the weight percent becomes negative. Don't allow + ! the the supsatl to be greater than 0. + ssl = max(-1.0_f, min(0._f, ssl)) + + ! Water activity + aw = 1._f + ssl ! ? + + ! Kelvin effect on water activity + fkelv = exp(akelvin(iz,igas) / r(ibin,igroup)) ! ? + aw = aw / fkelv + + ! Nucleation rate + ! + ! NOTE: This formulation is only valid for daw in the range of + ! 0.26 < daw < 0.34, so limit daw to that range. + daw = aw * exp(riv / (rsi*td)) - awi ! eqn 6 + daw = min(0.34_f, max(daw, 0.26_f)) ! eqn 7 + + rlogj = ((29180._f * daw - 26924._f) * daw + 8502._f) * daw - 906.7_f ! eqn 7 + rlogj = min(rlogj, POWMAX*0.3_f) + rjj = 10._f**(rlogj) ! [cm-3 s-1] + + + ! Calculate volume ratio of wet/dry aerosols + if (aw < 0.05_f) then + CONTL = 12.37208932_f * (aw**(-0.16125516114_f)) - 30.490657554_f * aw - 2.1133114241_f + CONTH = 13.455394705_f * (aw**(-0.1921312255_f)) - 34.285174604_f * aw - 1.7620073078_f + elseif (aw <= 0.85) then + CONTL = 11.820654354_f * (aw**(-0.20786404244_f)) - 4.807306373_f * aw - 5.1727540348_f + CONTH = 12.891938068_f * (aw**(-0.23233847708_f)) - 6.4261237757_f * aw - 4.9005471319_f + else + CONTL = -180.06541028_f * (aw**(-0.38601102592_f)) - 93.317846778_f * aw + 273.88132245_f + CONTH = -176.95814097_f * (aw**(-0.36257048154_f)) - 90.469744201_f * aw + 267.45509988_f + endif + + H2SO4m = CONTL + ((CONTH - CONTL) * (t(iz) - 190._f) / 70._f) + WT = (98.0_f * H2SO4m) / (1000._f + 98._f * H2SO4m) + WT = max(0._f, min(1._f, WT)) + WT = 100._f * WT + + ! Volume ratio of wet/dry aerosols. + if (WT <= 0._f) then + volrat = 1.e10_f + else + volrat = rhosol(isol) / RHO_W * ((100._f - WT) / WT) + 1._f + endif + + ! [s-1] + rnuclg(ibin,igroup,ignucto) = rnuclg(ibin,igroup,ignucto) + rjj * volrat * vol(ibin,igroup) + endif ! ssi > sifreeze .and. target droplets not evaporating + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPACT + endif + enddo ! inuc = 1,nnuc2elem(iepart) + endif ! pconmax .gt. FEW_PC + endif ! (igas = inucgas(igroup) .ne. 0) + enddo ! igroup = 1,NGROUP + endif + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end subroutine diff --git a/src/physics/carma/base/freezaerl_mohler2010.F90 b/src/physics/carma/base/freezaerl_mohler2010.F90 new file mode 100644 index 0000000000..a21604da77 --- /dev/null +++ b/src/physics/carma/base/freezaerl_mohler2010.F90 @@ -0,0 +1,183 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! aerosol freezing only. +!! +!! The parameterization described by Mohler et al., presented at the AMS +!! Cloud physics workshop (2010) is used. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! To avoid nucleation into an evaporating bin, this subroutine must +!! be called after growp, which evaluates evaporation loss rates . +!! +!! @author Chuck Bardeen +!! @version Aug-2010 +subroutine freezaerl_mohler2010(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f), parameter :: prenuc = 2.075e33_f * RHO_W / RHO_I + real(kind=f), parameter :: kt0 = 1.6e0_f + real(kind=f), parameter :: dkt0dp = -8.8e0_f + real(kind=f), parameter :: kti = 0.22e0_f + real(kind=f), parameter :: dktidp = -0.17e0_f + + logical :: evapfrom_nucto + integer :: igas ! gas index + integer :: igroup ! group index + integer :: ibin ! bin index + integer :: iepart ! element for condensing group index + integer :: inuc ! nucleating element index + integer :: isol ! solute index of freezing particle + integer :: ienucto ! index of target nucleation element + integer :: ignucto ! index of target nucleation group + integer :: inucto ! index of target nucleation bin + real(kind=f) :: sifreeze + real(kind=f) :: aw + real(kind=f) :: CONTL + real(kind=f) :: CONTH + real(kind=f) :: H2SO4m + real(kind=f) :: WT + real(kind=f) :: volrat + real(kind=f) :: ssi + real(kind=f) :: ssl + real(kind=f) :: rjj + real(kind=f) :: rlogj + real(kind=f) :: daw + real(kind=f) :: riv + real(kind=f) :: vw0 + real(kind=f) :: awi + real(kind=f) :: rsi + real(kind=f) :: dmy + real(kind=f) :: rlnt + real(kind=f) :: td + real(kind=f) :: pp + real(kind=f) :: pp2 + real(kind=f) :: pp3 + real(kind=f) :: vi + real(kind=f) :: fkelv + real(kind=f) :: fkelvi + + + rc = RC_OK + + ! Aerosol freezing limited to T < 240K + if (t(iz) <= 240._f) then + + ! Loop over particle groups. + do igroup = 1,NGROUP + + igas = inucgas(igroup) + iepart = ienconc(igroup) + isol = isolelem(iepart) + + if (igas .ne. 0) then + + ! Bypass calculation if few particles are present + if (pconmax(iz,igroup) .gt. FEW_PC) then + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + do inuc = 1, nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + if (ienucto /= 0) then + ignucto = igelem( ienucto ) + + ! Only compute nucleation rate for aerosol freezing + ! + ! NOTE: If heterogeneous nucleation of glassy aerosols is being used + ! as a nucleation mechanism, then both the heterogeneous nucleation and + ! the homogeneous freezing need to be considered. + if (iand(inucproc(iepart,ienucto), I_AF_MOHLER_2010) /= 0) then + + ! Loop over particle bins. + do ibin = 1, NBIN + + ssi = supsati(iz,igas) + ssl = supsatl(iz,igas) + + ! Adjust ssi for the Kelvin effect. + fkelvi = exp(akelvini(iz,igas) / r(ibin,igroup)) + ssi = ssi / fkelvi + + ! Calculate approximate critical saturation needed for homogeneous freezing + ! of sulfate aerosols (see Jensen and Toon, GRL, 1994). + sifreeze = 0.3_f + + ! Homogeneous freezing of sulfate aerosols should only occur if SL < Scrit + ! and SI > . + if (ssi > sifreeze) then + + ! Mohler et al. 2010? nucleation rate parameterization + rlogj = 97.973292_f - 154.67476_f * (ssi + 1._f) - 0.84952712_f * t(iz) + 1.0049467_f * (ssi + 1._f) * t(iz) + rjj = 10._f**(rlogj) ! [cm-3 s-1] + + ! NOTE: The weight percent can become negative from this parameterization, + ! which is not physicsal. With small supersaturations, the water activity + ! becomes postive (>1.013) the weight percent becomes negative. Don't allow + ! the the supsatl to be greater than 0. + ssl = max(-1.0_f, min(0._f, ssl)) + + ! Kelvin effect on water activity + aw = 1._f + ssl ! ? + fkelv = exp(akelvin(iz,igas) / r(ibin,igroup)) + aw = aw / fkelv + + ! Calculate volume ratio of wet/dry aerosols + if (aw < 0.05_f) then + CONTL = 12.37208932_f * (aw**(-0.16125516114_f)) - 30.490657554_f * aw - 2.1133114241_f + CONTH = 13.455394705_f * (aw**(-0.1921312255_f)) - 34.285174604_f * aw - 1.7620073078_f + elseif (aw <= 0.85) then + CONTL = 11.820654354_f * (aw**(-0.20786404244_f)) - 4.807306373_f * aw - 5.1727540348_f + CONTH = 12.891938068_f * (aw**(-0.23233847708_f)) - 6.4261237757_f * aw - 4.9005471319_f + else + CONTL = -180.06541028_f * (aw**(-0.38601102592_f)) - 93.317846778_f * aw + 273.88132245_f + CONTH = -176.95814097_f * (aw**(-0.36257048154_f)) - 90.469744201_f * aw + 267.45509988_f + endif + + H2SO4m = CONTL + ((CONTH - CONTL) * (t(iz) - 190._f) / 70._f) + WT = (98.0_f * H2SO4m) / (1000._f + 98._f * H2SO4m) + WT = max(0._f, min(1._f, WT)) + WT = 100._f * WT + + ! Volume ratio of wet/dry aerosols. + if (WT <= 0._f) then + volrat = 1.e10_f + else + volrat = rhosol(isol) / RHO_W * ((100._f - WT) / WT) + 1._f + endif + + ! NOTE: Limit the rate for stability. + ! [s-1] + rnuclg(ibin,igroup,ignucto) = rnuclg(ibin,igroup,ignucto) + min(1e20_f, rjj * volrat * vol(ibin,igroup)) + endif ! ssi > sifreeze .and. target droplets not evaporating + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPACT + endif + enddo ! inuc = 1,nnuc2elem(iepart) + endif ! pconmax .gt. FEW_PC + endif ! (igas = inucgas(igroup) .ne. 0) + enddo ! igroup = 1,NGROUP + endif + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end subroutine diff --git a/src/physics/carma/base/freezaerl_tabazadeh2000.F90 b/src/physics/carma/base/freezaerl_tabazadeh2000.F90 new file mode 100644 index 0000000000..e692abb46a --- /dev/null +++ b/src/physics/carma/base/freezaerl_tabazadeh2000.F90 @@ -0,0 +1,311 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! aerosol freezing only. +!! +!! The parameterization described by Tabazadeh et al. [GRL, 27, 1111, 2000.] is +!! used. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! @author Eric Jensen, Chuck Bardeen +!! @version Mar-1995, Nov-2009 +subroutine freezaerl_tabazadeh2000(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + ! Define parameters needed for freezing nucleation calculations. +! real(kind=f), parameter :: adelf = 1.29e-12_f +! real(kind=f), parameter :: bdelf = 0.05_f + real(kind=f), parameter :: prenuc = 2.075e33_f * RHO_W / RHO_I +! real(kind=f), parameter :: rmiv = 0.6_f + + integer :: igas !! gas index + integer :: igroup !! group index + integer :: ibin !! bin index + integer :: iepart !! element for condensing group index + integer :: inuc !! nucleating element index + integer :: ienucto !! index of target nucleation element + integer :: ignucto !! index of target nucleation group + integer :: isol + real(kind=f) :: A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 + real(kind=f) :: c0, C1, C2, C3, C4, c5 + real(kind=f) :: d0, d1, d2, d3, d4, d5 + real(kind=f) :: e0, e1, e2, e3, e4, e5 + real(kind=f) :: sifreeze + real(kind=f) :: rhoibar + real(kind=f) :: rlhbar + real(kind=f) :: act + real(kind=f) :: CONTL + real(kind=f) :: CONTH + real(kind=f) :: H2SO4m + real(kind=f) :: WT + real(kind=f) :: vrat + real(kind=f) :: wtfrac + real(kind=f) :: den + real(kind=f) :: diffact + real(kind=f) :: S260, S220, S180 + real(kind=f) :: sigma + real(kind=f) :: sigsula + real(kind=f) :: sigicea + real(kind=f) :: sigsulice + real(kind=f) :: ag + real(kind=f) :: delfg + real(kind=f) :: expon + real(kind=f) :: ssl + real(kind=f) :: fkelv + + + ! Loop over particle groups. + do igroup = 1,NGROUP + + igas = inucgas(igroup) + iepart = ienconc(igroup) + isol = isolelem(iepart) + + if( igas .ne. 0 )then + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. +! if( nnuc2elem(iepart) .gt. 1 )then + do inuc = 1,nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + if( ienucto .ne. 0 )then + ignucto = igelem( ienucto ) + + ! Only compute nucleation rate for aerosol freezing. + ! + ! NOTE: If heterogeneous nucleation of glassy aerosols is being used + ! as a nucleation mechanism, then both the heterogeneous nucleation and + ! the homogeneous freezing need to be considered. + if ((iand(inucproc(iepart,ienucto), I_AF_TABAZADEH_2000) /= 0)) then + + ! Loop over particle bins. Loop from largest to smallest for + ! evaluation of index of smallest bin nucleated during time step . + do ibin =NBIN,1,-1 + + ! Bypass calculation if few particles are present + if( pconmax(iz,igroup) .gt. FEW_PC )then + + ! Calculate approximate critical saturation needed for homogeneous freezing + ! of sulfate aerosols (see Jensen and Toon, GRL, 1994). + sifreeze = 0.3_f + + ! NOTE: The wieght percent can become negative from this parameterization, + ! which is not physicsal. With small supersaturations, the water activity + ! becomes postive (>1.013) the weight percent becomes negative. Don't allow + ! the the supsatl to be greater than 0. + ssl = max(-1.0_f, min(0._f, supsatl(iz,igas))) + + + ! Homogeneous freezing of sulfate aerosols should only occur of SL < Scrit + ! and SI > . + if( supsati(iz,igas) .gt. sifreeze)then + + ! Calculate mean ice density and latent heat of freezing over temperature + ! interval [T0,T] + + rhoibar = ( 0.916_f * (t(iz)-T0) - & + 1.75e-4_f/2._f * ((t(iz)-T0)**2) - & + 5.e-7_f * ((t(iz)-T0)**3)/3._f ) / (t(iz)-T0) + + rlhbar = ( 79.7_f * (t(iz)-T0) + & + 0.485_f/2._f * (t(iz)-T0)**2 - & + 2.5e-3_f/3._f * (t(iz)-T0)**3 ) & + / (t(iz)-T0) * 4.186e7*18._f + + ! Equilibrium H2SO4 weight percent for fixed water activity + act = min(1.0_f, ssl + 1._f) + + ! Kelvin effect on water activity + fkelv = exp(akelvin(iz,igas) / r(ibin,igroup)) ! ? + act = act / fkelv + + IF(act .LT. 0.05_f) THEN + CONTL = 12.37208932_f * (act**(-0.16125516114_f)) - & + 30.490657554_f * act - 2.1133114241_f + CONTH = 13.455394705_f * (act**(-0.1921312255_f)) - & + 34.285174604_f * act - 1.7620073078_f + END IF + IF(act .GE. 0.05_f .and. act .LE. 0.85_f) THEN + CONTL = 11.820654354_f * (act**(-0.20786404244_f)) - & + 4.807306373_f * act - 5.1727540348_f + CONTH = 12.891938068_f * (act**(-0.23233847708_f)) - & + 6.4261237757_f * act - 4.9005471319_f + END IF + IF(act .GT. 0.85_f) THEN + CONTL = -180.06541028_f * (act**(-0.38601102592_f)) - & + 93.317846778_f * act + 273.88132245_f + CONTH = -176.95814097_f * (act**(-0.36257048154_f)) - & + 90.469744201_f * act + 267.45509988_f + END IF + H2SO4m = CONTL + ((CONTH - CONTL) * (t(iz) -190._f)/70._f) + WT = (98.0_f * H2SO4m)/(1000._f + 98._f * H2SO4m) + WT = 100._f * WT + + ! Volume ratio of wet/dry aerosols. + vrat = rhosol(isol)/RHO_W * ((100._f-wt)/wt) + 1._f + + ! Calculation sulfate solution density from Myhre et al. (1998). + wtfrac = WT/100._f + C1 = t(iz) - 273.15_f + C2 = C1**2 + C3 = C1**3 + C4 = C1**4 + A0 = 999.8426_f + 334.5402e-4_f*C1 - 569.1304e-5_f*C2 + A1 = 547.2659_f - 530.0445e-2_f*C1 + 118.7671e-4_f*C2 & + + 599.0008e-6_f*C3 + A2 = 526.295e+1_f + 372.0445e-1_f*C1 + 120.1909e-3_f*C2 & + - 414.8594e-5_f*C3 + 119.7973e-7_f*C4 + A3 = -621.3958e+2_f - 287.7670_f*C1 - 406.4638e-3_f*C2 & + + 111.9488e-4_f*C3 + 360.7768e-7_f*C4 + A4 = 409.0293e+3_f + 127.0854e+1_f*C1 + 326.9710e-3_f*C2 & + - 137.7435e-4*C3 - 263.3585e-7*C4 + A5 = -159.6989e+4_f - 306.2836e+1_f*C1 + 136.6499e-3_f*C2 & + + 637.3031e-5_f*C3 + A6 = 385.7411e+4_f + 408.3717e+1_f*C1 - 192.7785e-3_f*C2 + A7 = -580.8064e+4_f - 284.4401e+1_f*C1 + A8 = 530.1976e+4_f + 809.1053_f*C1 + A9 = -268.2616e+4_f + A10 = 576.4288e+3_f + den = A0 + wtfrac*A1 + wtfrac**2 * A2 + & + wtfrac**3 * A3 + wtfrac**4 * A4 + den = den + wtfrac**5 * A5 + wtfrac**6 * A6 + & + wtfrac**7 * A7 + den = den + wtfrac**8 * A8 + wtfrac**9 * A9 + & + wtfrac**10 * A10 + + ! Activation energy is based on Koop's lab data. + IF(t(iz) .GT. 220._f) then + A0 = 104525.93058_f + A1 = -1103.7644651_f + A2 = 1.070332702_f + A3 = 0.017386254322_f + A4 = -1.5506854268e-06_f + A5 = -3.2661912497e-07_f + A6 = 6.467954459e-10_f + ELSE + A0 = -17459.516183_f + A1 = 458.45827551_f + A2 = -4.8492831317_f + A3 = 0.026003658878_f + A4 = -7.1991577798e-05_f + A5 = 8.9049094618e-08_f + A6 = -2.4932257419e-11_f + END IF + + diffact = ( A0 + A1*t(iz) + A2*t(iz)**2 + & + A3*t(iz)**3 + A4*t(iz)**4 + & + A5*t(iz)**5 + A6*t(iz)**6 ) * 1.0e-13_f + + ! Surface energy + + ! Weight percent function for T = 260 K + c0 = 77.40682664_f + c1 = -0.006963123274_f + c2 = -0.009682499074_f + c3 = 0.00088797988_f + c4 = -2.384669516e-05_f + c5 = 2.095358048e-07_f + S260 = c0 + c1*wt + c2*wt**2 + c3*wt**3 + & + c4*wt**4 + c5*wt**5 + + ! Weight percent function for T = 220 K + d0 = 82.01197792_f + d1 = 0.5312072092_f + d2 = -0.1050692123_f + d3 = 0.005415260617_f + d4 = -0.0001145573827_f + d5 = 8.969257061e-07_f + S220 = d0 + d1*wt + d2*wt**2 + d3*wt**3 + & + d4*wt**4 + d5*wt**5 + + ! Weight percent function for T = 180K + e0 = 85.75507114_f + e1 = 0.09541966318_f + e2 = -0.1103647657_f + e3 = 0.007485866933_f + e4 = -0.0001912224154_f + e5 = 1.736789787e-06_f + S180 = e0 + e1*wt + e2*wt**2 + e3*wt**3 + & + e4*wt**4 + e5*wt**5 + + if( t(iz) .GE. 220._f ) then + sigma = S260 + ((260._f-t(iz))*(S220-S260))/40._f + else + sigma = S220 + ((220._f-t(iz))*(S180-S220))/40._f + endif + + sigsula = sigma + sigicea = 105._f + sigsulice = abs( sigsula - sigicea ) + + ! Critical ice germ radius formed in the sulfate solution + ag = 2._f*gwtmol(igas)*sigsulice / & + ( rlhbar * rhoibar * log(T0/t(iz)) + & + rhoibar * rgas * 0.5_f * (T0+t(iz)) * & + log(ssl+1._f) ) + + if( ag .lt. 0._f ) ag = 1.e10_f + + ! Gibbs free energy of ice germ formation in the ice/sulfate solution + delfg = 4._f/3._f*PI * sigsulice * (ag**2) + + ! Ice nucleation rate in a 0.2 micron aerosol (/sec) + expon = ( -diffact - delfg ) / BK / t(iz) + expon = max( -100._f*ONE, expon ) + rnuclg(ibin,igroup,ignucto) = prenuc * & + sqrt(sigsulice*t(iz)) * & + vrat*vol(ibin,igroup) * exp( expon ) + + ! This parameterizations has problems that sometimes yield negative nucleation + ! rates. It would be best to fix the parameterization, but at least keep negative + ! values from being return. + if (rnuclg(ibin,igroup,ignucto) < 0._f) then + rnuclg(ibin,igroup,ignucto) = 0._f + end if + + + ! xh = 0.1 * r(ibin,igroup) / ag + ! phih = sqrt( 1. - 2.*rmiv*xh + xh**2 ) + ! rath = (xh-rmiv) / phih + ! fv3h = xh**3 * ( 2.*ONE - 3.*rath + rath**3 ) + ! fv4h = 3. * rmiv * xh**2 * (rath-1.) + ! if( abs(rath) .gt. 1.e0-1.e-8 ) fv3h = 0. + ! if( abs(rath) .gt. 1.e0-1.e-10 ) fv4h = 0. + ! + ! fh = 0.5 * ( ONE + ((ONE-rmiv*xh)/phih)**3 + + ! $ fv3h + fv4h ) + ! + ! expon = ( -delfwat2ice - delfg ) / BK / t3(ixyz) + ! expon = max( -POWMAX, expon ) + endif + endif ! pconmax(ixyz,igroup) .gt. FEW_PC + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPACT + endif + enddo ! inuc = 1,nnuc2elem(iepart) +! endif ! (nnuc2elem(iepart) .gt. 1) + endif ! (igas = inucgas(igroup) .ne. 0) + enddo ! igroup = 1,NGROUP + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/freezdropl.F90 b/src/physics/carma/base/freezdropl.F90 new file mode 100644 index 0000000000..f4151b4cbc --- /dev/null +++ b/src/physics/carma/base/freezdropl.F90 @@ -0,0 +1,74 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! droplet freezing only. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! @author Eric Jensen, Chuck Bardeen +!! @version Jan-2000, Nov-2009 +subroutine freezdropl(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup !! group index + integer :: ibin !! bin index + integer :: iepart !! element for condensing group index + integer :: inuc !! nucleating element index + integer :: ienucto !! index of target nucleation element + integer :: ignucto !! index of target nucleation group + + + ! Loop over particle groups. + do igroup = 1,NGROUP + + iepart = ienconc( igroup ) ! particle number density element + + ! Calculate nucleation loss rates. + do inuc = 1,nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + + if( ienucto .ne. 0 )then + ignucto = igelem( ienucto ) + + ! Only compute nucleation rate for droplet freezing + if( inucproc(iepart,ienucto) .eq. I_DROPFREEZE ) then + + ! Loop over particle bins. + do ibin = 1,NBIN + + ! Bypass calculation if few particles are present + if( pc(iz,ibin,iepart) .gt. FEW_PC )then + + ! Temporary simple kludge: Set to 1.e2 if T < -40C + if( t(iz) .lt. T0-40._f ) then + rnuclg(ibin,igroup,ignucto) = 1.e2_f + endif + + endif ! pc(source particles) .gt. FEW_PC + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPFREEZE + endif + enddo ! inuc = 1,nnuc2elem(iepart) + enddo ! igroup = 1,NGROUP + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/freezglaerl_murray2010.F90 b/src/physics/carma/base/freezglaerl_murray2010.F90 new file mode 100644 index 0000000000..1fa920fc86 --- /dev/null +++ b/src/physics/carma/base/freezglaerl_murray2010.F90 @@ -0,0 +1,136 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! heterogeneous nucleation of glassy aerosols only,. +!! +!! The parameterization of glass aerosols is described in Murray et al. +!! [Nature Geosciences, 2010], and is based upon measurements of the nucleation of +!! citric acid aerosols at cold temperatures. +!! +!! NOTE: This implementation assumes that the aerosol being nucleated is the total +!! aerosol population and not just the fraction of aerosols that are glassy. To +!! account for homogenous freezing of the aerosol population, the routine freezaerl +!! also needs to be called and the overall nucleation rate is the sum of +!! the rates for homogeneous freezing and for heterogenous nucleation. +!! +!! The parameter fglass is the fraction of the total aerosol population that will be +!! in a glassy state for T <= 212K. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! @author Chuck Bardeen, Eric Jensen +!! @version Apr-2010 +subroutine freezglaerl_murray2010(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + ! Define parameters needed for freezing nucleation calculations. + real(kind=f), parameter :: kice1 = 7.7211e-5_f ! Fit constant from Murray et al. + real(kind=f), parameter :: kice2 = 9.2688e-3_f ! Fit constant from Murray et al. + real(kind=f), parameter :: ssmin = 0.21_f ! Minimum supersaturation for nucleation + real(kind=f), parameter :: ssmax = 0.7_f ! Maximum supersaturation for nucleation + real(kind=f), parameter :: tglass = 212._f ! Maximum temperature for glassy state + real(kind=f), parameter :: fglass = 0.5_f ! Fraction of aerosols that can become glassy + + integer :: igas ! gas index + integer :: igroup ! group index + integer :: ibin ! bin index + integer :: iepart ! element for condensing group index + integer :: inuc ! nucleating element index + integer :: ienucto ! index of target nucleation element + integer :: ignucto ! index of target nucleation group + integer :: inucto ! index of target nucleation bin + real(kind=f) :: dfice ! difference in fraction of aerosol nucleated + real(kind=f) :: ssi, ssiold + + ! Assume success. + rc = RC_OK + + ! Loop over particle groups. + do igroup = 1,NGROUP + + igas = inucgas(igroup) ! condensing gas + iepart = ienconc( igroup ) ! particle number density element + + if (igas /= 0) then + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + do inuc = 1, nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + if (ienucto /= 0) then + ignucto = igelem(ienucto) + + ! Only compute nucleation rate for glassy aerosol freezing. + if ((iand(inucproc(iepart,ienucto), I_AF_MURRAY_2010) /= 0)) then + + ! Is it cold enough for aerosols to be in a glassy state. + if (t(iz) <= tglass) then + + ! Loop over particle bins. Loop from largest to smallest for + ! evaluation of index of smallest bin nucleated during time step . + do ibin = NBIN, 1, -1 + + ! Bypass calculation if few particles are present or if it isn't cold enough + ! for the aerosols to be present in a glassy state. + if (pconmax(iz,igroup) > FEW_PC) then + + ! Murray et al. [2010] doesn't really give a nucleation rate. Instead it gives + ! a fraction of glassy aerosol particles that have been nucleated as a function + ! of ice supersaturation. + ! + ! Since CARMA really wants to work with rates, use the difference in relative + ! humidity and the length of the timestep to come up with an approximation to + ! a nucleation rate. + + ! The supersaturation must be greater than .21 for heterogeneous nucleation to + ! commence. The fraction of glassy aerosol nucleated is: + ! + ! fice = 7.7211e-5 * RHi(%) - 9.2688e-3 for 121 % < RHi < 170 % + ! + ! To get a pseudo production rate, use + ! + ! rnuclg = (fice(RHi) - fice(RHi_old)) / dtime + ! + ssi = supsati(iz,igas) + ssiold = supsatiold(iz,igas) + + if ((ssi >= ssmin) .and. (ssi > ssiold)) then + dfice = kice1 * (1._f + min(ssmax, ssi)) * 100._f - kice2 + + if (ssiold >= ssmin) then + dfice = dfice - (kice1 * (1._f + min(ssmax, ssiold)) * 100._f - kice2) + endif + + ! Add the rate of heterogenous freezing to the rate of homogeneous + rnuclg(ibin,igroup,ignucto) = rnuclg(ibin,igroup,ignucto) + fglass * dfice / dtime + endif + endif + enddo + endif + endif + endif + enddo + endif + enddo + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/gasexchange.F90 b/src/physics/carma/base/gasexchange.F90 new file mode 100644 index 0000000000..14913b5b6b --- /dev/null +++ b/src/physics/carma/base/gasexchange.F90 @@ -0,0 +1,146 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the total production of gases due to nucleation, +!! growth, and evaporation [g/x_units/y_units/z_units/s]. +!! It also calculates the latent heating rate from a condensing gas +!! [deg_K/s] +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine gasexchange(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup !! group index + integer :: iepart + integer :: igas !! gasindex + integer :: i + integer :: i2 + integer :: ig2 + integer :: ienuc2 + integer :: ielem !! element index + real(kind=f) :: rlh + real(kind=f) :: gasgain + real(kind=f) :: gprod_nuc(NGROUP,NGAS) + real(kind=f) :: gprod_grow(NGROUP,NGAS) + + + ! Initialize local variables for keeping track of gas changes due + ! to nucleation and growth in each particle group. + gprod_nuc(:,:) = 0._f + gprod_grow(:,:) = 0._f + + ! First calculate gas loss and latent heat gain rates due to nucleation. + do igroup = 1,NGROUP + + igas = inucgas(igroup) ! condensing gas + ielem = ienconc(igroup) ! element of particle number concentration + + if( igas .ne. 0 .and. nnuc2elem(ielem) .gt. 0 )then + + do ienuc2 = 1,NELEM + + ig2 = igelem( ienuc2 ) ! target particle group + + if( if_nuc(ielem,ienuc2) ) then + + do i = 1,NBIN + + ! If there is no place for the nucleating particle bin to fit in the + ! nucleated particle, then just skip it. + ! + ! This could be an error if significant nucleation really happens from + ! these bins, but also more flexibility in setting up particle grids. + gprod_nuc(igroup,igas) = gprod_nuc(igroup,igas) - & + rhompe(i,ielem) * rmass(i,igroup) + + i2 = inuc2bin(i,igroup,ig2) ! target bin + if (i2 /= 0) then + gprod_nuc(igroup,igas) = gprod_nuc(igroup,igas) - & + pc(iz,i,ielem) * rnuclg(i,igroup,ig2) * diffmass(i2,ig2,i,igroup) + end if + enddo + + ! Latent heating rate from condensing gas: is latent heat of evaporation + ! ( + fusion, for ice deposition ) [erg/g] +! if(( inucproc(ielem,ienuc2) .eq. I_DROPACT ) .or. & +! ( inucproc(ielem,ienuc2) .eq. I_HOMNUC )) then +! rlh = rlhe(iz,igas) +! elseif(( inucproc(ielem,ienuc2) .eq. I_AERFREEZE ) .or. & +! ( inucproc(ielem,ienuc2) .eq. I_HETNUC ))then +! rlh = rlhe(iz,igas) + rlhm(iz,igas) +! endif + +! rlprod = rlprod - rlh * gprod_nuc(igroup,igas) / ( CP * rhoa(iz) ) + endif + enddo ! ienuc2 = 1,NELEM + endif ! (igas = inucgas(ielem) .ne. 0 + + ! Next calculate gas lost/gained due to and heat gained/lost from + ! growth/evaporation. + igas = igrowgas(ielem) ! condensing gas + + if( igas .ne. 0 )then + + do i = 1,NBIN-1 + + ! Calculate , mass concentration of gas gained due to evaporation + ! from each droplet in bin . First check for total evaporation. + if( totevap(i+1,igroup) )then + gasgain = ( 1._f - cmf(i+1,igroup) )*rmass(i+1,igroup) + else + gasgain = diffmass(i+1,igroup,i,igroup) + endif + + gprod_grow(igroup,igas) = gprod_grow(igroup,igas) & + + evaplg(i+1,igroup) * pc(iz,i+1,ielem) * & + gasgain & + - growlg(i,igroup) * pc(iz,i,ielem) * & + diffmass(i+1,igroup,i,igroup) + enddo + + ! Add evaporation out of smallest bin (always total evaporation). + gprod_grow(igroup,igas) = gprod_grow(igroup,igas) + & + evaplg(1,igroup) * pc(iz,1,ielem) * & + ( 1._f - cmf(1,igroup) ) * rmass(1,igroup) + + ! Latent heating rate from condensing gas: is latent heat of evaporation + ! ( + fusion, for ice deposition ) [erg/g] +! if( is_grp_ice(igroup) )then +! rlh = rlhe(iz,igas) + rlhm(iz,igas) +! else +! rlh = rlhe(iz,igas) +! endif + +! rlprod = rlprod - rlh * gprod_grow(igroup,igas) / & +! ( CP * rhoa(iz) ) + endif ! (igas = igrowgas(ielem)) .ne. 0 + enddo ! igroup=1,NGROUP + + ! Sum up gas production from nucleation and growth terms. + do igas = 1,NGAS + do igroup = 1,NGROUP + gasprod(igas) = gasprod(igas) + & + gprod_nuc(igroup,igas) + gprod_grow(igroup,igas) + enddo + enddo + + ! Return to caller with evaluated. + return +end diff --git a/src/physics/carma/base/growevapl.F90 b/src/physics/carma/base/growevapl.F90 new file mode 100644 index 0000000000..6190ff46bd --- /dev/null +++ b/src/physics/carma/base/growevapl.F90 @@ -0,0 +1,256 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluate particle loss rates due to condensational +!! growth and evaporation for all condensing gases. +!! +!! The loss rates for each group are and . +!! +!! Units are [s^-1]. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine growevapl(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup + integer :: iepart + integer :: igas + integer :: ibin + integer :: isol + integer :: nother + integer :: ieoth_rel + integer :: ieoth_abs + integer :: jother + real(kind=f) :: argsol + real(kind=f) :: othermtot + real(kind=f) :: condm + real(kind=f) :: akas + real(kind=f) :: expon + real(kind=f) :: g0 + real(kind=f) :: g1 + real(kind=f) :: g2 + real(kind=f) :: ss + real(kind=f) :: pvap + real(kind=f) :: dpc + real(kind=f) :: dpc1 + real(kind=f) :: dpcm1 + real(kind=f) :: rat1 + real(kind=f) :: rat2 + real(kind=f) :: rat3 + real(kind=f) :: rat4 + real(kind=f) :: ratt1 + real(kind=f) :: ratt2 + real(kind=f) :: ratt3 + real(kind=f) :: den1 + real(kind=f) :: test1 + real(kind=f) :: test2 + real(kind=f) :: x + integer :: ieother(NELEM) + real(kind=f) :: otherm(NELEM) + real(kind=f) :: dela(NBIN) + real(kind=f) :: delma(NBIN) + real(kind=f) :: aju(NBIN) + real(kind=f) :: ar(NBIN) + real(kind=f) :: al(NBIN) + real(kind=f) :: a6(NBIN) + real(kind=f) :: dmdt(NBIN) + real(kind=f) :: growlg_max + + + do igroup = 1,NGROUP + + ! element of particle number concentration + iepart = ienconc(igroup) + + ! condensing gas + igas = igrowgas(iepart) + + if (igas .ne. 0) then + ! Only valid for condensing liquid water and sulfric acid currently. + if ((igas /= igash2o) .and. (igas .ne. igash2so4)) then + if (do_print) write(LUNOPRT,*) 'growevapl::ERROR - Invalid gas (', igas, ').' + rc = -1 + return + endif + + ! Treat condensation of gas to/from particle group . + ! + ! Bypass calculation if few particles are present + if( pconmax(iz,igroup) .gt. FEW_PC )then + do ibin = 1,NBIN-1 + + ! Determine the growth rate (dmdt). This calculation may take into account + ! radiative effects on the particle which can affect the growth rates. + call pheat(carma, cstate, iz, igroup, iepart, ibin, igas, dmdt(ibin), rc) + + enddo ! ibin = 1,NBIN-1 + + ! Now calculate condensation/evaporation production and loss rates. + ! Use Piecewise Polynomial Method [Colela and Woodard, J. Comp. Phys., + ! 54, 174-201, 1984] + ! + ! First, use cubic fits to estimate concentration values at bin + ! boundaries + do ibin = 2,NBIN-1 + + dpc = pc(iz,ibin,iepart) / dm(ibin,igroup) + dpc1 = pc(iz,ibin+1,iepart) / dm(ibin+1,igroup) + dpcm1 = pc(iz,ibin-1,iepart) / dm(ibin-1,igroup) + ratt1 = pratt(1,ibin,igroup) + ratt2 = pratt(2,ibin,igroup) + ratt3 = pratt(3,ibin,igroup) + dela(ibin) = ratt1 * ( ratt2*(dpc1-dpc) + ratt3*(dpc-dpcm1) ) + delma(ibin) = 0._f + + if( (dpc1-dpc)*(dpc-dpcm1) .gt. 0._f ) & + delma(ibin) = min( abs(dela(ibin)), 2._f*abs(dpc-dpc1), & + 2._f*abs(dpc-dpcm1) ) * sign(1._f, dela(ibin)) + + enddo ! ibin = 2,NBIN-2 + + do ibin = 2,NBIN-2 + + dpc = pc(iz,ibin,iepart) / dm(ibin,igroup) + dpc1 = pc(iz,ibin+1,iepart) / dm(ibin+1,igroup) + dpcm1 = pc(iz,ibin-1,iepart) / dm(ibin-1,igroup) + rat1 = prat(1,ibin,igroup) + rat2 = prat(2,ibin,igroup) + rat3 = prat(3,ibin,igroup) + rat4 = prat(4,ibin,igroup) + den1 = pden1(ibin,igroup) + + ! is the estimate for concentration (dn/dm) at bin + ! boundary +1/2. + aju(ibin) = dpc + rat1*(dpc1-dpc) + 1._f/den1 * & + ( rat2*(rat3-rat4)*(dpc1-dpc) - & + dm(ibin,igroup)*rat3*delma(ibin+1) + & + dm(ibin+1,igroup)*rat4*delma(ibin) ) + enddo ! ibin = 2,NBIN-2 + + ! Now construct polynomial functions in each bin + do ibin = 3,NBIN-2 + al(ibin) = aju(ibin-1) + ar(ibin) = aju(ibin) + enddo + + ! Use linear functions in first two and last two bins + if( NBIN .gt. 1 )then + ibin = NBIN + + ar(2) = aju(2) + al(2) = pc(iz,1,iepart)/dm(1,igroup) + & + palr(1,igroup) * & + (pc(iz,2,iepart)/dm(2,igroup)- & + pc(iz,1,iepart)/dm(1,igroup)) + ar(1) = al(2) + al(1) = pc(iz,1,iepart)/dm(1,igroup) + & + palr(2,igroup) * & + (pc(iz,2,iepart)/dm(2,igroup)- & + pc(iz,1,iepart)/dm(1,igroup)) + + al(ibin-1) = aju(ibin-2) + ar(ibin-1) = pc(iz,ibin-1,iepart)/dm(ibin-1,igroup) + & + palr(3,igroup) * & + (pc(iz,ibin,iepart)/dm(ibin,igroup)- & + pc(iz,ibin-1,iepart)/dm(ibin-1,igroup)) + al(ibin) = ar(ibin-1) + ar(ibin) = pc(iz,ibin-1,iepart)/dm(ibin-1,igroup) + & + palr(4,igroup) * & + (pc(iz,ibin,iepart)/dm(ibin,igroup)- & + pc(iz,ibin-1,iepart)/dm(ibin-1,igroup)) + endif + + ! Next, ensure that polynomial functions do not deviate beyond the + ! range [,] + do ibin = 1,NBIN + + dpc = pc(iz,ibin,iepart) / dm(ibin,igroup) + + if( (ar(ibin)-dpc)*(dpc-al(ibin)) .le. 0._f )then + al(ibin) = dpc + ar(ibin) = dpc + endif + + test1 = (ar(ibin)-al(ibin))*(dpc - 0.5_f*(al(ibin)+ar(ibin))) + test2 = 1._f/6._f*(ar(ibin)-al(ibin))**2 + + if( test1 .gt. test2 )then + al(ibin) = 3._f*dpc - 2._f*ar(ibin) + elseif( test1 .lt. -test2 )then + ar(ibin) = 3._f*dpc - 2._f*al(ibin) + endif + enddo + + ! Lastly, calculate fluxes across each bin boundary. + ! + ! Use upwind advection when courant number > 1. + do ibin = 1,NBIN + dpc = pc(iz,ibin,iepart) / dm(ibin,igroup) + dela(ibin) = ar(ibin) - al(ibin) + a6(ibin) = 6._f * ( dpc - 0.5_f*(ar(ibin)+al(ibin)) ) + enddo + + do ibin = 1,NBIN-1 + + if( dmdt(ibin) .gt. 0._f .and. & + pc(iz,ibin,iepart) .gt. SMALL_PC )then + + x = dmdt(ibin)*dtime/dm(ibin,igroup) + + if( x .lt. 1._f )then + growlg(ibin,igroup) = dmdt(ibin)/pc(iz,ibin,iepart) & + * ( ar(ibin) - 0.5*dela(ibin)*x + & + (x/2._f - x**2/3._f)*a6(ibin) ) + else + growlg(ibin,igroup) = dmdt(ibin) / dm(ibin,igroup) + endif + + elseif( dmdt(ibin) .lt. 0._f .and. & + pc(iz,ibin+1,iepart) .gt. SMALL_PC )then + + x = -dmdt(ibin)*dtime/dm(ibin+1,igroup) + + if( x .lt. 1._f )then + evaplg(ibin+1,igroup) = -dmdt(ibin)/ & + pc(iz,ibin+1,iepart) & + * ( al(ibin+1) + 0.5_f*dela(ibin+1)*x + & + (x/2._f - (x**2)/3._f)*a6(ibin+1) ) + else + evaplg(ibin+1,igroup) = -dmdt(ibin) / dm(ibin+1,igroup) + endif + + ! Boundary conditions: for evaporation out of first bin (with cores), + ! use evaporation rate from second bin. +! if( ibin .eq. 1 .and. ncore(igroup) .gt. 0 )then + if( ibin .eq. 1)then + evaplg(1,igroup) = -dmdt(1) / dm(1,igroup) + endif + endif + + enddo ! ibin = 1,NBIN-1 + endif ! (pconmax .gt. FEW_PC) + endif ! (igas = igrowgas(ielem)) .ne. 0 + enddo ! igroup = 1,NGROUP + + + ! Return to caller with particle loss rates for growth and evaporation + ! evaluated. + return +end diff --git a/src/physics/carma/base/growp.F90 b/src/physics/carma/base/growp.F90 new file mode 100644 index 0000000000..b81b156027 --- /dev/null +++ b/src/physics/carma/base/growp.F90 @@ -0,0 +1,50 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to growth +!! for one particle size bin at one spatial grid point per call. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine growp(carma, cstate, iz, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: iepart + + + ! Define group & particle # concentration indices for current element + igroup = igelem(ielem) ! target particle group + iepart = ienconc(igroup) ! target particle number concentration element + + ! Calculate production terms due to condensational growth + ! only if group to which element belongs grows. + if( igrowgas(iepart) .ne. 0 .and. ibin .ne. 1 )then + + ! Bypass calculation if few droplets are present + if( pconmax(iz,igroup) .gt. FEW_PC )then + growpe(ibin,ielem) = pc(iz,ibin-1,ielem) * growlg(ibin-1,igroup) + endif + endif + + ! Return to caller with growth production terms evaluated. + return +end diff --git a/src/physics/carma/base/gsolve.F90 b/src/physics/carma/base/gsolve.F90 new file mode 100644 index 0000000000..e442575086 --- /dev/null +++ b/src/physics/carma/base/gsolve.F90 @@ -0,0 +1,101 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates new gas concentrations. +!! +!! @author Andy Ackerman, Bill McKie, Chuck Bardeen +!! @version Dec-1995, Sep-1997, Nov-2009 +subroutine gsolve(carma, cstate, iz, previous_ice, previous_liquid, scale_threshold, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(in) :: previous_ice(NGAS) !! total ice at the start of substep + real(kind=f), intent(in) :: previous_liquid(NGAS) !! total liquid at the start of substep + real(kind=f) :: scale_threshold !! Scaling factor for convergence thresholds + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: igas !! gas index + real(kind=f) :: gc_cgs + real(kind=f) :: rvap + real(kind=f) :: total_ice(NGAS) ! total ice + real(kind=f) :: total_liquid(NGAS) ! total liquid + real(kind=f) :: threshold ! convergence threshold + + + 1 format(/,'gsolve::ERROR - negative gas concentration for ',a,' : iz=',i4,',lat=', & + f7.2,',lon=',f7.2,',gc=',e10.3,',gasprod=',e10.3,',supsati=',e10.3, & + ',supsatl=',e10.3,',t=',f6.2) + 2 format('gsolve::ERROR - conditions at beginning of the step : gc=',e10.3,',supsati=',e17.10, & + ',supsatl=',e17.10,',t=',f6.2,',d_gc=',e10.3,',d_t=',f6.2) + 3 format(/,'microfast::WARNING - gas concentration change exceeds threshold: ',a,' : iz=',i4,',lat=', & + f7.2,',lon=',f7.2, ', (gc-gcl)/gcl=', e10.3) + + + ! Determine the total amount of condensate for each gas. + call totalcondensate(carma, cstate, iz, total_ice, total_liquid, rc) + + do igas = 1,NGAS + + ! We do not seem to be conserving mass and energy, so rather than relying upon gasprod + ! and rlheat, recalculate the total change in condensate to determine the change + ! in gas and energy. + ! + ! This is because in the old scheme, the particles were solved for implicitly, but the + ! gas and latent heat were solved for explicitly using the same rates. + gasprod(igas) = ((previous_ice(igas) - total_ice(igas)) + (previous_liquid(igas) - total_liquid(igas))) / dtime + rlprod = rlprod - ((previous_ice(igas) - total_ice(igas)) * (rlhe(iz,igas) + rlhm(iz,igas)) + & + (previous_liquid(igas) - total_liquid(igas)) * (rlhe(iz,igas))) / (CP * rhoa(iz) * dtime) + + ! Don't let the gas concentration go negative. + gc(iz,igas) = gc(iz,igas) + dtime * gasprod(igas) + + if (gc(iz,igas) < 0.0_f) then + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,1) trim(gasname(igas)), iz, lat, lon, gc(iz,igas), gasprod(igas), & + supsati(iz,igas), supsatl(iz,igas), t(iz) + if (do_print) write(LUNOPRT,2) gcl(iz,igas), supsatiold(iz,igas), supsatlold(iz,igas), told(iz), d_gc(iz,igas), d_t(iz) + end if + else + if (do_print) write(LUNOPRT,1) trim(gasname(igas)), iz, lat, lon, gc(iz,igas), gasprod(igas), & + supsati(iz, igas), supsatl(iz,igas), t(iz) + end if + + rc = RC_WARNING_RETRY + end if + + ! If gas changes by too much, then retry the calculation. + threshold = dgc_threshold(igas) / scale_threshold + + if (threshold /= 0._f) then + if ((dtime * gasprod(igas) / gc(iz,igas)) > threshold) then + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,3) trim(gasname(igas)), iz, lat, lon, dtime * gasprod(igas) / gc(iz,igas) + if (do_print) write(LUNOPRT,2) gcl(iz,igas), supsatiold(iz,igas), supsatlold(iz,igas), told(iz), d_gc(iz,igas), d_t(iz) + end if + else + if (do_print) write(LUNOPRT,3) trim(gasname(igas)), iz, lat, lon, dtime * gasprod(igas) / gc(iz,igas) + end if + + rc = RC_WARNING_RETRY + end if + end if + end do + + ! Return to caller with new gas concentrations. + return +end diff --git a/src/physics/carma/base/hetnucl.F90 b/src/physics/carma/base/hetnucl.F90 new file mode 100644 index 0000000000..13082e4932 --- /dev/null +++ b/src/physics/carma/base/hetnucl.F90 @@ -0,0 +1,163 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! heterogeneous deposition nucleation only. The parameters are adjusted +!! for mesospheric conditions, based upon the recommendations of Keesee. +!! +!! Based on expressions from ... +!! Keesee [JGR,1989] +!! Pruppacher and Klett [2000] +!! Rapp and Thomas [JASTP, 2006] +!! Trainer et al. [2008] +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! To avoid nucleation into an evaporating bin, this subroutine must +!! be called after growp, which evaluates evaporation loss rates . +!! +!! @author Eric Jensen, Chuck Bardeen +!! @version Oct-2000, Jan-2010 +subroutine hetnucl(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igas ! gas index + integer :: igroup ! group index + integer :: ibin ! bin index + integer :: iepart ! element for condensing group index + integer :: inuc ! nucleating element index + integer :: ienucto ! index of target nucleation element + integer :: ignucto ! index of target nucleation group + real(kind=f) :: rmw + real(kind=f) :: R_H2O + real(kind=f) :: rnh2o + real(kind=f) :: rlogs + real(kind=f) :: ag + real(kind=f) :: contang + real(kind=f) :: xh + real(kind=f) :: phih + real(kind=f) :: rath + real(kind=f) :: fv3h + real(kind=f) :: fv4h + real(kind=f) :: fh + real(kind=f) :: delfg + real(kind=f) :: expon + + ! Heterogeneous nucleation factors + real(kind=f), parameter :: gdes = 2.9e-13_f + real(kind=f), parameter :: gsd = 2.9e-14_f + real(kind=f), parameter :: zeld = 0.1_f + real(kind=f), parameter :: vibfreq = 1.e13_f + real(kind=f), parameter :: diflen = 0.1e-7_f + real(kind=f) :: rmiv + + rmiv = 0.95_f + + ! rmiv - Eq. 2, Trainer et al. [2008] +! rmiv = 0.94_f - (6005._f * exp(-0.065_f * max(150._f, t(iz)))) +! rmiv = max(0._f, 0.94_f - (6005._f * exp(-0.065_f * t(iz)))) + + ! Loop over particle groups. + do igroup = 1, NGROUP + + igas = inucgas(igroup) ! condensing gas + + if (igas .ne. 0) then + + iepart = ienconc(igroup) ! particle number density element + + rmw = gwtmol(igas) / AVG + R_H2O = RGAS / gwtmol(igas) + rnh2o = gc(iz,igas) * R_H2O / BK + + ! Calculate nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + ! + ! is index of target nucleation element; + ! is index of target nucleation group. + do inuc = 1, nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + + if (ienucto .ne. 0) then + ignucto = igelem(ienucto) + else + ignucto = 0 + endif + + ! Only compute nucleation rate for heterogenous nucleation + if (inucproc(iepart,ienucto) .eq. I_HETNUC) then + + ! Loop over particle bins. Loop from largest to smallest for + ! evaluation of index of smallest bin nucleated during time step . + do ibin = NBIN, 1, -1 + + ! Bypass calculation if few particles are present + if (pconmax(iz,igroup) .gt. FEW_PC) then + + ! Only proceed if ice supersaturated + ! + ! NOTE: We are only trying to model PMC partcles, so turn of nucleation + ! where the CAM microphysics takes over (~1 mb = 1000 dyne). + if ((p(iz) .lt. 1.e3_f) .and. (supsati(iz,igas) .gt. 0._f)) then + rlogs = log(supsati(iz,igas) + 1._f) + + ! Critical ice germ radius formed in the sulfate solution + ! + ! Eq. 2, Rapp & Thomas [2006] + ag = 2._f * gwtmol(igas) * surfctia(iz) / rgas / t(iz) / RHO_I / rlogs + + ! Heterogeneous nucleation geometric factor + ! + ! Eq. 9-22, Pruppacher & Klett [2000] + contang = acos(rmiv) + xh = r(ibin,igroup) / ag + phih = sqrt(1._f - 2._f * rmiv * xh + xh**2 ) + rath = (xh-rmiv) / phih + fv3h = xh**3 * (2._f - 3._f * rath + rath**3 ) + fv4h = 3._f * rmiv * xh**2 * (rath - 1._f) + + if (abs(rath) .gt. 1._f - 1.e-8_f) fv3h = 0._f + if (abs(rath) .gt. 1._f - 1.e-10_f) fv4h = 0._f + + fh = 0.5_f * (1._f + ((1._f - rmiv * xh) / phih)**3 + fv3h + fv4h) + + ! Gibbs free energy of ice germ formation in the ice/sulfate solution + ! + ! Eq. 3, Rapp & Thomas [2006] + delfg = 4._f * PI * ag**2 * surfctia(iz) - 4._f * PI * RHO_I * ag**3 *BK * t(iz) * rlogs / 3._f / rmw + + ! Ice nucleation rate in a 0.2 micron aerosol (/sec) + expon = (2._f * gdes - gsd - fh*delfg) / BK / t(iz) + + ! NOTE: Excessive nucleation makes it difficult for the substepping to find a + ! stable solution, so put a cap on really large nucleation values that can be produced. + rnuclg(ibin,igroup,ignucto) = min(1e10_f, zeld * BK * t(iz) * diflen * ag * sin(contang) * & + 4._f * PI * r(ibin,igroup)**2 * rnh2o**2 / (fh * rmw * vibfreq) * exp(expon)) + endif + endif ! pconmax(ixyz,igroup) .gt. FEW_PC + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPACT + enddo ! inuc = 1,nnuc2elem(iepart) + endif ! (igas = inucgas(igroup) .ne. 0) + enddo ! igroup = 1,NGROUP + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/lusolvec_mod.F90 b/src/physics/carma/base/lusolvec_mod.F90 new file mode 100644 index 0000000000..a6018a2ffc --- /dev/null +++ b/src/physics/carma/base/lusolvec_mod.F90 @@ -0,0 +1,213 @@ +!! +!! this module: lusolvec_mod Numerical solution of a set of linear +!! Equations / a matrix equation A * x = b +!! using LU decomposition, matrix A and +!! vectors b and x being double complex, +!! and inversion of A. +!! ****************************************************************** +!! Usage: +!! ====== +!! given a complex matrix A, a right hand side vector b and a +!! matrix equation A * x = b to solve for vector x. +!! +!! +!! First, call LUDCMPC(A,N,NP,INDX,D). The original Matrix A is lost +!! and substituted by its LU decomposition. +!! +!! Second, call LUBKSBC(A,N,NP,INDX,B). The original right-hand-side +!! vector ib in B is lost and replaced/returned as the solution +!! vector x ( x(i) = B(i) ). +!! Use same kind of call to solve for successive right-hand-sides. +!! +!! For Inversion of matrix A, call LUBKSBC() subsequently for each +!! column vector: +!! 1) Initialize matrix AINV(i,j) to be equal to the +!! identity matrix (AINV(i,j)=1 for i=j; =0 otherwise) +!! 2) DO jj=1,n +!! CALL LUBKSBC(A,N,NP,INDX,AINV(1,jj)) +!! END DO +!! (see textbook for further details). +!! ****************************************************************** + +module lusolvec_mod + + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + private + + ! public subroutines + public :: LUDCMPC + public :: LUBKSBC + + contains + + !! + !! SUBROUTINE LUDCMPC(A,N,NP,INDX,D) + !! + !! Given a general complex matrix A, this routine replaces it by its + !! LU decomposition of a rowwise permutation of itself. + !! This routine is used in combination with LUBKSBC(), a complex + !! extension of the routine LUBKSB() (DOUBLE COMPLEX). + !! For further details, refer to textbook (see below). + !! + !! Source: Own adaption/extension to complex matrix of the + !! Subroutine LUDCMP() taken from + !! Press et al, "Numerical Recipes in Fortran" + !! The adaption follows the statements given in section 2.3 + !! of the textbook "N.R. in C", following Eq.(2.3.16): + !! - definition of variables, vector and matrix elements + !! as complex variables (use of complex arithmetic does + !! not necessitate any adaption in fortran). + !! - complex modulus instead of absolute values in the + !! construction of the vector vv and in the search for the + !! largest pivot elements. + !! ****************************************************************** + !! Version: 28.08.2000 + !! ****************************************************************** + SUBROUTINE LUDCMPC(A,N,NP,INDX,D) + + INTEGER :: NP + COMPLEX(kind=f) :: A(NP,NP) + INTEGER :: N + INTEGER :: INDX(N) + REAL(kind=f) :: D + + INTEGER, PARAMETER :: NMAX=100 + REAL(kind=f), PARAMETER :: TINY=1.0e-20_f + REAL(kind=f) :: VV(NMAX) + REAL(kind=f) :: DUM,AAMAX + COMPLEX(kind=f) :: SUM,DUMC,ZEROC,TINYC + INTEGER I,J,K,IMAX + + D=1._f + TINYC=cmplx(TINY,0.0_f,kind=f) + ZEROC=cmplx(0.0_f,0.0_f,kind=f) + DO I=1,N + AAMAX=0._f + DO J=1,N + IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) + END DO +! IF (AAMAX.EQ.0._f) PAUSE 'Singular matrix.' + IF (AAMAX.EQ.0._f) STOP 'Singular matrix.' + VV(I)=1./AAMAX + END DO + DO J=1,N + IF (J.GT.1) THEN + DO I=1,J-1 + SUM=A(I,J) + IF (I.GT.1)THEN + DO K=1,I-1 + SUM=SUM-A(I,K)*A(K,J) + END DO + A(I,J)=SUM + ENDIF + END DO + ENDIF + AAMAX=0._f + DO I=J,N + SUM=A(I,J) + IF (J.GT.1)THEN + DO K=1,J-1 + SUM=SUM-A(I,K)*A(K,J) + END DO + A(I,J)=SUM + ENDIF + DUM=VV(I)*ABS(SUM) + IF (DUM.GE.AAMAX) THEN + IMAX=I + AAMAX=DUM + ENDIF + END DO + IF (J.NE.IMAX)THEN + DO K=1,N + DUMC=A(IMAX,K) + A(IMAX,K)=A(J,K) + A(J,K)=DUMC + END DO + D=-D + VV(IMAX)=VV(J) + ENDIF + INDX(J)=IMAX + IF(J.NE.N)THEN + IF(A(J,J).EQ.ZEROC)A(J,J)=TINYC + DUMC=1./A(J,J) + DO I=J+1,N + A(I,J)=A(I,J)*DUMC + END DO + ENDIF + END DO + IF (A(N,N).EQ.ZEROC) A(N,N)=TINYC + RETURN + END SUBROUTINE LUDCMPC + + !! + !! SUBROUTINE LUBKSBC(A,N,NP,INDX,B) + !! + !! Solution of the set of linear equations A' * x = b where + !! A is input not as the original matrix, but as a LU decomposition + !! of some original matrix A' as determined by the subroutine + !! LUDCMPC() (matrix and vectors being of type DOUBLE COMPLEX). + !! INDX() is input as the permutation vactor returned by LUDCMPC(). + !! B() is input as the right hand side vector b of the Eqn. to solve + !! and returns with the solution vector x. + !! A, N and INDX are not modified by this routine and can be left in + !! place for successive calls with different right-hand-sides b. + !! For further details, refer to textbook (see below). + !! + !! Source: Own adaption/extension to complex matrix of the + !! Subroutine LUBKSB() taken from + !! Press et al, "Numerical Recipes in Fortran" + !! The adaption follows the statements given in section 2.3 + !! of the textbook "N.R. in C", following Eq.(2.3.16). + !! ****************************************************************** + !! Version: 28.08.2000 + !! ****************************************************************** + SUBROUTINE LUBKSBC(A,N,NP,INDX,B) + + INTEGER :: NP + COMPLEX(kind=f) :: A(NP,NP) + INTEGER :: N + INTEGER :: INDX(N) + COMPLEX(kind=f) :: B(N) + + INTEGER, PARAMETER :: NMAX=100 + REAL(kind=f), PARAMETER :: TINY=1.0e-20_f + + COMPLEX(kind=f) :: SUM,ZEROC + INTEGER :: II,LL,I,J + + II=0 + ZEROC=cmplx(0.0_f,0.0_f,kind=f) + DO I=1,N + LL=INDX(I) + SUM=B(LL) + B(LL)=B(I) + IF (II.NE.0)THEN + DO J=II,I-1 + SUM=SUM-A(I,J)*B(J) + END DO + ELSE IF (SUM.NE.ZEROC) THEN + II=I + ENDIF + B(I)=SUM + END DO + DO I=N,1,-1 + SUM=B(I) + IF(I.LT.N)THEN + DO J=I+1,N + SUM=SUM-A(I,J)*B(J) + END DO + ENDIF + B(I)=SUM/A(I,I) + END DO + RETURN + END SUBROUTINE LUBKSBC + + +end module lusolvec_mod diff --git a/src/physics/carma/base/maxconc.F90 b/src/physics/carma/base/maxconc.F90 new file mode 100644 index 0000000000..0360c2a403 --- /dev/null +++ b/src/physics/carma/base/maxconc.F90 @@ -0,0 +1,47 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This determines the maximum particle concentration for each group in each +!! gridbox. This can be used to make calculations more efficient by skipping +!! calculations when concentrations are low +!! +!! @author Chuck Bardeen +!! @version Nov 2009 +subroutine maxconc(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Locals + integer :: igrp + integer :: iep + + + ! Find maximum particle concentration for each spatial grid box + ! (in units of cm^-3) + do igrp = 1,NGROUP + iep = ienconc(igrp) + + pconmax(iz,igrp) = maxval(pc(iz,:,iep)) + + pconmax(iz,igrp) = pconmax(iz,igrp) & + / xmet(iz) & + / ymet(iz) & + / zmet(iz) + enddo ! igrp + + return +end diff --git a/src/physics/carma/base/melticel.F90 b/src/physics/carma/base/melticel.F90 new file mode 100644 index 0000000000..26e1a904d7 --- /dev/null +++ b/src/physics/carma/base/melticel.F90 @@ -0,0 +1,74 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle loss rates due to nucleation : +!! Ice crystal melting only. +!! +!! The loss rates for all particle elements in a particle group are equal. +!! +!! @author Eric Jensen, Chuck Bardeen +!! @version Jan-2000, Nov-2009 +subroutine melticel(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup !! group index + integer :: ibin !! bin index + integer :: iepart !! element for condensing group index + integer :: ienucto !! index of target nucleation element + integer :: ignucto !! index of target nucleation group + integer :: inuc !! nucleating element index + + + ! Loop over particle groups. + do igroup = 1,NGROUP + + iepart = ienconc( igroup ) ! particle number density element + + ! Calculate nucleation loss rates. + do inuc = 1,nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + + if( ienucto .ne. 0 )then + ignucto = igelem( ienucto ) + + ! Only compute nucleation rate for ice crystal melting + if( inucproc(iepart,ienucto) .eq. I_ICEMELT ) then + + ! Loop over particle bins. Loop from largest to smallest for + ! evaluation of index of smallest bin nucleated during time step . + do ibin = NBIN,1,-1 + + ! Bypass calculation if few particles are present + if( pconmax(iz,igroup) .gt. FEW_PC )then + + ! Temporary simple kludge: Set to 1.e2 if T > 0C + if( t(iz) .gt. T0 ) then + rnuclg(ibin,igroup,ignucto) = 1.e2_f + endif + endif ! pconmax(ixyz,igroup) .gt. FEW_PC + enddo ! ibin = 1,NBIN + endif ! inucproc(iepart,ienucto) .eq. I_DROPFREEZE + endif + enddo ! inuc = 1,nnuc2elem(iepart) + enddo ! igroup = 1,NGROUP + + ! Return to caller with particle loss rates due to nucleation evaluated. + return +end diff --git a/src/physics/carma/base/microfast.F90 b/src/physics/carma/base/microfast.F90 new file mode 100644 index 0000000000..48b034403d --- /dev/null +++ b/src/physics/carma/base/microfast.F90 @@ -0,0 +1,277 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine drives the fast microphysics calculations. +!! +!! @author Eric Jensen, Bill McKie +!! @version Sep-1997 +subroutine microfast(carma, cstate, iz, scale_threshold, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f) :: scale_threshold !! Scaling factor for convergence thresholds + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: ielem ! element index + integer :: ibin ! bin index + integer :: igas ! gas index + real(kind=f) :: previous_ice(NGAS) ! total ice at the start of substep + real(kind=f) :: previous_liquid(NGAS) ! total liquid at the start of substep + real(kind=f) :: previous_supsatl(NGAS) ! supersaturation wrt ice at the start of substep + real(kind=f) :: previous_supsati(NGAS) ! supersaturation wrt liquid at the start of substep + real(kind=f) :: supsatold + real(kind=f) :: supsatnew + real(kind=f) :: srat + real(kind=f) :: srat1 + real(kind=f) :: srat2 + real(kind=f) :: s_threshold + + 1 format(/,'microfast::ERROR - excessive change in supersaturation for ',a,' : iz=',i4,',lat=', & + f7.2,',lon=',f7.2,',srat=',e10.3,',supsatiold=',e10.3,',supsatlold=',e10.3,',supsati=',e10.3, & + ',supsatl=',e10.3,',t=',f6.2) + 2 format('microfast::ERROR - conditions at beginning of the step : gc=',e10.3,',supsati=',e17.10, & + ',supsatl=',e17.10,',t=',f6.2,',d_gc=',e10.3,',d_t=',f6.2) + 3 format(/,'microfast::ERROR - excessive change in supersaturation for ',a,' : iz=',i4,',lat=', & + f7.2,',lon=',f7.2,',supsatiold=',e10.3,',supsatlold=',e10.3,',supsati=',e10.3, & + ',supsatl=',e10.3,',t=',f6.2) + + ! Set production and loss rates to zero. + call zeromicro(carma, cstate, iz, rc) + if (rc < RC_OK) return + + + ! Calculate (implicit) particle loss rates for nucleation, growth, + ! evaporation, melting, etc. + if (do_grow) then + + ! Save off the current condensate totals so the gas and latent heating can be + ! figured out in a way that conserves mass and energy. + call totalcondensate(carma, cstate, iz, previous_ice, previous_liquid, rc) + if (rc < RC_OK) return + + do igas = 1, NGAS + call supersat(carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + + previous_supsati(igas) = supsati(iz, igas) + previous_supsatl(igas) = supsatl(iz, igas) + end do + + ! Have water vapor and sulfuric acid been defined? + if ((igash2o /= 0) .and. (igash2so4 /= 0)) then + + ! Are both gases avaialble? + if ((gc(iz, igash2o) > 0._f) .and. (gc(iz,igash2so4) > 0._f)) then + + ! See if any sulfates will form. + call sulfnuc(carma, cstate, iz, rc) + endif + end if + + call growevapl(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call actdropl(carma, cstate, iz, rc) + if (rc < RC_OK) return + + ! The Koop, Tabazadeh and Mohler routines provide different schemes for aerosol freezing. + ! Only one of these parameterizatons should be active at one time. However, any + ! of these routines can be used in conjunction with heterogenous nucleation of glassy + ! aerosols. + call freezaerl_tabazadeh2000(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call freezaerl_koop2000(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call freezaerl_mohler2010(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call freezglaerl_murray2010(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call hetnucl(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call freezdropl(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call melticel(carma, cstate, iz, rc) + if (rc < RC_OK) return + endif + + ! Calculate particle production terms and solve for particle + ! concentrations at end of time step. + do ielem = 1,NELEM + do ibin = 1,NBIN + + if( do_grow )then + call growp(carma, cstate, iz, ibin, ielem, rc) + if (rc < RC_OK) return + + call upgxfer(carma, cstate, iz, ibin, ielem, rc) + if (rc < RC_OK) return + endif + + call psolve(carma, cstate, iz, ibin, ielem, rc) + if (rc < RC_OK) return + enddo + enddo + + ! Calculate particle production terms for evaporation; + ! gas loss rates and production terms due to particle nucleation; + ! growth, and evaporation; + ! apply evaporation production terms to particle concentrations; + ! and solve for gas concentrations at end of time step. + if (do_grow) then + call evapp(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call downgxfer(carma, cstate, iz, rc) + if (rc < RC_OK) return + +! NOTE: Not needed because changes in gas concentrations and latent +! heats are now calculated later in gsolve using total condensate. +! call gasexchange(carma, cstate, iz, rc) +! if (rc < RC_OK) return + + call downgevapply(carma, cstate, iz, rc) + if (rc < RC_OK) return + + call gsolve(carma, cstate, iz, previous_ice, previous_liquid, scale_threshold, rc) + if (rc /=RC_OK) return + endif + + ! Update temperature if thermal processes requested + if (do_thermo) then + call tsolve(carma, cstate, iz, scale_threshold, rc) + if (rc /= RC_OK) return + endif + + ! Update saturation ratios + if (do_grow .or. do_thermo) then + do igas = 1, NGAS + call supersat(carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + + ! Check to see how much the supersaturation changed during this step. If it + ! has changed to much, then cause a retry. + if (t(iz) >= T0) then + supsatold = previous_supsatl(igas) + supsatnew = supsatl(iz,igas) + else + supsatold = previous_supsati(igas) + supsatnew = supsati(iz,igas) + end if + + ! If ds_threshold is positive, then it indicates that the criteria should + ! be based on the percentage change in saturation. + if (ds_threshold(igas) > 0._f) then + + if (supsatold >= 1.e-4_f) then + srat1 = abs(supsatnew / supsatold - 1._f) + else + srat1 = 0._f + end if + + if (supsatnew >= 1.e-4_f) then + srat2 = abs(supsatold / supsatnew - 1._f) + else + srat2 = 0._f + end if + + srat = max(srat1, srat2) + + ! Don't let one substep change the supersaturation by too much. + if (ds_threshold(igas) > 0._f) then +! if (srat >= ds_threshold(igas)) then + if ((srat >= ds_threshold(igas)) .and. (abs(supsatold - supsatnew) > 0.1_f)) then + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,1) trim(gasname(igas)), iz, & + lat, lon, srat, previous_supsati(igas), previous_supsatl(igas), & + supsati(iz, igas), supsatl(iz,igas), t(iz) + if (do_print) write(LUNOPRT,2) gcl(iz,igas), supsatiold(iz, igas), & + supsatlold(iz,igas), told(iz), d_gc(iz, igas), d_t(iz) + end if + + rc = RC_WARNING_RETRY + else + if (do_print) write(LUNOPRT,1) trim(gasname(igas)), iz, lat, lon, & + srat, previous_supsati(igas), previous_supsatl(igas), & + supsati(iz, igas), supsatl(iz,igas), t(iz) + end if + end if + end if + + + ! If ds_threshold is negative, then it indicates that the criteria is based + ! upon the supersaturation crossing 0, Indicating a shift from growth to + ! evaporation and a potential overshoot in the result. + else if (ds_threshold(igas) < 0._f) then + + ! Adjust the saturation threshold to allow a worse solution if getting a better + ! solution is taking too much time. The particular solution at any individual + ! point is probably not going to affect the overall result by too much. + s_threshold = abs(ds_threshold(igas)) + + if (nretries >= (0.8_f * maxretries)) then + s_threshold = 4._f * s_threshold + else if (nretries >= (0.7_f * maxretries)) then + s_threshold = 3.5_f * s_threshold + else if (nretries >= (0.6_f * maxretries)) then + s_threshold = 3._f * s_threshold + else if (nretries >= (0.5_f * maxretries)) then + s_threshold = 2.5_f * s_threshold + else if (nretries >= (0.4_f * maxretries)) then + s_threshold = 2._f * s_threshold + end if + + ! If the supersaturation changed signs, then we went from growth to evaporation + ! or vice versa. Don't let the new supersaturation go too far past 0 in one substep. + ! This is to prevent overshooting as growth/evaporation should normally stop when + ! the supersaturation is 0. + if (((supsatnew * supsatold) < 0._f) .and. (abs(supsatnew) > s_threshold)) then + + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,3) trim(gasname(igas)), iz, & + lat, lon, previous_supsati(igas), previous_supsatl(igas), & + supsati(iz, igas), supsatl(iz,igas), t(iz) + if (do_print) write(LUNOPRT,2) gcl(iz,igas), supsatiold(iz, igas), & + supsatlold(iz,igas), told(iz), d_gc(iz, igas), d_t(iz) + end if + else + if (do_print) write(LUNOPRT,3) trim(gasname(igas)), iz, & + lat, lon, previous_supsati(igas), previous_supsatl(igas), & + supsati(iz, igas), supsatl(iz,igas), t(iz) + end if + + rc = RC_WARNING_RETRY + end if + end if + end do + endif + + + ! Update particle densities +! if (do_grow) then +! call rhopart(carma, cstate, iz, rc) +! end if + + ! Return to caller with new particle and gas concentrations. + return +end diff --git a/src/physics/carma/base/microslow.F90 b/src/physics/carma/base/microslow.F90 new file mode 100644 index 0000000000..11376da0c8 --- /dev/null +++ b/src/physics/carma/base/microslow.F90 @@ -0,0 +1,61 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine drives the potentially slower microphysics calculations. +!! +!! Originally part of microphy. Now in this separate routine to allow +!! time splitting of coagulation at a different timestep size from +!! other microphysical calcs. +!! +!! @author McKie +!! @version Sep-1997 +subroutine microslow(carma, cstate, rc) + + ! carma types defs + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Declarations + integer :: ibin + integer :: ielem + + + + ! Set production terms and loss rates due to slow microphysics + ! processes (coagulation) to zero. + coagpe(:,:,:) = 0._f + coaglg(:,:,:) = 0._f + + ! Calculate (implicit) particle loss rates for coagulation. + call coagl(carma, cstate, rc) + + ! Calculate particle production terms and solve for particle + ! concentrations at end of time step. + ! + ! NOTE: The order of elements required by CARMA to work with the + ! element loop first is: if you have a group that is both a source + ! and product of coagulation, then it needs to come after the + ! other group that participates in that coagulation in the element + ! table. For example, icoag(2,1) = 1 will not work, but + ! icoag(2,1) = 2 should work. + do ielem = 1,NELEM + do ibin = 1,NBIN + call coagp(carma, cstate, ibin, ielem, rc) + call csolve(carma, cstate, ibin, ielem, rc) + enddo + enddo + + ! Return to caller with new particle concentrations. + return +end diff --git a/src/physics/carma/base/mie.F90 b/src/physics/carma/base/mie.F90 new file mode 100644 index 0000000000..92758fb184 --- /dev/null +++ b/src/physics/carma/base/mie.F90 @@ -0,0 +1,143 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! There are several different algorithms that can be used to solve +!! a mie calculation for the optical properties of particles. This +!! routine provides a generic front end to these different mie +!! routines. +!! +!! Current methods are: +!! miess - Original CARMA code, from Toon and Ackerman, supports core/shell +!! bhmie - Homogeneous sphere, from Bohren and Huffman, handles wider range of parameters +!! +!! @author Chuck Bardeen +!! @version 2011 +subroutine mie(carma, miertn, radius, wavelength, nmonomer, fractaldim, rmonomer, falpha_in, m, lqext, lqsca, lasym, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carma_mod + use fractal_meanfield_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: miertn !! mie routine enumeration + real(kind=f), intent(in) :: radius !! radius (cm) + real(kind=f), intent(in) :: wavelength !! wavelength (cm) + real(kind=f), intent(in) :: nmonomer !! number of monomers per aggregate [fractal particles only] + real(kind=f), intent(in) :: fractaldim !! fractal dimension [fractal particles only] + real(kind=f), intent(in) :: rmonomer !! monomer size (units?) [fractal particles only] + real(kind=f), intent(in) :: falpha_in !! packing coefficient [fractal particles only] + complex(kind=f), intent(in) :: m !! refractive index particle + real(kind=f), intent(out) :: lqext !! EFFICIENCY FACTOR FOR EXTINCTION + real(kind=f), intent(out) :: lqsca !! EFFICIENCY FACTOR FOR SCATTERING + real(kind=f), intent(out) :: lasym !! asymmetry factor + integer, intent(inout) :: rc !! return code, negative indicates failure + + + integer, parameter :: nang = 10 ! Number of angles + + real(kind=f) :: theta(IT) + real(kind=f) :: wvno + real(kind=f) :: rfr + real(kind=f) :: rfi + real(kind=f) :: x + real(kind=f) :: qback + real(kind=f) :: ctbrqs + complex(kind=f) :: s1(2*nang-1) + complex(kind=f) :: s2(2*nang-1) + real(kind=f) :: rmonomer_out + real(kind=f) :: fractaldim_out + + ! Calculate the wave number. + wvno = 2._f * PI / wavelength + + ! Select the appropriate routine. + if (miertn == I_MIERTN_TOON1981) then + + ! We only care about the forward direction. + theta(:) = 0.0_f + + rfr = real(m) + rfi = aimag(m) + + call miess(carma, & + radius, & + rfr, & + rfi, & + theta, & + 1, & + lqext, & + lqsca, & + qback,& + ctbrqs, & + 0.0_f, & + rfr, & + rfi, & + wvno, & + rc) + + lasym = ctbrqs / lqsca + + else if (miertn == I_MIERTN_BOHREN1983) then + + x = radius * wvno + + call bhmie(carma, & + x, & + m, & + nang, & + s1, & + s2, & + lqext, & + lqsca, & + qback, & + lasym, & + rc) + + else if (miertn == I_MIERTN_BOTET1997) then + + rfr = real(m) + rfi = aimag(m) + + if (radius .le. rmonomer) then + rmonomer_out = radius + fractaldim_out = 3.0_f + else + rmonomer_out = rmonomer + fractaldim_out = fractaldim + end if + + call fractal_meanfield(carma, & !! carma object + wavelength*1.0e4_f, & !! lambda in microns + rfi, & !! imaginary index of refraction + rfr, & !! real index of refraction + nmonomer, & !! number of monomers + falpha_in, & !! packing coefficient + fractaldim_out, & !! fractal dimension + rmonomer_out, & !! monomer size + 1.0_f, & !! xv,"set to 1" + 0.0_f, & !! angle, set to 0 + lqext, & !! extinction efficiency + lqsca, & !! scattering efficiency + lasym, & !! asymmetry parameter + rc) + + else + if (do_print) write(LUNOPRT, *) "mie::Unknown Mie routine specified." + rc = RC_ERROR + end if + + ! The mie code isn't perfect, so don't let it return values that aren't + ! physical. + lqext = max(lqext, 0._f) + lqsca = max(0._f, min(lqext, lqsca)) + lasym = max(-1.0_f, min(1.0_f, lasym)) + + return +end subroutine mie diff --git a/src/physics/carma/base/miess.F90 b/src/physics/carma/base/miess.F90 new file mode 100644 index 0000000000..0cca466da9 --- /dev/null +++ b/src/physics/carma/base/miess.F90 @@ -0,0 +1,496 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This subroutine computes mie scattering by a stratified sphere, +!! i.e. a particle consisting of a spherical core surrounded by a +!! Spherical shell. The basic code used was that described in the +!! report: " Subroutines for computing the parameters of the +!! electromagnetic radiation scattered by a sphere " J.V. Dave, +!! IBM Scientific Center, Palo Alto , California. +!! Report No. 320 - 3236 .. May 1968 . +!! +!! The modifications for stratified spheres are described in +!! Toon and Ackerman, Appl. Optics, in press, 1981 +!! +!! The definitions for the output parameters can be found in "Light +!! scattering by small particles, H.C.Van de Hulst, John Wiley ' +!! Sons, Inc., New York, 1957". +!! +!! Also the subroutine computes the capital A function by making use of +!! downward recurrence relationship. +!! +!! @author Brian Toon +!! @version 1981? +SUBROUTINE miess(carma,RO,RFR,RFI,THETD,JX,QEXT,QSCAT,QBS,CTBRQS,R,RE2,TMAG2,WVNO,rc) + + ! types + use carma_precision_mod + use carma_constants_mod, only : IT, DEG2RAD + use carma_enums_mod, only : RC_ERROR + use carma_types_mod, only : carma_type + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: RO !! OUTER (SHELL) RADIUS + real(kind=f), intent(in) :: RFR !! REAL PART OF THE SHELL INDEX OF REFRACTION + real(kind=f), intent(in) :: RFI !! IMAGINARY PART OF THE SHELL INDEX OF REFRACTION + real(kind=f), intent(in) :: R !! CORE RADIUS + real(kind=f), intent(in) :: RE2 !! REAL PART OF THE CORE INDEX OF REFRACTION + real(kind=f), intent(in) :: TMAG2 !! IMAGINARY PART OF THE CORE INDEX OF REFRACTION + + !! ANGLE IN DEGREES BETWEEN THE DIRECTIONS OF THE INCIDENT + !! AND THE SCATTERED RADIATION. THETD(J) IS< OR= 90.0 + !! IF THETD(J) SHOULD HAPPEN TO BE GREATER THAN 90.0, ENTER WITH + !! SUPPLEMENTARY VALUE, SEE COMMENTS ON ELTRMX. + real(kind=f), intent(inout) :: THETD(IT) + + !! TOTAL NUMBER OF THETD FOR WHICH THE COMPUTATIONS ARE + !! REQUIRED. JX SHOULD NOT EXCEED IT UNLESS THE DIMENSIONS + !! STATEMENTS ARE APPROPRIATEDLY MODIFIED. + integer, intent(in) :: JX + + real(kind=f), intent(out) :: QEXT !! EFFICIENCY FACTOR FOR EXTINCTION,VAN DE HULST,P.14 ' 127. + real(kind=f), intent(out) :: QSCAT !! EFFICIENCY FACTOR FOR SCATTERING,V.D. HULST,P.14 ' 127. + real(kind=f), intent(out) :: QBS !! BACK SCATTER CROSS SECTION. + real(kind=f), intent(out) :: CTBRQS !! AVERAGE(COSINE THETA) * QSCAT,VAN DE HULST,P.128. + real(kind=f), intent(in) :: WVNO !! 2*PI / WAVELENGTH. + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f), parameter :: EPSILON_MIE = 1.e-14_f + + integer :: I + integer :: J + integer :: K + integer :: M + integer :: N + integer :: NN + integer :: NMX1 + integer :: NMX2 + integer :: IFLAG + integer :: IACAP + + ! FNAP, FNBP ARE THE PRECEDING VALUES OF FNA, FNB RESPECTIVELY. + complex(kind=f) :: FNAP, FNBP, & + FNA, FNB, RF, RRF, & + RRFX, WM1, FN1, FN2, & + TC1, TC2, WFN(2), Z(4), & + K1, K2, K3, & + RCR, U(8), DH1, & + DH2, DH4, P24H24, P24H21, & + PSTORE, HSTORE, DUMMY, DUMSQ + + complex(kind=f), allocatable :: ACAP(:), W(:,:) + + + ! TA(1): REAL PART OF WFN(1). TA(2): IMAGINARY PART OF WFN(1). + ! TA(3): REAL PART OF WFN(2). TA(4): IMAGINARY PART OF WFN(2). + real(kind=f) :: T(5), TA(4), & + PI(3,IT), TAU(3,IT), CSTHT(IT), SI2THT(IT), & + X, X1, X4, Y1, Y4, RX, SINX1, SINX4, COSX1, COSX4, & + EY1, E2Y1, EY4, EY1MY4, EY1PY4, AA, BB, CC, DD, DENOM, & + REALP, AMAGP, QBSR, QBSI, RMM, PIG, RXP4 + + !! ELTRMX(I,J,K): ELEMENTS OF THE TRANSFORMATION MATRIX F,V.D.HULST,P.34,45 ' 125. + !! I=1: ELEMENT M SUB 2..I=2: ELEMENT M SUB 1.. + !! I = 3: ELEMENT S SUB 21.. I = 4: ELEMENT D SUB 21.. + !! ELTRMX(I,J,1) REPRESENTS THE ITH ELEMENT OF THE MATRIX FOR + !! THE ANGLE THETD(J).. ELTRMX(I,J,2) REPRESENTS THE ITH ELEMENT + !! OF THE MATRIX FOR THE ANGLE 180.0 - THETD(J) .. + real(kind=f) :: ELTRMX(4,IT,2) + + + ! IF THE CORE IS SMALL SCATTERING IS COMPUTED FOR THE SHELL ONLY + IFLAG = 1 + if ( R/RO .LT. 1.e-6_f ) IFLAG = 2 + + if ( JX .gt. IT ) then + if (do_print) then + write(LUNOPRT, '(a,i3,a)') "miess:: The value of the argument JX=", & + JX, " is greater than IT." + end if + rc = RC_ERROR + return + endif + + RF = CMPLX( RFR, -RFI, kind=f ) + RCR = CMPLX( RE2, -TMAG2, kind=f ) + X = RO * WVNO + K1 = RCR * WVNO + K2 = RF * WVNO + K3 = CMPLX( WVNO, 0.0_f, kind=f ) + Z(1) = K2 * RO + Z(2) = K3 * RO + Z(3) = K1 * R + Z(4) = K2 * R + X1 = REAL( Z(1) ) + X4 = REAL( Z(4) ) + Y1 = aimag( Z(1) ) + Y4 = aimag( Z(4) ) + RRF = 1.0_f / RF + RX = 1.0_f / X + RRFX = RRF * RX + T(1) = ( X**2 ) * ( RFR**2 + RFI**2 ) + T(1) = SQRT( T(1) ) + NMX1 = 1.10_f * T(1) + + ! The dimension of ACAP. + ! + ! In the original program the dimension of ACAP was 7000. + ! For conserving space this should be not much higher than + ! The value, NMX1=1.1*(NREAL**2 + NIMAG**2)**.5 * X + 1 + IACAP = max(7000, int(1.5_f * NMX1)) + allocate(ACAP(IACAP)) + allocate(W(3,IACAP)) + + NMX2 = T(1) + + if ( NMX1 .le. 150 ) then + NMX1 = 150 + NMX2 = 135 + endif + + ACAP( NMX1+1 ) = ( 0.0_f, 0.0_f ) + + if ( IFLAG .ne. 2 ) then + do N = 1,3 + W( N,NMX1+1 ) = ( 0.0_f, 0.0_f ) + enddo + endif + + do N = 1,NMX1 + NN = NMX1 - N + 1 + ACAP(NN) = (NN+1) * RRFX - 1.0_f / ( (NN+1) * RRFX + ACAP(NN+1) ) + if ( IFLAG .ne. 2 ) then + do M = 1,3 + W( M,NN ) = (NN+1) / Z(M+1) - & + 1.0_f / ( (NN+1) / Z(M+1) + W( M,NN+1 ) ) + enddo + endif + enddo + + do J = 1,JX + if ( THETD(J) .lt. 0.0 ) THETD(J) = ABS( THETD(J) ) + + if ( THETD(J) .le. 0.0 ) then + CSTHT(J) = 1.0_f + SI2THT(J) = 0.0_f + else if ( THETD(J) .lt. 90.0_f ) then + T(1) = THETD(J) * DEG2RAD + CSTHT(J) = COS( T(1) ) + SI2THT(J) = 1.0_f - CSTHT(J)**2 + else if ( THETD(J) .le. 90.0_f ) then + CSTHT(J) = 0.0_f + SI2THT(J) = 1.0_f + else + if (do_print) then + write(LUNOPRT, '(a,i3)') "miess:: The value of the scattering angle & + &is greater than 90.0 Degrees. It is .", THETD(J) + end if + rc = RC_ERROR + return + end if + enddo + + do J = 1,JX + PI(1,J) = 0.0_f + PI(2,J) = 1.0_f + TAU(1,J) = 0.0_f + TAU(2,J) = CSTHT(J) + enddo + + ! INITIALIZATION OF HOMOGENEOUS SPHERE + T(1) = COS(X) + T(2) = SIN(X) + WM1 = CMPLX( T(1),-T(2), kind=f ) + WFN(1) = CMPLX( T(2), T(1), kind=f ) + TA(1) = T(2) + TA(2) = T(1) + WFN(2) = RX * WFN(1) - WM1 + TA(3) = REAL(WFN(2)) + TA(4) = aimag(WFN(2)) + + if ( IFLAG .ne. 2 ) then + N = 1 + + ! INITIALIZATION PROCEDURE FOR STRATIFIED SPHERE BEGINS HERE + SINX1 = SIN( X1 ) + SINX4 = SIN( X4 ) + COSX1 = COS( X1 ) + COSX4 = COS( X4 ) + EY1 = EXP( Y1 ) + E2Y1 = EY1 * EY1 + EY4 = EXP( Y4 ) + EY1MY4 = EXP( Y1 - Y4 ) + EY1PY4 = EY1 * EY4 + EY1MY4 = EXP( Y1 - Y4 ) + AA = SINX4 * ( EY1PY4 + EY1MY4 ) + BB = COSX4 * ( EY1PY4 - EY1MY4 ) + CC = SINX1 * ( E2Y1 + 1.0 ) + DD = COSX1 * ( E2Y1 - 1.0 ) + DENOM = 1.0_f + E2Y1 * ( 4.0_f * SINX1 * SINX1 - 2.0_f + E2Y1 ) + REALP = ( AA * CC + BB * DD ) / DENOM + AMAGP = ( BB * CC - AA * DD ) / DENOM + DUMMY = CMPLX( REALP, AMAGP, kind=f ) + AA = SINX4 * SINX4 - 0.5_f + BB = COSX4 * SINX4 + P24H24 = 0.5_f + CMPLX( AA,BB, kind=f ) * EY4 * EY4 + AA = SINX1 * SINX4 - COSX1 * COSX4 + BB = SINX1 * COSX4 + COSX1 * SINX4 + CC = SINX1 * SINX4 + COSX1 * COSX4 + DD = -SINX1 * COSX4 + COSX1 * SINX4 + P24H21 = 0.5_f * CMPLX( AA,BB, kind=f ) * EY1 * EY4 + 0.5_f * CMPLX( CC,DD, kind=f ) * EY1MY4 + DH4 = Z(4) / ( 1.0_f + ( 0.0_f, 1.0_f ) * Z(4) ) - 1.0_f / Z(4) + DH1 = Z(1) / ( 1.0_f + ( 0.0_f, 1.0_f ) * Z(1) ) - 1.0_f / Z(1) + DH2 = Z(2) / ( 1.0_f + ( 0.0_f, 1.0_f ) * Z(2) ) - 1.0_f / Z(2) + PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) + P24H24 = P24H24 / PSTORE + HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) + P24H21 = P24H21 / HSTORE + PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) + DUMMY = DUMMY * PSTORE + DUMSQ = DUMMY * DUMMY + + ! NOTE: THE DEFINITIONS OF U(I) IN THIS PROGRAM ARE NOT THE SAME AS + ! THE USUBI DEFINED IN THE ARTICLE BY TOON AND ACKERMAN. THE + ! CORRESPONDING TERMS ARE: + ! USUB1 = U(1) USUB2 = U(5) + ! USUB3 = U(7) USUB4 = DUMSQ + ! USUB5 = U(2) USUB6 = U(3) + ! USUB7 = U(6) USUB8 = U(4) + ! RATIO OF SPHERICAL BESSEL FTN TO SPHERICAL HENKAL FTN = U(8) + + U(1) = K3 * ACAP(N) - K2 * W(1,N) + U(2) = K3 * ACAP(N) - K2 * DH2 + U(3) = K2 * ACAP(N) - K3 * W(1,N) + U(4) = K2 * ACAP(N) - K3 * DH2 + U(5) = K1 * W(3,N) - K2 * W(2,N) + U(6) = K2 * W(3,N) - K1 * W(2,N) + U(7) = ( 0.0_f, -1.0_f ) * ( DUMMY * P24H21 - P24H24 ) + U(8) = TA(3) / WFN(2) + + FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / & + ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) + FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / & + ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) + else + TC1 = ACAP(1) * RRF + RX + TC2 = ACAP(1) * RF + RX + FNA = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) + FNB = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) + endif + + FNAP = FNA + FNBP = FNB + T(1) = 1.50_f + + ! FROM HERE TO THE STATMENT NUMBER 90, ELTRMX(I,J,K) HAS + ! FOLLOWING MEANING: + ! ELTRMX(1,J,K): REAL PART OF THE FIRST COMPLEX AMPLITUDE. + ! ELTRMX(2,J,K): IMAGINARY PART OF THE FIRST COMPLEX AMPLITUDE. + ! ELTRMX(3,J,K): REAL PART OF THE SECOND COMPLEX AMPLITUDE. + ! ELTRMX(4,J,K): IMAGINARY PART OF THE SECOND COMPLEX AMPLITUDE. + ! K = 1 : FOR THETD(J) AND K = 2 : FOR 180.0 - THETD(J) + ! DEFINITION OF THE COMPLEX AMPLITUDE: VAN DE HULST,P.125. + FNA = T(1) * FNA + FNB = T(1) * FNB + + do J = 1,JX + TC1 = FNA * PI(2,J) + FNB * TAU(2,J) + TC2 = FNB * PI(2,J) + FNA * TAU(2,J) + ELTRMX(1,J,1) = real(TC1) + ELTRMX(2,J,1) = aimag(TC1) + ELTRMX(3,J,1) = real(TC2) + ELTRMX(4,J,1) = aimag(TC2) + TC1 = FNA * PI(2,J) - FNB * TAU(2,J) + TC2 = FNB * PI(2,J) - FNA * TAU(2,J) + ELTRMX(1,J,2) = real(TC1) + ELTRMX(2,J,2) = aimag(TC1) + ELTRMX(3,J,2) = real(TC2) + ELTRMX(4,J,2) = aimag(TC2) + enddo + + QEXT = 2.0_f * ( real(FNA) + real(FNB) ) + QSCAT = ( real(FNA)**2 + aimag(FNA)**2 + & + real(FNB)**2 + aimag(FNB)**2 ) / 0.75_f + CTBRQS = 0.0_f + TC1 = -2.0_f * (FNB - FNA) + QBSR = real(TC1) + QBSI = aimag(TC1) + RMM = -1.0_f + N = 2 + + ! Iterate until the answer converges. + T(4) = EPSILON_MIE + + do while ( T(4) .ge. EPSILON_MIE ) + + T(1) = 2*N - 1 + T(2) = N - 1 + T(3) = 2*N + 1 + + do J = 1,JX + PI(3,J) = ( T(1) * PI(2,J) * CSTHT(J) - N * PI(1,J) ) / T(2) + TAU(3,J) = CSTHT(J) * ( PI(3,J) - PI(1,J) ) - & + T(1) * SI2THT(J) * PI(2,J) + TAU(1,J) + end do + + ! HERE SET UP HOMOGENEOUS SPHERE + WM1 = WFN(1) + WFN(1) = WFN(2) + TA(1) = REAL(WFN(1)) + TA(2) = aimag(WFN(1)) + TA(4) = aimag(WFN(2)) + WFN(2) = T(1) * RX * WFN(1) - WM1 + TA(3) = REAL(WFN(2)) + + if ( IFLAG .ne. 2 ) then + + ! HERE SET UP STRATIFIED SPHERE + DH2 = - N / Z(2) + 1.0_f / ( N / Z(2) - DH2 ) + DH4 = - N / Z(4) + 1.0_f / ( N / Z(4) - DH4 ) + DH1 = - N / Z(1) + 1.0_f / ( N / Z(1) - DH1 ) + PSTORE = ( DH4 + N / Z(4) ) * ( W(3,N) + N / Z(4) ) + P24H24 = P24H24 / PSTORE + HSTORE = ( DH1 + N / Z(1) ) * ( W(3,N) + N / Z(4) ) + P24H21 = P24H21 / HSTORE + PSTORE = ( ACAP(N) + N / Z(1) ) / ( W(3,N) + N / Z(4) ) + DUMMY = DUMMY * PSTORE + DUMSQ = DUMMY * DUMMY + + U(1) = K3 * ACAP(N) - K2 * W(1,N) + U(2) = K3 * ACAP(N) - K2 * DH2 + U(3) = K2 * ACAP(N) - K3 * W(1,N) + U(4) = K2 * ACAP(N) - K3 * DH2 + U(5) = K1 * W(3,N) - K2 * W(2,N) + U(6) = K2 * W(3,N) - K1 * W(2,N) + U(7) = ( 0.0_f, -1.0_f ) * ( DUMMY * P24H21 - P24H24 ) + U(8) = TA(3) / WFN(2) + + FNA = U(8) * ( U(1)*U(5)*U(7) + K1*U(1) - DUMSQ*K3*U(5) ) / & + ( U(2)*U(5)*U(7) + K1*U(2) - DUMSQ*K3*U(5) ) + FNB = U(8) * ( U(3)*U(6)*U(7) + K2*U(3) - DUMSQ*K2*U(6) ) / & + ( U(4)*U(6)*U(7) + K2*U(4) - DUMSQ*K2*U(6) ) + endif + + TC1 = ACAP(N) * RRF + N * RX + TC2 = ACAP(N) * RF + N * RX + FN1 = ( TC1 * TA(3) - TA(1) ) / ( TC1 * WFN(2) - WFN(1) ) + FN2 = ( TC2 * TA(3) - TA(1) ) / ( TC2 * WFN(2) - WFN(1) ) + M = WVNO * R + + if ( N .ge. M ) then + if ( IFLAG .ne. 2 ) then + if ( abs( ( FN1-FNA ) / FN1 ) .LT. EPSILON_MIE .AND. & + abs( ( FN2-FNB ) / FN2 ) .LT. EPSILON_MIE ) IFLAG = 2 + + if ( IFLAG .ne. 1 ) then + FNA = FN1 + FNB = FN2 + endif + else + FNA = FN1 + FNB = FN2 + endif + endif + + T(5) = N + T(4) = T(1) / ( T(5) * T(2) ) + T(2) = ( T(2) * ( T(5) + 1.0_f ) ) / T(5) + + CTBRQS = CTBRQS + T(2) * ( real(FNAP) * real(FNA) + & + aimag(FNAP) *aimag(FNA) & + + real(FNBP) * real(FNB) + & + aimag(FNBP) *aimag(FNB) ) & + + T(4) * ( real(FNAP) * real(FNBP) + & + aimag(FNAP) *aimag(FNBP) ) + QEXT = QEXT + T(3) * ( real(FNA) + real(FNB) ) + + ! $ T(3), real(FNA), real(FNB), QEXT + T(4) = real(FNA)**2 + aimag(FNA)**2 + & + real(FNB)**2 + aimag(FNB)**2 + QSCAT = QSCAT + T(3) * T(4) + RMM = -RMM + TC1 = T(3)*RMM*(FNB - FNA) + QBSR = QBSR + real(TC1) + QBSI = QBSI + aimag(TC1) + + T(2) = N * (N+1) + T(1) = T(3) / T(2) + K = (N/2)*2 + + do J = 1,JX + TC1 = FNA * PI(3,J) + FNB * TAU(3,J) + TC2 = FNB * PI(3,J) + FNA * TAU(3,J) + ELTRMX(1,J,1) = ELTRMX(1,J,1)+T(1)* real(TC1) + ELTRMX(2,J,1) = ELTRMX(2,J,1)+T(1)*aimag(TC1) + ELTRMX(3,J,1) = ELTRMX(3,J,1)+T(1)* real(TC2) + ELTRMX(4,J,1) = ELTRMX(4,J,1)+T(1)*aimag(TC2) + + IF ( K .EQ. N ) THEN + TC1 = -FNA * PI(3,J) + FNB * TAU(3,J) + TC2 = -FNB * PI(3,J) + FNA * TAU(3,J) + ELSE + TC1 = FNA * PI(3,J) - FNB * TAU(3,J) + TC2 = FNB * PI(3,J) - FNA * TAU(3,J) + END IF + ELTRMX(1,J,2) = ELTRMX(1,J,2)+T(1)* real(TC1) + ELTRMX(2,J,2) = ELTRMX(2,J,2)+T(1)*aimag(TC1) + ELTRMX(3,J,2) = ELTRMX(3,J,2)+T(1)* real(TC2) + ELTRMX(4,J,2) = ELTRMX(4,J,2)+T(1)*aimag(TC2) + + enddo + + if ( T(4) .ge. EPSILON_MIE ) then + N = N + 1 + + do J = 1,JX + PI(1,J) = PI(2,J) + PI(2,J) = PI(3,J) + TAU(1,J) = TAU(2,J) + TAU(2,J) = TAU(3,J) + enddo + + FNAP = FNA + FNBP = FNB + + if ( N .gt. NMX2 ) then + if (do_print) write(LUNOPRT, '(a)') "miess:: The upper limit for acap is not enough." + rc = RC_ERROR + return + endif + endif + enddo + + ! Calculate the results. + do J = 1,JX + do K = 1,2 + do I= 1,4 + T(I) = ELTRMX(I,J,K) + enddo + + ELTRMX(2,J,K) = T(1)**2 + T(2)**2 + ELTRMX(1,J,K) = T(3)**2 + T(4)**2 + ELTRMX(3,J,K) = T(1) * T(3) + T(2) * T(4) + ELTRMX(4,J,K) = T(2) * T(3) - T(4) * T(1) + enddo + enddo + + T(1) = 2.0_f * RX**2 + QEXT = QEXT * T(1) + QSCAT = QSCAT * T(1) + CTBRQS = 2.0_f * CTBRQS * T(1) + + ! QBS IS THE BACK SCATTER CROSS SECTION + PIG = ACOS(-1.0_f) + RXP4 = RX*RX/(4.0_f*PIG) + QBS = RXP4*(QBSR**2 + QBSI**2) + + deallocate(ACAP) + deallocate(W) + + return +end diff --git a/src/physics/carma/base/newstate.F90 b/src/physics/carma/base/newstate.F90 new file mode 100644 index 0000000000..f1762f1754 --- /dev/null +++ b/src/physics/carma/base/newstate.F90 @@ -0,0 +1,245 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine manages the calculations that update state variables +!! of the model with new values at the current simulation time. +!! +!! @author Bardeen +!! @version Jan 2012 +subroutine newstate(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + real(kind=f) :: pc_orig(NZ,NBIN,NELEM) + real(kind=f) :: gc_orig(NZ,NGAS) + real(kind=f) :: t_orig(NZ) + real(kind=f) :: cldfrc_orig(NZ) + real(kind=f) :: scale_cldfrc(NZ) + real(kind=f) :: pc_cloudy(NZ,NBIN,NELEM) + real(kind=f) :: gc_cloudy(NZ,NGAS) + real(kind=f) :: t_cloudy(NZ) + real(kind=f) :: rlheat_cloudy(NZ) + real(kind=f) :: partheat_cloudy(NZ) + real(kind=f) :: zsubsteps_cloudy(NZ) + real(kind=f) :: pc_clear(NZ,NBIN,NELEM) + real(kind=f) :: gc_clear(NZ,NGAS) + real(kind=f) :: t_clear(NZ) + real(kind=f) :: rlheat_clear(NZ) + real(kind=f) :: partheat_clear(NZ) + real(kind=f) :: zsubsteps_clear(NZ) + real(kind=f) :: scale_threshold(NZ) + integer :: igroup + integer :: igas + integer :: ielem + integer :: ibin + integer :: iz + + + ! Calculate changes due to vertical transport + if (do_vtran) then + + call vertical(carma, cstate, rc) + if (rc < RC_OK) return + endif + + + ! There can be two phases to the microphysics: in-cloud and clear sky. Particles + ! that are tagged as "In-cloud" will only be processed in the in-cloud loop, and their + ! concentrations will be scaled by the cloud fraction since it is assumed to be all + ! in-cloud. Other particle types will be process in-cloud and out of cloud; however, + ! their mass is assumed to be a gridbox average. + + ! If doing doing in-cloud processing, then scale the parameters for in-cloud concentrations. + ! + ! NOTE: Don't want to do this before sedimentation, since sedimentation doesn't take into + ! account the varying cloud fractions, and thus a particle scaled at one level and cloud + ! fraction would be scaled inappropriately at another level and cloud fraction. + ! + ! NOTE: All detrainment also happens only in the in-cloud portion. + if (do_incloud) then + + ! First do the in-cloud processing. + + ! Convert "cloud" particles to in-cloud values. + ! + ! NOTE: If a particle is a "cloud" particle, it means that the entire mass of the + ! particle is in the incloud portion of the grid box. Particle that are not "cloud + ! particles" have their mass spread throughout the grid box. + pc_orig(:,:,:) = pc(:,:,:) + gc_orig(:,:) = gc(:,:) + t_orig(:) = t(:) + + ! If the cloud fraction gets too small it causes the microphysics to require a + ! lot of substeps. Enforce a minimum cloud fraction for the purposes of scaling + ! to incloud values. + scale_cldfrc(:) = max(CLDFRC_MIN, cldfrc(:)) + scale_cldfrc(:) = min(1._f - CLDFRC_MIN, scale_cldfrc(:)) + + do ielem = 1, NELEM + igroup = igelem(ielem) + + if (is_grp_cloud(igroup)) then + do ibin = 1, NBIN + pc(:, ibin, ielem) = pc(:, ibin, ielem) / scale_cldfrc(:) + pcd(:, ibin, ielem) = pcd(:, ibin, ielem) / scale_cldfrc(:) + end do + end if + end do + + call newstate_calc(carma, cstate, scale_cldfrc(:), rc) + if (rc < RC_OK) return + + ! Save the new in-cloud values for the gas, particle and temperature fields. + pc_cloudy(:,:,:) = pc(:,:,:) + gc_cloudy(:,:) = gc(:,:) + t_cloudy(:) = t(:) + rlheat_cloudy(:) = rlheat(:) + partheat_cloudy(:) = partheat(:) + + if (do_substep) zsubsteps_cloudy(:) = zsubsteps(:) + + + + ! Now do the clear sky portion, using the original gridbox average concentrations. + ! This is optional. If clear sky is not selected then all of the microphysics is + ! done in-cloud. + pc(:,:,:) = pc_orig(:,:,:) + gc(:,:) = gc_orig(:,:) + t(:) = t_orig(:) + + if (do_clearsky) then + + ! Convert "cloud" particles to clear sky values. + ! + ! NOTE: If a particle is a "cloud" particle, it means that the entire mass of the + ! particle is in the in-cloud portion of the grid box. They have no mass in the + ! clear sky portion. + do ielem = 1, NELEM + igroup = igelem(ielem) + + if (is_grp_cloud(igroup)) then + pc(:, :, ielem) = 0._f + pcd(:, :, ielem) = 0._f + end if + end do + + ! Don't let the supersaturation be scaled by setting the cloud fraction used + ! by the saturation code to 1.0. Any clouds formed in-situ in the clear sky + ! are assumed to fill the grid box. + cldfrc_orig(:) = cldfrc(:) + cldfrc(:) = 1._f + + ! Recalculate supersaturation. + do igas = 1, NGAS + do iz = 1, NZ + call supersat(carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + end do + end do + + call newstate_calc(carma, cstate, (1._f - scale_cldfrc(:)), rc) + if (rc < RC_OK) return + + ! Restore the cloud fraction + cldfrc(:) = cldfrc_orig(:) + + ! Save the new clear sky values for the gas, particle and temperature fields. + pc_clear(:,:,:) = pc(:,:,:) + gc_clear(:,:) = gc(:,:) + t_clear(:) = t(:) + rlheat_clear(:) = rlheat(:) + partheat_clear(:) = partheat(:) + + if (do_substep) zsubsteps_clear(:) = zsubsteps(:) + + ! If not doing a clear sky calculation, then the clear sky portion reamins + ! the same except for any contribution from advection. + else + + ! NOTE: If a particle is a "cloud" particle, it means that the entire mass of the + ! particle is in the in-cloud portion of the grid box. They have no mass in the + ! clear sky portion. + do ielem = 1, NELEM + igroup = igelem(ielem) + + if (is_grp_cloud(igroup)) then + pc_clear(:, :, ielem) = 0._f + else + pc_clear(:, :, ielem) = pc(:, :, ielem) + end if + end do + + do igas = 1, NGAS + gc_clear(:,:) = gc(:,:) + end do + + t_clear(:) = t(:) + rlheat_clear(:) = 0._f + partheat_clear(:) = 0._f + + ! If substepping, then add the advected part that is being doled out over + ! the substeps. + if (do_substep) then + do igas = 1, NGAS + gc_clear(:, igas) = gc_clear(:, igas) + d_gc(:, igas) + end do + t_clear(:) = t_clear(:) + d_t(:) + + zsubsteps_clear(:) = 0._f + end if + end if + + + ! Add up the changes to the particle from the cloudy and clear sky components. + do ielem = 1, NELEM + igroup = igelem(ielem) + + do ibin = 1, NBIN + pc(:, ibin, ielem) = (1._f - scale_cldfrc(:)) * pc_clear(:, ibin, ielem) + scale_cldfrc(:) * pc_cloudy(:, ibin, ielem) + end do + end do + + t(:) = (1._f - scale_cldfrc(:)) * t_clear(:) + scale_cldfrc(:) * t_cloudy(:) + + if (do_grow) then + rlheat(:) = (1._f - scale_cldfrc(:)) * rlheat_clear(:) + scale_cldfrc(:) * rlheat_cloudy(:) + partheat(:) = (1._f - scale_cldfrc(:)) * partheat_clear(:) + scale_cldfrc(:) * partheat_cloudy(:) + end if + + do igas = 1, NGAS + gc(:, igas) = (1._f - scale_cldfrc(:)) * gc_clear(:, igas) + scale_cldfrc(:) * gc_cloudy(:, igas) + + ! Recalculate gridbox average supersaturation. + do iz = 1, NZ + call supersat(carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + end do + end do + + if (do_substep) zsubsteps(:) = zsubsteps_clear(:) + zsubsteps_cloudy(:) + + + + ! No special in-cloud/clear sky processing, everything is gridbox average. + else + scale_threshold(:) = 1._f + call newstate_calc(carma, cstate, scale_threshold, rc) + if (rc < RC_OK) return + end if + + ! Return to caller with new state computed + return +end diff --git a/src/physics/carma/base/newstate_calc.F90 b/src/physics/carma/base/newstate_calc.F90 new file mode 100644 index 0000000000..ee88a4faf5 --- /dev/null +++ b/src/physics/carma/base/newstate_calc.F90 @@ -0,0 +1,277 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine manages the calculations that update state variables +!! of the model with new values at the current simulation time. It supports +!! a retry mechanism, so the the number of steps can be increased dynamically +!! if the fast microphysics was not able to generate a valid solution. The +!! validity of the solution is control by the convergence thresholds +!! (dgc_threshold, dt_threshold and ds_threshold) +!! +!! NOTE: For cloud models, this routine may get called multiple times, once for +!! in-cloud calculations and again for clear sky. +!! +!! @author Bardeen +!! @version Jan 2012 +subroutine newstate_calc(carma, cstate, scale_threshold, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + real(kind=f), intent(in) :: scale_threshold(NZ) !! Scaling factor for convergence thresholds + integer, intent(inout) :: rc !! return code, negative indicates failure + + real(kind=f) :: sedlayer(NBIN,NELEM) + real(kind=f) :: pcd_last(NBIN,NELEM) + integer :: kb + integer :: ke + integer :: idk + integer :: iz + integer :: isubstep + integer :: igroup + integer :: igas + integer :: ielem + integer :: ibin + integer :: ntsubsteps + logical :: takeSteps + real(kind=f) :: fraction ! Fraction of dT, dgc and pdc to be added in a substep. + + 1 format(/,'newstate::ERROR - Substep failed, maximum retries execeed. : iz=',i4,',isubstep=',i12, & + ',ntsubsteps=',i12,',nretries=',F9.0) + + + ! Redetermine the maximum particle values. + if ((do_vtran) .or. do_incloud) then + do iz = 1, NZ + call maxconc(carma, cstate, iz, rc) + if (rc < RC_OK) return + end do + end if + + ! Calculate changes in particle concentrations due to microphysical + ! processes, part 1. (potentially slower microphysical calcs) + ! All spatial points are handled by one call to this routine. + if (do_coag) then + call microslow(carma, cstate, rc) + if (rc < RC_OK) return + endif + + ! If there is any microsphysics that happens on a faster time scale, + ! then check to see if the time step needs to be subdivided and then + ! perform the fast microphysical calculations. + if (do_grow) then + + ! Set vertical loop index to increment downwards + ! (for substepping of sedimentation) + if (igridv .eq. I_CART) then + kb = NZ + ke = 1 + idk = -1 + else + kb = 1 + ke = NZ + idk = 1 + endif + + ! Initialize sedimentation source to zero at top of model + dpc_sed(:,:) = 0._f + + ! Save the results from the slow operations, since we might need to retry the + ! fast operations + pcl(:,:,:) = pc(:,:,:) + + if (do_substep) then + do igas = 1,NGAS + gcl(:,igas) = gc(:,igas) + end do + told(:) = t(:) + endif + + + do iz = kb,ke,idk + + ! Compute or specify number of sub-timestep intervals for current spatial point + ! (Could be same for all spatial pts, or could vary as a function of location) + ntsubsteps = minsubsteps + + call nsubsteps(carma, cstate, iz, dtime_orig, ntsubsteps, rc) + if (rc < RC_OK) return + + ! Grab sedimentation source for entire step for this layer + ! and set accumlated source for underlying layer to zero + sedlayer(:,:) = dpc_sed(:,:) + + ! Do sub-timestepping for current spatial grid point, and allow for + ! retrying should this level of substepping not be enough to keep the + ! gas concentration from going negative. + nretries = 0._f + takeSteps = .true. + + do while (takeSteps) + + ! Compute sub-timestep time interval for current spatial grid point + dtime = dtime_orig / ntsubsteps + + ! Don't retry unless requested. + takeSteps = .false. + + ! Reset the amount that has been collected to sedimented down to the + ! layer below. + dpc_sed(:,:) = 0._f + + ! Reset the total nucleation for the step. + pc_nucl(iz,:,:) = 0._f + + ! Remember the amount of detrained particles. + if (do_detrain) then + pcd_last(:,:) = pcd(iz,:,:) + end if + + ! Reset average heating rates. + rlheat(iz) = 0._f + partheat(iz) = 0._f + + do isubstep = 1,ntsubsteps + + ! If substepping, then increment the gas concentration and the temperature by + ! an amount for one substep. + if (do_substep) then + + ! Since we don't really know how the gas and temperature changes arrived during the + ! step, we can try different assumptions for how the gas and temperature are add to + ! the values from the previous substep. + + ! Linear increment for substepping. + fraction = 1._f / ntsubsteps + + do igas = 1,NGAS + gc(iz,igas) = gc(iz,igas) + d_gc(iz,igas) * fraction + enddo + + t(iz) = t(iz) + d_t(iz) * fraction + + + ! Detrainment puts the full gridbox amount into the incloud portion. + if (do_detrain) then + pc(iz,:,:) = pc(iz,:,:) + pcd_last(:,:) * fraction + pcd(iz,:,:) = pcd(iz,:,:) - pcd_last(:,:) * fraction + end if + endif + + + ! Redetermine maximum particle concentrations. + call maxconc(carma, cstate, iz, rc) + if (rc < RC_OK) return + + ! Calculate changes in particle concentrations for current spatial point + ! due to microphysical processes, part 2. (faster microphysical calcs) + call microfast(carma, cstate, iz, scale_threshold(iz), rc) + if (rc < RC_OK) return + + + ! If there was a retry warning message and substepping is enabled, then retry + ! the operation with more substepping. + if (rc == RC_WARNING_RETRY) then + if (do_substep) then + + ! Only retry for so long ... + nretries = nretries + 1 + + if (nretries > maxretries) then + if (do_print) write(LUNOPRT,1) iz, isubstep, ntsubsteps, nretries - 1._f + rc = RC_ERROR + exit + end if + + ! Try twice the substeps + ! + ! NOTE: We are going to rely upon retries, so don't clutter the log + ! with retry print statements. They slow down the run. + ntsubsteps = ntsubsteps * 2 + +! if (do_print) write(LUNOPRT,*) "newstate::WARNING - Substep failed, retrying with ", ntsubsteps, " substeps." + + ! Reset the state to the beginning of the step + pc(iz,:,:) = pcl(iz,:,:) + pcd(iz,:,:) = pcd_last(:,:) + t(iz) = told(iz) + do igas = 1,NGAS + gc(iz,igas) = gcl(iz,igas) + + ! Now that we have reset the gas concentration, we need to recalculate the supersaturation. + call supersat(carma, cstate, iz, igas, rc) + if (rc < RC_OK) return + end do + + rc = RC_OK + takeSteps = .true. + exit + + + ! If substepping is not enabled, than the retry warning should be treated as an error. + else + + if (do_print) write(LUNOPRT,*) "newstate::ERROR - Step failed, suggest enabling substepping." + rc = RC_ERROR + exit + end if + end if + end do + end do + + + ! Keep track of substepping and retry statistics for performance tuning. + max_nsubstep = max(max_nsubstep, ntsubsteps) + max_nretry = max(max_nretry, nretries) + + nstep = nstep + 1._f + nsubstep = nsubstep + ntsubsteps + nretry = nretry + nretries + + if (do_substep) zsubsteps(iz) = ntsubsteps + end do + + ! Restore normal timestep + dtime = dtime_orig + + else + + ! If there is no reason to substep, but substepping was enabled, get the gas and + ! temperature back to their final states. + if (do_substep) then + + do igas = 1,NGAS + gc(:,igas) = gc(:,igas) + d_gc(:,igas) + enddo + + t(:) = t(:) + d_t(:) + end if + + ! Do the detrainment, if it was being done in the growth loop. + if (do_detrain) then + pc(:,:,:) = pc(:,:,:) + pcd(:,:,:) + + ! Remove the ice from the detrained ice, so that total ice will be conserved. + pcd(:,:,:) = 0._f + end if + end if + + ! Calculate average heating rates. + if (do_grow) then + rlheat(:) = rlheat(:) / dtime + partheat(:) = partheat(:) / dtime + end if + + ! Return to caller with new state computed + return +end diff --git a/src/physics/carma/base/nsubsteps.F90 b/src/physics/carma/base/nsubsteps.F90 new file mode 100644 index 0000000000..0eeed28107 --- /dev/null +++ b/src/physics/carma/base/nsubsteps.F90 @@ -0,0 +1,178 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the number of sub-timesteps +!! for the current model spatial point. +!! +!! @author Eric Jensen +!! @version Apr-2000 +subroutine nsubsteps(carma, cstate, iz, dtime_save, ntsubsteps, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(in) :: dtime_save !! original (not substepped) dtime + integer, intent(inout) :: ntsubsteps !! suggested number of substeps + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ig ! group index + integer :: igas ! gas index + integer :: ibin ! bin index + integer :: iepart + integer :: inuc + integer :: ienucto + integer :: ibin_small(NGROUP) + real(kind=f) :: g0 + real(kind=f) :: g1 + real(kind=f) :: dmdt + real(kind=f) :: dt_adv + real(kind=f) :: ss + real(kind=f) :: ssold + real(kind=f) :: pvap + real(kind=f) :: vf_max + + + ! If substepping is disabled, then use one substep + if (.not. do_substep) then + ntsubsteps = 1 + else + ! Set default values + ntsubsteps = minsubsteps + + ! Find the bin number of the smallest particle bin that + ! contains a significant number of particles. + ! Also check for significant activation of water droplets. + + if( ntsubsteps .lt. maxsubsteps )then + + do ig = 1, NGROUP + + if( pconmax(iz,ig) .gt. FEW_PC) then + + ibin_small(ig) = NBIN + + ! element of particle number concentration + iepart = ienconc(ig) + + if( itype(iepart) .eq. I_INVOLATILE ) then + + ! condensing gas + igas = inucgas(ig) + + if (igas /= 0) then + + ss = max( supsatl(iz,igas), supsatlold(iz,igas) ) + + do inuc = 1,nnuc2elem(iepart) + ienucto = inuc2elem(inuc,iepart) + + if( inucproc(iepart,ienucto) .eq. I_DROPACT ) then + do ibin = 1, NBIN + if( pc(iz,ibin,iepart) / xmet(iz) / ymet(iz) / zmet(iz) .gt. conmax * pconmax(iz,ig) .and. & + ss .gt. scrit(iz,ibin,ig) )then + ntsubsteps = maxsubsteps + endif + enddo + endif + enddo + endif + + elseif( itype(iepart) .eq. I_VOLATILE ) then + + do ibin = NBIN-1, 1, -1 + if( pc(iz,ibin,iepart) / xmet(iz) / ymet(iz) / zmet(iz) .gt. conmax * pconmax(iz,ig) )then + ibin_small(ig) = ibin + endif + enddo + + endif + endif + enddo + endif + + ! Calculate the growth rate of a particle with the mode radius for + ! each volatile group. The maximum time-step to use is then the + ! mass growth rate divided by the mass bin width / 2. + if( ntsubsteps .lt. maxsubsteps )then + + dt_adv = dtime_save + do ig = 1, NGROUP + + ! element of particle number concentration + iepart = ienconc(ig) + + ! condensing gas + igas = igrowgas(iepart) + + if (igas /= 0) then + + if( pconmax(iz,ig) .gt. FEW_PC ) then + + if( itype(iepart) .eq. I_VOLATILE ) then + + if( is_grp_ice(ig) )then + ss = supsati(iz,igas) + pvap = pvapi(iz,igas) + else + ss = supsatl(iz,igas) + pvap = pvapl(iz,igas) + endif + + g0 = gro(iz,ibin_small(ig),ig) + g1 = gro1(iz,ibin_small(ig),ig) + dmdt = abs( pvap * ss * g0 / ( 1._f + g0*g1*pvap ) ) + + if (dmdt /= 0._f) then + dt_adv = min( dt_adv, dm(ibin_small(ig),ig)/dmdt ) + end if + endif + endif + endif + enddo + + ntsubsteps = nint(min(real(maxsubsteps, kind=f), real(dtime_save, kind=f) / dt_adv)) + ntsubsteps = max( minsubsteps, ntsubsteps ) + endif + + ! If the ice supersaturation is large enough for homogeneous freezing + ! of sulfate aerosols, then use maximum number of substeps + if( ntsubsteps .lt. (maxsubsteps) )then + do ig = 1, NGROUP + + ! element of particle number concentration + iepart = ienconc(ig) + + ! condensing gas + igas = inucgas(ig) + + if (igas /= 0) then + + do inuc = 1,nnuc2elem(iepart) + ienucto = inuc2elem(inuc,iepart) + + if (iand(inucproc(iepart,ienucto), I_AERFREEZE) .ne. 0) then + if( (supsati(iz,igas) .gt. 0.4_f) .and. (t(iz) .lt. 233.16_f) ) then + ntsubsteps = maxsubsteps + endif + endif + enddo + endif + enddo + endif + endif + + ! Return to caller with number of sub-timesteps evaluated. + return +end diff --git a/src/physics/carma/base/pheat.F90 b/src/physics/carma/base/pheat.F90 new file mode 100644 index 0000000000..cb930f148c --- /dev/null +++ b/src/physics/carma/base/pheat.F90 @@ -0,0 +1,373 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluate particle loss rates due to particle heating. +!! +!! The net energy absorbed by each particle is calculatated as , and +!! this heating rate is included in the caclulation of in growevapl. The +!! particle temperature perturbation realtive to atmospheric temperature +!! and the radiative heating of the atmosphere by particles +!! are also calculated. +!! +!! This algorithm is based upon the model described in the appendix of +!! Toon et al., J. Geophys. Res., 94, 11359-11380, 1989. +!! +!! This routine assumes that the following variable/tables have already been +!! set up: +!! +!! intensity of incoming radiance (solar+ir) [erg/cm2/sr/s/cm] +!! wavelengths used for integration [cm] +!! width of wavelength bands for integration [cm] +!! whether planck emission should be doen for the band +!! extinction [cm2] +!! single scattering albedo +!! +!! @author Chuck Bardeen +!! @version Jan-2010 +subroutine pheat(carma, cstate, iz, igroup, iepart, ibin, igas, dmdt, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + use planck, only : planckIntensity, planckBandIntensity, planckBandIntensityWidger1976, planckBandIntensityConley2011 + + implicit none + + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! vertical index + integer, intent(in) :: igroup !! group index + integer, intent(in) :: iepart !! group's concentration element index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: igas !! gas index + real(kind=f), intent(out) :: dmdt !! particle growth rate (g/s) + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer, parameter :: MAX_ITER = 10 ! Maximum number of iterations + real(kind=f), parameter :: DDTP_LIMIT = 0.01_f ! Convergence criteria for iteration. + + integer :: iter ! iteration + integer :: iwvl ! wavelength band index + integer :: ieother(NELEM) + integer :: nother + integer :: ieoth_rel + integer :: ieoth_abs + integer :: jother + integer :: isol + real(kind=f) :: otherm(NELEM) + real(kind=f) :: argsol + real(kind=f) :: othermtot + real(kind=f) :: othervtot + real(kind=f) :: condm + real(kind=f) :: condv + real(kind=f) :: volfrc + real(kind=f) :: akas + real(kind=f) :: expon + real(kind=f) :: g0 + real(kind=f) :: g1 + real(kind=f) :: g2 + real(kind=f) :: ss + real(kind=f) :: pvap + real(kind=f) :: qrad ! particle net radiation (erg/s) +! real(kind=f) :: qrad0 ! particle net radiation (Tp=Ta) (erg/s) + real(kind=f) :: rlh ! latent heat (erg/g) + real(kind=f) :: tp ! particle temperature (K) + real(kind=f) :: dtp ! change in particle temperature (K) + real(kind=f) :: dtpl ! last change in particle temperature (K) + real(kind=f) :: ddtp ! change in particle temperature in last iteration (K) + real(kind=f) :: plkint ! planck intensity + + ! is combined kelvin (curvature) and solute factors. + ! + ! Ignore solute factor for ice particles. + if( is_grp_ice(igroup) )then + expon = akelvini(iz,igas) / rup_wet(iz,ibin,igroup) + + ! Ice can't be neutralized, so set the volume fraction to 0. + volfrc = 0._f + else + + argsol = 0._f + + ! Consider growth of average particle at radius . + ! + ! Treat solute effect first: is solute factor. + ! + ! Only need to treat solute effect if > 1 + if( nelemg(igroup) .gt. 1 )then + + ! is mass concentration of condensed gas in particle. + ! is number of other elements in group having mass. + ! are mass concentrations of other elements in particle group. + ! is total mass concentrations of other elements in particle. + nother = 0 + othermtot = 0._f + othervtot = 0._f + + ! is relative element number of other element in group. + do ieoth_rel = 2,nelemg(igroup) + + ! is absolute element number of other element. + ieoth_abs = iepart + ieoth_rel - 1 + + if( itype(ieoth_abs) .eq. I_COREMASS )then + nother = nother + 1 + ieother(nother) = ieoth_abs + otherm(nother) = pc(iz,ibin,ieoth_abs) + othermtot = othermtot + otherm(nother) + othervtot = othervtot + otherm(nother) / pc(iz,ibin,iepart) / rhoelem(ibin,ieoth_abs) + endif + enddo + + condm = rmass(ibin,igroup) * pc(iz,ibin,iepart) - othermtot + condv = min(0._f, (rmass(ibin,igroup) / rhoelem(ibin,iepart)) - othervtot) + + if( condm .le. 0._f )then + + ! Zero mass for the condensate -- is a small value << 1 + argsol = 1e6_f + + ! If there is no condensed mass, then the volume fraction of core is 1. + volfrc = 1._f + else + + ! Sum over masses of other elements in group for argument of solute factor. + do jother = 1,nother + isol = isolelem(ieother(jother)) + + ! Some elements aren't soluble, so skip them. + if(isol .gt. 0 ) argsol = argsol + sol_ions(isol)*otherm(jother)/solwtmol(isol) + enddo + + argsol = argsol*gwtmol(igas)/condm + + volfrc = othervtot / (othervtot + condv) + endif + endif ! nelemg(igroup) > 1 + expon = akelvin(iz,igas) / rup_wet(iz,ibin,igroup) - argsol + endif + + expon = max(-POWMAX, expon) + akas = exp( expon ) + + ! Trick for removing haze droplets from droplet bins: + ! allows haze droplets to exist under supersaturated conditions; + ! when below supersaturation, haze droplets will evaporate. +! if( (.not. is_grp_ice(igroup)) .and. (akas .lt. 1._f) .and. & +! (supsatl(iz,igas) .lt. 0._f) ) akas = 1._f + + ! is growth rate in mass space [g/s]. + g0 = gro(iz,ibin+1,igroup) + g1 = gro1(iz,ibin+1,igroup) + g2 = gro2(iz,igroup) + + if( is_grp_ice(igroup) )then + ss = supsati(iz,igas) + pvap = pvapi(iz,igas) + else + ss = supsatl(iz,igas) + pvap = pvapl(iz,igas) + endif + + + ! If particle heating is being considered, then determine qrad and tpart to + ! determine dmdt. + ! + ! NOTE: If no optical properties, then can't do the particle heating calculation. + if ((.not. do_pheat) .or. (.not. do_mie(igroup))) then + + ! Ignore the qrad term. + dmdt = pvap * ( ss + 1._f - akas ) * g0 / ( 1._f + g0 * g1 * pvap ) + + ! Is neutralization set up for the group? + if (neutral_volfrc(igroup) > 0._f) then + + ! When the particle is less than fully neutralized, calculate a new + ! dmdt based upon assuming that the saturation vapor pressure (pvap) + ! is 0. + if (volfrc >= neutral_volfrc(igroup)) then + dmdt = max((pvap * (ss + 1._f)) * g0, dmdt) + else + + ! You can only lose sulfuric acid (condensed) mass until the volume fraction + ! for neutralization is reached. At that point the particle is fully + ! neutralized and the vapor pressure goes to 0. The volume of condensed gas + ! in excess of full neutralization is: + ! + ! condv - othervtot * ((1 - neutral_volfrc) / neutral_volfrc) + ! + ! NOTE: Limit the growth rate so that the neutralized volume fraction is + ! not overshot. Test have shown that this requires reducing the rate by a + ! factor of 2; although, other values probably work too. + dmdt = max(-(condv - othervtot * ((1._f - neutral_volfrc(igroup)) / neutral_volfrc(igroup))) & + * rhoelem(ibin,iepart) / 2._f / dtime, & + dmdt) + end if + end if + else + + ! Latent heat of condensing gas + if( is_grp_ice(igroup) )then + rlh = rlhe(iz,igas) + rlhm(iz,igas) + else + rlh = rlhe(iz,igas) + endif + + ! The particle temperature must be solved for by iterating, with an + ! initial guess that the particle temperature is the ambient temperature. + ! + ! NOTE: We could also try a guest that is based upon an equilibrium + ! between upwelling IR and collisonal heating, which was identified by + ! Jensen [1989] as the dominant terms. + ! + ! radp = 0.d0 + ! + ! do iwvl = 1, Nwave + ! radp = radp + (4.0d0*PI * absk(iwvl,ibin+1,igroup) * + ! $ radint3(ixyz,iwvl) * dwave(iwvl)) + ! end do + ! + ! dtp2 = radp / + ! $ (4.d0*PI*rlow(ibin+1,igroup)*thcondnc(iz)*ft(iz,ibin+1,igroup)) + tp = t(iz) + dtp = 0._f + dtpl = 0._f + + do iter = 1, MAX_ITER + + ! Calculate the net radiative flux on the particle, which requires + ! integrating the incoming and outgoing flux over the spectral + ! interval. + qrad = 0._f + + do iwvl = 1, NWAVE + + ! There may be overlap between bands, so only do the emission + ! for each range of wavelengths once. + if (do_wave_emit(iwvl)) then + + ! Get an integral across the entire band. There are several + ! techniques for doing this that vary in accuracy and + ! performance. Comments below are based on the CAM RRTMG + ! band structure. + + ! Just use the band center. + ! + ! NOTE: This generates about a 20% error, but is the fastest +! plkint = planckIntensity(wave(iwvl), tp) + + ! Brute Force integral + ! + ! The slowest technique, and not as accurate as either Widger + ! and Woodall or Conley, even at 100 iterations. +! plkint = planckBandIntensity(wave(iwvl), dwave(iwvl), tp, 60) + + ! Integral using Widger and Woodall, 1976. + ! + ! NOTE: One of the fastest technique at 2 iterations, but yields errors + ! of about 2%. Can handle wide rage of band sizes. +! plkint = planckBandIntensityWidger1976(wave(iwvl), dwave(iwvl), tp, 2) + + ! Using method developed by Andrew Conley. + ! + ! This is similar in performance to Widger and Woodall, but is more + ! accurate with errors of about 0.3%. It had trouble with SW bands that + ! are very large, but the latest version has improved performance and + ! it does work with the RRTMG band structure. + plkint = planckBandIntensityConley2011(wave(iwvl), dwave(iwvl), tp, 1) + + else + plkint = 0._f + end if + + qrad = qrad + 4.0_f * PI * (1._f - ssa(iwvl,ibin+1,igroup)) * & + qext(iwvl,ibin+1,igroup) * PI * (rlow_wet(iz,ibin+1,igroup) ** 2) & + * arat(ibin+1,igroup) * (radint(iz,iwvl) - plkint) * dwave(iwvl) + end do + + ! Save of the Qrad association with the ambient air temperature. +! if (iter == 0) then +! qrad0 = qrad +! end if + + ! Calculate the change in mass using eq. A3 from Toon et al. [1989]. + dmdt = pvap * ( ss + 1._f - akas * (1._f + qrad * g1 * g2 )) * & + g0 / ( 1._f + g0 * g1 * pvap ) + + ! Calculate a new particle temperature based upon the loss of mass and + ! energy being absorbed. + if ((dmdt * dtime) .le. (- rmass(ibin+1, igroup))) then + dtp = ((rlh * (- rmass(ibin+1, igroup) / dtime)) + qrad) / & + (4._f * PI * rlow_wet(iz,ibin+1,igroup) * thcondnc(iz,ibin+1,igroup) * ft(iz,ibin+1,igroup)) + else + dtp = ((rlh * dmdt) + qrad) / & + (4._f * PI * rlow_wet(iz,ibin+1,igroup) * thcondnc(iz,ibin+1,igroup) * ft(iz,ibin+1,igroup)) + end if + + tp = t(iz) + dtp + + ddtp = dtp - dtpl + dtpl = dtp + + if (abs(ddtp) .le. DDTP_LIMIT) then + exit + end if + + if ((iter .gt. 1) .and. (ddtp .gt. dtpl)) then + exit + end if + end do + + dtpart(iz,ibin,igroup) = dtp + + ! Calculate the contribution of this bin to the heating of the atmosphere. CARMA does + ! not actually apply this heating to change the temperature. + ! + ! From Pruppacher & Klett [2000], eq. 13-19, the heat transfer to + ! one particle is: + ! + ! dq/dt = 4*pi*r*thcondnc*Ft(r)*(T - Tp(r)) + ! + ! so the total heating rate of the air by the particle is: + ! + ! dT/dt = -Sum((4*pi*r*thcondnc*Ft(r)*(T-Tp(r))*pc(r))) / (Cp,air*arho) + ! + ! or + ! + ! dT/dt = Sum((4*pi*r*thcondnc*Ft(r)*dtp*pc(r))) / (Cp,air*arho) + ! + ! where dtp = Tp(r) - T + ! + ! NOTE: Using these terms will cause the model parent model to go out of + ! energy balance, since qrad difference is not being communicated to the + ! other layers. + if (do_pheatatm) then + + ! NOTE: If the particle is going to evaporate entirely during the timestep, + ! then assume that there is no particle heating. + if ((dmdt * dtime) .gt. (- rmass(ibin+1, igroup))) then + + ! If the particles are radiatively active, then the parent model's radiation + ! code is calculated based upon Ta, not Tp. Adjust for this error in Qrad. +! phprod = phprod + (qrad - qrad0) * pc(iz,ibin+1,iepart) / CP / rhoa(iz) + + ! Now add in the heating from thermal conduction. + phprod = phprod + 4._f * PI * rlow_wet(iz,ibin+1,igroup) * & + thcondnc(iz,ibin+1,igroup) * ft(iz,ibin+1,igroup) * dtp * & + pc(iz,ibin+1,iepart) / (CP * rhoa(iz)) + end if + end if + end if + + ! Return to caller with particle loss rates for growth and evaporation + ! evaluated. + return +end diff --git a/src/physics/carma/base/planck.F90 b/src/physics/carma/base/planck.F90 new file mode 100644 index 0000000000..346a767dad --- /dev/null +++ b/src/physics/carma/base/planck.F90 @@ -0,0 +1,326 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +module planck + +contains + + !! This routine calculates the planck intensity. + !! + !! This algorithm is based upon eqn 1.2.4 from Liou[2002]. + !! + !! @author Chuck Bardeen + !! @version Jan-2010 + function planckIntensity(wvl, temp) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + real(kind=f), intent(in) :: wvl !! wavelength (cm) + real(kind=f), intent(in) :: temp !! temperature (K) + real(kind=f) :: planckIntensity !! Planck intensity (erg/s/cm2/sr/cm) + + ! Local declarations + + real(kind=f), parameter :: C = 2.9979e10_f ! Speed of light [cm/s] + real(kind=f), parameter :: H = 6.62608e-27_f ! Planck constant [erg s] + + ! Calculate the planck intensity. + planckIntensity = 2._f * H * C**2 / ((wvl**5) * (exp(H * C / (BK * wvl * temp)) - 1._f)) + + ! Return the planck intensity to the caller. + return + end function + + + !! This routine calculates the total planck intensity from the specified + !! wavelength to a wavelength of 0. + !! + !! This algorithm is based upon Widger and Woodall, BAMS, 1976 as + !! indicated at http://www.spectralcalc.com/blackbody/appendixA.html. + !! + !! @author Chuck Bardeen + !! @version Aug-2011 + function planckIntensityWidger1976(wvl, temp, miniter) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + real(kind=f), intent(in) :: wvl !! band center wavelength (cm) + real(kind=f), intent(in) :: temp !! temperature (K) + integer, intent(in) :: miniter !! minimum iterations + real(kind=f) :: planckIntensityWidger1976 !! Planck intensity (erg/s/cm2/sr/cm) + + ! Local Variables + real(kind=f), parameter :: C = 299792458.0_f ! Speed of light [m/s] + real(kind=f), parameter :: H = 6.6260693e-34_f ! Planck constant [J s] + real(kind=f), parameter :: BZ = 1.380658e-23_f ! Boltzman constant + + real(kind=f) :: c1, x, x2, x3, sumJ, dn, sigma + integer :: iter, n + + sigma = 1._f / wvl + + c1 = H * C / BZ + x = c1 * 100._f * sigma / temp + x2 = x * x + x3 = x2 * x + + ! Use fewer iterations, since speed is more important than accuracy for + ! the particle heating code, and even with fewer iterations the results + ! with CAM bands still show good accuracy. +! iter = min(512, int(2._f + 20._f / x)) + iter = min(miniter, int(2._f + 20._f / x)) + + sumJ = 0._f + + do n = 1, iter + dn = 1._f / n + sumJ = sumJ + exp(-n*x) * (x3 + (3.0_f * x2 + 6.0_f * (x + dn) * dn) * dn) * dn + end do + + ! Convert results from W/m2/sr to erg/cm2/s/sr + planckIntensityWidger1976 = 2.0_f * H * (C**2) * ((temp / c1) ** 4) * sumJ * 1e7_f / 1e4_f + + return + end function + + + !! This routine calculates the average planck intensity in the wavelength + !! band defined by wvl and dwvl. + !! + !! This algorithm is based upon Widger and Woodall, BAMS, 1976 as + !! indicated at http://www.spectralcalc.com/blackbody/appendixA.html. + !! + !! @author Chuck Bardeen + !! @version Aug-2011 + function planckBandIntensityWidger1976(wvl, dwvl, temp, miniter) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + real(kind=f), intent(in) :: wvl !! band center wavelength (cm) + real(kind=f), intent(in) :: dwvl !! band width (cm) + real(kind=f), intent(in) :: temp !! temperature (K) + integer, intent(in) :: miniter !! minimum iterations + real(kind=f) :: planckBandIntensityWidger1976 !! Planck intensity (erg/s/cm2/sr/cm) + + ! Calculate the integral from the edges to 0 and subtract. + planckBandIntensityWidger1976 = & + (planckIntensityWidger1976(wvl + (dwvl / 2._f), temp, miniter) & + - planckIntensityWidger1976(wvl - (dwvl / 2._f), temp, miniter)) / dwvl + + return + end function + + + !! This routine calculates the average planck intensity in the wavelength + !! band defined by wvl and dwvl. + !! + !! This algorithm does a brute force integral by dividing the band into + !! small sub-bands. This routine can be slow. + !! + !! @author Chuck Bardeen + !! @version Aug-2011 + function planckBandIntensity(wvl, dwvl, temp, iter) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + real(kind=f), intent(in) :: wvl !! band center wavelength (cm) + real(kind=f), intent(in) :: dwvl !! band width (cm) + real(kind=f), intent(in) :: temp !! temperature (K) + integer, intent(in) :: iter !! number of iterations + real(kind=f) :: planckBandIntensity !! Planck intensity (erg/s/cm2/sr/cm) + + ! Local Variables + real(kind=f) :: wstart ! Starting wavelength (cm) + real(kind=f) :: ddwave ! sub-band width (cm) + integer :: i + + wstart = wvl - (dwvl / 2._f) + ddwave = dwvl / iter + + planckBandIntensity = 0._f + + do i = 1, iter + planckBandIntensity = planckBandIntensity + planckIntensity(wstart + (i - 0.5) * ddwave, temp) * ddwave + end do + + planckBandIntensity = planckBandIntensity / dwvl + + return + end function + + + !! This routine calculates the average planck intensity in the wavelength + !! band defined by wvl and dwvl. + !! + !! error computed on full spectrum compared to planck function. Band-levels may be different + !! 8.9% error with 5 quadrature points in [100 micrometer, 1 millimeter] + !! 1.7% error with 10 quadrature points in [100 micrometer, 1 millimeter] + !! 0.001% error with 100 quadrature points in [100 micrometer, 1 millimeter] + !! + !! NOTE: This code was design to work with the CAM RRTMG band structure, it may not work as + !! well with arbitrary bands. + !! + !! NOTE: For most RRTMG bands, 3 quadrature points are probably sufficient, but testing is + !! left to the reader. + !! + !! @author Andrew Conley, Chuck Bardeen + !! @version Aug-2011 + function planckBandIntensityConley2011(wvl, dwvl, temp, iter) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + real(kind=f), intent(in) :: wvl !! band center wavelength (cm) + real(kind=f), intent(in) :: dwvl !! band width (cm) + real(kind=f), intent(in) :: temp !! temperature (K) + integer, intent(in) :: iter !! number of iterations + real(kind=f) :: planckBandIntensityConley2011 !! Planck intensity (erg/s/cm2/sr/cm) + + real(kind=f) :: half = 0.5_f + real(kind=f) :: third= 1._f / 3._f + real(kind=f) :: sixth= 1._f / 6._f + real(kind=f) :: tfth = 1._f /24._f + + real(kind=f) :: k = 1.3806488e-23_f ! boltzmann J/K + real(kind=f) :: c = 2.99792458e8_f ! light m/s + real(kind=f) :: h = 6.62606957e-34_f ! planck J s + real(kind=f) :: sigma = 5.670373e-8_f ! stef-bolt W/m/m/k/k/k/k + + real(kind=f) :: lambda1 ! wavelength m (lower bound) + real(kind=f) :: lambda2 ! wavelength m (upper bound) + + ! quadrature iteration + integer :: i,inumber + + ! internal temporary variables + real(kind=f) :: fr1, fr2 ! frequency bounds of partition + real(kind=f) :: kt ! k_boltzmann * temperature + real(kind=f) :: l1,l2 ! lower and upper bounds of (wavelength) + real(kind=f) :: dellam ! fraction multiplier for next lambda interval + real(kind=f) :: t1,t3 ! 2nd and 4th order terms + real(kind=f) :: total, total2 ! 2nd and 4th order cumulative partial integral + real(kind=f) :: e,d,em1i,di,ci ! exponential terms appearing in integral + real(kind=f) :: dfr,m,a,o,tt,mi ! terms appearing in integral + real(kind=f) :: argexp ! argument to exponent + real(kind=f) :: coeff ! front coefficient of integral + real(kind=f) :: planck ! planck function + + inumber = iter ! number of partitions + + !initialize + total = 0._f ! partial (cumulative) integral (4th order) +! total2 = 0._f ! partial (cumulative) integral (2nd order) + + kt = k*temp + lambda1 = (wvl - (dwvl / 2._f)) * 1e-2_f + lambda2 = (wvl + (dwvl / 2._f)) * 1e-2_f + ci = 1._f/c + + if (inumber .gt. 1) then + l1 = lambda1 + dellam = exp(log(lambda1/lambda2)/inumber) + l2 = l1/dellam + fr1 = c/l2 + fr2 = c/l1 + else + dellam = 1._f ! meaningless + l1 = lambda1 + l2 = lambda2 + fr1 = c/l2 + fr2 = c/l1 + endif + + ! accumulate integral by stepping (backwards) through partions of frequency + do i = 1,inumber + + ! constants + dfr = half * (fr2-fr1) ! half-range freq interval + m = half * (fr1+fr2) ! mean freq + mi = 1._f/m + a = h/kt ! alpha + + argexp = a*m + if (argexp .lt. 0.5_f) then + e = 1._f + & + argexp + & + (argexp*argexp)*half + & + (argexp*argexp*argexp)*sixth + & + (argexp*argexp*argexp*argexp)*tfth + em1i = 1._f/(e - 1._f ) + di = e*em1i + else if (argexp .lt. 20.0_f) then + e = exp(argexp) + em1i = 1._f/(e - 1._f ) + di = e*em1i + else + e = 1.e+20_f ! exp(20) is large. Use this for frequency >> Temperature + em1i = 1.e-20_f + di = 1._f + endif + + ! frontpiece + coeff = 2._f*h*m*m*m*ci*ci*em1i + + ! integrals + o = fr2-fr1 ! int 1 deps + tt = 2._f*(dfr*dfr*dfr)*third ! int eps^2 deps + + ! term and 4th order correction + t1 = 1._f + t3 = 3._f*mi*mi - 3._f*a*di*mi + a*a*di*di - half*a*a*di + ! t3 could be made more stable by placing (-) terms in denominator of pade approx. + + ! sum it up. Total is 4th order, total2 is 2nd order + total = total + coeff*(o*t1+tt*t3) +! total2 = total2 + coeff*o*t1 + + fr2 = fr1 + fr1 = fr1 * dellam + enddo + + ! Convert to erg/cm2/s/sr/cm + planckBandIntensityConley2011 = total * 1e7 / 1e4 / dwvl + + return + end function +end diff --git a/src/physics/carma/base/prestep.F90 b/src/physics/carma/base/prestep.F90 new file mode 100644 index 0000000000..be9862b50a --- /dev/null +++ b/src/physics/carma/base/prestep.F90 @@ -0,0 +1,105 @@ +#include "carma_globaer.h" + +!! This routine handles all preliminary setup at the beginning +!! of every timestep. Things that would appropriately be done +!! here include: +!! Input or otherwise define interface quantities from other submodels. +!! Save any model state that is needed to compute tendencies. +!! Save any model state that might be needed for comparison at end of step. +!! Update timestep counter and simulation time. +!! +!! @author Bill McKie +!! @version Oct-1995 +subroutine prestep(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + integer :: iz ! z index + integer :: igrp ! group index + integer :: igas ! gas index + integer :: ibin ! bin index + integer :: ielem ! element index + integer :: iep + real(kind=f) :: tmp_gc(NZ, NGAS) + real(kind=f) :: tmp_t(NZ) + + + ! If substepping is enabled, then determine how much the + ! gas concentration and temperature changed during this time step. + if (do_substep) then + if (NGAS > 0) then + d_gc(:,:) = gc(:,:) - gcl(:,:) + + do igas = 1, NGAS + do iz = 1, NZ + + ! NOTE: When d_gc is negative, you can get into problems with overshoot + ! to negative gas concentrations. To prevent that, when gc is negative + ! apply it all in the first step. Only substep gc when gc is increasing. + ! + ! NOTE: Perhaps there should be a limit, so that small changes happen + ! over the course of the timestep, but large changes get applied on the + ! first step. For now, doing it all on the first step should be the most + ! stable. + ! + ! NOTE: The case that is problematic is when the particle is growing + ! (i.e. supersaturated) and d_gc is negative. For better performance, + ! substep the gas unless both of these are true. This might run into + ! trouble if d_t is large and negative. +! if (d_gc(iz, igas) < 0._f) then + if ((d_gc(iz, igas) < 0._f) .and. ((supsatiold(iz, igas) > 0._f) & + .or. (supsati(iz, igas) > 0._f))) then + + ! Start from the new state and don't step the gas. + d_gc(iz, igas) = 0._f + gcl(iz, igas) = gc(iz, igas) + else + + ! Start the step from the old state and step the gas. + gc(iz, igas) = gcl(iz, igas) + end if + end do + end do + end if + + ! Start the temperature from the old state. + d_t(:) = t(:) - told(:) + t(:) = told(:) + endif + + + ! Don't allow particle concentrations to get too small. + do iz = 1, NZ + do ibin = 1, NBIN + do ielem = 1, NELEM + call smallconc(carma, cstate, iz, ibin, ielem, rc) + end do + end do + end do + + ! Set to from previous time step. This is needed by coagulation + ! as well as substepping. + if (do_substep .or. do_coag) then + pcl(:,:,:) = pc(:,:,:) + endif + + ! Find maximum particle concentrations. + do iz = 1, NZ + call maxconc(carma, cstate, iz, rc) + end do + + ! Return to caller with preliminary timestep things completed. + return +end diff --git a/src/physics/carma/base/psolve.F90 b/src/physics/carma/base/psolve.F90 new file mode 100644 index 0000000000..5939604503 --- /dev/null +++ b/src/physics/carma/base/psolve.F90 @@ -0,0 +1,85 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates new particle concentrations. +!! +!! The basic form from which the solution is derived is +!! ( new_value - old_value ) / dtime = source_term - loss_rate*new_value +!! +!! Modified Sep-1997 (McKie) +!! New particle concentrations due to coagulation processes +!! were moved to the csolve routine. Csolve is called to +!! update particle concentrations due to coagulation. +!! This new psolve now updates particle concentrations due +!! to the faster calcs of the non-coag microphysical processes. +!! +!! @author Eric Jensen, Bill McKie +!! @version Oct-1995, Sep-1997 +subroutine psolve(carma, cstate, iz, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: iepart + integer :: igto + integer :: iz_no_sed + real(kind=f) :: ppd ! particle prodocution rate + real(kind=f) :: pc_nonuc ! particles - no nucleation + real(kind=f) :: pls ! particle loss rate + real(kind=f) :: sed_rate + real(kind=f) :: rnuclgtot + real(kind=f) :: dsed + + + ! Define current group & particle number concentration element indices + igroup = igelem(ielem) + iepart = ienconc(igroup) + + if(do_grow) then + + ! Compute total production rate + ppd = rnucpe(ibin,ielem) + rhompe(ibin,ielem) + growpe(ibin,ielem) + evappe(ibin,ielem) + + ! Sum up nucleation loss rates + rnuclgtot = sum(rnuclg(ibin,igroup,:)) + + ! Compute total loss rate + pls = rnuclgtot + growlg(ibin,igroup) + evaplg(ibin,igroup) + + ! Figure out the new particle concentration without nucleation. + pc_nonuc = (pc(iz,ibin,ielem) + dtime * (ppd - rnucpe(ibin,ielem) - rhompe(ibin,ielem))) / (ONE + (pls - rnuclgtot) * dtime) + + ! Update net particle number concentration during current timestep + ! due to production and loss rates. + pc(iz,ibin,ielem) = (pc(iz,ibin,ielem) + dtime * ppd) / (ONE + pls * dtime) + + ! Now determine the number of particles produced by nucleation as the difference + ! between the actual particle count and that done without nucleation rates. + ! + ! NOTE: This is for statistics and is done as a total for the step, not per substep. + pc_nucl(iz,ibin,ielem) = pc_nucl(iz,ibin,ielem) + (pc(iz,ibin,ielem) - pc_nonuc) + end if + + ! Prevent particle concentrations from dropping below SMALL_PC + call smallconc(carma, cstate, iz, ibin, ielem, rc) + + ! Return to caller with new particle number concentrations. + return +end diff --git a/src/physics/carma/base/rhoice_heymsfield2010.F90 b/src/physics/carma/base/rhoice_heymsfield2010.F90 new file mode 100644 index 0000000000..ee48054f8e --- /dev/null +++ b/src/physics/carma/base/rhoice_heymsfield2010.F90 @@ -0,0 +1,101 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the effective ice densities for each bin, based upon +!! the parameterization of Heymsfield et al. [2010]. +!! +!! @author Chuck Bardeen +!! @ version March 2010 +!! +!! @see CARMAELEMENT_Create +subroutine rhoice_heymsfield2010(carma, rhoice, igroup, regime, rho, aratelem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: rhoice !! ice density(g/cm3) + integer, intent(in) :: igroup !! group index + character(len=4), intent(in) :: regime !! crystal regime [warm | cold | conv] + real(kind=f), intent(out) :: rho(NBIN) !! crystal density per bin (g/cm3) + real(kind=f), intent(out) :: aratelem(NBIN) !! projected area ratio () + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ibin ! bin index + real(kind=f) :: a ! scalar coefficient from Heysfield and Schmitt [2010] + real(kind=f), parameter :: b = 2.1_f ! exponential coefficient from Heysfield and Schmitt [2010] + real(kind=f) :: rbin ! predicated crystal radius (cm) + real(kind=f) :: dmax ! maximum diameter + real(kind=f) :: totalmass ! bin mass + +1 format(/,'rhoice_heymsfield2010::ERROR - unknown ice regime (', a, ').') + + + rc = RC_OK + +! Figure out the 'a' coefficient. + if (regime == "deep") then + a = 1.10e-2_f + else if (regime == "conv") then + a = 6.33e-3_f + else if (regime == "cold") then + a = 5.74e-3_f + else if (regime == "avg") then + a = 5.28e-3_f + else if (regime == "synp") then + a = 4.22e-3_f + else if (regime == "warm") then + a = 3.79e-3_f + else + if (do_print) write(LUNOPRT,1) regime + rc = RC_ERROR + return + end if + + ! Get the starting mass for the first bin and the volume ratio from the CARMA_GROUP. This + ! call is used before initialization has happened, so the bin structure hasn't been + ! determined yet. + + do ibin = 1, NBIN + + ! Determine the total mass of the particle. + ! + ! NOTE: This needs to match the logic in setupbins.F90, so that the ice density + ! and radii will be determined properly. + totalmass = rmassmin(igroup) * (rmrat(igroup)**(ibin-1)) + + ! Determine the radius of the particle from Heymsfield et al. [2010]. + ! + ! m(D) = a * D ^ b (all in cgs units) + rbin = ((totalmass / a) ** (1._f/b)) / 2._f + + ! Determine the density of an equivalent sphere. + rho(ibin) = totalmass / ((4._f / 3._f ) * PI * (rbin ** 3._f)) + + ! Don't let the density be larger than the bulk density of ice. This + ! will happen for r < ~ 50 um in the parameterization, but this is + ! not physical. + rho(ibin) = min(rho(ibin), rhoice) + + ! Determine the area ratio based on the formulation given in Schmitt and Heymsfield + ! [2009]. + dmax = 2._f * rbin + + if (dmax <= 200.e-4_f) then + aratelem(ibin) = exp(-38._f * dmax) + else + aratelem(ibin) = 0.16_f * (dmax ** (-0.27_f)) + end if + + end do + +end subroutine rhoice_heymsfield2010 diff --git a/src/physics/carma/base/rhopart.F90 b/src/physics/carma/base/rhopart.F90 new file mode 100644 index 0000000000..434ad51ea4 --- /dev/null +++ b/src/physics/carma/base/rhopart.F90 @@ -0,0 +1,172 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates new average particle densities. +!! +!! The particle mass density can change at each time-step due to +!! changes in the core mass fraction. +!! +!! For particles that are hydrophilic and whose particle size changes based +!! upon the relative humidity, and wet radius and density are also calculated. +!! For particles that do not swell, the wet and dry radius and densities are +!! the same. +!! +!! @author Chuck Bardeen Eric Jensen +!! @ version May-2009; Oct-1995 +!! +!! @see wetr +subroutine rhopart(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + use wetr + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: iz !! z index + integer :: igroup !! group index + integer :: ibin !! bin index + integer :: iepart !! element in group containing the particle concentration + integer :: jcore + integer :: iecore + real(kind=f) :: vcore(NBIN) + real(kind=f) :: mcore(NBIN) + real(kind=f) :: r_ratio + real(kind=f) :: h2o_mass + + 1 format(/,'rhopart::WARNING - core mass > total mass, truncating : iz=',i4,',igroup=',& + i4,',ibin=',i4,',total mass=',e10.3,',core mass=',e10.3,',using rhop=',f9.4) + + ! Calculate average particle mass density for each group + do igroup = 1,NGROUP + + ! Define particle # concentration element index for current group + iepart = ienconc(igroup) ! element of particle number concentration + + do iz = 1, NZ + + ! If there are no cores, than the density of the particle is just the density + ! of the element. + if (ncore(igroup) < 1) then + rhop(iz,:,igroup) = rhoelem(:,iepart) + + ! Otherwise, the density changes depending on the amount of core and volatile + ! components. + else + + ! Calculate volume of cores and the mass of shell material + ! is the volume of core material and is the + ! mass of shell material. + vcore(:) = 0._f + mcore(:) = 0._f + + do jcore = 1,ncore(igroup) + iecore = icorelem(jcore,igroup) ! core element + + mcore(:) = mcore(:) + pc(iz,:,iecore) + vcore(:) = vcore(:) + pc(iz,:,iecore) / rhoelem(:,iecore) + enddo + + ! Calculate average density + do ibin = 1,NBIN + + ! If there is no core, the the density is that of the volatile element. + if (mcore(ibin) == 0._f) then + rhop(iz,ibin,igroup) = rhoelem(ibin,iepart) + else + + ! Since core mass and particle number (i.e. total mass) are advected separately, + ! numerical diffusion during advection can cause problems where the core mass + ! becomes greater than the total mass. To prevent adevction errors from making the + ! group inconsistent, we will truncate core mass if it is larger than the total + ! mass. + if (mcore(ibin) > (rmass(ibin,igroup) * pc(iz,ibin,iepart))) then + + ! Calculate the density. + rhop(iz,ibin,igroup) = mcore(ibin) / vcore(ibin) + + ! NOTE: This error happens a lot, so this error message is commented out + ! by default. +! if (do_print) write(LUNOPRT,1) iz, igroup, ibin, pc(iz,ibin,iepart)*rmass(ibin,igroup), & +! mcore(ibin), rhop(iz,ibin,igroup) +! rc = RC_WARNING + + ! Repair total mass. + pc(iz,ibin,iepart) = mcore(ibin) / rmass(ibin,igroup) + else + rhop(iz,ibin,igroup) = (rmass(ibin,igroup) * pc(iz,ibin,iepart)) / & + ((pc(iz,ibin,iepart)*rmass(ibin,igroup) - mcore(ibin))/rhoelem(ibin,iepart) + vcore(ibin)) + end if + end if + enddo + endif + + ! If these particles are hygroscopic and grow in response to the relative + ! humidity, then caclulate a wet radius and wet density. Otherwise the wet + ! and dry radius are the same. + + ! Determine the weight percent of sulfate, and store it for later use. + if (irhswell(igroup) == I_WTPCT_H2SO4) then + h2o_mass = gc(iz, igash2o) / (xmet(iz) * ymet(iz) * zmet(iz)) + end if + + ! Loop over particle size bins. + do ibin = 1,NBIN + + ! If humidity affects the particle, then determine the equilbirium + ! radius and density based upon the relative humidity. + if (irhswell(igroup) == I_WTPCT_H2SO4) then + + ! rlow + call getwetr(carma, igroup, relhum(iz), rlow(ibin,igroup), rlow_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc, h2o_mass=h2o_mass, & + h2o_vp=pvapl(iz, igash2o), temp=t(iz)) + if (rc < 0) return + + ! rup + call getwetr(carma, igroup, relhum(iz), rup(ibin,igroup), rup_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc, h2o_mass=h2o_mass, & + h2o_vp=pvapl(iz, igash2o), temp=t(iz)) + if (rc < 0) return + + ! r + call getwetr(carma, igroup, relhum(iz), r(ibin,igroup), r_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc, h2o_mass=h2o_mass, & + h2o_vp=pvapl(iz, igash2o), temp=t(iz)) + if (rc < 0) return + + else + ! rlow + call getwetr(carma, igroup, relhum(iz), rlow(ibin,igroup), rlow_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc) + if (rc < 0) return + + ! rup + call getwetr(carma, igroup, relhum(iz), rup(ibin,igroup), rup_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc) + if (rc < 0) return + + ! r + call getwetr(carma, igroup, relhum(iz), r(ibin,igroup), r_wet(iz,ibin,igroup), & + rhop(iz,ibin,igroup), rhop_wet(iz,ibin,igroup), rc) + if (rc < 0) return + end if + end do + end do + enddo + + ! Return to caller with new particle number densities. + return +end diff --git a/src/physics/carma/base/setupatm.F90 b/src/physics/carma/base/setupatm.F90 new file mode 100644 index 0000000000..f841f36a73 --- /dev/null +++ b/src/physics/carma/base/setupatm.F90 @@ -0,0 +1,146 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine setups up parameters related to the atmospheric state. It assumes that the +!! pressure, temperature, and dimensional fields (xc, dx, yc, dy, zc, zl) have already been +!! specified and all state arrays allocated via CARMASTATE_Create(). +!! +!! @author Chuck Bardeen +!! @ version Feb-1995 +!! @see CARMASTATE_Create +subroutine setupatm(carma, cstate, rescale, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + logical, intent(in) :: rescale !! rescale the fall velocity for zmet change, this is instead of realculating + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + !-- + ! For air viscosity calculations + ! Air viscosity is from Sutherland's equation (using Smithsonian + ! Meteorological Tables, in which there is a misprint -- T is deg_K, not + ! deg_C. + real(kind=f), parameter :: rmu_0 = 1.8325e-4_f + real(kind=f), parameter :: rmu_t0 = 296.16_f + real(kind=f), parameter :: rmu_c = 120._f + real(kind=f), parameter :: rmu_const = rmu_0 * (rmu_t0 + rmu_c) + + integer :: ielem, ibin, i, j, ix, iy, iz, ie, ig, ip, igrp, jgrp, igroup + + + ! Calculate the dry air density at each level, using the ideal gas + ! law. This will be used to calculate zmet. + rhoa(:) = p(:) / (R_AIR * t(:)) + + ! Calculate the dimensions and the dimensional metrics. + dz(:) = abs(zl(2:NZP1) - zl(1:NZ)) + + ! Horizontal Metrics + select case(igridh) + ! Cartesian + case (I_CART) + xmet(:) = 1._f + ymet(:) = 1._f + + ! Latitude/Longitude + case (I_LL) + xmet(:) = REARTH * DEG2RAD * cos(DEG2RAD * yc(:)) + ymet(:) = REARTH * DEG2RAD + + case default + if (do_print) write(LUNOPRT,*) "setupatm:: ERROR - The specified horizontal grid type (", igridh, & + ") is not supported." + rc = -1 + end select + + + ! Put the fall velocity back into cgs units, so that we can determine + ! new metrics and then scale it back. This is optional and is done instead + ! of recalculating everything from scratch to improve performance. + if (rescale .and. (igridv /= I_CART)) then + do ibin = 1, NBIN + do igroup = 1, NGROUP + vf(:, ibin, igroup) = vf(:, ibin, igroup) * zmetl(:) + dkz(:, ibin, igroup) = dkz(:, ibin, igroup) * (zmetl(:)**2) + end do + end do + end if + + + ! Vertical Metrics + select case(igridv) + ! Cartesian + case (I_CART) + zmet = 1._f + + ! Sigma + case (I_SIG) + zmet(:) = abs(((pl(1:NZ) - pl(2:NZP1)) / (zl(1:NZ) - zl(2:NZP1))) / & + (GRAV * rhoa(:))) + + ! Hybrid + case (I_HYBRID) + zmet(:) = abs(((pl(1:NZ) - pl(2:NZP1)) / (zl(1:NZ) - zl(2:NZP1))) / & + (GRAV * rhoa(:))) + + case default + if (do_print) write(LUNOPRT,*) "setupatm:: ERROR - The specified vertical grid type (", igridv, & + ") is not supported." + rc = -1 + end select + + ! Interpolate the z metric to the grid box edges. + if (NZ == 1) then + zmetl(:) = zmet(1) + else + + ! Extrpolate the top and bottom. + zmetl(1) = zmet(1) + (zmet(2) - zmet(1)) / (zc(2) - zc(1)) * (zl(1) - zc(1)) + zmetl(NZP1) = zmet(NZ) + (zmet(NZ) - zmet(NZ-1)) / (zc(NZ) - zc(NZ-1)) * (zl(NZP1) - zc(NZ)) + + ! Interpolate the middles. + if (NZ > 2) then + do iz = 2, NZ + zmetl(iz) = zmet(iz-1) + (zmet(iz) - zmet(iz-1)) / (zc(iz) - zc(iz-1)) * (zl(iz) - zc(iz-1)) + end do + end if + end if + + + ! Determine the z metrics at the grid box edges and then use this to put the + ! fall velocity back into /x/y/z units. + if (rescale .and. (igridv /= I_CART)) then + do ibin = 1, NBIN + do igroup = 1, NGROUP + vf(:, ibin, igroup) = vf(:, ibin, igroup) / zmetl(:) + dkz(:, ibin, igroup) = dkz(:, ibin, igroup) / (zmetl(:)**2) + end do + end do + end if + + + ! Scale the density into the units carma wants (i.e. /x/y/z) + rhoa(:) = rhoa(:) * xmet(:) * ymet(:) * zmet(:) + + ! Use the pressure difference across the cell and the fact that the + ! atmosphere is hydrostatic to caclulate an average density in the + ! grid box. + rhoa_wet(:) = abs((pl(2:NZP1) - pl(1:NZ))) / (GRAV) + rhoa_wet(:) = (rhoa_wet(:) * xmet(:) * ymet(:)) / dz(:) + + ! Calculate the thermal properties of the atmosphere. + rmu(:) = rmu_const / ( t(:) + rmu_c ) * (t(:) / rmu_t0 )**1.5_f + thcond(:) = (5.69_f + .017_f*(t(:) - T0)) * 4.186e2_f +end subroutine diff --git a/src/physics/carma/base/setupbdif.F90 b/src/physics/carma/base/setupbdif.F90 new file mode 100644 index 0000000000..54423d4f1f --- /dev/null +++ b/src/physics/carma/base/setupbdif.F90 @@ -0,0 +1,114 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle vertical diffusion coefficients, +!! dkz(k,i,j) [cm^2 s^-1]. +!! +!! Method: Uses equation 8.73 from Seinfeld and Pandis [1998] along +!! with the slip correction factor (bpm) calculated in the fall +!! velocity setup. +!! +!! This routine requires that vertical profiles of temperature , +!! air density , viscosity , and slip correction are +!! defined (i.e., initatm.f and setupvf.f must be called before this). +!! +!! NOTE: Eddy diffusion is carried out by the parent model, so the only +!! diffusion that CARMA does is Brownian diffusion. +!! +!! @author Chuck Bardeen +!! @version Aug-2010 +subroutine setupbdif(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup, ibin, iz, k1, k2, nzm1 + + ! Define formats + 2 format(/,'Brownian diffusion coefficient (prior to interpolation)') + 3 format(/,'Particle group ',i3,/,' bin lev p [dyne/cm2] T [K] r [cm] wet r [cm] dkz [cm2/s]',/) + 4 format(i3,4x,i3,5(1pe11.3,4x)) + + + ! Loop over all groups. + do igroup = 1, NGROUP + + ! Loop over particle size bins. + do ibin = 1,NBIN + + ! Loop over all atltitudes. + do iz = 1, NZ + + ! Vertical brownian diffusion coefficient + dkz(iz,ibin,igroup) = (BK*t(iz)*bpm(iz,ibin,igroup)) / (6._f*PI*rmu(iz)*r_wet(iz,ibin,igroup) * rprat(ibin,igroup)) + + enddo + enddo + enddo + + ! Print out diffusivities. +#ifdef DEBUG + if (do_print_init) then + + write(LUNOPRT,2) + + do igroup = 1, NGROUP + + write(LUNOPRT,3) igroup + + do ibin = 1,NBIN + + do iz = NZ, 1, -1 + write(LUNOPRT,4) ibin,iz,p(iz),t(iz),r(ibin,igroup),r_wet(iz,ibin,igroup),dkz(iz,ibin,igroup) + end do + enddo + enddo + + write(LUNOPRT,*) "" + end if +#endif + + ! Interpolate from layer mid-pts to layer boundaries. + ! is the diffusion coefficient at the lower edge of the layer + nzm1 = max(1, NZ-1) + + ! Set upper boundary before averaging + dkz(NZP1,:,:) = dkz(NZ,:,:) + + if (NZ .gt. 1) then + dkz(NZ,:,:) = sqrt(dkz(nzm1,:,:) * dkz(NZ,:,:)) + + if (NZ .gt. 2) then + do iz = NZ-1, 2, -1 + dkz(iz,:,:) = sqrt(dkz(iz-1,:,:) * dkz(iz,:,:)) + enddo + endif + endif + + ! Scale cartesian diffusivities to the appropriate vertical coordinate system. + ! Non--cartesion coordinates are assumed to be positive downward, but + ! vertical velocities in this model are always assumed to be positive upward. + if( igridv .ne. I_CART )then + do igroup=1,NGROUP + do ibin=1,NBIN + dkz(:,ibin,igroup) = dkz(:,ibin,igroup) / (zmetl(:)**2) + enddo + enddo + endif + + ! Return to caller with fall velocities evaluated. + return +end diff --git a/src/physics/carma/base/setupbins.F90 b/src/physics/carma/base/setupbins.F90 new file mode 100644 index 0000000000..c4f1ab0c8d --- /dev/null +++ b/src/physics/carma/base/setupbins.F90 @@ -0,0 +1,235 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates the derived mapping arrays and sets up +!! the particle size bins. +!! +!! @author Eric Jensen +!! @ version Oct-1995 +subroutine setupbins(carma, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carma_mod + + implicit none + + type(carma_type), intent(inout) :: carma !! the carma object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ielem, ibin, i, j, ix, iy, iz, ie, ig, ip, igrp, jgrp + real(kind=f) :: tmp_rhop(NBIN, NGROUP) + real(kind=f) :: vrfact + real(kind=f) :: cpi + ! Local declarations needed for creation of fractal bin structure + real(kind=f) :: rf, rp + real(kind=f) :: vpor, upor, gamma, happel, perm, brinkman, epsil, omega + + ! Define formats + ! + 1 format(a,': ',12i6) + 2 format(a,': ',i6) + 3 format(a,': ',f12.2) + 4 format(a,': ',12f12.2) + 5 format(/,'Particle grid structure (setupbins):') + 6 format(a,': ',1p12e12.3) + 7 format(a,': ',12l6) + + + ! Determine which elements are particle number concentrations + ! is the element corresponding to particle number + ! concentration in group + ! + igrp = 0 + do ielem = 1, NELEM + if( itype(ielem) .eq. I_INVOLATILE .or. & + itype(ielem) .eq. I_VOLATILE )then + + igrp = igrp + 1 + ienconc(igrp) = ielem + endif + enddo + + if( igrp .gt. NGROUP )then + if (do_print) write(LUNOPRT,'(/,a)') 'CARMA_setupbin:: ERROR - bad itype array' + rc = -1 + return + endif + + ! Determine which group each element belongs to + ! i.e., is the group to which element belongs! + igrp = 0 + do ielem = 1, NELEM + if( itype(ielem) .eq. I_INVOLATILE .or. & + itype(ielem) .eq. I_VOLATILE )then + igrp = igrp + 1 + endif + igelem(ielem) = igrp + enddo + + ! Determine how many cores are in each group . + ! The core elements in a group are given by . + ! + ! Also evaluate whether or not second moment is used for each group. + ielem = 0 + + do igrp = 1, NGROUP + + ncore(igrp) = 0 + if_sec_mom(igrp) = .false. + imomelem(igrp) = 0 + + do j = 1, nelemg(igrp) + + ielem = ielem + 1 + + if( itype(ielem) .eq. I_COREMASS .or. & + itype(ielem) .eq. I_VOLCORE )then + + ncore(igrp) = ncore(igrp) + 1 + icorelem(ncore(igrp),igrp) = ielem + + elseif( itype(ielem) .eq. I_CORE2MOM )then + + if_sec_mom(igrp) = .true. + imomelem(igrp) = ielem + + endif + + enddo + enddo + + ! Particle mass densities (NBIN for each group) -- the user might want + ! to modify this (this code segment does not appear in setupaer subroutine + ! because is not defined until this subroutine). + do ig = 1,NGROUP + ie = ienconc(ig) + do ibin = 1,NBIN + tmp_rhop(ibin, ig) = rhoelem(ibin, ie) + + ! Set initial density of all hydrometeor groups to 1 such that nucleation + ! mapping arrays are calculated correctly. + ! or not +! if( itype(ie) .ne. I_INVOLATILE ) then +! rhop3(ixyz,ibin,ig) = 1. +! endif + enddo + enddo + + ! Set up the particle bins. + ! For each particle group, the mass of a particle in + ! bin j is times that in bin j-1 + ! + ! rmass(NBIN,NGROUP) = bin center mass [g] + ! r(NBIN,NGROUP) = bin mean (volume-weighted) radius [cm] + ! vol(NBIN,NGROUP) = bin center volume [cm^3] + ! dr(NBIN,NGROUP) = bin width in radius space [cm] + ! dv(NBIN,NGROUP) = bin width in volume space [cm^3] + ! dm(NBIN,NGROUP) = bin width in mass space [g] + cpi = 4._f/3._f*PI + + do igrp = 1, NGROUP + + vrfact = ( (3._f/2._f/PI/(rmrat(igrp)+1._f))**(ONE/3._f) )* & + ( rmrat(igrp)**(ONE/3._f) - 1._f ) + + ! If rmassmin wasn't specified, then use rmin to determine the mass + ! of the first bin. + if (rmassmin(igrp) == 0._f) then + rmassmin(igrp) = cpi*tmp_rhop(1,igrp)*rmin(igrp)**3 + else + + ! Just for internal consistency, recalculate rmin based on the rmass + ! that is being used. + rmin(igrp) = (rmassmin(igrp) / cpi / tmp_rhop(1,igrp)) ** (1._f / 3._f) + end if + + do j = 1, NBIN + rmass(j,igrp) = rmassmin(igrp) * rmrat(igrp)**(j-1) + rmassup(j,igrp) = 2._f*rmrat(igrp)/(rmrat(igrp)+1._f)*rmass(j,igrp) + dm(j,igrp) = 2._f*(rmrat(igrp)-1._f)/(rmrat(igrp)+1._f)*rmass(j,igrp) + vol(j,igrp) = rmass(j,igrp) / tmp_rhop(j,igrp) + r(j,igrp) = ( rmass(j,igrp)/tmp_rhop(j,igrp)/cpi )**(ONE/3._f) + rup(j,igrp) = ( rmassup(j,igrp)/tmp_rhop(j,igrp)/cpi )**(ONE/3._f) + dr(j,igrp) = vrfact*(rmass(j,igrp)/tmp_rhop(j,igrp))**(ONE/3._f) + rlow(j,igrp) = rup(j,igrp) - dr(j,igrp) + + if (is_grp_fractal(igrp)) then + ! fractal flag is true + + if (r(j,igrp) .le. rmon(igrp)) then ! if the bin radius is less than the monomer size + + nmon(j,igrp) = 1.0_f + rrat(j,igrp) = 1.0_f + arat(j,igrp) = 1.0_f + rprat(j,igrp) = 1.0_f + df(j,igrp) = 3.0_f ! Reset fractal dimension to 3 (this is a formality) + + else ! if bin radius is greater than the monomer size + + rf = (1.0_f/falpha(igrp))**(1.0_f/df(j,igrp))*r(j,igrp)**(3.0_f/df(j,igrp))*rmon(igrp)**(1.0_f-3.0_f/df(j,igrp)) + nmon(j,igrp) = falpha(igrp)*(rf/rmon(igrp))**df(j,igrp) + + rrat(j,igrp) = rf/r(j,igrp) + + ! Calculate mobility radius for permeable aggregates + ! using Vainshtein (2003) formulation + vpor = 1.0_f - (nmon(j,igrp))**(1.0_f-3.0_f/df(j,igrp)) ! Volume average porosity (eq. 3.2) + upor = 1.0_f-(1.0_f - vpor)*sqrt(df(j,igrp)/3.0_f) ! Uniform poroisty (eq. 3.10) + gamma = (1.0_f - upor)**(1.0_f/3.0_f) + happel = 2.0_f/(9.0_f*(1.0_f-upor))* & ! Happel permeability model + (3.0_f-4.5_f*gamma+4.5_f*gamma**5.0_f-3.0_f*gamma**6.0_f)/ & + (3.0_f+2.0_f*gamma**5.0_f) + perm = happel*rmon(igrp)**2.0_f ! Permeability (eq. 3.3) + brinkman = nmon(j,igrp)**(1.0_f/df(j,igrp))*1.0_f/sqrt(happel) ! Brinkman parameter (eq. 3.9) + epsil = 1.0_f - brinkman**(-1.)*tanh(brinkman) ! + omega = 2.0_f/3.0_f*epsil/(2.0_f/3.0_f+epsil/brinkman**2.0_f) ! drag coefficient (eq. 2.7) + rp = rf * omega + rprat(j,igrp) = rp/r(j,igrp) + + arat(j,igrp) = (rprat(j,igrp) / rrat(j, igrp))**2.0_f + endif + else + ! Not a fractal. + nmon(j,igrp) = 1.0_f + rprat(j,igrp) = 1.0_f + df(j,igrp) = 3.0_f + endif + enddo + enddo + + ! Evaluate differences between valuse of in different bins. + do igrp = 1, NGROUP + do jgrp = 1, NGROUP + do i = 1, NBIN + do j = 1, NBIN + diffmass(i,igrp,j,jgrp) = rmass(i,igrp) - rmass(j,jgrp) + enddo + enddo + enddo + enddo + + ! Report some initialization values + if (do_print_init) then + write(LUNOPRT,5) + write(LUNOPRT,2) 'NGROUP ',NGROUP + write(LUNOPRT,2) 'NELEM ',NELEM + write(LUNOPRT,2) 'NBIN ',NBIN + write(LUNOPRT,6) 'Massmin',(rmassmin(i),i=1,NGROUP) + write(LUNOPRT,4) 'Mrat ',(rmrat(i),i=1,NGROUP) + write(LUNOPRT,1) 'nelemg ',(nelemg(i),i=1,NGROUP) + write(LUNOPRT,1) 'itype ',(itype(i),i=1,NELEM) + write(LUNOPRT,1) 'ienconc',(ienconc(i),i=1,NGROUP) + write(LUNOPRT,1) 'igelem ',(igelem(i),i=1,NELEM) + write(LUNOPRT,1) 'ncore ',(ncore(i),i=1,NGROUP) + write(LUNOPRT,7) 'fractal',(is_grp_fractal(i),i=1,NGROUP) + end if + + ! Return to caller with particle grid initialized + return +end diff --git a/src/physics/carma/base/setupckern.F90 b/src/physics/carma/base/setupckern.F90 new file mode 100644 index 0000000000..084825c4ec --- /dev/null +++ b/src/physics/carma/base/setupckern.F90 @@ -0,0 +1,523 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates the coagulation kernels, ckernel(k,j1,j2,i1,i2) +!! [cm^3 s^-1] and pkernel. Indices correspond to aritrary array of columns +!! vertical level , aerosol groups and bins of colliding particles. +!! +!! ckernel is calculated as a static array for use each timestep +!! ckern0 is also created for a basis to calculate new ckernels each timestep, if desired. (coagwet.f) +!! +!! This routine requires that vertical profiles of temperature , +!! air density , and viscosity are defined. +!! +!! @version Oct-1995 +!! @author Andy Ackerman +subroutine setupckern(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + ! 2-D collision efficiency for current group pair under + ! consideration (for extrapolation of input data) + real(kind=f) :: e_coll2(NBIN,NBIN) + integer, parameter :: NP_DATA = 21 ! number of collector/collected pairs in input data + integer, parameter :: NR_DATA = 12 ! number of radius bins in input data + real(kind=f), parameter :: e_small = 0.0001_f ! smallest collision efficiency + logical, save :: init_data = .FALSE. ! did data_p and data_r get initialized? + real(kind=f), save :: data_p(NP_DATA) ! radius ratios (collected/collector) + real(kind=f), save :: data_r(NR_DATA) ! collector drop radii (um) + real(kind=f), save :: data_e(NP_DATA, NR_DATA) ! geometric collection efficiencies + + integer :: ip + integer :: ig, jg + + ! The probability that two particles that collide through thermal + ! coagulation will stick to each other. + real(kind=f) :: cstick_calc + + integer :: i1, i2, j1, j2, k + integer :: i, j + integer :: igrp + integer :: ibin + + real(kind=f) :: rhoa_cgs + real(kind=f) :: temp1, temp2 + + real(kind=f) :: r1 + real(kind=f) :: di + real(kind=f) :: gi + real(kind=f) :: rlbi + real(kind=f) :: dti1 + real(kind=f) :: dti2 + real(kind=f) :: dti + + real(kind=f) :: r2 + real(kind=f) :: dj + real(kind=f) :: gj + real(kind=f) :: rlbj + real(kind=f) :: dtj1 + real(kind=f) :: dtj2 + real(kind=f) :: dtj + + real(kind=f) :: rp + real(kind=f) :: dp + real(kind=f) :: gg + real(kind=f) :: delt + real(kind=f) :: term1 + real(kind=f) :: term2 + real(kind=f) :: cbr + + real(kind=f) :: r_larg + real(kind=f) :: r_smal + integer :: i_larg + integer :: i_smal + integer :: ig_larg + integer :: ig_smal + real(kind=f) :: d_larg + + real(kind=f) :: re_larg + real(kind=f) :: pe + real(kind=f) :: pe3 + real(kind=f) :: ccd + + real(kind=f) :: e_coll + real(kind=f) :: vfc_smal + real(kind=f) :: vfc_larg + real(kind=f) :: sk + real(kind=f) :: e1 + real(kind=f) :: e3 + real(kind=f) :: e_langmuir + real(kind=f) :: re60 + + real(kind=f) :: pr + real(kind=f) :: e_fuchs + + integer :: jp, jj, jr + + real(kind=f) :: pblni + real(kind=f) :: rblni + + real(kind=f) :: term3 + real(kind=f) :: term4 + + real(kind=f) :: beta + real(kind=f) :: b_coal + real(kind=f) :: a_coal + real(kind=f) :: x_coal + real(kind=f) :: e_coal + real(kind=f) :: vfc_1 + real(kind=f) :: vfc_2 + real(kind=f) :: cgr + + +! Add constants for calculating effect of Van Der Waal's forces on coagulation +! See Chan and Mozurkewich, J. Atmos. Sci., June 2001 + real(kind=f), parameter :: vwa1 = 0.0757_f + real(kind=f), parameter :: vwa3 = 0.0015_f + real(kind=f), parameter :: vwb0 = 0.0151_f + real(kind=f), parameter :: vwb1 = -0.186_f + real(kind=f), parameter :: vwb3 = -0.0163_f + real(kind=f), parameter :: ham = 6.4e-13_f ! erg, Hamaker constant + real(kind=f) :: hp, hpln, Enot, Einf + logical :: use_vw(NGROUP, NGROUP) + integer :: ielem + + +! Initialization of input data for gravitational collection. +! The data were compiled by Hall (J. Atmos. Sci. 37, 2486-2507, 1980). + + data data_p/0.00_f,0.05_f,0.10_f,0.15_f,0.20_f,0.25_f,0.30_f,0.35_f,0.40_f,0.45_f, & + 0.50_f,0.55_f,0.60_f,0.65_f,0.70_f,0.75_f,0.80_f,0.85_f,0.90_f,0.95_f,1.00_f/ + + data data_r( 1), (data_e(ip, 1),ip=1,NP_DATA) / 10.0, & + 0.0001, 0.0001, 0.0001, 0.0001, 0.0140, 0.0170, 0.0190, 0.0220, & + 0.0270, 0.0300, 0.0330, 0.0350, 0.0370, 0.0380, 0.0380, 0.0370, & + 0.0360, 0.0350, 0.0320, 0.0290, 0.0270 / + data data_r( 2), (data_e(ip, 2),ip=1,NP_DATA) / 20.0, & + 0.0001, 0.0001, 0.0001, 0.0050, 0.0160, 0.0220, 0.0300, 0.0430, & + 0.0520, 0.0640, 0.0720, 0.0790, 0.0820, 0.0800, 0.0760, 0.0670, & + 0.0570, 0.0480, 0.0400, 0.0330, 0.0270 / + data data_r( 3), (data_e(ip, 3),ip=1,NP_DATA) / 30.0, & + 0.0001, 0.0001, 0.0020, 0.0200, 0.0400, 0.0850, 0.1700, 0.2700, & + 0.4000, 0.5000, 0.5500, 0.5800, 0.5900, 0.5800, 0.5400, 0.5100, & + 0.4900, 0.4700, 0.4500, 0.4700, 0.5200 / + data data_r( 4), (data_e(ip, 4),ip=1,NP_DATA) / 40.0, & + 0.0001, 0.0010, 0.0700, 0.2800, 0.5000, 0.6200, 0.6800, 0.7400, & + 0.7800, 0.8000, 0.8000, 0.8000, 0.7800, 0.7700, 0.7600, 0.7700, & + 0.7700, 0.7800, 0.7900, 0.9500, 1.4000 / + data data_r( 5), (data_e(ip, 5),ip=1,NP_DATA) / 50.0, & + 0.0001, 0.0050, 0.4000, 0.6000, 0.7000, 0.7800, 0.8300, 0.8600, & + 0.8800, 0.9000, 0.9000, 0.9000, 0.9000, 0.8900, 0.8800, 0.8800, & + 0.8900, 0.9200, 1.0100, 1.3000, 2.3000 / + data data_r( 6), (data_e(ip, 6),ip=1,NP_DATA) / 60.0, & + 0.0001, 0.0500, 0.4300, 0.6400, 0.7700, 0.8400, 0.8700, 0.8900, & + 0.9000, 0.9100, 0.9100, 0.9100, 0.9100, 0.9100, 0.9200, 0.9300, & + 0.9500, 1.0000, 1.0300, 1.7000, 3.0000 / + data data_r( 7), (data_e(ip, 7),ip=1,NP_DATA) / 70.0, & + 0.0001, 0.2000, 0.5800, 0.7500, 0.8400, 0.8800, 0.9000, 0.9200, & + 0.9400, 0.9500, 0.9500, 0.9500, 0.9500, 0.9500, 0.9500, 0.9700, & + 1.0000, 1.0200, 1.0400, 2.3000, 4.0000 / + data data_r( 8), (data_e(ip, 8),ip=1,NP_DATA) / 100.0, & + 0.0001, 0.5000, 0.7900, 0.9100, 0.9500, 0.9500, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000 / + data data_r( 9), (data_e(ip, 9),ip=1,NP_DATA) / 150.0, & + 0.0001, 0.7700, 0.9300, 0.9700, 0.9700, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000 / + data data_r(10), (data_e(ip,10),ip=1,NP_DATA) / 200.0, & + 0.0001, 0.8700, 0.9600, 0.9800, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000 / + data data_r(11), (data_e(ip,11),ip=1,NP_DATA) / 300.0, & + 0.0001, 0.9700, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000 / + data data_r(12), (data_e(ip,12),ip=1,NP_DATA) / 1000.0, & + 0.0001, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, & + 1.0000, 1.0000, 1.0000, 1.0000, 1.0000 / + + + ! Use constant kernel if = I_COAGOP_CONST + if( icoagop .eq. I_COAGOP_CONST )then + ckernel(:,:,:,:,:) = ck0 + else + + if( icollec .eq. I_COLLEC_DATA )then + + ! Convert from um to cm and take logarithm of ; + ! however, we only want to do this once. + ! + ! If we are using Open/MP, we only want one thread to do this + ! operation once. This is a kludge, and this table should probably + ! get set up a different way. + !$OMP CRITICAL(CARMA_HALL) + if (.not. init_data) then + init_data = .TRUE. + + do i = 1, NR_DATA + data_r(i) = data_r(i)/1.e4_f + do ip = 1, NP_DATA + data_e(ip,i) = log(data_e(ip,i)) + enddo + enddo + endif + !$OMP END CRITICAL(CARMA_HALL) + endif + + ! Loop over the grid + do k = 1, NZ + + ! This is in cartesian coordinates. + rhoa_cgs = rhoa(k) / (xmet(k)*ymet(k)*zmet(k)) + + temp1 = BK*t(k) + temp2 = 6._f*PI*rmu(k) + + do j1 = 1, NGROUP + do j2 = j1, NGROUP + use_vw(j1, j2) = is_grp_sulfate(j1) .and. is_grp_sulfate(j2) + end do + end do + + ! Loop over groups! + do j1 = 1, NGROUP + do j2 = 1, NGROUP + + if( icoag(j1,j2) .ne. 0 )then + + ! First particle + do i1 = 1, NBIN + + r1 = r_wet(k,i1,j1) * rrat(i1,j1) + di = temp1*bpm(k,i1,j1)/(temp2*r1) + gi = sqrt( 8._f*temp1/(PI*rmass(i1,j1)) ) + rlbi = 8._f*di/(PI*gi) + dti1= (2._f*r1 + rlbi)**3 + dti2= (4._f*r1*r1 + rlbi*rlbi)**1.5_f + dti = 1._f/(6._f*r1*rlbi) + dti = dti*(dti1 - dti2) - 2._f*r1 + + ! Second particle + do i2 = 1, NBIN + r2 = r_wet(k,i2,j2) * rrat(i2,j2) + dj = temp1*bpm(k,i2,j2)/(temp2*r2) + gj = sqrt( 8._f*temp1/(PI*rmass(i2,j2)) ) + rlbj = 8._f*dj/(PI*gj) + dtj1= (2._f*r2 + rlbj)**3 + dtj2= (4._f*r2*r2 + rlbj*rlbj)**1.5_f + dtj = 1._f/(6._f*r2*rlbj) + dtj = dtj*(dtj1 - dtj2) - 2._f*r2 + + ! Account for the charging effect of small particles (Van Der Waal's forces). + ! Set cstick to E_infinity/Eo, then multiply cbr kernel by Eo + ! See Chan and Mozurkewich, J. Atmos. Sci., June 2001 + ! Only applicable to groups with sulfate elements + if (use_vw(j1,j2)) then + hp = ham / temp1 * (4._f * r1 * r2 / (r1 + r2)**2) + hpln = log(1._f + hp) + Enot = 1._f + vwa1 * hpln + vwa3 * hpln**3 + Einf = 1._f + sqrt(hp / 3._f) / (1._f + vwb0*sqrt(hp)) + vwb1 * hpln + vwb3 * hpln**3 + cstick_calc = Einf / Enot + else + cstick_calc = cstick + end if + + ! First calculate thermal coagulation kernel + rp = r1 + r2 + dp = di + dj + gg = sqrt(gi*gi + gj*gj)*cstick_calc + delt= sqrt(dti*dti + dtj*dtj) + term1 = rp/(rp + delt) + term2 = 4._f*dp/(gg*rp) + + ! is thermal (brownian) coagulation coefficient + cbr = 4._f*PI*rp*dp/(term1 + term2) + + ! Determine indices of larger and smaller particles (of the pair) + if (r2 .ge. r1) then + r_larg = r2 + r_smal = r1 + i_larg = i2 + i_smal = i1 + ig_larg = j2 + ig_smal = j1 + d_larg = dj + else + r_larg = r1 + r_smal = r2 + i_larg = i1 + i_smal = i2 + ig_larg = j1 + ig_smal = j2 + d_larg = di + endif + + ! Calculate enhancement of coagulation due to convective diffusion + ! as described in Pruppacher and Klett (Eqs. 17-12 and 17-14). + + ! Enhancement applies to larger particle. + re_larg = re(k,i_larg,ig_larg) + + ! is Peclet number. + pe = re_larg*rmu(k) / (rhoa_cgs*d_larg) + pe3 = pe**(1._f/3._f) + + ! is convective diffusion coagulation coefficient + if( re_larg .lt. 1._f )then + ccd = 0.45_f*cbr*pe3 + else + ccd = 0.45_f*cbr*pe3*re_larg**(ONE/6._f) + endif + + ! Next calculate gravitational collection kernel. + + ! First evaluate collection efficiency . + if( icollec .eq. I_COLLEC_CONST )then + ! constant value + e_coll = grav_e_coll0 + else if( icollec .eq. I_COLLEC_FUCHS )then + ! Find maximum of Langmuir's formulation and Fuchs' value. + ! First calculate Langmuir's efficiency . + + ! is stokes number. + ! is the fallspeed in cartesian coordinates.! + vfc_smal = vf(k,i_smal,ig_smal) * zmet(k) + vfc_larg = vf(k,i_larg,ig_larg) * zmet(k) + + sk = vfc_smal * (vfc_larg - vfc_smal) / (r_larg*GRAV) + + if( sk .lt. 0.08333334_f )then + e1 = 0._f + else + e1 = (sk/(sk + 0.25_f))**2 + endif + + if( sk .lt. 1.214_f )then + e3 = 0._f + else + e3 = 1._f/(1._f+.75_f*log(2._f*sk)/(sk-1.214_f))**2 + endif + + if( re_larg .lt. 1._f )then + e_langmuir = e3 + else if( re_larg .gt. 1000._f )then + e_langmuir = e1 + else if( re_larg .le. 1000._f )then + re60 = re_larg/60._f + e_langmuir = (e3 + re60*e1)/(1._f + re60) + endif + + ! Next calculate Fuchs' efficiency (valid for r < 10 um). + pr = r_smal/r_larg + e_fuchs = (pr/(1.414_f*(1. + pr)))**2 + + e_coll = max( e_fuchs, e_langmuir ) + + else if( icollec .eq. I_COLLEC_DATA )then + + ! Interpolate input data (from data statment at beginning of subroutine). + pr = r_smal/r_larg + + ! First treat cases outside the data range + if( pr .lt. data_p(2) )then + + ! Radius ratio is smaller than lowest nonzero ratio in input data -- + ! use constant values (as in Beard and Ochs, 1984) if available, + ! otherwise use very small efficiencty + if( i2 .eq. i_larg )then + if( i2.eq.1 )then + e_coll = e_small + else + e_coll = e_coll2(i1,i2-1) + endif + else + if( i1.eq.1 )then + e_coll = e_small + else + e_coll = e_coll2(i1-1,i2) + endif + endif + + elseif( r_larg .lt. data_r(1) )then + ! Radius of larger particle is smaller than smallest radius in input data -- + ! assign very small efficiency. + e_coll = e_small + else + + ! Both droplets are either within grid (interpolate) or larger + ! droplet is larger than maximum on grid (extrapolate) -- in both cases + ! will interpolate on ratio of droplet radii. + + ! Find such that data_p(jp) <= pr <= data_p(jp+1) and calculate + ! = fractional distance of between points in + jp = NP_DATA + do jj = NP_DATA-1, 2, -1 + if( pr .le. data_p(jj+1) ) jp = jj + enddo + + ! should not need this if-stmt + if( jp .lt. NP_DATA )then + pblni = (pr - data_p(jp)) / (data_p(jp+1) - data_p(jp)) + else + ! nor this else-stmt + if (do_print) write(LUNOPRT, *) 'setupckern::ERROR NP_DATA < jp = ', jp + return + endif + + if( r_larg .gt. data_r(NR_DATA) )then + + ! Extrapolate on R and interpolate on p + ! + ! NOTE: This expression has a bugin it, since jr won't + ! be defined. + e_coll = (1._f-pblni)*data_e(jp ,jr) + & + ( pblni)*data_e(jp+1,jr) + + else + + ! Find such that data_r(jr) <= r_larg <= data_r(jr+1) and calculate + ! = fractional distance of between points in + jr = NR_DATA + do jj = NR_DATA-1, 1, -1 + if( r_larg .le. data_r(jj+1) ) jr = jj + enddo + rblni = (r_larg - data_r(jr)) / (data_r(jr+1) - data_r(jr)) + + ! Bilinear interpolation of logarithm of data. + e_coll = (1._f-pblni)*(1._f-rblni)*data_e(jp ,jr ) + & + ( pblni)*(1._f-rblni)*data_e(jp+1,jr ) + & + (1._f-pblni)*( rblni)*data_e(jp ,jr+1) + & + ( pblni)*( rblni)*data_e(jp+1,jr+1) + + ! (since data_e is logarithm of efficiencies) + term1 = (1._f-rblni)*(1._f-pblni)*data_e(jp,jr) + + if( jp .lt. NP_DATA )then + term2 = pblni*(1.-rblni)*data_e(jp+1,jr) + else + term2 = -100._f + endif + + if( jr .lt. NR_DATA )then + term3 = (1._f-pblni)*rblni*data_e(jp,jr+1) + else + term3 = -100._f + endif + + if( jr .lt. NR_DATA .and. jp .lt. NP_DATA )then + term4 = pblni*rblni*data_e(jp+1,jr+1) + else + term4 = -100._f + endif + + e_coll = exp(term1 + term2 + term3 + term4) + endif + endif + + e_coll2(i1,i2) = e_coll + endif + + ! Now calculate coalescence efficiency from Beard and Ochs + ! (J. Geophys. Res. 89, 7165-7169, 1984). + beta = log(r_smal*1.e4_f) + 0.44_f*log(r_larg*50._f) + b_coal = 0.0946_f*beta - 0.319_f + a_coal = sqrt(b_coal**2 + 0.00441) + x_coal = (a_coal-b_coal)**(ONE/3._f) & + - (a_coal+b_coal)**(ONE/3._f) + x_coal = x_coal + 0.459_f + + ! Limit extrapolated values to no less than 50% and no more than 100% + x_coal = max(x_coal,.5_f) + e_coal = min(x_coal,1._f) + + ! Now use coalescence efficiency and collision efficiency in definition + ! of (geometric) gravitational collection efficiency . + vfc_1 = vf(k,i1,j1) * zmet(k) + vfc_2 = vf(k,i2,j2) * zmet(k) + cgr = e_coal * e_coll * PI * rp**2 * abs( vfc_1 - vfc_2 ) + + ! Long's (1974) kernel that only depends on size of larger droplet + ! if( r_larg .le. 50.e-4_f )then + ! cgr = 1.1e10_f * vol(i_larg,ig_larg)**2 + ! else + ! cgr = 6.33e3_f * vol(i_larg,ig_larg) + ! endif + + ! Now combine all the coagulation and collection kernels into the + ! overall kernel. + ckernel(k,i1,i2,j1,j2) = cbr + ccd + cgr + + ! To avoid generation of large, non-physical hydrometeors by + ! coagulation, cut down ckernel for large radii + ! if( ( r1 .gt. 0.18_f .and. r2 .gt. 10.e-4_f ) .or. & + ! ( r2 .gt. 0.18_f .and. r1 .gt. 10.e-4_f ) ) then + ! ckernel(k,i1,i2,j1,j2) = ckernel(k,i1,i2,j1,j2) / 1.e6_f + ! endif + + enddo ! second particle bin + enddo ! first particle bin + endif ! icoag ne 0 + enddo ! second particle group + enddo ! first particle group + enddo ! vertical level + endif ! not constant + + ! return to caller with coagulation kernels evaluated. + return +end diff --git a/src/physics/carma/base/setupcoag.F90 b/src/physics/carma/base/setupcoag.F90 new file mode 100644 index 0000000000..3897d9a32c --- /dev/null +++ b/src/physics/carma/base/setupcoag.F90 @@ -0,0 +1,388 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine sets up mapping arrays for coagulation. It only computes varaibles that +!! are independent of the model state. The calculation of factors needed for coagulation +!! that depend on state are calculated in setupckern. +!! +!! @author Eric Jensen +!! @ version Oct-1995 +subroutine setupcoag(carma, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carma_mod + + implicit none + + type(carma_type), intent(inout) :: carma !! the CARMA object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ielem, isolto, icompto, igto, ig, iepart + integer :: icompfrom, ic, iecore + integer :: isolfrom + integer :: igrp, jg, i, j , ipair + real(kind=f) :: rmsum + integer :: ibin + real(kind=f) :: rmkbin + integer :: kb, ncg + real(kind=f) :: rmk + logical :: fill_bot ! used for filling + integer :: irow, icol + logical :: isCoag + integer :: igtest + real(kind=f) :: pkernl, pkernu + + + ! NOTE: Moved this section from from setupckern.f, since it is not dependent on the + ! model's state. + ! + ! Fill , maintaining diagonal symmetry + ! ------------------------------------------- + ! Fill bottom of matrix if non-zero term(s) in upper half; + ! also check for non-zero, non-matching, non-diagonal terms. + fill_bot = .true. + do irow = 2, NGROUP + do icol = 1, irow-1 + if( icoag(irow,icol) .ne. 0 )then + fill_bot = .false. + if( icoag(icol,irow) .ne. 0 .and. & + icoag(icol,irow) .ne. icoag(irow,icol) )then + if (do_print) write(LUNOPRT, *) 'setupcoag::ERROR bad icoag array' + rc = -1 + return + endif + endif + enddo + enddo + + do ig = 2, NGROUP + do jg = 1, ig-1 + if( fill_bot )then + irow = ig + icol = jg + else + irow = jg + icol = ig + endif + icoag(irow,icol) = icoag(icol,irow) + enddo + enddo + + ! Initialize with zeros + do ielem = 1,NELEM + do ig = 1,NGROUP + icoagelem(ielem,ig) = 0 + icoagelem_cm(ielem,ig) = 0 + enddo + enddo + + ! For each element and each group , determine which element in + ! contributes to production in : . + ! If no elements in are transfered into element during coagulation, + ! then set to 0. + do ielem = 1,NELEM + isolto = isolelem(ielem) ! target solute type + icompto = icomp(ielem) ! target element compound + igto = igelem(ielem) ! target group + + do ig = 1, NGROUP ! source group + ! source particle number concentration element + iepart = ienconc(ig) + + ! source element compound + icompfrom = icomp(iepart) + + ! Check to see if the target group is produced by coagulation of any + ! group with the source group. + isCoag = .FALSE. + + do igtest = 1, NGROUP + if (icoag(ig, igtest) .eq. igto .or. icoag(igtest, ig) .eq. igto) then + isCoag = .TRUE. + endif + end do + + ! Only find the source production element if the group igto can + ! be produced by coagulation from group ig. + if (isCoag) then + + ! If only has no cores, then the only way to make particles + ! would be if the one element is the same type as the + ! source. + if( ncore(ig) .eq. 0 ) then + + if( icompfrom .eq. icompto )then + icoagelem(ielem,ig) = iepart + endif + else + + ! Search the elements in the group to see if one has the same + ! type as the source. + + ! First check the particle number concentration element of the group. + ! + ! NOTE: No matter what else happens, you need to adjust the total + ! particle mass. + if( icompfrom .eq. icompto )then + icoagelem(ielem,ig) = iepart + else + + ! Now check the other cores for a match. + do ic = 1,ncore(ig) + iecore = icorelem(ic,ig) ! absolute element number of core + icompfrom = icomp(iecore) ! source element compound + + if( icompfrom .eq. icompto ) then + + ! For core second moment elements, we need additional pairs of source + ! elements c to account for core moment production due to products + ! of source particle core mass. + if( itype(ielem) .eq. I_CORE2MOM )then + icoagelem_cm(ielem,ig) = iecore + icoagelem(ielem,ig) = imomelem(ig) + else + icoagelem(ielem,ig) = iecore + endif + endif + enddo + endif + endif + + ! If is a core mass type and is a pure CN group and the + ! solutes don't match, then set to zero to make sure no + ! coag production occurs. + if( itype(ielem) .eq. I_COREMASS .and. & + itype(ienconc(ig)).eq. I_INVOLATILE & + .and. ncore(ig) .eq. 0 ) then + isolfrom = isolelem(ienconc(ig)) + if( isolfrom .ne. isolto ) then + icoagelem(ielem,ig) = 0 + endif + endif + + ! If there is a source and this is a multi-component group, + ! then we need to make sure that the particle concentration + ! of the group also gets updated, since this keeps track of + ! the total mass. + if (icoagelem(ielem,ig) .ne. 0) then + if (ncore(igto) .ne. 0 .and. ielem .ne. ienconc(igto)) then + icoagelem(ienconc(igto), ig) = iepart + endif + endif + + endif + enddo ! end of (ig = 1, NGROUP) + enddo ! end of (ielem = 1,NELEM) + + + ! Coagulation won't work properly if any of the elements are produced by + ! items that come later in the element list than themselves. Report an + ! error if that is the case. + do ielem = 1, NELEM + do ig = 1, NGROUP + if (icoagelem(ielem, ig) .gt. ielem) then + if (do_print) write(LUNOPRT, '(a,i3,a,i3,a)') & + 'setupcoag::ERROR For coagulation, element (', & + icoagelem(ielem,ig), ') must come before (', ielem, & + ') in the element list.' + rc = -1 + return + endif + enddo + enddo + + + ! Calculate lower bin which coagulated particle goes into + ! and make sure it is less than +1 + ! + ! Colliding particles come from group , bin and group , bin + ! Resulting particle lands in group , between and + 1 + do igrp = 1, NGROUP + do ig = 1, NGROUP + do jg = 1, NGROUP + do i = 1, NBIN + do j = 1, NBIN + + rmsum = rmass(i,ig) + rmass(j,jg) + + do ibin = 1, NBIN-1 + if( rmsum .ge. rmass(ibin,igrp) .and. rmsum .lt. rmass(ibin+1,igrp) ) then + kbin(igrp,ig,jg,i,j) = ibin + endif + enddo + + ibin = NBIN + if( rmsum .ge. rmass(ibin,igrp) ) kbin(igrp,ig,jg,i,j) = NBIN + enddo + enddo + enddo + enddo + enddo + + ! Calculate partial loss fraction + ! + ! This fraction is needed because when a particle in bin collides + ! with a particle in bin resulting in a particle whose mass falls + ! between and +1, only partial loss occurs from bin . + ! + ! Since different particle groups have different radius grids, this + ! fraction is a function of the colliding groups and the resulting group. + do igrp = 1, NGROUP + do ig = 1, NGROUP + do jg = 1, NGROUP + + if( igrp .eq. icoag(ig,jg) ) then + + do i = 1, NBIN + do j = 1,NBIN + volx(igrp,ig,jg,i,j) = 1. + + if(kbin(igrp,ig,jg,i,j).eq.i) then + + ibin = kbin(igrp,ig,jg,i,j) + rmkbin = rmass(ibin,igrp) + volx(igrp,ig,jg,i,j) = 1. - & + (rmrat(igrp)*rmkbin-rmass(i,ig)-rmass(j,jg)) & + /(rmrat(igrp)*rmkbin-rmkbin)* & + rmass(i,ig)/(rmass(i,ig) + rmass(j,jg)) + endif + enddo + enddo + endif + enddo + enddo + enddo + + ! Calculate mapping functions that specify sets of quadruples + ! (group pairs and bin pairs) that contribute to production + ! in each bin. Mass transfer from to occurs due to + ! collisions between particles in and particles in . + ! 2 sets of quadruples must be generated: + ! low: k = ibin and (k != i or ig != igrp) and icoag(ig,jg) = igrp + ! up: k+1 = ibin and icoag(ig,jg) = igrp + ! + ! npair#(igrp,ibin) is the number of pairs in each set (# = l,u) + ! i#, j#, ig#, and jg# are the bin pairs and group pairs in each + ! set (# = low, up) + do igrp = 1, NGROUP + do ibin = 1, NBIN + + npairl(igrp,ibin) = 0 + npairu(igrp,ibin) = 0 + + do ig = 1, NGROUP + do jg = 1, NGROUP + do i = 1, NBIN + do j = 1, NBIN + kb = kbin(igrp,ig,jg,i,j) + ncg = icoag(ig,jg) + + if( kb+1.eq.ibin .and. ncg.eq.igrp ) then + npairu(igrp,ibin) = npairu(igrp,ibin) + 1 + iup(igrp,ibin,npairu(igrp,ibin)) = i + jup(igrp,ibin,npairu(igrp,ibin)) = j + igup(igrp,ibin,npairu(igrp,ibin)) = ig + jgup(igrp,ibin,npairu(igrp,ibin)) = jg + endif + + if( kb.eq.ibin .and. ncg.eq.igrp .and. (i.ne.ibin .or. ig.ne.igrp) ) then + npairl(igrp,ibin) = npairl(igrp,ibin) + 1 + ilow(igrp,ibin,npairl(igrp,ibin)) = i + jlow(igrp,ibin,npairl(igrp,ibin)) = j + iglow(igrp,ibin,npairl(igrp,ibin)) = ig + jglow(igrp,ibin,npairl(igrp,ibin)) = jg + endif + enddo + enddo + enddo + enddo + enddo + enddo + + +! NOTE: Split ckernel out of pkernel, so that it can be made independent of model state. +! It also reduces the size of the tables and should improve the intialization time. + +! Calculate variables needed in routine coagp.f + do igrp = 1, NGROUP + do jg = 1, NGROUP + do ig = 1, NGROUP + + if( igrp .eq. icoag(ig,jg) ) then + + do j = 1, NBIN + do i = 1, NBIN + + ibin = kbin(igrp,ig,jg,i,j) + rmk = rmass(ibin,igrp) + rmsum = rmass(i,ig) + rmass(j,jg) + + pkernl = (rmrat(igrp)*rmk - rmsum) / (rmrat(igrp)*rmk - rmk) + + pkernu = (rmsum - rmk) / (rmrat(igrp)*rmk - rmk) + + if( ibin .eq. NBIN )then + pkernl = rmsum / rmass(ibin,igrp) + pkernu = 0._f + endif + + pkernel(i,j,ig,jg,igrp,1) = pkernu * rmass(i,ig)/rmsum + pkernel(i,j,ig,jg,igrp,2) = pkernl * rmass(i,ig)/rmsum + pkernel(i,j,ig,jg,igrp,3) = pkernu * rmk*rmrat(igrp)/rmsum + pkernel(i,j,ig,jg,igrp,4) = pkernl * rmk/rmsum + pkernel(i,j,ig,jg,igrp,5) = pkernu * ( rmk*rmrat(igrp)/rmsum )**2 + pkernel(i,j,ig,jg,igrp,6) = pkernl * ( rmk/rmsum )**2 + enddo + enddo + endif + enddo + enddo + enddo + + ! Do some extra debugging reports (normally commented) + if (do_print_init) then + write(LUNOPRT,*) ' ' + write(LUNOPRT,*) 'Coagulation group mapping:' + do ig = 1, NGROUP + do jg = 1, NGROUP + write(LUNOPRT,*) 'ig jg icoag = ', ig, jg, icoag(ig,jg) + enddo + enddo + write(LUNOPRT,*) ' ' + write(LUNOPRT,*) 'Coagulation element mapping:' + do ielem = 1, NELEM + do ig = 1, NGROUP + write(LUNOPRT,*) 'ielem ig icoagelem icomp(ielem) = ', & + ielem, ig, icoagelem(ielem,ig), icomp(ielem) + enddo + enddo + write(LUNOPRT,*) ' ' + write(LUNOPRT,*) 'Coagulation bin mapping arrays' + do igrp = 1, NGROUP + do ibin = 1,3 + write(LUNOPRT,*) 'igrp, ibin = ',igrp, ibin + do ipair = 1,npairl(igrp,ibin) + write(LUNOPRT,*) 'low:np,ig,jg,i,j ', & + ipair,iglow(igrp,ibin,ipair), & + jglow(igrp,ibin,ipair), ilow(igrp,ibin,ipair), & + jlow(igrp,ibin,ipair) + enddo + do ipair = 1,npairu(igrp,ibin) + write(LUNOPRT,*) 'up:np,ig,jg,i,j ', & + ipair,igup(igrp,ibin,ipair), & + jgup(igrp,ibin,ipair), iup(igrp,ibin,ipair), & + jup(igrp,ibin,ipair) + enddo + enddo + enddo + endif + + ! Return to caller with coagulation mapping arrays defined + return +end diff --git a/src/physics/carma/base/setupgkern.F90 b/src/physics/carma/base/setupgkern.F90 new file mode 100644 index 0000000000..39105ba72f --- /dev/null +++ b/src/physics/carma/base/setupgkern.F90 @@ -0,0 +1,315 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine defines radius-dependent but time-independent parameters +!! used to calculate condensational growth of particles. Growth rates +!! are calculated at bin boundaries: the parameters calculated here +!! ( , , , and ) +!! are defined at lower bin boundaries through the growth rate expression +!! (for one particle) used in growevapl.f: +!!> +!! dm = gro*pvap*( S + 1 - Ak*As - gro1*gro2*qrad ) +!! -- ------------------------------------------- +!! dt 1 + gro*gro1*pvap +!! +!! where +!! +!! S = supersaturation +!! Ak = exp(akelvin/r) +!! As = exp(-sol_ions * solute_mass/solwtmol * gwtmol/condensate_mass) +!! pvap = saturation vapor pressure [dyne cm**-2] +!! qrad = radiative energy absorbed +!!< +!! This routine requires that vertical profiles of temperature , +!! and pressure

are defined. +!! +!! This routine also requires that particle Reynolds' numbers are +!! defined (setupvfall.f must be called before this). +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine setupgkern(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igas !! gas index + integer :: ielem !! element index + integer :: k !! z index + integer :: igroup !! group index + integer :: i + real(kind=f) :: gstick + real(kind=f) :: cor + real(kind=f) :: phish + real(kind=f) :: esh1 + real(kind=f) :: a1 + real(kind=f) :: br + real(kind=f) :: rknudn + real(kind=f) :: rknudnt + real(kind=f) :: rlam + real(kind=f) :: rlamt + real(kind=f) :: rhoa_cgs(NZ, NGAS) + real(kind=f) :: freep(NZ, NGAS) + real(kind=f) :: freept(NZ, NGAS) + real(kind=f) :: rlh + real(kind=f) :: diffus1 + real(kind=f) :: thcond1 + real(kind=f) :: reyn_shape + real(kind=f) :: schn + real(kind=f) :: prnum + real(kind=f) :: x1 + real(kind=f) :: x2 + real(kind=f) :: fv + real(kind=f) :: surf_tens ! surface tension of H2SO4 particle + real(kind=f) :: rho_H2SO4 ! wet density of H2SO4 particle + + + ! Calculate gas properties for all of the gases. Better to do them all once, than to + ! repeat this for multiple groups. + do igas = 1, NGAS + + ! Radius-independent parameters for condensing gas + ! + ! This is in cgs units. + ! + rhoa_cgs(:, igas) = rhoa(:) / (xmet(:)*ymet(:)*zmet(:)) + + if (igas .eq. igash2o) then + + ! Condensing gas is water vapor + ! + ! is surface tension of water-air interface (valid from 0 to 40 C) + ! from Pruppacher and Klett (eq. 5-12). + surfctwa(:) = 76.10_f - 0.155_f*( t(:) - 273.16_f ) + + ! is surface tension of water-ice interface + ! from Pruppacher and Klett (eq. 5-48).! + surfctiw(:) = 28.5_f + 0.25_f*( t(:) - 273.16_f ) + + ! is surface tension of water-ice interface + ! from Hale and Plummer [J. Chem. Phys., 61, 1974]. + surfctia(:) = 141._f - 0.15_f * t(:) + + ! is argument of exponential in kelvin curvature term. + akelvin(:,igas) = 2._f*gwtmol(igas)*surfctwa(:) & + / ( t(:)*RHO_W*RGAS ) + + akelvini(:,igas) = 2._f*gwtmol(igas)*surfctia(:) & + / ( t(:)*RHO_W*RGAS ) + + ! condensing gas is H2SO4 + else if (igas .eq. igash2so4) then + + ! Calculate Kelvin curvature factor for H2SO4 interactively with temperature: + do k = 1, NZ + surf_tens = sulfate_surf_tens(carma, wtpct(k), t(k), rc) + rho_H2SO4 = sulfate_density(carma, wtpct(k), t(k), rc) + akelvin(k, igas) = 2._f * gwtmol(igas) * surf_tens / (t(k) * rho_H2SO4 * RGAS) + + ! Not doing condensation of h2So4 on ice, so just set it to the value + ! for water vapor. + akelvini(k, igas) = akelvini(k, igash2o) + end do + else + + ! Condensing gas is not yet configured. + if (do_print) write(LUNOPRT,*) 'setupgkern::ERROR - invalid igas' + rc = RC_ERROR + return + endif + + ! Molecular free path of condensing gas + freep(:,igas) = 3._f*diffus(:,igas) & + * sqrt( ( PI*gwtmol(igas) ) / ( 8._f*RGAS*t(:) ) ) + + ! Thermal free path of condensing gas + freept(:,igas) = freep(:,igas)*thcond(:) / & + ( diffus(:,igas) * rhoa_cgs(:, igas) & + * ( CP - RGAS/( 2._f*WTMOL_AIR ) ) ) + end do + + + ! Loop over aerosol groups only (no radius, gas, or spatial dependence). + do igroup = 1, NGROUP + + ! Use gstickl or gsticki, depending on whether group is ice or not + if( is_grp_ice(igroup) ) then + gstick = gsticki + else + gstick = gstickl + endif + + ! Non-spherical corrections (need a reference for these) + if( ishape(igroup) .eq. I_SPHERE )then + + ! Spheres + cor = 1._f + phish = 1._f + else + + if( ishape(igroup) .eq. I_HEXAGON )then + + ! Hexagons + phish = 6._f/PI*tan(PI/6._f)*( eshape(igroup) + 0.5_f ) & + * ( PI / ( 9._f*eshape(igroup)*tan(PI/6._f) ) )**(2._f/3._f) + + else if( ishape(igroup) .eq. I_CYLINDER )then + + ! Spheroids + phish = ( eshape(igroup) + 0.5_f ) & + * ( 2._f / ( 3._f*eshape(igroup) ) )**(2._f/3._f) + endif + + if( eshape(igroup) .lt. 1._f )then + + ! Oblate spheroids + esh1 = 1._f / eshape(igroup) + a1 = sqrt(esh1**2 - 1._f) + cor = a1 / asin( a1 / esh1 ) / esh1**(2._f/3._f) + else + + ! Prolate spheroids + a1 = sqrt( eshape(igroup)**2 - 1._f ) + cor = a1 / log( eshape(igroup) + a1 ) & + / eshape(igroup)**(ONE/3._f) + endif + endif + + ! Evaluate growth terms only for particle elements that grow. + ! particle number concentration element + ielem = ienconc(igroup) + + ! condensing gas is + igas = igrowgas(ielem) + + ! If the group doesn't grow, but is involved in aerosol + ! freezing, then the gas properties still need to be calculated. + if( igas .eq. 0 ) igas = inucgas(igroup) + + if( igas .ne. 0 )then + + do k = 1, NZ + + ! Latent heat of condensing gas + if( is_grp_ice(igroup) )then + rlh = rlhe(k,igas) + rlhm(k,igas) + else + rlh = rlhe(k,igas) + endif + + ! Radius-dependent parameters + do i = 1, NBIN + + br = rlow_wet(k,i,igroup) ! particle bin Boundary Radius + + ! These are Knudsen numbers + rknudn = freep(k,igas) / br + rknudnt = freept(k,igas) / br + + ! These are "lambdas" used in correction for gas kinetic effects. + rlam = ( 1.33_f*rknudn + 0.71_f ) / ( rknudn + 1._f ) & + + ( 4._f*( 1._f - gstick ) ) / ( 3._f*gstick ) + + rlamt = ( 1.33_f*rknudnt + 0.71_f ) / ( rknudnt + 1._f ) & + + ( 4._f*( 1._f - tstick ) ) / ( 3._f*tstick ) + + ! Diffusion coefficient and thermal conductivity modified for + ! free molecular limit and for particle shape. + diffus1 = diffus(k,igas)*cor / ( 1._f + rlam*rknudn*cor/phish ) + thcond1 = thcond(k)*cor / ( 1._f + rlamt*rknudnt*cor/phish ) + + ! Save the modified thermal conductivity off so it can be used in pheat. + thcondnc(k,i,igroup) = thcond1 + + ! Reynolds' number based on particle shape + if( ishape(igroup) .eq. I_SPHERE )then + reyn_shape = re(k,i,igroup) + + else if( eshape(igroup) .lt. 1._f )then + reyn_shape = re(k,i,igroup) * ( 1._f + 2._f*eshape(igroup) ) + + else + reyn_shape = re(k,i,igroup) * PI*( 1._f+2._f*eshape(igroup) ) & + / ( 2._f*( 1._f + eshape(igroup) ) ) + endif + + ! Particle Schmidt number + schn = rmu(k) / ( rhoa_cgs(k,igas) * diffus1 ) + + ! Prandtl number + prnum = rmu(k)*CP/thcond1 + + ! Ventilation factors and from Pruppacher and Klett + x1 = schn **(ONE/3._f) * sqrt( reyn_shape ) + x2 = prnum**(ONE/3._f) * sqrt( reyn_shape ) + + if( is_grp_ice(igroup) )then + + ! Ice crystals + if( x1 .le. 1._f )then + fv = 1._f + 0.14_f*x1**2 + else + fv = 0.86_f + 0.28_f*x1 + endif + + if( x2 .le. 1._f )then + ft(k,i,igroup) = 1._f + 0.14_f*x2**2 + else + ft(k,i,igroup) = 0.86_f + 0.28_f*x2 + endif + else + + ! Liquid water drops + if( x1 .le. 1.4_f )then + fv = 1._f + 0.108_f*x1**2 + else + fv = 0.78_f + 0.308_f*x1 + endif + + if( x2 .le. 1.4_f )then + ft(k,i,igroup) = 1._f + 0.108_f*x2**2 + else + ft(k,i,igroup) = 0.78_f + 0.308_f*x2 + endif + endif + + ! Growth kernel for particle without radiation or heat conduction at + ! radius lower boundary [g cm^3 / erg / s] + gro(k,i,igroup) = 4._f*PI*br & + * diffus1*fv*gwtmol(igas) & + / ( BK*t(k)*AVG ) + + ! Coefficient for conduction term in growth kernel [s/g] + gro1(k,i,igroup) = gwtmol(igas)*rlh**2 & + / ( RGAS*t(k)**2*ft(k,i,igroup)*thcond1 ) & + / ( 4._f*PI*br ) + + ! Coefficient for radiation term in growth kernel [g/erg] + ! (note: no radial dependence). + if( i .eq. 1 )then + gro2(k,igroup) = 1._f / rlh + endif + + enddo ! i=1,NBIN + enddo ! k=1,NZ + endif ! igas ne 0 + enddo ! igroup=1,NGROUP + + ! Return to caller with time-independent particle growth + ! parameters initialized. + return +end diff --git a/src/physics/carma/base/setupgrow.F90 b/src/physics/carma/base/setupgrow.F90 new file mode 100644 index 0000000000..aea804923f --- /dev/null +++ b/src/physics/carma/base/setupgrow.F90 @@ -0,0 +1,118 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine defines time-independent parameters used to calculate +!! condensational growth/evaporation. +!! +!! The parameters defined for each gas are +!1> +!! gwtmol: molecular weight [g/mol] +!! diffus: diffusivity [cm^2/s] +!! rlhe : latent heat of evaporation [cm^2/s^2] +!! rlhm : latent heat of melting [cm^2/s^2] +!!< +!! Time-independent parameters that depend on particle radius are +!! defined in setupgkern.f. +!! +!! This routine requires that vertical profiles of temperature , +!! and pressure

are defined. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine setupgrow(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variable + integer :: ielem !! element index + integer :: k !! z index + integer :: i + real(kind=f) :: rhoa_cgs, aden + ! Define formats + 1 format(a,': ',12i6) + 2 format(a,': ',i6) + 3 format(/' id gwtmol gasname',(/,i3,3x,f5.1,3x,a)) + 5 format(/,'Particle growth mapping arrays (setupgrow):') + + + !-----Check that values are valid------------------------------------------ + do ielem = 1, NELEM + if( igrowgas(ielem) .gt. NGAS )then + if (do_print) write(LUNOPRT,*) 'setupgrow::ERROR - component of igrowgas > NGAS' + rc = -1 + return + endif + enddo + + ! Define parameters with weak time-dependence to be used in + ! growth equation. + do k = 1, NZ + + ! Diffusivity of water vapor in air from Pruppacher & Klett (eq. 13-3); + ! units are [cm^2/s]. + if (igash2o /= 0) then + diffus(k, igash2o) = 0.211_f * (1.01325e+6_f / p(k)) * (t(k) / 273.15_f )**1.94_f + + ! Latent heat of evaporation for water; units are [cm^2/s^2] + if (do_cnst_rlh) then + rlhe(k, igash2o) = RLHE_CNST + else + ! from Stull + rlhe(k, igash2o) = (2.5_f - .00239_f * (t(k) - 273.16_f)) * 1.e10_f + end if + + ! Latent heat of ice melting; units are [cm^2/s^2] + if (do_cnst_rlh) then + rlhm(k, igash2o) = RLHM_CNST + else + + ! from Pruppacher & Klett (eq. 4-85b) + ! + ! NOTE: This expression yields negative values for rlmh at mesospheric + ! temperatures. + rlhm(k, igash2o) = (79.7_f + 0.485_f * (t(k) - 273.16_f) - 2.5e-3_f * & + ((t(k) - 273.16_f)**2)) * 4.186e7_f + end if + end if + + ! Properties for H2SO4 + if (igash2so4 /= 0) then + ! Diffusivity + rhoa_cgs = rhoa(k) / (xmet(k) * ymet(k) * zmet(k)) + aden = rhoa_cgs * AVG / WTMOL_AIR + diffus(k,igash2so4) = 1.76575e+17_f * sqrt(t(k)) / aden + + ! HACK: make H2SO4 latent heats same as water + rlhe(k,igash2so4) = rlhe(k, igash2o) + rlhm(k,igash2so4) = rlhe(k, igash2o) + end if + + enddo + +#ifdef DEBUG + ! Report some initialization values + if (do_print_init) then + write(LUNOPRT,5) + write(LUNOPRT,2) 'NGAS ',NGAS + write(LUNOPRT,1) 'igrowgas',(igrowgas(i),i=1,NELEM) + write(LUNOPRT,3) (i,gwtmol(i),gasname(i),i=1,NGAS) + endif +#endif + + ! Return to caller with particle growth mapping arrays and time-dependent + ! parameters initialized. + return +end diff --git a/src/physics/carma/base/setupnuc.F90 b/src/physics/carma/base/setupnuc.F90 new file mode 100644 index 0000000000..3862ab8534 --- /dev/null +++ b/src/physics/carma/base/setupnuc.F90 @@ -0,0 +1,97 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates derived mapping arrays and calculates the critical +!! supersaturation used to nucleate dry particles (CN) to droplets. +!! +!! This routine requires that array is defined. +!! (i.e., setupgkern.f must be called before this) +!! +!! NOTE: Most of the code from this routine has been moced to CARMA_InitializeGrowth +!! because it does not rely upon the model's state and thus can be called one during +!! CARMA_Initialize rather than being called every timestep if left in this routine. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine setupnuc(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: igas ! gas index + integer :: isol ! solute index + integer :: ibin ! bin index + integer :: k ! z index + real(kind=f) :: bsol + integer :: i + + ! Define formats + 3 format(a,a) + 6 format(i4,5x,1p2e11.3) + 8 format(/,'Critical supersaturations for ',a,//, ' i r [cm] scrit',/) + + + ! Define critical supersaturation and target bin for each (dry) particle + ! size bin that is subject to nucleation. + ! (only for CN groups subject to nucleation) + do igroup = 1,NGROUP + + igas = inucgas(igroup) + + if( igas .ne. 0 .and. itype( ienconc( igroup ) ) .eq. I_INVOLATILE )then + + isol = isolelem( ienconc( igroup ) ) + + ! If here is no solute are specified, then no scrit value is defined. + if (isol .ne. 0) then + + do ibin = 1,NBIN + + ! This is term "B" in Pruppacher and Klett's eqn. 6-28. + bsol = 3._f*sol_ions(isol)*rmass(ibin,igroup)*gwtmol(igas) & + / ( 4._f*PI*solwtmol(isol)*RHO_W ) + + ! Loop over vertical grid layers because of temperature dependence + ! in solute term. + do k = 1,NZ + scrit(k,ibin,igroup) = sqrt( 4._f * akelvin(k,igas)**3 / ( 27._f * bsol ) ) + enddo + enddo + endif + endif + enddo + +#ifdef DEBUG + if (do_print_init) then + do isol = 1,NSOLUTE + + write(LUNOPRT,3) 'solute name: ',solname(isol) + + do igroup = 1,NGROUP + if( isol .eq. isolelem(ienconc(igroup)) )then + write(LUNOPRT,8) groupname(igroup) + write(LUNOPRT,6) (i,r(i,igroup),scrit(1,i,igroup),i=1,NBIN) + endif + enddo + enddo + endif +#endif + + ! Return to caller with nucleation mapping arrays and critical + ! supersaturations defined. + return +end diff --git a/src/physics/carma/base/setupvdry.F90 b/src/physics/carma/base/setupvdry.F90 new file mode 100644 index 0000000000..2caa8da666 --- /dev/null +++ b/src/physics/carma/base/setupvdry.F90 @@ -0,0 +1,106 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the dry deposition velocity, vd [cm s^-1] +!! Method: Zhang et al., 2001 +!! vd = vf(pver) + 1./ (rs + ra) +!! rs is the surface resistance, which is calculated in here +!! ra is the aerodynamic resistance, which is from parent dynamic model, like CAM +!! use carma_do_drydep flag optionally to decide if the CARMA or the parent model does the dry deposition +!! @author Tianyi Fan +!! @version Nov-2010 +subroutine setupvdry(carma, cstate, lndfv, ocnfv, icefv, lndram, ocnram, iceram, lndfrac, ocnfrac, icefrac, rc) + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + real(kind=f), intent(in) :: lndfv !! the surface friction velocity over land [cm/s] + real(kind=f), intent(in) :: ocnfv !! the surface friction velocity over ocean [cm/s] + real(kind=f), intent(in) :: icefv !! the surface friction velocity over ice [cm/s] + real(kind=f), intent(in) :: lndram !! the aerodynamic resistance over land [s/cm] + real(kind=f), intent(in) :: ocnram !! the aerodynamic resistance over ocean [s/cm] + real(kind=f), intent(in) :: iceram !! the aerodynamic resistance over ice [s/cm] + real(kind=f), intent(in) :: lndfrac !! land fraction + real(kind=f), intent(in) :: ocnfrac !! ocn fraction + real(kind=f), intent(in) :: icefrac !! ice fraction + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: ielem, igroup, ibin, icnst, k + real(kind=f) :: vd_lnd, vd_ocn, vd_ice ! the deposition velocity of land,ocean and sea ice + real(kind=f) :: rs ! surface resistance [s/m] + real(kind=f) :: vfall(NBIN, NGROUP) ! fall velocity [m/s] + integer :: cnsttype ! if constituent is prognostic + integer :: maxbin ! last prognostic bin + integer :: ibot, ibotp1 ! index of bottom layer + + + if (do_drydep) then + + if (igridv .eq. I_CART) then + ibot = 1 + ibotp1 = 1 + vfall(:,:) = vf(ibotp1, :, :) ![cm/s] + else + ibot = NZ + ibotp1 = NZP1 + vfall(:,:) = -vf(ibotp1, :, :) * zmetl(ibotp1) ! [z_unit/s] -> [cm/s] + end if + + do ielem = 1, NELEM + igroup = igelem(ielem) + + if (grp_do_drydep(igroup)) then + do ibin = 1, NBIN + vd_lnd = 0._f + vd_ocn = 0._f + vd_ice = 0._f + + ! land + if (lndfrac > 0._f) then + call calcrs(carma, cstate, lndfv, t(ibot), r_wet(ibot, ibin, igroup), & + bpm(ibot, ibin, igroup), vfall(ibin,igroup), rs, 1, rc) + vd_lnd = vfall(ibin, igroup) + 1._f / (lndram + rs) + end if + + ! ocean + if (ocnfrac > 0._f) then + call calcrs(carma, cstate, ocnfv, t(ibot), r_wet(ibot, ibin, igroup), & + bpm(ibot, ibin, igroup), vfall(ibin,igroup), rs, 2, rc) + vd_ocn = vfall(ibin, igroup) + 1._f / (ocnram + rs) + end if + + ! sea ice + if (icefrac > 0._f) then + call calcrs(carma, cstate, icefv, t(ibot), r_wet(ibot, ibin, igroup), & + bpm(ibot, ibin, igroup), vfall(ibin,igroup), rs, 3, rc) + vd_ice = vfall(ibin, igroup) + 1._f / (iceram + rs) + end if + + vd(ibin, igroup) = (lndfrac * vd_lnd + ocnfrac * vd_ocn + icefrac * vd_ice) ![cm/s] + end do ! ibin + else + vd(:, igroup) = vfall(:, igroup) ! [cm/s] + end if ! if grp_do_drydep + end do ! ielem + + ! change scale for non-catesian vertical coordinate + ! Scale cartesian fallspeeds to the appropriate vertical coordinate system. + ! Non--cartesion coordinates are assumed to be positive downward, but + ! vertical velocities in this model are always assumed to be positive upward. + if( igridv /= I_CART )then + vd(:,:) = -vd(:,:) / zmetl(NZP1) + end if + end if + + return +end diff --git a/src/physics/carma/base/setupvf.F90 b/src/physics/carma/base/setupvf.F90 new file mode 100644 index 0000000000..e6fb9ad198 --- /dev/null +++ b/src/physics/carma/base/setupvf.F90 @@ -0,0 +1,120 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates fall velocities for particles. Since there are +!! several different approaches, this routine dispatches the call to the +!! proper subordinate routine based upon the setup routine defined in the +!! particle group. +!! +!! +!! @author Andy Ackerman +!! @version Mar-2010 +subroutine setupvf(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup, i, j, k, k1, k2, ibin, iz, nzm1 + + ! Define formats + 2 format(/,'Fall velocities and Reynolds number (prior to interpolation)') + 3 format(/,'Particle group ',i3,' using algorithm ',i3,/, & + ' bin lev p [dyne/cm2] T [K] r [cm] wet r [cm] bpm', & + ' vf [cm/s] re'/) + 4 format(i3,4x,i3,7(1pe11.3,4x)) + + ! Loop over all groups. + do igroup = 1, NGROUP + + ! There are different implementations of the fall velocity calculation. Some of + ! these routines may be more appropriate for certain types of partciles. + select case(ifallrtn(igroup)) + + case (I_FALLRTN_STD) + call setupvf_std(carma, cstate, igroup, rc) + + case(I_FALLRTN_STD_SHAPE) + call setupvf_std_shape(carma, cstate, igroup, rc) + + case(I_FALLRTN_HEYMSFIELD2010) + call setupvf_heymsfield2010(carma, cstate, igroup, rc) + + case default + if (do_print) write(LUNOPRT,*) "setupvf:: ERROR - Unknown fall velocity routine (", ifallrtn(igroup), & + ") for group (", igroup, ")." + rc = -1 + return + end select + enddo + + ! Constant value if = 0 + if (ifall .eq. 0) then + vf(:,:,:) = vf_const + end if + + ! Print out fall velocities and reynolds' numbers. +#ifdef DEBUG + if (do_print_init) then + + write(LUNOPRT,2) + + do j = 1, NGROUP + + write(LUNOPRT,3) j, ifallrtn(j) + + do i = 1,NBIN + + do k = NZ, 1, -1 + write(LUNOPRT,4) i,k,p(k),t(k),r(i,j),r_wet(k,i,j),bpm(k,i,j),vf(k,i,j),re(k,i,j) + end do + enddo + enddo + + write(LUNOPRT,*) "" + end if +#endif + + ! Interpolate from layer mid-pts to layer boundaries. + ! is the fall velocity at the lower edge of the layer + nzm1 = max(1, NZ-1) + + ! Set upper boundary before averaging + vf(NZP1,:,:) = vf(NZ,:,:) + + if (NZ .gt. 1) then + vf(NZ,:,:) = sqrt(vf(nzm1,:,:) * vf(NZ,:,:)) + + if (NZ .gt. 2) then + do iz = NZ-1, 2, -1 + vf(iz,:,:) = sqrt(vf(iz-1,:,:) * vf(iz,:,:)) + enddo + endif + endif + + ! Scale cartesian fallspeeds to the appropriate vertical coordinate system. + ! Non--cartesion coordinates are assumed to be positive downward, but + ! vertical velocities in this model are always assumed to be positive upward. + if( igridv .ne. I_CART )then + do igroup=1,NGROUP + do ibin=1,NBIN + vf(:,ibin,igroup) = -vf(:,ibin,igroup) / zmetl(:) + enddo + enddo + endif + + ! Return to caller with fall velocities evaluated. + return +end diff --git a/src/physics/carma/base/setupvf_heymsfield2010.F90 b/src/physics/carma/base/setupvf_heymsfield2010.F90 new file mode 100644 index 0000000000..0dd1aaaf61 --- /dev/null +++ b/src/physics/carma/base/setupvf_heymsfield2010.F90 @@ -0,0 +1,90 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle fall velocities, vf(k) [cm s^-1] +!! and reynolds' numbers based on fall velocities, re(j,i,k) [dimensionless]. +!! indices correspond to vertical level , bin index , and aerosol +!! group . +!! +!! Method: Use the routined from Heymsfield and Westbrook [2010], which is +!! designed only for ice particles. Thus this routine uses the dry mass and +!! radius, not the wet mass and radius. The area ration (Ar) is determined +!! based upon the formulation of Schmitt and Heymsfield [JAS, 2009]. +!! +!! @author Chuck Bardeen +!! @version Mar-2010 +subroutine setupvf_heymsfield2010(carma, cstate, j, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: j !! group index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i, k + real(kind=f) :: rhoa_cgs, vg, rmfp, rkn, expon, x + real(kind=f), parameter :: c0 = 0.35_f + real(kind=f), parameter :: delta0 = 8.0_f + + real(kind=f) :: dmax ! maximum diameter + + + ! Loop over all atltitudes. + do k = 1, NZ + + ! This is in cartesian coordinates (good old cgs units) + rhoa_cgs = rhoa(k) / (xmet(k)*ymet(k)*zmet(k)) + + ! is mean thermal velocity of air molecules [cm/s] + vg = sqrt(8._f / PI * R_AIR * t(k)) + + ! is mean free path of air molecules [cm] + rmfp = 2._f * rmu(k) / (rhoa_cgs * vg) + + ! Loop over particle size bins. + do i = 1,NBIN + + ! is knudsen number +! rkn = rmfp / r(i,j) + rkn = rmfp / (r_wet(k,i,j) * rrat(i,j)) + + ! is the slip correction factor, the correction term for + ! non-continuum effects. Also used to calculate coagulation kernels + ! and diffusion coefficients. + expon = -.87_f / rkn + expon = max(-POWMAX, expon) + bpm(k,i,j) = 1._f + (1.246_f*rkn + 0.42_f*rkn*exp(expon)) + + dmax = 2._f * r_wet(k,i,j) * rrat(i,j) + + x = (rhoa_cgs / (rmu(k)**2)) * & + ((8._f * rmass(i,j) * GRAV) / (PI * (arat(i,j)**0.5_f))) + + ! Apply the slip correction factor. This is not included in the formulation + ! from Heymsfield and Westbrook [2010]. + ! + ! NOTE: This is applied according to eq 8.46 and surrounding discussion in + ! Seinfeld and Pandis [1998]. + x = x * bpm(k,i,j) + + re(k,i,j) = ((delta0**2) / 4._f) * (sqrt(1._f + (4._f * sqrt(x) / (delta0**2 * sqrt(c0)))) - 1._f)**2 + + + vf(k,i,j) = rmu(k) * re(k,i,j) / (rhoa_cgs * dmax) + enddo ! + enddo ! + + ! Return to caller with particle fall velocities evaluated. + return +end diff --git a/src/physics/carma/base/setupvf_std.F90 b/src/physics/carma/base/setupvf_std.F90 new file mode 100644 index 0000000000..8012df7e45 --- /dev/null +++ b/src/physics/carma/base/setupvf_std.F90 @@ -0,0 +1,138 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle fall velocities, vf(k) [cm s^-1] +!! and reynolds' numbers based on fall velocities, re(j,i,k) [dimensionless]. +!! indices correspond to vertical level , bin index , and aerosol +!! group . +!! +!! Method: first use Stokes flow (with Fuchs' size corrections, +!! valid only for Stokes flow) to estimate fall velocity, then calculate +!! Reynolds' number (Re) (for spheres, Stokes drag coefficient is 24/Re). +!! Then for Re > 1, correct drag coefficient (Cd) for turbulent boundary +!! layer through standard trick to solving the drag problem: +!! fit y = log( Re ) as a function of x = log( Cd Re^2 ). +!! We use the data for rigid spheres taken from Figure 10-6 of +!! Pruppacher and Klett (1978): +!! +!! Re Cd +!! ----- ------ +!! 1 24 +!! 10 4.3 +!! 100 1.1 +!! 1000 0.45 +!! +!! Note that we ignore the "drag crisis" at Re > 200,000 +!! (as discussed on p. 341 and shown in Fig 10-36 of P&K 1978), where +!! Cd drops dramatically to 0.2 for smooth, rigid spheres, and instead +!! assume Cd = 0.45 for Re > 1,000 +!! +!! Note that we also ignore hydrodynamic deformation of liquid droplets +!! as well as any breakup due to Rayleigh-Taylor instability. +!! +!! This routine requires that vertical profiles of temperature , +!! air density , and viscosity are defined (i.e., initatm.f +!! must be called before this). The vertical profile with ix = iy = 1 +!! is used. +!! +!! We assume spherical particles -- call setupvf_std_shape() to use legacy +!! code from old Toon model for non-spherical effects -- use (better +!! yet, fix) at own risk. +!! +!! Added support for the particle radius being dependent on the relative +!! humidity according to the parameterizations of Gerber [1995] and +!! Fitzgerald [1975]. The fall velocity is then based upon the wet radius +!! rather than the dry radius. For particles that are not subject to +!! swelling, the wet and dry radii are the same. +!! +!! @author Chuck Bardeen, Pete Colarco from Andy Ackerman +!! @version Mar-2010 from Nov-2000 +subroutine setupvf_std(carma, cstate, j, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: j !! group index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i, k + real(kind=f) :: x, y, cdrag + real(kind=f) :: rhoa_cgs, vg, rmfp, rkn, expon + + ! Define formats + 1 format(/,'Non-spherical particles specified for group ',i3, & + ' (ishape=',i3,') but spheres assumed in I_FALLRTN_STD.', & + ' Suggest using non-spherical code in I_FALLRTN_STD_SHAPE.') + + ! Warning message for non-spherical particles! + if( ishape(j) .ne. 1 )then + if (do_print) write(LUNOPRT,1) j, ishape(j) + endif + + ! Loop over all atltitudes. + do k = 1, NZ + + ! This is in cartesian coordinates (good old cgs units) + rhoa_cgs = rhoa(k) / (xmet(k)*ymet(k)*zmet(k)) + + ! is mean thermal velocity of air molecules [cm/s] + vg = sqrt(8._f / PI * R_AIR * t(k)) + + ! is mean free path of air molecules [cm] + rmfp = 2._f * rmu(k) / (rhoa_cgs * vg) + + ! Loop over particle size bins. + do i = 1,NBIN + + ! is knudsen number + rkn = rmfp / (r_wet(k,i,j) * rrat(i,j)) + + ! is the slip correction factor, the correction term for + ! non-continuum effects. Also used to calculate coagulation kernels + ! and diffusion coefficients. + expon = -.87_f / rkn + expon = max(-POWMAX, expon) + bpm(k,i,j) = 1._f + (1.246_f*rkn + 0.42_f*rkn*exp(expon)) + + ! Stokes fall velocity and Reynolds' number + vf(k,i,j) = (ONE * 2._f / 9._f) * rhop_wet(k,i,j) * r_wet(k,i,j)**2 * GRAV * bpm(k,i,j) / rmu(k) / rprat(i,j) + re(k,i,j) = 2. * rhoa_cgs * r_wet(k,i,j) * rprat(i,j) * vf(k,i,j) / rmu(k) + + if (re(k,i,j) .ge. 1._f) then + + ! Correct drag coefficient for turbulence + x = log(re(k,i,j) / bpm(k,i,j)) + y = x*(0.83_f - 0.013_f*x) + + re(k,i,j) = exp(y) * bpm(k,i,j) + + if (re(k,i,j) .le. 1.e3_f) then + + ! drag coefficient from quadratic fit y(x) when Re < 1,000 + vf(k,i,j) = re(k,i,j) * rmu(k) / (2._f * r_wet(k,i,j) * rprat(i,j) * rhoa_cgs) + else + + ! drag coefficient = 0.45 independent of Reynolds number when Re > 1,000 + cdrag = 0.45_f + vf(k,i,j) = bpm(k,i,j) * & + sqrt( 8._f * rhop_wet(k,i,j) * r_wet(k,i,j) * GRAV / & + (3._f * cdrag * rhoa_cgs * rprat(i,j)**2.) ) + endif + endif + enddo ! + enddo ! + + ! Return to caller with particle fall velocities evaluated. + return +end diff --git a/src/physics/carma/base/setupvf_std_shape.F90 b/src/physics/carma/base/setupvf_std_shape.F90 new file mode 100644 index 0000000000..6b140e6fcc --- /dev/null +++ b/src/physics/carma/base/setupvf_std_shape.F90 @@ -0,0 +1,282 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates particle fall velocities, vf(k) [cm s^-1] +!! and reynolds' numbers based on fall velocities, re(j,i,k) [dimensionless]. +!! indices correspond to vertical level , bin index , and aerosol +!! group . +!! +!! Non-spherical particles are treated through shape factors +!! and . +!! +!! General method is to first use Stokes' flow to estimate fall +!!! velocity, then calculate reynolds' number, then use "y function" +!! (defined in Pruppacher and Klett) to reevaluate reynolds' number, +!! from which the fall velocity is finally obtained. +!! +!! This routine requires that vertical profiles of temperature , +!! air density , and viscosity are defined (i.e., initatm.f +!! must be called before this). +!! +!! @author Chuck Bardeen, Pete Colarco from Andy Ackerman +!! @version Mar-2010 from Oct-1995 + + +subroutine setupvf_std_shape(carma, cstate, j, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: j !! group index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i, k, ilast + real(kind=f) :: x, y + real(kind=f) :: rhoa_cgs, vg, rmfp, rkn, expon + real(kind=f) :: f1, f2, f3, ex, exx, exy, xcc, xa, bxx, r_shape, rfix, b0, bb1, bb2, bb3, z + + ! Define formats + 1 format('setupvfall::ERROR - ishape != 1, no fall velocity algorithm') + + + ! First evaluate factors that depend upon particle shape (used in correction + ! factor below). + if (ishape(j) .eq. I_SPHERE) then + + ! Spheres + f1 = 1.0_f + f2 = 1.0_f + + else if (ishape(j) .eq. I_HEXAGON) then + + ! Hexagons: taken from Turco et al (Planet. Space Sci. Rev. 30, 1147-1181, 1982) + ! with diffuse reflection of air molecules assumed + f2 = (PI / 9._f / tan(PI / 6._f))**(ONE/3._f) * eshape(j)**(ONE/6._f) + + else if (ishape(j) .eq. I_CYLINDER)then + + ! Spheroids: also from Turco et al. [1982] + f2 = (2._f / 3._f)**(ONE/3._f) * eshape(j)**(ONE/6._f) + endif + + ! (following statement yields = 1.0 for = I_SPHERE) + f3 = 1.39_f / sqrt((1.14_f + 0.25_f / eshape(j)) * (0.89_f + eshape(j) / 2._f)) + f2 = f2 * f3 + + if (eshape(j) .gt. 1._f) then + + ! For Stokes regime there is no separate data for hexagonal plates or columns, + ! so we use prolate spheroids. This is from Fuchs' book. + exx = eshape(j)**2 - 1._f + exy = sqrt(exx) + xcc = 1.333_f * exx / ((2._f * eshape(j)**2 - 1._f) * log(eshape(j) + exy) / exy-eshape(j)) + xa = 2.666_f * exx / ((2._f * eshape(j)**2 - 3._f) * log(eshape(j) + exy) / exy+eshape(j)) +! f1 = eshape(j)**(-ONE/3._f) * (xcc + 2._f*xa) / 3._f + f1 = eshape(j)**(-2._f/3._f) * (xcc + 2._f*xa) / 3._f + + elseif (eshape(j) .lt. 1._f) then + + ! Use oblate spheroids for disks (eshape < 1.). Also from Fuchs' book. + bxx = 1._f / eshape(j) + exx = bxx**2 - 1._f + exy = sqrt(exx) + xcc = 1.333_f * exx / (bxx * (bxx**2 - 2._f) * atan(exy) / exy + bxx) + xa = 2.666_f * exx / (bxx * (3._f * bxx**2 - 2._f) * atan(exy) / exy - bxx) + f1 = bxx**(ONE/3._f) * (xcc + 2._f * xa) / 3._f + endif + + + ! Loop over column with ixy = 1 + do k = 1,NZ + + ! This is in cartesian coordinates (good old cgs units) + rhoa_cgs = rhoa(k) / (xmet(k)*ymet(k)*zmet(k)) + + ! is mean thermal velocity of air molecules [cm/s] + vg = sqrt(8._f / PI * R_AIR * t(k)) + + ! is mean free path of air molecules [cm] + rmfp = 2._f * rmu(k) / (rhoa_cgs * vg) + + ! Loop over particle size bins. + do i = 1,NBIN + + ! is radius of particle used to calculate . + if (ishape(j) .eq. I_SPHERE) then + r_shape = r_wet(k,i,j) + else if (ishape(j) .eq. I_HEXAGON) then + r_shape = r_wet(k,i,j) * 0.8456_f * eshape(j)**(-ONE/3._f) + else if(ishape(j) .eq. I_CYLINDER) then +! r_shape = r_wet(k,i,j) * eshape(j)**(-ONE/3._f) + + ! Shouldn't this have a factor related to being a cylinder vs a + ! sphere in addition to the aspect ratio factor? + r_shape = r_wet(k,i,j) * 0.8736_f * eshape(j)**(-ONE/3._f) + endif + + ! is knudsen number + rkn = rmfp / r_wet(k,i,j) + + ! is the slip correction factor, the correction term for + ! non-continuum effects. Also used to calculate coagulation kernels + ! and diffusion coefficients. + expon = -.87_f / rkn + expon = max(-POWMAX, expon) + bpm(k,i,j) = 1._f + f1*f2*(1.246_f*rkn + 0.42_f*rkn*exp(expon)) + + ! These are first guesses for fall velocity and Reynolds' number, + ! valid for Reynolds' number < 0.01 + ! + ! This is "regime 1" in Pruppacher and Klett (chap. 10, pg 416). + vf(k,i,j) = (2._f / 9._f) * rhop_wet(k,i,j) *(r_wet(k,i,j)**2) * GRAV * bpm(k,i,j) / (f1 * rmu(k)) + re(k,i,j) = 2._f * rhoa_cgs * r_shape * vf(k,i,j) / rmu(k) + + + ! is used in drag coefficient. + rfix = vol(i,j) * rhop_wet(k,i,j) * GRAV * rhoa_cgs / rmu(k)**2 + + if ((re(k,i,j) .ge. 0.01_f) .and. (re(k,i,j) .le. 300._f)) then + + ! This is "regime 2" in Pruppacher and Klett (chap. 10, pg 417). + ! + ! NOTE: This sphere case is not the same solution used when + ! interpolating other shape factors. This seems potentially inconsistent. + if (ishape(j) .eq. I_SPHERE) then + + x = log(24._f * re(k,i,j) / bpm(k,i,j)) + y = -0.3318657e1_f + x * 0.992696_f - x**2 * 0.153193e-2_f - & + x**3 * 0.987059e-3_f - x**4 * 0.578878e-3_f + & + x**5 * 0.855176E-04_f - x**6 * 0.327815E-05_f + + if (y .lt. -675._f) y = -675._f + if (y .ge. 741._f) y = 741._f + + re(k,i,j) = exp(y) * bpm(k,i,j) + + else if (eshape(j) .le. 1._f) then + + ! P&K pg. 427 + if (ishape(j) .eq. I_HEXAGON) then + x = log10(16._f * rfix / (3._f * sqrt(3._f))) + else if (ishape(j) .eq. I_CYLINDER) then + x = log10(8._f * rfix / PI) + endif + + if (eshape(j) .le. 0.2_f) then + + ! P&K, page 424-427 + b0 = -1.33_f + bb1 = 1.0217_f + bb2 = -0.049018_f + bb3 = 0.0_f + else if (eshape(j) .le. 0.5_f) then + + ! NOTE: This interpolation/extrapolation method is + ! not discussed in P&K; although, the solution for + ! eshape = 0.5 is shown. Does this really work? + ex = (eshape(j) - 0.2_f) / 0.3_f + b0 = -1.33_f + ex * (-1.3247_f + 1.33_f) + bb1 = 1.0217_f + ex * (1.0396_f - 1.0217_f) + bb2 = -0.049018_f + ex * (-0.047556_f + 0.049018_f) + bb3 = ex * (-0.002327_f) + else + + ! Extrapolating to cylinder cases on 436. + ex = (eshape(j) - 0.5_f) / 0.5_f + b0 = -1.3247_f + ex * (-1.310_f + 1.3247_f) + bb1 = 1.0396_f + ex * (0.98968_f - 1.0396_f) + bb2 = -0.047556_f + ex * (-0.042379_f + 0.047556_f) + bb3 = -0.002327_f + ex * ( 0.002327_f) + endif + + y = b0 + x * bb1 + x**2 * bb2 + x**3 * bb3 + re(k,i,j) = 10._f**y * bpm(k,i,j) + + else if (eshape(j) .gt. 1._f) then + ! Why is this so different from the oblate case? + ! This seems wrong. +! x = log10(2._f * rfix / eshape(j)) + if (ishape(j) .eq. I_CYLINDER) then + x = log10(8._f * rfix / PI) + endif + + ! P&K pg 430 + if( eshape(j) .le. 2._f )then + ex = eshape(j) - 1._f + b0 = -1.310_f + ex * (-1.11812_f + 1.310_f) + bb1 = 0.98968_f + ex * (0.97084_f - 0.98968_f) + bb2 = -0.042379_f + ex * (-0.058810_f + 0.042379_f) + bb3 = ex * (0.002159_f) + else if (eshape(j) .le. 10._f) then + ex = (eshape(j) - 2._f) / 8.0_f + b0 = -1.11812_f + ex * (-0.90629_f + 1.11812_f) + bb1 = 0.97084_f + ex * (0.90412_f - 0.97084_f) + bb2 = -0.058810_f + ex * (-0.059312_f + 0.058810_f) + bb3 = 0.002159_f + ex * (0.0029941_f - 0.002159_f) + else + + ! This is interpolating to a solution for an infinite + ! cylinder, so it may not be the greatest estimate. + ex = 10._f / eshape(j) + b0 = -0.79888_f + ex * (-0.90629_f + 0.79888_f) + bb1 = 0.80817_f + ex * (0.90412_f - 0.80817_f) + bb2 = -0.030528_f + ex * (-0.059312_f + 0.030528_f) + bb3 = ex * (0.0029941_f) + endif + + y = b0 + x * bb1 + x**2 * bb2 + x**3 * bb3 + re(k,i,j) = 10._f**y * bpm(k,i,j) + + endif + + ! Adjust for non-sphericicity. + vf(k,i,j) = re(k,i,j) * rmu(k) / (2._f * r_shape * rhoa_cgs) + + endif + + if (re(k,i,j) .gt. 300._f) then + + ! This is "regime 3" in Pruppacher and Klett (chap. 10, pg 418). + +! if ((do_print) .and. (ishape(j) .ne. I_SPHERE)) write(LUNOPRT,1) +! if ((do_print) .and. (ishape(j) .ne. I_SPHERE)) write(LUNOPRT,*) "setupvfall:", j, i, k, re(k,i,j) +! rc = RC_ERROR +! return + + z = ((1.e6_f * rhoa_cgs**2) / (GRAV * rhop_wet(k,i,j) * rmu(k)**4))**(ONE/6._f) + b0 = (24._f * vf(k,i,j) * rmu(k)) / 100._f + x = log(z * b0) + y = -5.00015_f + x * (5.23778_f - x * (2.04914_f - x * (0.475294_f - & + x * (0.0542819_f - x * 0.00238449_f)))) + + if (y .lt. -675._f) y = -675.0_f + if (y .ge. 741._f) y = 741.0_f + + re(k,i,j) = z * exp(y) * bpm(k,i,j) + vf(k,i,j) = re(k,i,j) * rmu(k) / ( 2._f * r_wet(k,i,j) * rhoa_cgs) + + ! Values should not decrease with diameter, but instead should + ! reach a limiting velocity that is independent of size (see + ! Figure 10-25 of Pruppacher and Klett, 1997) + ilast = max(1,i-1) + if ((vf(k,i,j) .lt. vf(k,ilast,j)) .or. (re(k,i,j) .gt. 4000._f)) then + vf(k,i,j) = vf(k,ilast,j) + endif + endif + enddo ! + enddo ! + + ! Return to caller with particle fall velocities evaluated. + return +end diff --git a/src/physics/carma/base/smallconc.F90 b/src/physics/carma/base/smallconc.F90 new file mode 100644 index 0000000000..2856e383a3 --- /dev/null +++ b/src/physics/carma/base/smallconc.F90 @@ -0,0 +1,63 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine ensures limits all particle concentrations in a grid box +!! to SMALL_PC. In bins where this limitation results in the particle +!! concentration changing, the core mass fraction and second moment fraction +!! are set to . +!! +!! @author Andy Ackerman +!! @version Oct-1997 +subroutine smallconc(carma, cstate, iz, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Locals + integer :: ig + integer :: ip + real(kind=f) :: small_val + + + ig = igelem(ielem) + ip = ienconc(ig) + + + ! Element is particle concentration + if (ielem == ip) then + pc(iz,ibin,ielem) = max(pc(iz,ibin,ielem), SMALL_PC) + else + + ! Element is core mass + if ((itype(ielem) .eq. I_COREMASS) .or. (itype(ielem) .eq. I_VOLCORE)) then + small_val = SMALL_PC * rmass(ibin,ig) * FIX_COREF + + ! Element is core second moment + elseif (itype(ielem) .eq. I_CORE2MOM) then + small_val = SMALL_PC * (rmass(ibin,ig) * FIX_COREF)**2 + end if + + ! Reset if either the particle concentration or the element mass are too small. + if ((pc(iz,ibin,ip) <= SMALL_PC) .or. (pc(iz,ibin,ielem) < small_val)) then + pc(iz,ibin,ielem) = small_val + endif + endif + + ! Return to caller with particle concentrations limited to SMALL_PC + return +end diff --git a/src/physics/carma/base/step.F90 b/src/physics/carma/base/step.F90 new file mode 100644 index 0000000000..346d8cf9c9 --- /dev/null +++ b/src/physics/carma/base/step.F90 @@ -0,0 +1,37 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine performs all calculations necessary to take one timestep. +!! +!! @author McKie +!! @version Oct-1995 +subroutine step(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + + ! Iterate over each column. Each of these columns should be independent, so + ! the work for each column could be done by a different thread. + + ! Do pre-timestep processing + if (rc >= 0) call prestep(carma, cstate, rc) + + ! Update model state at new time + if (rc >= 0) call newstate(carma, cstate, rc) + + ! Return to caller with one timestep taken + return +end diff --git a/src/physics/carma/base/sulfate_utils.F90 b/src/physics/carma/base/sulfate_utils.F90 new file mode 100644 index 0000000000..9395afd8db --- /dev/null +++ b/src/physics/carma/base/sulfate_utils.F90 @@ -0,0 +1,283 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +module sulfate_utils + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + ! Declare the public methods. + public wtpct_tabaz + public sulfate_density + public sulfate_surf_tens + + real(kind=f), public:: dnwtp(46), dnc0(46), dnc1(46) + + data dnwtp / 0._f, 1._f, 5._f, 10._f, 20._f, 25._f, 30._f, 35._f, 40._f, & + 41._f, 45._f, 50._f, 53._f, 55._f, 56._f, 60._f, 65._f, 66._f, 70._f, & + 72._f, 73._f, 74._f, 75._f, 76._f, 78._f, 79._f, 80._f, 81._f, 82._f, & + 83._f, 84._f, 85._f, 86._f, 87._f, 88._f, 89._f, 90._f, 91._f, 92._f, & + 93._f, 94._f, 95._f, 96._f, 97._f, 98._f, 100._f / + + data dnc0 / 1._f, 1.13185_f, 1.17171_f, 1.22164_f, 1.3219_f, 1.37209_f, & + 1.42185_f, 1.4705_f, 1.51767_f, 1.52731_f, 1.56584_f, 1.61834_f, 1.65191_f, & + 1.6752_f, 1.68708_f, 1.7356_f, 1.7997_f, 1.81271_f, 1.86696_f, 1.89491_f, & + 1.9092_f, 1.92395_f, 1.93904_f, 1.95438_f, 1.98574_f, 2.00151_f, 2.01703_f, & + 2.03234_f, 2.04716_f, 2.06082_f, 2.07363_f, 2.08461_f, 2.09386_f, 2.10143_f,& + 2.10764_f, 2.11283_f, 2.11671_f, 2.11938_f, 2.12125_f, 2.1219_f, 2.12723_f, & + 2.12654_f, 2.12621_f, 2.12561_f, 2.12494_f, 2.12093_f / + + data dnc1 / 0._f, -0.000435022_f, -0.000479481_f, -0.000531558_f, -0.000622448_f,& + -0.000660866_f, -0.000693492_f, -0.000718251_f, -0.000732869_f, -0.000735755_f, & + -0.000744294_f, -0.000761493_f, -0.000774238_f, -0.00078392_f, -0.000788939_f, & + -0.00080946_f, -0.000839848_f, -0.000845825_f, -0.000874337_f, -0.000890074_f, & + -0.00089873_f, -0.000908778_f, -0.000920012_f, -0.000932184_f, -0.000959514_f, & + -0.000974043_f, -0.000988264_f, -0.00100258_f, -0.00101634_f, -0.00102762_f, & + -0.00103757_f, -0.00104337_f, -0.00104563_f, -0.00104458_f, -0.00104144_f, & + -0.00103719_f, -0.00103089_f, -0.00102262_f, -0.00101355_f, -0.00100249_f, & + -0.00100934_f, -0.000998299_f, -0.000990961_f, -0.000985845_f, -0.000984529_f, & + -0.000989315_f / +contains + + !! This function calculates the weight % H2SO4 composition of + !! sulfate aerosol, using Tabazadeh et. al. (GRL, 1931, 1997). + !! Rated for T=185-260K, activity=0.01-1.0 + !! + !! Argument list input: + !! temp = temperature (K) + !! h2o_mass = water vapor mass concentration (g/cm3) + !! h2o_vp = water eq. vaper pressure (dynes/cm2) + !! + !! Output: + !! wtpct_tabaz = weight % H2SO4 in H2O/H2SO4 particle (0-100) + !! + !! Include global constants and variables (BK=Boltzman constant, + !! AVG=Avogadro's constant) + !! + !! @author Jason English + !! @ version Apr-2010 + function wtpct_tabaz(carma, temp, h2o_mass, h2o_vp, rc) + + real(kind=f) :: wtpct_tabaz + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: temp !! temperature [K] + real(kind=f), intent(in) :: h2o_mass !! water vapor mass concentration (g/cm3) + real(kind=f), intent(in) :: h2o_vp !! water eq. vaper pressure (dynes/cm2) + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Declare variables for this routine only + real(kind=f) :: atab1,btab1,ctab1,dtab1,atab2,btab2,ctab2,dtab2 + real(kind=f) :: h2o_num, p_h2o, vp_h2o + real(kind=f) :: contl, conth, contt, conwtp + real(kind=f) :: activ + + ! Get number density of water (/cm3) from mass concentration (g/cm3) + h2o_num=h2o_mass*AVG/gwtmol(1) + + ! Get partial pressure of water (dynes/cm2) from concentration (/cm3) + ! Ideal gas law: P=nkT + p_h2o=h2o_num*bk*temp + + ! Convert from dynes/cm2 to mb (hPa) + p_h2o=p_h2o/1000.0_f ! partial pressure + vp_h2o=h2o_vp/1000.0_f ! eq. vp + + ! Activity = water pp in mb / water eq. vp over pure water in mb + activ = p_h2o/vp_h2o + + if (activ.lt.0.05_f) then + activ = max(activ,1.e-32_f) ! restrict minimum activity + atab1 = 12.37208932_f + btab1 = -0.16125516114_f + ctab1 = -30.490657554_f + dtab1 = -2.1133114241_f + atab2 = 13.455394705_f + btab2 = -0.1921312255_f + ctab2 = -34.285174607_f + dtab2 = -1.7620073078_f + elseif (activ.ge.0.05_f.and.activ.le.0.85_f) then + atab1 = 11.820654354_f + btab1 = -0.20786404244_f + ctab1 = -4.807306373_f + dtab1 = -5.1727540348_f + atab2 = 12.891938068_f + btab2 = -0.23233847708_f + ctab2 = -6.4261237757_f + dtab2 = -4.9005471319_f + elseif (activ.gt.0.85_f) then + activ = min(activ,1._f) ! restrict maximum activity + atab1 = -180.06541028_f + btab1 = -0.38601102592_f + ctab1 = -93.317846778_f + dtab1 = 273.88132245_f + atab2 = -176.95814097_f + btab2 = -0.36257048154_f + ctab2 = -90.469744201_f + dtab2 = 267.45509988_f + else + if (do_print) write(LUNOPRT,*) 'invalid activity: activity,pp,vp=',activ, p_h2o + rc = RC_ERROR + return + endif + + contl = atab1*(activ**btab1)+ctab1*activ+dtab1 + conth = atab2*(activ**btab2)+ctab2*activ+dtab2 + + contt = contl + (conth-contl) * ((temp -190._f)/70._f) + conwtp = (contt*98._f) + 1000._f + + wtpct_tabaz = (100._f*contt*98._f)/conwtp + wtpct_tabaz = min(max(wtpct_tabaz,1._f),100._f) ! restrict between 1 and 100 % + + return + end function wtpct_tabaz + + !! Calculates specific gravity (g/cm3) of sulfate of + !! different compositions as a linear function of temperature, + !! based of measurements of H2SO4/H2O solution densities made + !! at 0 to 100C tabulated in the International Critical Tables + !! (Washburn, ed., NRC, 1928). Measurements have confirmed that + !! this data may be linearly extrapolated to stratospheric + !! temperatures (180-380K) with excellent accuracy + !! (Beyer, Ravishankara, & Lovejoy, JGR, 1996). + !! + !! Argument list input: + !! wtp = aerosol composition in weight % H2SO4 (0-100) + !! temp = temperature in Kelvin + !! + !! Output: + !! sulfate_density (g/cm3) [function name] + !! + !! This function requires setup_sulfate_density to be run + !! first to read in the density coefficients DNC0 and DNC1 + !! and the tabulated weight percents DNWTP. + !! + !! @author Mike Mills + !! @version Mar-2013 + function sulfate_density(carma, wtp, temp, rc) + + !! Include global constants and variables + + real(kind=f) :: sulfate_density + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: wtp !! weight percent + real(kind=f), intent(in) :: temp !! temperature + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i + real(kind=f) :: den1, den2 + real(kind=f) :: frac, temp_loc + + if (wtp .lt. 0.0_f .or. wtp .gt. 100.0_f) then + if (do_print) write(LUNOPRT,*)'sulfate_density: Illegal value for wtp:',wtp + rc = RC_ERROR + return + endif + + ! limit temperature to bounds of extrapolation + temp_loc=min(temp, 380.0_f) + temp_loc=max(temp_loc, 180.0_f) + + i=1 + + do while (wtp .gt. dnwtp(i)) + i=i+1 + end do + + den2=dnc0(i)+dnc1(i)*temp_loc + + if (i.eq.1 .or. wtp.eq.dnwtp(i)) then + sulfate_density=den2 + return + endif + + den1=dnc0(i-1)+dnc1(i-1)*temp_loc + frac=(dnwtp(i)-wtp)/(dnwtp(i)-dnwtp(i-1)) + sulfate_density=den1*frac+den2*(1.0_f-frac) + + return + end function sulfate_density + + !! Calculates surface tension (erg/cm2 = dyne/cm) of sulfate of + !! different compositions as a linear function of temperature, + !! as described in Mills (Ph.D. Thesis, 1996), derived from + !! the measurements of Sabinina and Terpugow (1935). + !! + !! Argument list input: + !! WTP = aerosol composition in weight % H2SO4 (0-100) + !! TEMP = temperature in Kelvin + !! + !! Output: + !! sulfate_surf_tens (erg/cm2) [function name] + !! + !! This function requires setup_sulfate_density to be run + !! first to read in the density coefficients DNC0 and DNC1 + !! and the tabulated weight percents DNWTP. + !! + !! @author Mike Mills + !! @version Mar-2013 + function sulfate_surf_tens(carma, wtp, temp, rc) + + real(kind=f) :: sulfate_surf_tens + type(carma_type), intent(in) :: carma !! the carma object + real(kind=f), intent(in) :: wtp !! weight percent + real(kind=f), intent(in) :: temp !! temperature + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i + real(kind=f) :: sig1, sig2 + real(kind=f) :: frac, temp_loc + real(kind=f) :: stwtp(15), stc0(15), stc1(15) + + data stwtp/0._f, 23.8141_f, 38.0279_f, 40.6856_f, 45.335_f, 52.9305_f, 56.2735_f, & + & 59.8557_f, 66.2364_f, 73.103_f, 79.432_f, 85.9195_f, 91.7444_f, 97.6687_f, 100._f/ + + data stc0/117.564_f, 103.303_f, 101.796_f, 100.42_f, 98.4993_f, 91.8866_f, & + & 88.3033_f, 86.5546_f, 84.471_f, 81.2939_f, 79.3556_f, 75.608_f, 70.0777_f, & + & 63.7412_f, 61.4591_f / + + data stc1/-0.153641_f, -0.0982007_f, -0.0872379_f, -0.0818509_f, & + & -0.0746702_f, -0.0522399_f, -0.0407773_f, -0.0357946_f, -0.0317062_f, & + & -0.025825_f, -0.0267212_f, -0.0269204_f, -0.0276187_f, -0.0302094_f, & + & -0.0303081_f / + + ! limit temperature to reasonable bounds of extrapolation + temp_loc=min(temp, 380.0_f) + temp_loc=max(temp_loc, 180.0_f) + + if (wtp .lt. 0.0_f .OR. wtp .gt. 100.0_f) then + if (do_print) write(LUNOPRT,*)'sulfate_surf_tens: Illegal value for wtp:',wtp + if (do_print) write(LUNOPRT,*)'sulfate_surf_tens: temp=',temp + rc = RC_ERROR + return + endif + + i=1 + + do while (wtp.gt.stwtp(i)) + i=i+1 + end do + + sig2=stc0(i)+stc1(i)*temp_loc + + if (i.eq.1 .or. wtp.eq.stwtp(i)) then + sulfate_surf_tens=sig2 + return + end if + + sig1=stc0(i-1)+stc1(i-1)*temp_loc + frac=(stwtp(i)-wtp)/(stwtp(i)-stwtp(i-1)) + sulfate_surf_tens=sig1*frac+sig2*(1.0_f-frac) + + return + end function sulfate_surf_tens + +end module sulfate_utils diff --git a/src/physics/carma/base/sulfhetnucrate.F90 b/src/physics/carma/base/sulfhetnucrate.F90 new file mode 100644 index 0000000000..6d01bf0ab6 --- /dev/null +++ b/src/physics/carma/base/sulfhetnucrate.F90 @@ -0,0 +1,98 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates particle production rates due to heterogeneous +!! nucleation : +!! +!! This was moved from sulfnuc to make the code more manageable. +!! +!! @author Mike Mills, Chuck Bardeen +!! @version Jun-2013 +subroutine sulfhetnucrate(carma, cstate, iz, igroup, nucbin, h2o, h2so4, beta1, beta2, ftry, rstar, nucrate, rc) + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! level index + integer, intent(in) :: igroup !! group index + integer, intent(in) :: nucbin !! bin in which nucleation occurs + real(kind=f), intent(in) :: h2o !! H2O concentrations in molec/cm3 + real(kind=f), intent(in) :: h2so4 !! H2SO4 concentrations in molec/cm3 + real(kind=f), intent(in) :: beta1 + real(kind=f), intent(in) :: beta2 + real(kind=f), intent(in) :: ftry + real(kind=f), intent(in) :: rstar !! critical radius (cm) + real(kind=f), intent(out) :: nucrate !! nucleation rate #/x/y/z/s + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: cnucl + real(kind=f) :: chom + real(kind=f) :: expc + real(kind=f) :: chet + real(kind=f) :: xm + real(kind=f) :: xm1 + real(kind=f) :: fxm + real(kind=f) :: fv2 + real(kind=f) :: fu2 + real(kind=f) :: fv3 + real(kind=f) :: fv4 + real(kind=f) :: v1 + real(kind=f) :: fv1 + real(kind=f) :: ftry1 + real(kind=f) :: rarea + real(kind=f) :: gg + real(kind=f) :: FM = cos(50._f * DEG2RAD) ! cos(contact angle) + + ! Heterogeneous nucleation which depends on r + cnucl = 4._f * PI * rstar**(2._f) + chom = h2so4 * h2o * beta1 * cnucl + expc = 2.4e-16_f * exp(4.51872e+11_f / RGAS / t(iz)) + chet = chom * expc * beta2 + + xm = r(nucbin, igroup) / rstar + + if (xm .lt. 1._f) then + fxm = sqrt(1._f - 2._f * FM * xm + xm**(2._f)) + fv2 = (xm - FM) / fxm + fu2 = (1._f - xm * FM) / fxm + fv3 = (2._f + fv2) * xm**3._f * (fv2 - 1._f)**(2._f) + fv4 = 3._f * FM * xm**2._f * (fv2 - 1._f) + else + xm1 = 1._f / xm + fxm = sqrt(1._f - 2._f * FM * xm1 + xm1**2._f) + fu2 = (xm1 - FM) / fxm + fv2 = (1._f - xm1 * FM) / fxm + v1 = (FM**(2._f) - 1._f) / (fv2 + 1._f) / fxm**(2._f) + fv3 = (2._f + fv2) * xm1 * v1**2._f + fv4 = 3._f * FM * v1 + endif + + fv1 = 0.5_f * (1._f + fu2**3._f + fv3 + fv4) + + ftry1 = ftry * fv1 +! ftry1 = ftry * fh + if (ftry1 .lt. -1000._f) then + nucrate = 0._f + else + + rarea = 4._f * PI * r(nucbin, igroup)**2._f ! surface area per nucleus + gg = exp(ftry1) + + ! Calculate heterogeneous nucleation rate [embryos/s] + ! NOTE: for [embryos/gridpoint/s], multipy rnuclg by pc [nuclei/gridpoint] + nucrate = chet * gg * rarea ! embryos/s + end if + + return +end subroutine sulfhetnucrate + diff --git a/src/physics/carma/base/sulfnuc.F90 b/src/physics/carma/base/sulfnuc.F90 new file mode 100644 index 0000000000..7f271eeac7 --- /dev/null +++ b/src/physics/carma/base/sulfnuc.F90 @@ -0,0 +1,131 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates particle production rates due to nucleation : +!! binary homogeneous nucleation of sulfuric acid and water only +!! Numerical method follows Zhao & Turco, JAS, V.26, No.5, 1995. +!! +!! @author Mike Mills, Chuck Bardeen +!! @version Jun-2013 +subroutine sulfnuc(carma,cstate, iz, rc) + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! level index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: ibin ! bin index + integer :: igas ! gas index + integer :: iepart ! concentration element index + integer :: nucbin ! bin in which nucleation takes place + integer :: ignucto ! index of target nucleation group + integer :: ienucto ! index of target nucleation element + integer :: inuc + real(kind=f) :: nucrate ! nucleation rate (#/x/y/z/s) + real(kind=f) :: h2o ! H2O concentrations in molec/cm3 + real(kind=f) :: h2so4 ! H2SO4 concentrations in molec/cm3 + real(kind=f) :: beta1 + real(kind=f) :: beta2 + real(kind=f) :: ftry + real(kind=f) :: rstar ! critical radius (cm) + + ! Cycle through each group, only proceed if BHN + rstar = -1._f + + do igroup = 1 , NGROUP + + igas = inucgas(igroup) ! condensing gas + + if (igas .ne. 0) then + + iepart = ienconc(igroup) ! particle number density element + + if (inucproc(iepart,iepart) .eq. I_HOMNUC) then + + ! This is where all of the pre calculation needs to go, so that it isn't + ! done when the model is not configured for homogeneous nucleation of + ! sulfates. + call sulfnucrate(carma, cstate, iz, igroup, h2so4, h2o, beta1, beta2, ftry, rstar, nucbin, nucrate, rc) + if (rc /= RC_OK) return + + ! Do further calculations only if nucleation occurred + if (nucrate .gt. 0._f) then + + rhompe(nucbin, iepart) = rhompe(nucbin, iepart) + nucrate + + ! Since homogeneous nucleation doesn't go through upgxfer or downgxfer, then + ! then the effects of latent heat need to be accounted for here. + ! rlprod = rlprod + rhompe(nucbin, ielem) * rmass(nucbin,igroup) * rlh_nuc(ielem,ielem) / (CP * rhoa(iz)) + end if + end if + end if + end do + + ! Cycle through each group, only proceed if heterogeneous nucleation + ! + ! NOTE: Only do heterogeneous nucleation if an rstar was determined by homogeneous + ! nucleation. + if (rstar > 0._f) then + do igroup = 1 , NGROUP + + igas = inucgas(igroup) ! condensing gas + + if (igas .ne. 0) then + + iepart = ienconc(igroup) ! particle number density element + + ! Calculate heterogeneous nucleation loss rates. Do not allow nucleation into + ! an evaporating bin. + ! + ! NOTE: Heterogeneous nucleation assumes that homogeneous nucleation was called + ! first to determine the critical cluster size. + ! + ! is index of target nucleation element; + ! is index of target nucleation group. + do inuc = 1, nnuc2elem(iepart) + + ienucto = inuc2elem(inuc,iepart) + + if (ienucto .ne. 0) then + ignucto = igelem(ienucto) + else + ignucto = 0 + endif + + if (inucproc(iepart,ienucto) .eq. I_HETNUCSULF) then + + do ibin = NBIN, 1, -1 + + ! Bypass calculation if few particles are present + if (pconmax(iz,igroup) .gt. FEW_PC) then + + ! This is where all of the pre calculation needs to go, so that it isn't + ! done when the model is not configured for homogeneous nucleation of + ! sulfates. + call sulfhetnucrate(carma, cstate, iz, igroup, ibin, h2so4, h2o, beta1, beta2, ftry, rstar, nucrate, rc) + if (rc /= RC_OK) return + + rnuclg(ibin, igroup, ignucto) = rnuclg(ibin, igroup, ignucto) + nucrate + end if + end do + end if + end do + end if + + end do + end if + + return +end diff --git a/src/physics/carma/base/sulfnucrate.F90 b/src/physics/carma/base/sulfnucrate.F90 new file mode 100644 index 0000000000..1efea9adcd --- /dev/null +++ b/src/physics/carma/base/sulfnucrate.F90 @@ -0,0 +1,318 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates particle production rates due to nucleation : +!! binary homogeneous nucleation of sulfuric acid and water only +!! Numerical method follows Zhao & Turco, JAS, V.26, No.5, 1995. +!! +!! This was moved from sulfnuc to make the code more manageable. +!! +!! @author Mike Mills, Chuck Bardeen +!! @version Jun-2013 +subroutine sulfnucrate(carma,cstate, iz, igroup, h2o, h2so4, beta1, beta2, ftry, rstar, nucbin, nucrate, rc) + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! level index + integer, intent(in) :: igroup !! group index + real(kind=f), intent(out) :: h2o !! H2O concentrations in molec/cm3 + real(kind=f), intent(out) :: h2so4 !! H2SO4 concentrations in molec/cm3 + real(kind=f), intent(out) :: beta1 + real(kind=f), intent(out) :: beta2 + real(kind=f), intent(out) :: ftry + real(kind=f), intent(out) :: rstar !! critical radius (cm) + integer, intent(out) :: nucbin !! bin in which nucleation occurs + real(kind=f), intent(out) :: nucrate !! nucleation rate #/x/y/z/s + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: i, ibin, ie + real(kind=f) :: dens(46) + real(kind=f) :: pa(46) + real(kind=f) :: pb(46) + real(kind=f) :: c1(46) + real(kind=f) :: c2(46) + real(kind=f) :: fct(46) + real(kind=f) :: wtmolr ! molecular weight ration of H2SO4/H2O + real(kind=f) :: h2o_cgs ! H2O densities in g/cm3 + real(kind=f) :: h2so4_cgs ! H2SO4 densities in g/cm3 + real(kind=f) :: h2oln ! H2O ambient vapor pressures [dynes/cm2] + real(kind=f) :: h2so4ln ! H2SO4 ambient vapor pressures [dynes/cm2] + real(kind=f) :: rh ! relative humidity of water wrt liquid water + real(kind=f) :: SA ! total surface area of pre-existing wet particles + real(kind=f) :: SAbin ! bin surface area of pre-existing wet particles + real(kind=f) :: cw + real(kind=f) :: dw + real(kind=f) :: wvp ! water eq.vp over solution + real(kind=f) :: wvpln + real(kind=f) :: t0_kulm + real(kind=f) :: seqln + real(kind=f) :: t_crit_kulm + real(kind=f) :: factor_kulm + real(kind=f) :: dw1, dw2 + real(kind=f) :: dens1 + real(kind=f) :: dens11 + real(kind=f) :: dens12 + real(kind=f) :: xfrac + real(kind=f) :: wstar + real(kind=f) :: dstar + real(kind=f) :: rhln + real(kind=f) :: raln + real(kind=f) :: wfstar + real(kind=f) :: sigma + real(kind=f) :: ystar + real(kind=f) :: r2 + real(kind=f) :: gstar + real(kind=f) :: rb + real(kind=f) :: rpr + real(kind=f) :: rpre + real(kind=f) :: fracmol + real(kind=f) :: zphi + real(kind=f) :: zeld + real(kind=f) :: cfac + real(kind=f) :: ahom + real(kind=f) :: exhom + real(kind=f) :: rmstar + real(kind=f) :: frac_h2so4 + real(kind=f) :: rhomlim + real(kind=f) :: dnpot(46), dnwf(46) + real(kind=f) :: rho_H2SO4_wet + + 5 format(/,'microfast::WARNING - nucleation rate exceeds 5.e1: ie=', i2,', iz=',i4,',lat=', & + f7.2,',lon=',f7.2, ', rhompe=', e10.3) + + rstar = -1._f + + ! Parameterized fit developed by Mike Mills in 1994 to the partial molal + ! Gibbs energies (F2|o-F2) vs. weight percent H2SO4 table in Giauque et al., + ! J. Am. Chem. Soc, 82, 62-70, 1960. The parameterization gives excellent + ! agreement. Ayers (GRL, 7, 433-436, 1980) refers to F2|o-F2 as mu - mu_0 + ! (chemical potential). This parameterization may be replaced by a lookup + ! table, as was done ultimately in the Garcia-Solomon sulfate code. + do i = 1, 46 + dnpot(i) = 4.184_f * (23624.8_f - 1.14208e8_f / ((dnwtp(i) - 105.318_f)**2 + 4798.69_f)) + dnwf(i) = dnwtp(i) / 100._f + end do + + ! Molecular weight ratio of H2SO4 / H2O: + wtmolr = gwtmol(igash2so4) / gwtmol(igash2o) + + ! Compute H2O and H2SO4 densities in g/cm3 + h2o_cgs = gc(iz, igash2o) / (zmet(iz) * xmet(iz) * ymet(iz)) + h2so4_cgs = gc(iz, igash2so4) / (zmet(iz) * xmet(iz) * ymet(iz)) + + ! Compute H2O and H2SO4 concentrations in molec/cm3 + h2o = h2o_cgs * AVG / gwtmol(igash2o) + h2so4 = h2so4_cgs * AVG / gwtmol(igash2so4) + + ! Compute relative humidity of water wrt liquid water + rh = (supsatl(iz, igash2o) + 1._f) * 100._f + + ! Compute ln of H2O and H2SO4 ambient vapor pressures [dynes/cm2] + h2oln = log(h2o_cgs * (RGAS / gwtmol(igash2o)) * t(iz)) + h2so4ln = log(h2so4_cgs * (RGAS / gwtmol(igash2so4)) * t(iz)) + + ! loop through wt pcts and calculate vp/composition for each + do i = 1, 46 + dens(i) = dnc0(i) + dnc1(i) * t(iz) + + ! Calc. water eq.vp over solution using (Lin & Tabazadeh eqn 5, JGR, 2001) + cw = 22.7490_f + 0.0424817_f * dnwtp(i) - 0.0567432_f * dnwtp(i)**0.5_f - 0.000621533_f * dnwtp(i)**2 + dw = -5850.24_f + 21.9744_f * dnwtp(i) - 44.5210_f * dnwtp(i)**0.5_f - 0.384362_f * dnwtp(i)**2 + + ! pH20 | eq[mb] + wvp = exp(cw + dw / t(iz)) + + ! Ln(pH2O | eq [dynes/cm2]) + wvpln = log(wvp * 1013250._f / 1013.25_f) + + ! Save the water eq.vp over solution at each wt pct into this array: + ! + ! Ln(pH2O/pH2O|eq) with both terms in dynes/cm2 + pb(i) = h2oln - wvpln + + ! Calc. sulfuric acid eq.vp over solution using (Ayers et. al., GRL, V.7, No.6, June 1980) + ! + ! T0 set in the low end of the Ayers measurement range (338-445K) + t0_kulm = 340._f + seqln = -10156._f / t0_kulm + 16.259_f + + ! Now calc. Kulmala correction (J. CHEM. PHYS. V.93, No.1, 1 July 1990) + ! + ! Critical temperature = 1.5 * Boiling point + t_crit_kulm = 905._f + factor_kulm = -1._f / t(iz) + 1._f / t0_kulm + 0.38_f / (t_crit_kulm - t0_kulm) * & + (1.0_f + log(t0_kulm / t(iz)) - t0_kulm / t(iz)) + + ! For pure sulfuric acid + seqln = seqln + 10156._f * factor_kulm + + ! Now adjust vp based on weight % composition using parameterization of Giauque 1960 + ! + ! Adjust for WTPCT composition + seqln = seqln - dnpot(i) / (8.3143_f * t(iz)) + + ! Convert atmospheres => dynes/cm2 + seqln = seqln + log(1013250._f) + + ! Save the sulfuric acid eq.vp over solution at each wt pct into this array: + ! + ! Ln(pH2SO4/pH2SO4|eq) with both terms in dynes/cm2 + pa(i) = h2so4ln - seqln + + ! Create 2-component solutions of varying composition c1 and c2 + c1(i) = pa(i) - pb(i) * wtmolr + c2(i) = pa(i) * dnwf(i) + pb(i) * (1._f - dnwf(i)) * wtmolr + end do ! end of loop through wtpcts + + ! Now loop through until we find the c1+c2 combination with minimum Gibbs free energy + dw2 = dnwtp(46) - dnwtp(45) + dens1 = (dens(46) - dens(45)) / dw2 + fct(46) = c1(46) + c2(46) * 100._f * dens1 / dens(46) + dens12 = dens1 + + do i = 45, 2, -1 + dw1 = dw2 + dens11 = dens12 + dw2 = dnwtp(i) - dnwtp(i-1) + dens12 = (dens(i) - dens(i-1)) / dw2 + dens1 = (dens11 * dw2 + dens12 * dw1) / (dw1 + dw2) + + fct(i) = c1(i) + c2(i) * 100._f * dens1 / dens(i) + + ! Find saddle where fct(i)<0 0._f) then + nucbin = 0 + nucrate = 0.0_f + + return + + ! Possibility 2: loop crossed the saddle; interpolate to find exact value: + else if (fct(i) * fct(i+1) < 0._f) then + xfrac = fct(i+1) / (fct(i+1) - fct(i)) + wstar = dnwtp(i+1) * (1.0_f - xfrac) + dnwtp(i) * xfrac ! critical wtpct + dstar = dens(i+1) * (1.0_f - xfrac) + dens(i) * xfrac + rhln = pb(i+1) * (1.0_f - xfrac) + pb(i) * xfrac + raln = pa(i+1) * (1.0_f - xfrac) + pa(i) * xfrac + + ! Possibility 3: loop found the saddle point exactly + else + dstar = dens(i) + + ! critical wtpct + wstar = dnwtp(i) + rhln = pb(i) + raln = pa(i) + end if + + ! Critical weight fraction + wfstar = wstar / 100._f + + if ((wfstar < 0._f) .or. (wfstar > 1._f)) then + write(LUNOPRT,*)'sulfnuc: wstar out of bounds!' + rc = RC_ERROR + return + end if + + ! Critical surface tension [erg/cm2] + sigma = sulfate_surf_tens(carma, wstar, t(iz), rc) + + ! Critical Y (eqn 13 in Zhao & Turco 1993) [erg/cm3] + ystar = dstar * RGAS * t(iz) * (wfstar / gwtmol(igash2so4) & + * raln + (1._f - wfstar) / gwtmol(igash2o) * rhln) + if (ystar < 1.e-20_f) then + nucbin = 0 + nucrate = 0.0_f + + return + end if + + ! Critical cluster radius [cm] + rstar = 2._f * sigma / ystar + rstar = max(rstar, 0.0_f) + r2 = rstar * rstar + + ! Critical Gibbs free energy [erg] + gstar = (4._f * PI / 3._f) * r2 * sigma + + ! kT/(2*Pi*M) = [erg/mol/K]*[K]/[g/mol] = [erg/g] = [cm2/s2] + ! RB[erg/mol] = RGAS[erg/mol/K] * T[K] / (2Pi) + rb = RGAS * t(iz) / 2._f / PI + + ! Beta[cm/s] = sqrt(RB[erg/mol] / WTMOL[g/mol]) + beta1 = sqrt(rb / gwtmol(igash2so4)) ! H2SO4 + beta2 = sqrt(rb / gwtmol(igash2o)) ! H2O + + ! RPR[molecules/s] = 4Pi * R2[cm2] * H2O[molecules/cm3] * Beta[cm/s] + rpr = 4._f * PI * r2 * h2o * beta1 + + ! RPRE[/cm3/s] = RPR[/s] * H2SO4[/cm3]; first part of Zhao & Turco eqn 16 + rpre = rpr * h2so4 + + ! Zeldovitch non-equilibrium correction factor [unitless] + ! Jaecker-Voirol & Mirabel, 1988 (not considered in Zhao & Turco) + fracmol = 1._f /(1._f + wtmolr * (1._f - wfstar) / wfstar) + zphi = atan(fracmol) + zeld = 0.25_f / (sin(zphi))**2 + + ! Empirical correction factor: + cfac = 0.0_f + + ! Gstar exponential term in Zhao & Turco eqn 16 [unitless] + ftry = (-gstar / BK / t(iz)) + ahom = ftry + cfac + if (ahom .lt. -500._f) then + exhom=0.0_f + else + exhom = exp(min(ahom, 28.0_f)) + endif + + ! Calculate mass of critical nucleus + rho_H2SO4_wet = sulfate_density(carma, wtpct(iz),t(iz), rc) + rmstar = (4._f * PI / 3._f) * rho_H2SO4_wet * r2 * rstar + + ! Calculate dry mass of critical nucleus + rmstar = rmstar * wfstar + + ! Calc bin # of crit nucleus + if (rmstar.lt.rmassup(1,igroup)) then + nucbin = 1 + else + nucbin = 2 + int(log(rmstar / rmassup(1,igroup)) / log(rmrat(igroup))) + endif + + ! If none of the bins are large enough for the critical radius, then + ! no nucleation will occur. + if (nucbin > NBIN) then + nucbin = 0 + nucrate = 0.0_f + else + ! Calculate the nucleation rate [#/cm3/s], Zhao & Turco eqn 16. + nucrate = rpre * zeld * exhom + + ! Scale to #/x/y/z/s + nucrate = nucrate * zmet(iz) * xmet(iz) * ymet(iz) + endif + + return +end subroutine sulfnucrate + diff --git a/src/physics/carma/base/supersat.F90 b/src/physics/carma/base/supersat.F90 new file mode 100644 index 0000000000..94c5b1a490 --- /dev/null +++ b/src/physics/carma/base/supersat.F90 @@ -0,0 +1,107 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine evaluates supersaturations and for all gases. +!! +!! @author Andy Ackerman, Chuck Bardeen +!! @version Dec-1995, Aug-2010 +subroutine supersat(carma, cstate, iz, igas, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: igas !! gas index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: rvap + real(kind=f) :: gc_cgs + real(kind=f) :: alpha + + ! Calculate vapor pressures. + call vaporp(carma, cstate, iz, igas, rc) + + ! Define gas constant for this gas + rvap = RGAS / gwtmol(igas) + + gc_cgs = gc(iz,igas) / (zmet(iz)*xmet(iz)*ymet(iz)) + + supsatl(iz,igas) = (gc_cgs * rvap * t(iz) - pvapl(iz,igas)) / pvapl(iz,igas) + supsati(iz,igas) = (gc_cgs * rvap * t(iz) - pvapi(iz,igas)) / pvapi(iz,igas) + + ! For subgrid scale clouds, the supersaturation needs to be increased be scaled + ! based upon cloud fraction. This approach is similar to Wilson and Ballard (1999), + ! except that only the water vapor (no liquid water) is used to determine the available + ! water. + ! + ! NOTE: This assumes that the cloud is an ice cloud. + if (do_incloud) then + alpha = rhcrit(iz) * (1._f - cldfrc(iz)) + cldfrc(iz) + + supsatl(iz,igas) = (gc_cgs * rvap * t(iz) - alpha * pvapl(iz,igas)) / pvapl(iz,igas) + supsati(iz,igas) = (gc_cgs * rvap * t(iz) - alpha * pvapi(iz,igas)) / pvapi(iz,igas) + + ! Limit supersaturation to liquid saturation. + supsatl(iz,igas) = min(supsatl(iz,igas), 0._f) + supsati(iz,igas) = min(supsati(iz,igas), (pvapl(iz,igas) - alpha * pvapi(iz,igas)) / pvapi(iz,igas)) + end if + + return +end + + +!! This routine evaluates supersaturations and for all gases, but +!! thus version of the routine does not scale the supersaturation based on the cloud +!! fraction. It also assumes that vaporp has already been called. +!! +!! @author Andy Ackerman, Chuck Bardeen +!! @version Dec-1995, Aug-2010 +subroutine supersat_nocldf(carma, cstate, iz, igas, ssi, ssl, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: igas !! gas index + real(kind=f), intent(out) :: ssl + real(kind=f), intent(out) :: ssi + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: rvap + real(kind=f) :: gc_cgs + real(kind=f) :: alpha + + ! Calculate vapor pressures. + call vaporp(carma, cstate, iz, igas, rc) + + ! Define gas constant for this gas + rvap = RGAS / gwtmol(igas) + + gc_cgs = gc(iz,igas) / (zmet(iz)*xmet(iz)*ymet(iz)) + + ssl = (gc_cgs * rvap * t(iz) - pvapl(iz,igas)) / pvapl(iz,igas) + ssi = (gc_cgs * rvap * t(iz) - pvapi(iz,igas)) / pvapi(iz,igas) + + return +end diff --git a/src/physics/carma/base/totalcondensate.F90 b/src/physics/carma/base/totalcondensate.F90 new file mode 100644 index 0000000000..5479059e4c --- /dev/null +++ b/src/physics/carma/base/totalcondensate.F90 @@ -0,0 +1,88 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the total amount of condensate associated with each gas. +!! +!! @author Chuck Bardeen +!! @version Nov-2009 +subroutine totalcondensate(carma, cstate, iz, total_ice, total_liquid, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(out) :: total_ice(NGAS) !! total ice at the start of substep + real(kind=f), intent(out) :: total_liquid(NGAS) !! total liquid at the start of substep + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: icore ! core index + integer :: igas ! gas index + integer :: ibin ! bin index + integer :: ielem ! element index + integer :: i + real(kind=f) :: coremass + real(kind=f) :: volatilemass + + + ! Initialize local variables for keeping track of gas changes due + ! to nucleation and growth in each particle group. + total_ice(:) = 0._f + total_liquid(:) = 0._f + + ! Iterate over each particle type and total up that ones that interact + ! with the gases. + ! + ! This code assumes that all changes in condensate are associated with + ! growth in a particular gas. This doesn't handle all possible changes + ! associated with nucleation, if the group do not also participate in + ! growth. + do igroup = 1,NGROUP + + ielem = ienconc(igroup) ! element of particle number concentration + + igas = igrowgas(ielem) ! condensing gas + + if ((itype(ielem) == I_VOLATILE) .and. (igas /= 0)) then + + do ibin = 1, NBIN + + ! If this group has core masses, then determine the involatile component. + coremass = 0._f + + do i = 1, ncore(igroup) + icore = icorelem(i, igroup) + coremass = coremass + pc(iz, ibin, icore) + end do + + volatilemass = (pc(iz, ibin, ielem) * rmass(ibin, igroup)) - coremass + + ! There seem to be times when the coremass becomes larger than the total + ! mass. This shouldn't happen, but check for it here. + ! + ! NOTE: This can be caused by advection in the parent model or sedimentation + ! in this model. + if (volatilemass > 0._f) then + if (is_grp_ice(igroup)) then + total_ice(igas) = total_ice(igas) + volatilemass + else + total_liquid(igas) = total_liquid(igas) + volatilemass + end if + end if + end do + end if + end do + + return +end diff --git a/src/physics/carma/base/tsolve.F90 b/src/physics/carma/base/tsolve.F90 new file mode 100644 index 0000000000..4b7b57e790 --- /dev/null +++ b/src/physics/carma/base/tsolve.F90 @@ -0,0 +1,115 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates new potential temperature concentration +!! (and updates temperature) due to microphysical and radiative forcings. +!! The equation solved (the first law of thermodynamics in flux form) is +!! +!! d(rhostar theta) rhostar theta d(qv) 1 dF +!! --------------- = - ------------- * ( L ----- + --- -- ) +!! dt Cp T dt rho dz +!! +!! where +!! rhostar = scaled air density +!! theta = potential temperature +!! t = time +!! Cp = specific heat (at constant pressure) of air +!! T = air temperature +!! qv = water vapor mixing ratio +!! L = latent heat +!! F = net radiative flux +!! z = unscaled altitude +!! +!! @author Andy Ackerman +!! @version Oct-1997 +subroutine tsolve(carma, cstate, iz, scale_threshold, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f) :: scale_threshold !! Scaling factor for convergence thresholds + integer, intent(inout) :: rc !! return code, negative indicates failure + + 1 format(/,'tsolve::ERROR - negative temperature for : iz=',i4,',lat=',& + f7.2,',lon=',f7.2,',T=',e10.3,',dT=',e10.3,',t_old=',e10.3,',d_gc=',e10.3,',dT_adv=',e10.3) + 2 format(/,'tsolve::ERROR - temperature change to large for : iz=',i4,',lat=',& + f7.2,',lon=',f7.2,',T=',e10.3,',dT_rlh=',e10.3,',dT_pth=',e10.3,',t_old=',e10.3,',d_gc=',e10.3,',dT_adv=',e10.3) + 3 format(/,'tsolve::ERROR - temperature change to large for : iz=',i4,',lat=',& + f7.2,',lon=',f7.2,',T=',e10.3,',dT_rlh=',e10.3,',dT_pth=',e10.3,',t_old=',e10.3) + 4 format(/,'tsolve::ERROR - negative temperature for : iz=',i4,',lat=',& + f7.2,',lon=',f7.2,',T=',e10.3,',dT=',e10.3,',t_old=',e10.3) + + real(kind=f) :: dt ! delta temperature + real(kind=f) :: threshold ! convergence threshold + + + ! Solve for the new due to latent heat exchange and radiative heating. + ! Latent and radiative heating rates are in units of [deg_K/s]. + ! + ! NOTE: In the embedded model rhoa and p are handled by the parent model and + ! won't change during one time step. + ! + ! NOTE: Radiative heating by the particles is handled by the parent model, so + ! that term does not need to be added here. + dt = dtime * rlprod + rlheat(iz) = rlheat(iz) + rlprod * dtime + + ! With particle heating, you must also include the impact of heat + ! conduction from the particle + ! + ! NOTE: We are ignoring the energy to heat the particle, since we + ! are not tracking the particle temperature. Thus ... + if (do_pheatatm) then + dt = dt + dtime * phprod + partheat(iz) = partheat(iz) + phprod * dtime + end if + + t(iz) = t(iz) + dt + + + ! Don't let the temperature go negative. + if (t(iz) < 0._f) then + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,1) iz, lat, lon, t(iz), dt, told(iz), d_gc(iz, 1), d_t(iz) + end if + else + if (do_print) write(LUNOPRT,4) iz, lat, lon, t(iz), dt, told(iz) + end if + + rc = RC_WARNING_RETRY + end if + + ! Don't let the temperature change by more than the threshold in any given substep, + ! to prevent overshooting that doesn't result in negative gas concentrations, but + ! does result in excessive temperature swings. + threshold = dt_threshold / scale_threshold + + if (threshold /= 0._f) then + if (abs(abs(dt)) > threshold) then + if (do_substep) then + if (nretries == maxretries) then + if (do_print) write(LUNOPRT,2) iz, lat, lon, t(iz), rlprod*dtime, dtime*partheat(iz), told(iz), d_gc(iz, 1), d_t(iz) + end if + else + if (do_print) write(LUNOPRT,3) iz, lat, lon, t(iz), rlprod*dtime, dtime*partheat(iz), told(iz) + end if + + rc = RC_WARNING_RETRY + end if + end if + + ! Return to caller with new temperature. + return +end diff --git a/src/physics/carma/base/upgxfer.F90 b/src/physics/carma/base/upgxfer.F90 new file mode 100644 index 0000000000..c32c138870 --- /dev/null +++ b/src/physics/carma/base/upgxfer.F90 @@ -0,0 +1,142 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates particle source terms due to element transfer +!! processes for which the target element number is greater than the source element +!! number. (Otherwise, the source terms are calculated in downgxfer.f.) +!! The calculation is done for one particle size bin at one spatial grid point per +!! call. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine upgxfer(carma, cstate, iz, ibin, ielem, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: ibin !! bin index + integer, intent(in) :: ielem !! element index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: igroup ! group index + integer :: iepart + integer :: jefrom + integer :: iefrom + integer :: igfrom + integer :: ipow_from + integer :: ipow_to + integer :: ipow + integer :: jfrom + integer :: ifrom + integer :: ic + integer :: iecore + real(kind=f) :: xyzmet + real(kind=f) :: rhoa_cgs + real(kind=f) :: elemass + real(kind=f) :: totmass + real(kind=f) :: rmasscore + real(kind=f) :: fracmass + real(kind=f) :: rnucprod + + + ! Define group & particle # concentration indices for current element + igroup = igelem(ielem) ! target particle group + iepart = ienconc(igroup) ! target particle number concentration element + + ! Calculate production terms due to nucleation . + + ! Loop over elements that nucleate to element . + do jefrom = 1,nnucelem(ielem) + + iefrom = inucelem(jefrom,ielem) ! source particle element + + ! Only calculate production rates here if is greater than + ! . Otherwise, production is calculated in downgxfer.f + if( ielem .gt. iefrom ) then + + igfrom = igelem(iefrom) ! source particle group + + ! is the power to which the source particle mass must be taken + ! to match the type of the target element. This ugliness could be + ! handled much more slickly in setupnuc() + if( itype(iefrom) .eq. I_INVOLATILE .or. & + itype(iefrom) .eq. I_VOLATILE )then + ipow_from = 0 + elseif ( itype(iefrom) .eq. I_COREMASS .or. & + itype(iefrom) .eq. I_VOLCORE )then + ipow_from = 1 + else + ipow_from = 2 + endif + + if( itype(ielem) .eq. I_INVOLATILE .or. & + itype(ielem) .eq. I_VOLATILE )then + ipow_to = 0 + elseif ( itype(ielem) .eq. I_COREMASS .or. & + itype(ielem) .eq. I_VOLCORE )then + ipow_to = 1 + else + ipow_to = 2 + endif + + ipow = ipow_to - ipow_from + + ! Loop over bins that nucleate to bin . + do jfrom = 1,nnucbin(igfrom,ibin,igroup) + + ifrom = inucbin(jfrom,igfrom,ibin,igroup) ! bin of source + + ! Bypass calculation if few source particles are present + if( pconmax(iz,igfrom) .gt. FEW_PC )then + + if( rnuclg(ifrom,igfrom,igroup) .gt. 0._f )then + + ! First calculate mass associated with the source element + ! (this is for all source elements except particle number + ! concentration in a multicomponent particle group). + if( ncore(igfrom) .eq. 0 .or. & + itype(iefrom) .gt. I_VOLATILE )then + elemass = rmass(ifrom,igfrom) + else + totmass = pc(iz,ifrom,iefrom) * rmass(ifrom,igfrom) + rmasscore = pc(iz,ifrom,icorelem(1,igfrom)) + + do ic = 2,ncore(igfrom) + iecore = icorelem(ic,igfrom) + rmasscore = rmasscore + pc(iz,ifrom,iecore) + enddo + + fracmass = 1._f - rmasscore/totmass + elemass = fracmass * rmass(ifrom,igfrom) + endif + + rnucprod = rnuclg(ifrom,igfrom,igroup) * & + pc(iz,ifrom,iefrom) * elemass**ipow + + rnucpe(ibin,ielem) = rnucpe(ibin,ielem) + rnucprod + + ! Calculate latent heat associated with nucleation to + ! from +! rlprod = rlprod + rnucprod * rlh_nuc(iefrom,ielem) / & +! (CP * rhoa(iz)) * elemass + endif ! (rnuclg > 0.) + endif ! (pconmax > FEW_PC) + enddo ! (jfrom = 1,nnucbin) + endif ! (ielem > iefrom) + enddo ! (jefrom = 1,nnucelem) + + ! Return to caller with nucleation production terms evaluated. + return +end diff --git a/src/physics/carma/base/vaporp.F90 b/src/physics/carma/base/vaporp.F90 new file mode 100644 index 0000000000..f909991959 --- /dev/null +++ b/src/physics/carma/base/vaporp.F90 @@ -0,0 +1,58 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates the vapor pressure for all gases at one altitude. +!! +!! and are vapor pressures in units of [dyne/cm^2] +!! +!! Uses temperature as input. +!! +!! @author Andy Ackerman +!! @version Dec-1995 +subroutine vaporp(carma, cstate, iz, igas, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + integer, intent(in) :: igas !! gas index + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Each gas should have a vapor pressure routine specified for it. + ! + ! As new gases are supported, this table should be expanded with new entries for + ! the appropriate vapor pressure rotuines. + select case(ivaprtn(igas)) + + case (I_VAPRTN_H2O_BUCK1981) + call vaporp_h2o_buck1981(carma, cstate, iz, rc, pvapl(iz, igas), pvapi(iz, igas)) + + case(I_VAPRTN_H2O_MURPHY2005) + call vaporp_h2o_murphy2005(carma, cstate, iz, rc, pvapl(iz, igas), pvapi(iz, igas)) + + case(I_VAPRTN_H2O_GOFF1946) + call vaporp_h2o_goff1946(carma, cstate, iz, rc, pvapl(iz, igas), pvapi(iz, igas)) + + case(I_VAPRTN_H2SO4_AYERS1980) + call vaporp_h2so4_ayers1980(carma, cstate, iz, rc, pvapl(iz, igas), pvapi(iz, igas)) + + case default + if (do_print) write(LUNOPRT,*) "vaporp:: ERROR - Unknown vapor pressure routine (", ivaprtn(igas), & + ") for gas (", igas, ")." + rc = RC_ERROR + return + end select + + ! Return to caller with vapor pressures evaluated. + return +end diff --git a/src/physics/carma/base/vaporp_h2o_buck1981.F90 b/src/physics/carma/base/vaporp_h2o_buck1981.F90 new file mode 100644 index 0000000000..d4f914d246 --- /dev/null +++ b/src/physics/carma/base/vaporp_h2o_buck1981.F90 @@ -0,0 +1,66 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates the vapor pressure of water vapor over liquid water and ice according +!! to the parameterization of Buck [1981]. +!! +!! NOTE: and are vapor pressures in units of [dyne/cm^2] +!! +subroutine vaporp_h2o_buck1981(carma, cstate, iz, rc, pvap_liq, pvap_ice) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(out) :: pvap_liq !! vapor pressure wrt liquid + real(kind=f), intent(out) :: pvap_ice !! vapor pressure wrt ice + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + + ! Define coefficients in Buck's formulation for saturation vapor pressures + ! Table 2 + ! + ! Ice: valid temperature interval -80 - 0 C + real(kind=f), parameter :: BAI = 6.1115e2_f + real(kind=f), parameter :: BBI = 23.036_f + real(kind=f), parameter :: BCI = 279.82_f + real(kind=f), parameter :: BDI = 333.7_f + + ! Liquid: valid temperature interval -40 - +50 C + real(kind=f), parameter :: BAL = 6.1121e2_f + real(kind=f), parameter :: BBL = 18.729_f + real(kind=f), parameter :: BCL = 257.87_f + real(kind=f), parameter :: BDL = 227.3_f + + real(kind=f) :: tt + + + ! Saturation vapor pressure over liquid water and water ice from + ! Buck [J. Atmos. Sci., 20, 1527, 1981] + tt = t(iz) - 273.16_f + + pvap_liq = BAL * exp( (BBL - tt/BDL)*tt / (tt + BCL) ) + pvap_ice = BAI * exp( (BBI - tt/BDI)*tt / (tt + BCI) ) + + ! Check to see whether temperature is ouside range of validity for the parameterization. + ! + ! NOTE: Don't stop the simulation if the limits are exceeded. + if (pvap_liq .le. 1.e-13_f) then + if (do_print) write(LUNOPRT,*) 'vaporp_buck1981::WARNING - Temperature (', t(iz), ') too small for iz = ', iz + rc = RC_WARNING + endif + + ! Return to caller with vapor pressures evaluated. + return +end diff --git a/src/physics/carma/base/vaporp_h2o_goff1946.F90 b/src/physics/carma/base/vaporp_h2o_goff1946.F90 new file mode 100644 index 0000000000..3dae13edcf --- /dev/null +++ b/src/physics/carma/base/vaporp_h2o_goff1946.F90 @@ -0,0 +1,65 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates the vapor pressure of water vapor over liquid water and ice according +!! to the parameterization of Goff & Gratch [1946] as used in CAM (wv_saturation.F90). +!! +!! NOTE: and are vapor pressures in units of [dyne/cm^2] +!! +!! @author Chuck Bardeen +!! @version Dec-2010 +subroutine vaporp_h2o_goff1946(carma, cstate, iz, rc, pvap_liq, pvap_ice) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(out) :: pvap_liq !! vapor pressure wrt liquid [dyne/cm2] + real(kind=f), intent(out) :: pvap_ice !! vapor pressure wrt ice [dyne[cm2] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: tt + + + ! Saturation vapor pressure over liquid water and water ice from + ! Goff and Gatch, [1946]. + tt = t(iz) + + pvap_liq = 10.0_f * 10._f**(-7.90298_f * (373.16_f / tt - 1._f) + & + 5.02808_f * log10(373.16_f / tt) - & + 1.3816e-7_f * (10._f**(11.344_f * (1._f - tt / 373.16_f)) - 1._f) + & + 8.1328e-3_f * (10._f**(-3.49149_f * (373.16_f / tt - 1._f)) - 1._f) + & + log10(1013.246_f)) * 100._f + + pvap_ice = 10.0_f * 10._f**(-9.09718_f * (273.16_f / tt - 1._f) - 3.56654_f * & + log10(273.16_f / tt) + 0.876793_f * (1._f - tt / 273.16_f) + & + log10(6.1071_f)) * 100._f + + ! Check to see whether temperature is ouside range of validity for the parameterization. + ! + ! pvapl is defined for -50 C < T < 102 C , Gibbons [1990] + ! pvapi is defined for T > -100 C + ! + ! NOTE: Don't stop the simulation if the limits are exceeded. + if ((t(iz) .le. 173.0_f) .or. (t(iz) .ge. 375.0_f)) then +! if (do_print) then +! write(LUNOPRT,*) 'vaporp_h2o_goff1946::WARNING - Temperature', t(iz), & +! ' out of range at iz = ', iz, "lat=", lat, "lon=", lon +! end if + rc = RC_WARNING + endif + + ! Return to caller with vapor pressures evaluated. + return +end diff --git a/src/physics/carma/base/vaporp_h2o_murphy2005.F90 b/src/physics/carma/base/vaporp_h2o_murphy2005.F90 new file mode 100644 index 0000000000..60f45adb28 --- /dev/null +++ b/src/physics/carma/base/vaporp_h2o_murphy2005.F90 @@ -0,0 +1,59 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates the vapor pressure of water vapor over liquid water and ice according +!! to the parameterization of Murphy & Koop [2005]. +!! +!! NOTE: and are vapor pressures in units of [dyne/cm^2] +!! +!! @author Chuck Bardeen +!! @version May-2009 +subroutine vaporp_h2o_murphy2005(carma, cstate, iz, rc, pvap_liq, pvap_ice) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(out) :: pvap_liq !! vapor pressure wrt liquid [dyne/cm2] + real(kind=f), intent(out) :: pvap_ice !! vapor pressure wrt ice [dyne[cm2] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: tt + + + ! Saturation vapor pressure over liquid water and water ice from + ! Murphy and Koop, Quart. J. Roy. Meteo. Soc., 131, 1539-1565, [2005]. + tt = t(iz) + + pvap_liq = 10.0_f * exp(54.842763_f - (6763.22_f / tt) - (4.210_f * log(tt)) + (0.000367_f * tt) + & + (tanh(0.0415_f * (tt - 218.8_f)) * & + (53.878_f - (1331.22_f / tt) - (9.44523_f * log(tt)) + 0.014025_f * tt))) + + pvap_ice = 10.0_f * exp(9.550426_f - (5723.265_f / tt) + (3.53068_f * log(tt)) - (0.00728332_f * tt)) + + ! Check to see whether temperature is ouside range of validity for the parameterization. + ! + ! pvapl is defined for 123 < T < 332 K + ! pvapi is defined for T > 110 K + ! + ! NOTE: Don't stop the simulation if the limits are exceeded. +! if ((t(iz) .le. 123.0_f) .or. (t(iz) .ge. 332.0_f)) then +! if (do_print) write(LUNOPRT,*) 'vaporp_h2o_murphy2005::WARNING - Temperature', t(iz), & +! ' out of range at iz = ', iz, "lat=", lat, "lon=", lon +! rc = RC_WARNING +! endif + + ! Return to caller with vapor pressures evaluated. + return +end diff --git a/src/physics/carma/base/vaporp_h2so4_ayers1980.F90 b/src/physics/carma/base/vaporp_h2so4_ayers1980.F90 new file mode 100644 index 0000000000..2335892aca --- /dev/null +++ b/src/physics/carma/base/vaporp_h2so4_ayers1980.F90 @@ -0,0 +1,91 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! Calculates the vapor pressure for sulfuric acid. +!! +!! and are vapor pressures in units of [dyne/cm^2] +!! +!! Created Dec-1995 (Ackerman) +!! Modified Sep-1997 (McKie) +!! Modified Jul-2001 (Mills) +!! +!! NOTE: To calculate vapor pressure of H2SO4 water vapor pressure (pvapl(iz, igash2o)) +!! should be calculated before this calculation. +!! +!! @author Mike Mills, Tianyi Fan +!! @version Feb-2011 +subroutine vaporp_H2SO4_Ayers1980(carma, cstate, iz, rc, pvap_liq, pvap_ice) +! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! z index + real(kind=f), intent(out) :: pvap_liq !! vapor pressure wrt liquid [dyne/cm2] + real(kind=f), intent(out) :: pvap_ice !! vapor pressure wrt ice [dyne[cm2] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + real(kind=f) :: gc_cgs ! water vapor mass concentration [g/cm3] + real(kind=f) :: fk1, fk4, fk4_1, fk4_2 + real(kind=f) :: factor_kulm ! Kulmala correction terms + real(kind=f) :: en, temp + real(kind=f) :: sulfeq + real(kind=f), parameter :: t0_kulm = 340._f ! T0 set in the low end of the Ayers measurement range (338-445K) + real(kind=f), parameter :: t_crit_kulm = 905._f ! Critical temperature = 1.5 * Boiling point + real(kind=f), parameter :: fk0 = -10156._f / t0_kulm + 16.259_f ! Log(Kulmala correction factor) + real(kind=f), parameter :: fk2 = 1._f / t0_kulm + real(kind=f), parameter :: fk3 = 0.38_f / (t_crit_kulm - t0_kulm) + + + ! Saturation vapor pressure of sulfuric acid + ! + ! Don't allow saturation vapor pressure to underflow at very low temperatures + temp=max(t(iz),140._f) + + ! Convert water vapor concentration to g/cm3: + gc_cgs = gc(iz, igash2o) / (xmet(iz) * ymet(iz) * zmet(iz)) + + ! Compute the sulfate composition based on Hanson parameterization + ! to temperature and water vapor concentration. + wtpct(iz) = wtpct_tabaz(carma, temp, gc_cgs, pvapl(iz, igash2o), rc) + + ! Parameterized fit to Giauque's (1959) enthalpies v. wt %: + en = 4.184_f * (23624.8_f - 1.14208e8_f / ((wtpct(iz) - 105.318_f)**2 + 4798.69_f)) + en = max(en, 0.0_f) + + ! Ayers' (1980) fit to sulfuric acid equilibrium vapor pressure: + ! (Remember this is the log) + ! SULFEQ=-10156/Temp+16.259-En/(8.3143*Temp) + ! + ! Kulmala correction (J. CHEM. PHYS. V.93, No.1, 1 July 1990) + fk1 = -1._f / temp + fk4_1 = log(t0_kulm / temp) + fk4_2 = t0_kulm / temp + fk4 = 1.0_f + fk4_1 - fk4_2 + factor_kulm = fk1 + fk2 + fk3 * fk4 + + ! This is for pure H2SO4 + sulfeq = fk0 + 10156._f * factor_kulm + + ! Adjust for WTPCT composition: + sulfeq = sulfeq - en / (8.3143_f * temp) + + ! REMEMBER TO TAKE THE EXPONENTIAL! + sulfeq = exp(sulfeq) + + ! BUT this is in Atmospheres. Convert ==> dynes/cm2 + pvap_liq = sulfeq * 1.01325e6_f + pvap_ice = sulfeq * 1.01325e6_f + + return +end diff --git a/src/physics/carma/base/versol.F90 b/src/physics/carma/base/versol.F90 new file mode 100644 index 0000000000..4c54b0fa55 --- /dev/null +++ b/src/physics/carma/base/versol.F90 @@ -0,0 +1,143 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine solves the vertical transport equation. +!! is temporary storage for concentrations (particles, +!! gas, potential temperature) being transported. +!! New values of are calculated. +!! +!! @author Eric Jensen +!! @version Dec-1996 +subroutine versol(carma, cstate, cvert, itbnd, ibbnd, ftop, fbot, cvert_tbnd, cvert_bbnd, & + vertadvu, vertadvd, vertdifu, vertdifd, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + real(kind=f), intent(inout) :: cvert(NZ) !! quantity being transported + integer, intent(in) :: itbnd !! top boundary condition + integer, intent(in) :: ibbnd !! bottom boundary condition + real(kind=f), intent(in) :: ftop !! flux at top boundary + real(kind=f), intent(in) :: fbot !! flux at bottom boundary + real(kind=f), intent(in) :: cvert_tbnd !! quantity at top boundary + real(kind=f), intent(in) :: cvert_bbnd !! quantity at bottom boundary + real(kind=f), intent(in) :: vertadvu(NZP1) !! upward vertical transport rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertadvd(NZP1) !! downward vertical transport rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertdifu(NZP1) !! upward vertical diffusion rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertdifd(NZP1) !! downward vertical diffusion rate into level k from level k-1 [cm/s] + integer, intent(inout) :: rc !! return code, negative indicates failure + +! Declare local variables +! + integer :: k + real(kind=f) :: al(NZ) + real(kind=f) :: bl(NZ) + real(kind=f) :: dl(NZ) + real(kind=f) :: el(NZ) + real(kind=f) :: fl(NZ) + real(kind=f) :: ul(NZ) + real(kind=f) :: ctempl(NZ) + real(kind=f) :: ctempu(NZ) + real(kind=f) :: divcor(NZ) + real(kind=f) :: uc + real(kind=f) :: cour + real(kind=f) :: denom + + ! Divergence adjustments are not being generated. + divcor(:) = 0._f + + ! Determine whether transport should be solved explicitly (uc=0) + ! or implicitly (uc=1). + uc = 0._f + do k = 1,NZ + cour = dz(k)/dtime - & + ( vertdifu(k+1) + vertdifd(k) + vertadvu(k+1) + vertadvd(k) ) + + if( cour .lt. 0._f .and. uc .ne. 1._f )then + uc = 1.0_f + + ! NOTE: This can happen a lot and clutters up the log. Should we print it out or not? +! write(LUNOPRT,'(a,i3,7(1x,1pe8.1))') & +! 'in versol: k dz/dt vdifd vdifu vadvd vadvu cour uc = ', & +! k, dz(k)/dtime, vertdifd(k), vertdifu(k+1), & +! vertadvd(k), vertadvu(k+1), cour, uc + endif + enddo + + ! Store concentrations in local variables (shifted up and down + ! a vertical level). + do k = 2,NZ + ctempl(k) = cvert(k-1) + ctempu(k-1) = cvert(k) + enddo + + if( ibbnd .eq. I_FIXED_CONC ) then + ctempl(1) = cvert_bbnd + else + ctempl(1) = 0._f + endif + + if( itbnd .eq. I_FIXED_CONC ) then + ctempu(NZ) = cvert_tbnd + else + ctempu(NZ) = 0._f + endif + + ! Calculate coefficients of the transport equation: + ! al(k)c(k+1) + bl(k)c(k) + ul(k)c(k-1) = dl(k) + + do k = 1,NZ + al(k) = uc * ( vertdifd(k+1) + vertadvd(k+1) ) + bl(k) = -( uc*(vertdifd(k)+vertdifu(k+1)+ & + vertadvd(k)+vertadvu(k+1)) & + + dz(k)/dtime ) + ul(k) = uc * ( vertdifu(k) + vertadvu(k) ) + dl(k) = cvert(k) * & + ( (1._f - uc)*(vertdifd(k)+vertdifu(k+1)+ & + vertadvd(k)+vertadvu(k+1)) & + - dz(k)/dtime ) - & + (1._f - uc) * ( (vertdifu(k)+vertadvu(k))*ctempl(k) + & + (vertdifd(k+1)+vertadvd(k+1))*ctempu(k) ) - & + divcor(k) * dz(k) + enddo + + ! Boundary fluxes: is the downward flux across the + ! upper boundary; is the upward flux across the + ! lower boundary. + if(( igridv .eq. I_SIG ) .or. ( igridv .eq. I_HYBRID )) then + if( itbnd .eq. I_FLUX_SPEC ) dl(1) = dl(1) - ftop + if( ibbnd .eq. I_FLUX_SPEC ) dl(NZ) = dl(NZ) - fbot + else + if( itbnd .eq. I_FLUX_SPEC ) dl(NZ) = dl(NZ) - ftop + if( ibbnd .eq. I_FLUX_SPEC ) dl(1) = dl(1) - fbot + endif + + ! Calculate recursion relations. + el(1) = dl(1)/bl(1) + fl(1) = al(1)/bl(1) + do k = 2,NZ + denom = bl(k) - ul(k) * fl(k-1) + el(k) = ( dl(k) - ul(k)*el(k-1) ) / denom + fl(k) = al(k) / denom + enddo + + ! Calculate new concentrations. + + cvert(NZ) = el(NZ) + do k = NZ-1,1,-1 + cvert(k) = el(k) - fl(k)*cvert(k+1) + enddo + + ! Return to caller with new concentrations. + return +end diff --git a/src/physics/carma/base/versub.F90 b/src/physics/carma/base/versub.F90 new file mode 100644 index 0000000000..92fd963aad --- /dev/null +++ b/src/physics/carma/base/versub.F90 @@ -0,0 +1,127 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine solves for sedimentation using an explicit substepping approach. It +!! is faster and handles large cfl and irregular grids better than the normal PPM +!! solver (versol), but it is more diffusive. +!! +!! @author Andy Ackerman, Chuck Bardeen +!! version Aug 2010 +subroutine versub(carma, cstate, pcmax, cvert, itbnd, ibbnd, ftop, fbot, cvert_tbnd, cvert_bbnd, & + vertadvu, vertadvd, vertdifu, vertdifd, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + real(kind=f), intent(in) :: pcmax(NZ) !! maximum particle concentration (#/x/y/z) + real(kind=f), intent(inout) :: cvert(NZ) !! quantity being transported (#/x/y/z) + integer, intent(in) :: itbnd !! top boundary condition + integer, intent(in) :: ibbnd !! bottom boundary condition + real(kind=f), intent(in) :: ftop !! flux at top boundary + real(kind=f), intent(in) :: fbot !! flux at bottom boundary + real(kind=f), intent(in) :: cvert_tbnd !! quantity at top boundary + real(kind=f), intent(in) :: cvert_bbnd !! quantity at bottom boundary + real(kind=f), intent(in) :: vertadvu(NZP1) !! upward vertical transport rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertadvd(NZP1) !! downward vertical transport rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertdifu(NZP1) !! upward vertical diffusion rate into level k from level k-1 [cm/s] + real(kind=f), intent(in) :: vertdifd(NZP1) !! downward vertical diffusion rate into level k from level k-1 [cm/s] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Declare local variables + integer :: iz + integer :: istep + integer :: nstep_sed + real(kind=f) :: fvert(NZ) + real(kind=f) :: up(NZP1) + real(kind=f) :: dn(NZP1) + real(kind=f) :: cfl_max + real(kind=f) :: fvert_1 + real(kind=f) :: fvert_nz + + ! Determine the total upward and downward velocities. + up(:) = vertadvu(:) + vertdifu(:) + dn(:) = vertadvd(:) + vertdifd(:) + + ! Compute the maximum CFL for each bin that has a significant concentration + ! of particles. + cfl_max = 0._f + + do iz = 1, NZ + if (pcmax(iz) > SMALL_PC) then + cfl_max = max(cfl_max, max(abs(up(iz)), abs(up(iz+1)), abs(dn(iz)), abs(dn(iz+1))) * dtime / dz(iz)) + end if + end do + + ! Use the maximum CFL determined above to figure out how much substepping is + ! needed to sediment explicitly without violating the CFL anywhere in the column. + if (cfl_max >= 0._f) then + nstep_sed = int(1._f + cfl_max) + else + nstep_sed = 0 + endif + + ! If velocities are in both directions, then more steps are needed to make sure + ! that no more than half of the concentration can be transported in either direction. + if (maxval(up(:) * dn(:)) > 0._f) then + nstep_sed = nstep_sed * 2 + end if + + ! Determine the top and bottom boundary fluxes, keeping in mind that + ! the velocities and grid coordinates are reversed in sigma or hybrid + ! coordinates + if ((igridv .eq. I_SIG) .or. (igridv .eq. I_HYBRID)) then + if (itbnd .eq. I_FLUX_SPEC) then + fvert_nz = -fbot + else + fvert_nz = cvert_bbnd*dn(NZ+1) + end if + + if (ibbnd .eq. I_FLUX_SPEC) then + fvert_1 = -ftop + else + fvert_1 = cvert_tbnd*up(1) + end if + + else + if (itbnd .eq. I_FLUX_SPEC) then + fvert_nz = ftop + else + fvert_nz = cvert_tbnd*dn(NZ+1) + end if + + if (ibbnd .eq. I_FLUX_SPEC) then + fvert_1 = fbot + else + fvert_1 = cvert_bbnd*up(1) + end if + endif + + ! Sediment the particles using multiple iterations to satisfy the CFL. + do istep = 1, nstep_sed + + ! Determine the net particle flux at each gridbox. The first and last levels + ! need special treatment to handle to bottom and top boundary conditions. + fvert(1) = (-cvert(1)*dn(1) + fvert_1 + cvert(2)*dn(2) - cvert(1)*up(2)) + + do iz = 2, NZ-1 + fvert(iz) = (-cvert(iz)*dn(iz) + cvert(iz-1)*up(iz) + cvert(iz+1)*dn(iz+1) - cvert(iz)*up(iz+1)) + end do + + fvert(NZ) = (-cvert(NZ)*dn(NZ) + cvert(NZ-1)*up(NZ) + fvert_nz - cvert(NZ)*up(NZ+1)) + + ! Now update the actual concentrations. + cvert(:) = cvert(:) + fvert(:) * dtime / nstep_sed / dz(:) + enddo + + return +end subroutine versub diff --git a/src/physics/carma/base/vertadv.F90 b/src/physics/carma/base/vertadv.F90 new file mode 100644 index 0000000000..1647f98898 --- /dev/null +++ b/src/physics/carma/base/vertadv.F90 @@ -0,0 +1,256 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates vertrical advection rates using +!! Piecewise Polynomial Method [Colela and Woodard, J. Comp. Phys., +!! 54, 174-201, 1984] +!! +!! @author Eric Jensen +!! @version Dec-1996 +subroutine vertadv(carma, cstate, vtrans, cvert, itbnd, ibbnd, cvert_tbnd, cvert_bbnd, vertadvu, vertadvd, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + real(kind=f), intent(inout) :: vtrans(NZP1) !! vertical velocity + real(kind=f), intent(in) :: cvert(NZ) !! quantity being transported + integer, intent(in) :: itbnd !! top boundary condition + integer, intent(in) :: ibbnd !! bottom boundary condition + real(kind=f), intent(in) :: cvert_tbnd !! quantity at top boundary + real(kind=f), intent(in) :: cvert_bbnd !! quantity at bottom boundary + real(kind=f), intent(out) :: vertadvu(NZP1) !! upward vertical transport rate into level k from level k-1 [cm/s] + real(kind=f), intent(out) :: vertadvd(NZP1) !! downward vertical transport rate into level k from level k-1 [cm/s] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local declarations + integer :: k + integer :: nzm1 + integer :: nzm2 + integer :: itwo + real(kind=f) :: dela(NZ) + real(kind=f) :: delma(NZ) + real(kind=f) :: aju(NZ) + real(kind=f) :: ar(NZ) + real(kind=f) :: al(NZ) + real(kind=f) :: a6(NZ) + real(kind=f) :: dpc, dpc1, dpcm1 + real(kind=f) :: ratt1, ratt2, ratt3, rat1, rat2, rat3, rat4, den1 + real(kind=f) :: com2, x, xpos + real(kind=f) :: cvert0, cvertnzp1 + + + ! Initialize fluxes to zero + vertadvu(:) = 0._f + vertadvd(:) = 0._f + + ! If doing explicit sedimentation then do a simple sorting of positive and negative + ! velocities into up and down components. + if (do_explised) then + where (vtrans < 0._f) + vertadvd = -vtrans + elsewhere + vertadvu = vtrans + end where + else + + + if( ibbnd .eq. I_FLUX_SPEC ) vtrans(1) = 0._f + if( itbnd .eq. I_FLUX_SPEC ) vtrans(NZP1) = 0._f + + ! Set some constants + nzm1 = max( 1, NZ-1 ) + nzm2 = max( 1, NZ-2 ) + itwo = min( 2, NZ ) + + ! First, use cubic fits to estimate concentration values at layer + ! boundaries + do k = 2,NZ-1 + dpc = cvert(k) / dz(k) + dpc1 = cvert(k+1) / dz(k+1) + dpcm1 = cvert(k-1) / dz(k-1) + ratt1 = dz(k) / ( dz(k-1) + dz(k) + dz(k+1) ) + ratt2 = ( 2._f*dz(k-1) + dz(k) ) / ( dz(k+1) + dz(k) ) + ratt3 = ( 2._f*dz(k+1) + dz(k) ) / ( dz(k-1) + dz(k) ) + dela(k) = ratt1 * ( ratt2*(dpc1-dpc) + ratt3*(dpc-dpcm1) ) + + if( (dpc1-dpc)*(dpc-dpcm1) .gt. 0._f .and. dela(k) .ne. 0._f ) then + delma(k) = min(abs(dela(k)), 2._f*abs(dpc-dpc1), 2._f*abs(dpc-dpcm1)) * abs(dela(k))/dela(k) + else + delma(k) = 0._f + endif + enddo ! k = 2,NZ-2 + + do k = 2,NZ-2 + dpc = cvert(k) / dz(k) + dpc1 = cvert(k+1) / dz(k+1) + dpcm1 = cvert(k-1) / dz(k-1) + rat1 = dz(k) / ( dz(k) + dz(k+1) ) + rat2 = 2._f * dz(k+1) * dz(k) / ( dz(k) + dz(k+1) ) + rat3 = ( dz(k-1) + dz(k) ) / ( 2._f*dz(k) + dz(k+1) ) + rat4 = ( dz(k+2) + dz(k+1) ) / ( 2._f*dz(k+1) + dz(k) ) + den1 = dz(k-1) + dz(k) + dz(k+1) + dz(k+2) + + ! is the estimate for concentration (dn/dz) at layer + ! boundary +1/2. + aju(k) = dpc + rat1*(dpc1-dpc) + 1._f/den1 * ( rat2*(rat3-rat4)*(dpc1-dpc) - & + dz(k)*rat3*delma(k+1) + dz(k+1)*rat4*delma(k) ) + + enddo ! k = 2,NZ-2 + + ! Now construct polynomial functions in each layer + do k = 3,NZ-2 + al(k) = aju(k-1) + ar(k) = aju(k) + enddo + + ! Use linear functions in first two and last two layers + ar(itwo) = aju(itwo) + al(itwo) = cvert(1)/dz(1) + (zl(itwo)-zc(1)) / & + (zc(itwo)-zc(1)) * (cvert(itwo)/dz(itwo)-cvert(1)/dz(1)) + ar(1) = al(itwo) + al(1) = cvert(1)/dz(1) - (zc(1)-zl(1)) / & + (zc(itwo)-zc(1)) * (cvert(itwo)/dz(itwo)-cvert(1)/dz(1)) + + al(nzm1) = aju(nzm2) + ar(nzm1) = cvert(nzm1)/dz(nzm1) + (zl(NZ)-zc(nzm1)) & + / (zc(NZ)-zc(nzm1)) * (cvert(NZ)/dz(NZ)-cvert(nzm1)/dz(nzm1)) + al(NZ) = ar(nzm1) + ar(NZ) = cvert(nzm1)/dz(nzm1) + (zl(NZ+1)-zc(nzm1)) & + / (zc(NZ)-zc(nzm1)) * (cvert(NZ)/dz(NZ)-cvert(nzm1)/dz(nzm1)) + + ! Ensure that boundary values are not negative + al(1) = max( al(1), 0._f ) + ar(NZ) = max( ar(NZ), 0._f ) + + ! Next, ensure that polynomial functions do not deviate beyond the + ! range [,] + do k = 1,NZ + dpc = cvert(k) / dz(k) + if( (ar(k)-dpc)*(dpc-al(k)) .le. 0._f ) then + al(k) = dpc + ar(k) = dpc + endif + + if( (ar(k)-al(k))*( dpc - 0.5_f*(al(k)+ar(k)) ) .gt. 1._f/6._f*(ar(k)-al(k))**2 ) & + al(k) = 3._f*dpc - 2._f*ar(k) + + if( (ar(k)-al(k))*( dpc - 0.5_f*(al(k)+ar(k)) ) .lt. -1._f/6._f*(ar(k)-al(k))**2 ) & + ar(k) = 3._f*dpc - 2._f*al(k) + enddo + + ! Calculate fluxes across each layer boundary + do k = 1,NZ + dpc = cvert(k) / dz(k) + dela(k) = ar(k) - al(k) + a6(k) = 6._f * ( dpc - 0.5_f*(ar(k)+al(k)) ) + enddo + + do k = 1,NZ-1 + com2 = ( dz(k) + dz(k+1) ) / 2._f + x = vtrans(k+1)*dtime/dz(k) + xpos = abs(x) + + ! Upward transport rate + if( vtrans(k+1) .gt. 0._f )then + + if( x .lt. 1._f .and. cvert(k) .ne. 0._f )then + vertadvu(k+1) = ( vtrans(k+1) * com2 ) * ( ( ar(k) - 0.5_f*dela(k)*x + & + (x/2._f - (x**2)/3._f)*a6(k) ) / cvert(k) ) + + ! If Courant # > 1, use upwind advection + else + vertadvu(k+1) = vtrans(k+1) + endif + + ! Downward transport rate + elseif( vtrans(k+1) .lt. 0._f )then + + if( x .gt. -1._f .and. cvert(k+1) .ne. 0._f )then + vertadvd(k+1) = ( -vtrans(k+1) * com2 ) * & + ( ( al(k+1) + 0.5_f*dela(k+1)*xpos + & + ( xpos/2._f - (xpos**2)/3._f)*a6(k+1) ) / cvert(k+1) ) + else + vertadvd(k+1) = -vtrans(k+1) + endif + endif + + enddo ! k = 1,NZ-1 + + ! Lower boundary transport rates: If I_FIXED_CONC boundary + ! condtion is selected, then use concentration assumed just beyond + ! the lowest layer edge to calculate the transport rate across + ! the bottom boundary of the model. + if( ibbnd .eq. I_FIXED_CONC ) then + + com2 = ( dz(1) + dz(itwo) ) / 2._f + x = vtrans(1)*dtime/dz(1) + xpos = abs(x) + cvert0 = cvert_bbnd + if( vtrans(1) .gt. 0._f )then + + if( x .lt. 1._f .and. cvert0 .ne. 0._f )then + vertadvu(1) = vtrans(1)/cvert0*com2 & + * ( ar(1) - 0.5_f*dela(1)*x + & + (x/2._f - (x**2)/3._f)*a6(1) ) + else + vertadvu(1) = vtrans(1) + endif + + elseif( vtrans(1) .lt. 0._f )then + + if( x .gt. -1._f .and. cvert(1) .ne. 0._f )then + vertadvd(1) = -vtrans(1)/ & + cvert(1)*com2 & + * ( al(1) + 0.5_f*dela(1)*xpos + & + (xpos/2._f - (xpos**2)/3._f)*a6(1) ) + else + vertadvd(1) = -vtrans(1) + endif + endif + endif + + ! Upper boundary transport rates + if( itbnd .eq. I_FIXED_CONC ) then + + com2 = ( dz(NZ) + dz(nzm1) ) / 2._f + x = vtrans(NZ+1)*dtime/dz(NZ) + xpos = abs(x) + cvertnzp1 = cvert_tbnd + + if( vtrans(NZ+1) .gt. 0._f )then + + if( x .lt. 1._f .and. cvert(NZ) .ne. 0._f )then + vertadvu(NZ+1) = vtrans(NZ+1)/cvert(NZ)*com2 & + * ( ar(NZ) - 0.5_f*dela(NZ)*x + & + (x/2._f - (x**2)/3._f)*a6(NZ) ) + else + vertadvu(NZ+1) = vtrans(NZ+1) + endif + + elseif( vtrans(NZ+1) .lt. 0._f )then + + if( x .gt. -1._f .and. cvertnzp1 .ne. 0._f )then + vertadvd(NZ+1) = -vtrans(NZ+1)/ & + cvertnzp1*com2 & + * ( al(NZ) + 0.5_f*dela(NZ)*xpos + & + (xpos/2._f - (xpos**2)/3._f)*a6(NZ) ) + else + vertadvd(NZ+1) = -vtrans(NZ+1) + endif + endif + endif + endif + + ! Return to caller with vertical transport rates. + return +end diff --git a/src/physics/carma/base/vertdif.F90 b/src/physics/carma/base/vertdif.F90 new file mode 100644 index 0000000000..25078ca468 --- /dev/null +++ b/src/physics/carma/base/vertdif.F90 @@ -0,0 +1,125 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine calculates vertrical transport rates. +!! Currently treats diffusion only. +!! Not necessarily generalized for irregular grid. +!! +!! @author Eric Jensen +!! @version Dec-1996 +subroutine vertdif(carma, cstate, igroup, ibin, itbnd, ibbnd, vertdifu, vertdifd, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: igroup !! particle group index + integer, intent(in) :: ibin !! particle bin index + integer, intent(in) :: itbnd !! top boundary condition + integer, intent(in) :: ibbnd !! bottom boundary condition + real(kind=f), intent(out) :: vertdifu(NZP1) !! upward vertical diffusion rate into level k from level k-1 [cm/s] + real(kind=f), intent(out) :: vertdifd(NZP1) !! downward vertical diffusion rate into level k from level k-1 [cm/s] + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Local Variables + integer :: k + integer :: nzm1 + integer :: itwo + real(kind=f) :: dz_avg + real(kind=f) :: rhofact + real(kind=f) :: xex + real(kind=f) :: ttheta + + + ! Set some constants + nzm1 = max( 1, NZ-1 ) + itwo = min( 2, NZ ) + + ! Loop over vertical levels. + do k = 2, NZ + + dz_avg = dz(k) ! layer thickness + + ! Check the vertical coordinate + + if( igridv .eq. I_CART ) then + rhofact = log( rhoa(k)/rhoa(k-1) & + * zmet(k-1)/zmet(k) ) + xex = rhoa(k-1)/rhoa(k) * & + zmet(k)/zmet(k-1) + vertdifu(k) = ( rhofact * dkz(k, ibin, igroup) / dz_avg ) / ( 1._f - xex ) + + vertdifd(k) = vertdifu(k) * xex + + + ! ...else you're in sigma or hybrid coordinates... + elseif(( igridv .eq. I_SIG ) .or. ( igridv .eq. I_HYBRID )) then + vertdifu(k) = dkz(k, ibin, igroup) / dz_avg + vertdifd(k) = dkz(k, ibin, igroup) / dz_avg + + ! ...else write an error (maybe redundant)... + else + if (do_print) write(LUNOPRT,*) 'vertdif::ERROR - Invalid vertical grid type (', igridv, ').' + rc = -1 + return + endif + enddo + + ! Fluxes at boundaries specified by user + if( ibbnd .eq. I_FLUX_SPEC ) then + vertdifu(1) = 0._f + vertdifd(1) = 0._f + endif + + if( itbnd .eq. I_FLUX_SPEC ) then + vertdifu(NZ+1) = 0._f + vertdifd(NZ+1) = 0._f + endif + + ! Diffusion across boundaries using fixed boundary concentration: + if( ibbnd .eq. I_FIXED_CONC ) then + dz_avg = dz(1) ! layer thickness + rhofact = log( rhoa(itwo)/rhoa(1) ) + ttheta = rhofact + if( ttheta .ge. 0._f ) then + ttheta = min(ttheta,POWMAX) + else + ttheta = max(ttheta,-POWMAX) + endif + + xex = exp(-ttheta) + if( abs(ONE - xex) .lt. ALMOST_ZERO ) xex = ALMOST_ONE + + vertdifu(1) = ( rhofact * dkz(1, ibin, igroup) / dz_avg ) / ( 1._f - xex ) + vertdifd(1) = vertdifu(1) * xex + endif + + if( itbnd .eq. I_FIXED_CONC ) then + dz_avg = dz(NZ) ! layer thickness + rhofact = log( rhoa(NZ)/rhoa(nzm1) ) + ttheta = rhofact + if( ttheta .ge. 0._f ) then + ttheta = min(ttheta,POWMAX) + else + ttheta = max(ttheta,-POWMAX) + endif + + xex = exp(-ttheta) + if( abs(ONE - xex) .lt. ALMOST_ZERO ) xex = ALMOST_ONE + + vertdifu(NZ+1) = ( rhofact * dkz(NZ+1, ibin, igroup) / dz_avg ) / ( 1._f - xex ) + vertdifd(NZ+1) = vertdifu(NZ+1) * xex + endif + + ! Return to caller with vertical diffusion rates. + return +end diff --git a/src/physics/carma/base/vertical.F90 b/src/physics/carma/base/vertical.F90 new file mode 100644 index 0000000000..2a2173880f --- /dev/null +++ b/src/physics/carma/base/vertical.F90 @@ -0,0 +1,110 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine drives the vertical transport calculations. +!! +!! NOTE: Since this is only for sedimentation and brownian diffusion of a column within +!! a parent model, the advection of air density, gases and potential temperature have +!! been removed. Also, the divergence corrections (divcor) for 1D transport are not +!! applied, since these columns exist within a parent model that is responsible for the +!! advection. +!! +!! @author Eric Jensen +!! version Mar-1995 +subroutine vertical(carma, cstate, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(inout) :: rc !! return code, negative indicates failure + + ! Declare local variables + integer :: ielem + integer :: ibin + integer :: ig + real(kind=f) :: vertadvu(NZP1) + real(kind=f) :: vertadvd(NZP1) + real(kind=f) :: vertdifu(NZP1) + real(kind=f) :: vertdifd(NZP1) + real(kind=f) :: vtrans(NZP1) + real(kind=f) :: old_pc(NZ) + + rc = RC_OK + + do ielem = 1,NELEM ! Loop over particle elements + ig = igelem(ielem) ! particle group + + ! Should this group participate in sedimentation? + if (grp_do_vtran(ig)) then + + ! Are there enough particles in the column to bother? + if (maxval(pconmax(:,ig)) .gt. FEW_PC) then + + do ibin = 1,NBIN ! Loop over particle mass bins + vtrans(:) = -vf(:,ibin,ig) + + ! If dry deposition is enabled for this group, then set + ! the deposition velocity at the surface. + if (grp_do_drydep(ig)) then + if (igridv .eq. I_CART) then + vtrans(1) = -vd(ibin, ig) + else + vtrans(NZP1) = -vd(ibin, ig) + end if + end if + + ! Calculate particle transport rates due to vertical advection + ! and vertical diffusion, and solve for concentrations at end of time step. + call vertadv(carma, cstate, vtrans, pc(:,ibin,ielem), itbnd_pc, ibbnd_pc, & + pc_topbnd(ibin,ielem), pc_botbnd(ibin,ielem), vertadvu, vertadvd, rc) + if (rc < RC_OK) return + + call vertdif(carma, cstate, ig, ibin, itbnd_pc, ibbnd_pc, vertdifu, vertdifd, rc) + if (rc < RC_OK) return + + old_pc(:) = pc(:,ibin,ielem) + + ! There are 2 different solvers, versol with uses a PPM scheme and versub + ! which using an explicit substepping approach. + if (do_explised) then + call versub(carma, cstate, pconmax(:,ig)*xmet(:)*ymet(:)*zmet(:), pc(:,ibin,ielem), itbnd_pc, ibbnd_pc, & + ftoppart(ibin,ielem), fbotpart(ibin,ielem), & + pc_topbnd(ibin,ielem), pc_botbnd(ibin,ielem), & + vertadvu, vertadvd, vertdifu, vertdifd, rc) + if (rc < RC_OK) return + else + call versol(carma, cstate, pc(:,ibin,ielem), itbnd_pc, ibbnd_pc, & + ftoppart(ibin,ielem), fbotpart(ibin,ielem), & + pc_topbnd(ibin,ielem), pc_botbnd(ibin,ielem), & + vertadvu, vertadvd, vertdifu, vertdifd, rc) + if (rc < RC_OK) return + end if + + ! A clunky way to get the mass flux to the surface and to conserve mass + ! is to determine the total before and after. Anything lost went to the + ! surface. + ! + ! NOTE: This only works if you assume nothing is lost out the top. It would be + ! better to figure out how to get this directly from versol. + pc_surf(ibin,ielem) = pc_surf(ibin, ielem) + sum(old_pc(:) * dz(:) / xmet(:) / ymet(:)) - & + sum(pc(:,ibin,ielem) * dz(:) / xmet(:) / ymet(:)) + sedimentationflux(ibin,ielem) = ( sum(old_pc(:) * dz(:) / xmet(:) / ymet(:)) - & + sum(pc(:,ibin,ielem) * dz(:) / xmet(:) / ymet(:)) ) / dtime + enddo ! ibin + endif + endif + enddo ! ielem + + ! Return to caller with new particle concentrations. + return +end diff --git a/src/physics/carma/base/wetr.F90 b/src/physics/carma/base/wetr.F90 new file mode 100644 index 0000000000..814232e19e --- /dev/null +++ b/src/physics/carma/base/wetr.F90 @@ -0,0 +1,240 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +module wetr + +contains + + !! This routine calculates the wet radius for hydrophilic particles that are + !! assumed to grow in size based upon the realtive humidity. + !! + !! Parameterizations based upon Fitzgerald [1975] and Gerber [1985] are support and the + !! particles are assumed to be spherical. + !! + !! @author Chuck Bardeen, Pete Colarco + !! @version May-2009 from Nov-2000 + subroutine getwetr(carma, igroup, rh, rdry, rwet, rhopdry, rhopwet, rc, h2o_mass, h2o_vp, temp) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + use sulfate_utils + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + integer, intent(in) :: igroup !! group index + real(kind=f), intent(in) :: rh !! relative humidity + real(kind=f), intent(in) :: rdry !! dry radius [cm] + real(kind=f), intent(out) :: rwet !! wet radius [cm] + real(kind=f), intent(in) :: rhopdry !! dry radius [cm] + real(kind=f), intent(out) :: rhopwet !! wet radius [cm] + integer, intent(inout) :: rc !! return code, negative indicates failure + real(kind=f), intent(in), optional :: h2o_mass!! water vapor mass concentration (g/cm3) + real(kind=f), intent(in), optional :: h2o_vp !! water eq. vaper pressure (dynes/cm2) + real(kind=f), intent(in), optional :: temp !! temperature [K] + + ! Local declarations + real(kind=f) :: humidity + real(kind=f) :: r_ratio + real(kind=f) :: wtpkelv, den1, den2, drho_dwt + real(kind=f) :: sigkelv, sig1, sig2, dsigma_dwt + real(kind=f) :: rkelvinH2O_a, rkelvinH2O_b, rkelvinH2O, h2o_kelv + + ! The following parameters relate to the swelling of seasalt like particles + ! following Fitzgerald, Journal of Applied Meteorology, [1975]. + ! + ! Question - Should epsilon be 1._f? It means alpharat is 1 by definition. + real(kind=f), parameter :: epsilon_ = 1._f ! soluble fraction of deliquescing particle + real(kind=f) :: alphaComp + real(kind=f) :: alpha + real(kind=f) :: alpha1 + real(kind=f) :: alpharat + real(kind=f) :: beta + real(kind=f) :: theta + real(kind=f) :: f1 + real(kind=f) :: f2 + + ! Parameters from Gerber [1985] + real(kind=f) :: c1 + real(kind=f) :: c2 + real(kind=f) :: c3 + real(kind=f) :: c4 + + ! Define formats + 1 format(/,'Non-spherical particles specified for group ',i3, & + ' (ishape=',i3,') but spheres assumed in wetr.f.'/) + + ! If humidty affects the particle, then determine the equilbirium + ! radius and density based upon the relative humidity. + if (irhswell(igroup) == I_NO_SWELLING) then + + ! No swelling, just use the dry values. + rwet = rdry + rhopwet = rhopdry + else + + ! Warning message for non-spherical particles! + if( ishape(igroup) .ne. I_SPHERE )then + if (do_print) write(LUNOPRT,1) igroup, ishape(igroup) + rc = RC_ERROR + return + endif + + ! The Parameterizations don't handly relative humidities of 0, and + ! behave poorly when RH > 0.995, so cap the relative humidity + ! used to these values. + humidity = min(max(rh,tiny(1.0_f)), 0.995_f) + + ! Fitzgerald Parameterization + if (irhswell(igroup) == I_FITZGERALD) then + + ! Calculate the alpha and beta parameters for the wet particle + ! relative to amonium sulfate + beta = exp((0.00077_f * humidity) / (1.009_f - humidity)) + if (humidity .le. 0.97_f) then + theta = 1.058_f + else + theta = 1.058_f - (0.0155_f * (humidity - 0.97_f)) / (1.02_f - humidity**1.4_f) + endif + + alpha1 = 1.2_f * exp((0.066_f * humidity) / (theta - humidity)) + f1 = 10.2_f - 23.7_f * humidity + 14.5_f * humidity**2 + f2 = -6.7_f + 15.5_f * humidity - 9.2_f * humidity**2 + alpharat = 1._f - f1 * (1._f - epsilon_) - f2 * (1._f - epsilon_**2) + + ! Scale the size based on the composition of the particle. + select case(irhswcomp(igroup)) + + case (I_SWF_NH42SO4) + alphaComp = 1.00_f + + case(I_SWF_NH4NO3) + alphaComp = 1.06_f + + case(I_SWF_NANO3) + alphaComp = 1.17_f + + case(I_SWF_NH4CL) + alphaComp = 1.23_f + + case(I_SWF_CACL2) + alphaComp = 1.29_f + + case(I_SWF_NABR) + alphaComp = 1.32_f + + case(I_SWF_NACL) + alphaComp = 1.35_f + + case(I_SWF_MGCL2) + alphaComp = 1.41_f + + case(I_SWF_LICL) + alphaComp = 1.54_f + + case default + if (do_print) write(LUNOPRT,*) "wetr:: ERROR - Unknown composition type (", irhswcomp(igroup), & + ") for Fitzgerald." + rc = RC_ERROR + return + end select + + alpha = alphaComp * (alpha1 * alpharat) + + ! Determine the wet radius. + ! + ! NOTE: Fitgerald's equations assume r in [um], so scale the cgs units + ! appropriately. + rwet = (alpha * (rdry * 1e4_f)**beta) * (1e-4_f) + + ! Determine the wet density from the wet radius. + r_ratio = (rdry / rwet)**3 + rhopwet = r_ratio * rhopdry + (1._f - r_ratio) * RHO_W + end if + + + ! Gerber Paremeterization + if (irhswell(igroup) == I_GERBER) then + + ! Scale the size based on the composition of the particle. + select case(irhswcomp(igroup)) + + case (I_SWG_NH42SO4) + c1 = 0.4809_f + c2 = 3.082_f + c3 = 3.110e-11_f + c4 = -1.428_f + + case(I_SWG_URBAN) + c1 = 0.3926_f + c2 = 3.101_f + c3 = 4.190e-11_f + c4 = -1.404_f + + case(I_SWG_RURAL) + c1 = 0.2789_f + c2 = 3.115_f + c3 = 5.415e-11_f + c4 = -1.399_f + + case(I_SWG_SEA_SALT) + c1 = 0.7674_f + c2 = 3.079_f + c3 = 2.572e-11_f + c4 = -1.424_f + + case default + if (do_print) write(LUNOPRT,*) "wetr:: ERROR - Unknown composition type (", irhswcomp(igroup), & + ") for Gerber." + rc = RC_ERROR + return + end select + + rwet = ((c1 * rdry**c2 / (c3 * rdry**c4 - log10(humidity))) + rdry**3)**(1._f / 3._f) + + ! Determine the wet density from the wet radius. + r_ratio = (rdry / rwet)**3 + rhopwet = r_ratio * rhopdry + (1._f - r_ratio) * RHO_W + end if + end if + + + ! Sulfate Aerosol, using weight percent. + if (irhswell(igroup) == I_WTPCT_H2SO4) then + + ! Adjust calculation for the Kelvin effect of H2O: + wtpkelv = 80._f ! start with assumption of 80 wt % H2SO4 + den1 = 2.00151_f - 0.000974043_f * temp ! density at 79 wt % + den2 = 2.01703_f - 0.000988264_f * temp ! density at 80 wt % + drho_dwt = den2-den1 ! change in density for change in 1 wt % + + sig1 = 79.3556_f - 0.0267212_f * temp ! surface tension at 79.432 wt % + sig2 = 75.608_f - 0.0269204_f * temp ! surface tension at 85.9195 wt % + dsigma_dwt = (sig2-sig1) / (85.9195_f - 79.432_f) ! change in density for change in 1 wt % + sigkelv = sig1 + dsigma_dwt * (80.0_f - 79.432_f) + + rwet = rdry * (100._f * rhopdry / wtpkelv / den2)**(1._f / 3._f) + + rkelvinH2O_b = 1._f + wtpkelv * drho_dwt / den2 - 3._f * wtpkelv & + * dsigma_dwt / (2._f*sigkelv) + + rkelvinH2O_a = 2._f * gwtmol(igash2so4) * sigkelv / (den1 * RGAS * temp * rwet) + + rkelvinH2O = exp (rkelvinH2O_a*rkelvinH2O_b) + + h2o_kelv = h2o_mass / rkelvinH2O + wtpkelv = wtpct_tabaz(carma, temp, h2o_kelv, h2o_vp, rc) + rhopwet = sulfate_density(carma, wtpkelv, temp, rc) + rwet = rdry * (100._f * rhopdry / wtpkelv / rhopwet)**(1._f / 3._f) + end if + + ! Return to caller with wet radius evaluated. + return + end subroutine +end module diff --git a/src/physics/carma/base/zeromicro.F90 b/src/physics/carma/base/zeromicro.F90 new file mode 100644 index 0000000000..6e03a85862 --- /dev/null +++ b/src/physics/carma/base/zeromicro.F90 @@ -0,0 +1,52 @@ +! Include shortname defintions, so that the F77 code does not have to be modified to +! reference the CARMA structure. +#include "carma_globaer.h" + +!! This routine zeroes the fast microphysics sinks and sources, +!! at one spatial point per call. +!! +!! @author Andy Ackerman +!! @version Oct-1997 +subroutine zeromicro(carma, cstate, iz, rc) + + ! types + use carma_precision_mod + use carma_enums_mod + use carma_constants_mod + use carma_types_mod + use carmastate_mod + use carma_mod + + implicit none + + type(carma_type), intent(in) :: carma !! the carma object + type(carmastate_type), intent(inout) :: cstate !! the carma state object + integer, intent(in) :: iz !! vertical index + integer, intent(inout) :: rc !! return code, negative indicates failure + + + ! Set production terms and loss rates due to nucleation, growth, + ! and evaporation to zero. Also set index of smallest bin nuceleated + ! during time step equal to first time through spatial loop. + + if (do_grow) then + + phprod = 0._f + rlprod = 0._f + dtpart(iz,:,:) = 0._f + + if (NGAS > 0) gasprod(:) = 0._f + + rhompe(:, :) = 0._f + rnucpe(:,:) = 0._f + growpe(:,:) = 0._f + evappe(:,:) = 0._f + rnuclg(:,:,:) = 0._f + growlg(:,:) = 0._f + evaplg(:,:) = 0._f + + end if + + ! Return to caller with fast microphysics sinks and sources zeroed. + return +end diff --git a/src/physics/clubb/ChangeLog b/src/physics/clubb/ChangeLog new file mode 100644 index 0000000000..7aaaa2109d --- /dev/null +++ b/src/physics/clubb/ChangeLog @@ -0,0 +1,119 @@ +====================================================================== +Tag: vendor_clubb_r8099_n02 +Tag creator: cacraig, vlarson +Date created: Oct 4, 2017 + +Comment: + This tag was created to bring in the changes to saturation.F90 (rev 8471) from Vince Larson. Vince's comment follows: + + "I clipped temperature within the Goff-Gratch functions for saturation over liquid and ice. + The goal was to avoid the creation of NaNs that caused CAM to crash over the Himalayas. + The result of applying a minimal threshold on temperature is to set saturation to the same small + value in all cold areas. + + To test the code change, I ran the priority single-column cases and determined that the new code + produces bin-diff identical results for these cases. That just means that these cases are not cold. + However, the code change might increase + saturation in cold areas in CAM, thereby diminishing condensation in the upper atmosphere. + It would be prudent to check a WACCM simulation for degradation. If there is degradation, + the minimum temperatures could be set to smaller values." + +Command(s) issued: + svn co http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core (revision # at UWM was 8471) + replace saturation.F90 + +Status: +M saturation.F90 +M ChangeLog + +====================================================================== +Tag: clubb_r8099 +Tag creator: bogensch +Date created: May 17, 2016 +Command(s) issued: + svn co https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_trunk + cd vendor_trunk + svn merge -r8029:8099 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core + +Status: +M ChangeLog +M advance_clubb_core_module.F90 +M advance_helper_module.F90 +M advance_windm_edsclrm_module.F90 +M advance_wp2_wp3_module.F90 +M advance_xm_wpxp_module.F90 +M clubb_api_module.F90 +M model_flags.F90 +M parameter_indices.F90 +M parameters_tunable.F90 +M stats_variables.F90 +M stats_zm_module.F90 +M stats_zt_module.F90 + +====================================================================== +Tag: clubb_r8029 +Tag creator: cacraig +Date created: April 7, 2016 +Command(s) issued: + svn co https://svn-ccsm-models.cgd.ucar.edu/clubb_core/vendor_trunk clubb_r8029-TRUNK + cd clubb_r8029-TRUNK + svn merge -r7416:8029 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core + svn resolve --accept=working Skw_module.F90 + svn delete Skw_module.F90 + +Status: +M ChangeLog +A Skx_module.F90 +D Skw_module.F90 +M advance_clubb_core_module.F90 +M advance_helper_module.F90 +M advance_xm_wpxp_module.F90 +A calc_roots.F90 +M clubb_api_module.F90 +A code_timer_module.F90 +M constants_clubb.F90 +M corr_varnce_module.F90 +M csr_matrix_module.F90 +M endian.F90 +M file_functions.F90 +M gmres_cache.F90 +M grid_class.F90 +M hydromet_pdf_parameter_module.F90 +M input_reader.F90 +M interpolation.F90 +M matrix_operations.F90 +M model_flags.F90 +M mt95.f90 +M output_grads.F90 +M output_netcdf.F90 +M parameter_indices.F90 +M parameters_model.F90 +M parameters_tunable.F90 +M pdf_closure_module.F90 +M pdf_parameter_module.F90 +M pdf_utilities.F90 +A precipitation_fraction.F90 +M saturation.F90 +M setup_clubb_pdf_params.F90 +M sponge_layer_damping.F90 +M stat_file_module.F90 +M stats_clubb_utilities.F90 +M stats_lh_zt_module.F90 +M stats_sfc_module.F90 +M stats_type.F90 +M stats_type_utilities.F90 +M stats_variables.F90 +M stats_zm_module.F90 +M stats_zt_module.F90 +M variables_diagnostic_module.F90 +M variables_prognostic_module.F90 + +====================================================================== +Tag: clubb_r7416 +Tag creator: cacraig +Date created: April 7, 2016 +Command(s) issued: + svn co -r7416 http://carson.math.uwm.edu/repos/clubb_repos/trunk/src/CLUBB_core clubb_r7416 + svn import clubb_r7416 http://svn-ccsm-models.cgd.ucar.edu/clubb_core_vendor_trunk -m"Initial checkout of revision 7416 + +====================================================================== diff --git a/src/physics/clubb/Nc_Ncn_eqns.F90 b/src/physics/clubb/Nc_Ncn_eqns.F90 new file mode 100644 index 0000000000..a6fcc43c1d --- /dev/null +++ b/src/physics/clubb/Nc_Ncn_eqns.F90 @@ -0,0 +1,963 @@ +!--------------------------------------------------------------------------- +! $Id: Nc_Ncn_eqns.F90 7130 2014-07-29 23:29:54Z raut@uwm.edu $ +!=============================================================================== +module Nc_Ncn_eqns + + ! Description: + ! Equations are provided to perform calculations back-and-forth between Nc and + ! Ncn, where Nc is cloud droplet concentration and Ncn is simplified cloud + ! nuclei concentration. The equation that relates the two is: + ! + ! Nc = Ncn * H(chi); + ! + ! where chi is extended liquid water mixing ratio, which is equal to cloud + ! water mixing ratio, rc, when both are positive. However, chi is negative in + ! subsaturated air. + ! + ! Equation are provided relating mean cloud droplet concentration (overall), + ! Ncm, and/or mean cloud droplet concentration (in-cloud), Nc_in_cloud, to + ! mean simplified cloud nuclei concentration, Ncnm. + + ! Notes: + ! + ! Meaning of Nc flag combinations: + ! + ! l_const_Nc_in_cloud: + ! When this flag is enabled, cloud droplet concentration (in-cloud) is + ! constant (spatially) at a grid level (it is constant over the subgrid + ! domain, but could vary over time depending on the value of l_predict_Nc). + ! The value of in-cloud Nc does not vary at a grid level. This also means + ! that Ncn is constant across the entire grid level. When this flag is turned + ! off, both in-cloud Nc and Ncn vary at a grid level. + ! + ! l_predict_Nc: + ! When this flag is enabled, Nc_in_cloud (or alternatively Ncm) is predicted. + ! It is advanced every time step by a predictive equation, and can change + ! at every time step at a grid level. When this flag is turned off, + ! Nc_in_cloud does not change at a grid level over the course of a model run. + ! + ! 1) l_predict_Nc turned on and l_const_Nc_in_cloud turned on: + ! The value of Nc_in_cloud (mean in-cloud Nc) is predicted and can change + ! at every timestep at a grid level. However, the value of in-cloud Nc is + ! constant (spatially) at a grid level (no subgrid variability). + ! + ! 2) l_predict_Nc turned on and l_const_Nc_in_cloud turned off: + ! The value of Nc_in_cloud (mean in-cloud Nc) is predicted and can change + ! at every timestep at a grid level. The value of in-cloud Nc also varies + ! (spatially) at a grid level (subgrid variability around mean + ! in-cloud Nc). + ! + ! 3) l_predict_Nc turned off and l_const_Nc_in_cloud turned on: + ! The value of Nc_in_cloud (mean in-cloud Nc) is constant over time at a + ! grid level. It retains its initial value. Additionally, the value of + ! in-cloud Nc is constant (spatially) at a grid level (no subgrid + ! variability). This configuration is used most often in idealized cases. + ! + ! 4) l_predict_Nc turned off and l_const_Nc_in_cloud turned off: + ! The value of Nc_in_cloud (mean in-cloud Nc) is constant over time at a + ! grid level. It retains its initial value. However, the value of + ! in-cloud Nc varies (spatially) at a grid level (subgrid variability + ! around mean in-cloud Nc). + ! + ! + ! + ! Nc_in_cloud/Nc - Ncn flow chart of CLUBB code: + ! + ! (Please update when warranted). + ! + ! + ! Ncm/Nc-in-cloud Ncnm/Ncn PDF params. + ! ---> + ! | | Start of CLUBB main time step loop + ! | | + ! | | advance_clubb_core + ! | | + ! | | + ! | |\ + ! | | \ + ! | | (intent in)-------setup_pdf_parameters-------->calc. Ncnm (local) + ! | | | + ! | | \ / + ! | | mu_Ncn_i, sigma_Ncn_i, + ! | | corr_xNcn_i + ! | | | + ! | | \ / + ! | | PDF param. arrays: + ! | | mu_x_i_n, sigma_x_i_n, + ! | | corr_array_i_n + ! | | (intent out) + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | |--(intent in)-------microphys_schemes-------------(intent in) + ! | | | + ! | | | + ! | | call a microphysics scheme + ! | | | + ! | | Local micro. scheme-----------Latin Hypercube-----------Upscaled KK + ! | | | | | + ! | | Ncm/Nc-in-cloud: Populate sample points Use PDF params. + ! | | used to find micro. using PDF params (Ncn). of Ncn + ! | | tendencies. At every sample point: (mu_Ncn_i, etc.) + ! | | | Nc = Ncn * H(chi). to find micro. + ! | | | Use sample-point Nc to tendencies. + ! | | | find micro. tendencies | + ! | | | when calling micro. scheme. | + ! | | | | | + ! | | hydromet_mc/-----------------hydromet_mc/-------------hydromet_mc + ! | | Ncm_mc (intent out) | Ncm_mc (intent out) (intent out) + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | | + ! | | (intent in) + ! | | | + ! | |--(intent inout)----advance_microphys + ! | | + ! | | + ! | | advance microphysics variables (hydromet, Nc_in_cloud/Ncm) one timestep + ! | | + ! | | l_predict_Nc = true: + ! | | Nc_in_cloud/Ncm necessary for starting + ! | | value of Nc_in_cloud/Ncm when advancing + ! | | one timestep using predictive equation. + ! | | + ! | | + ! | | End of CLUBB main time step loop + ! <--- + + ! References: + !------------------------------------------------------------------------- + + implicit none + + private ! default scope + + public :: Ncnm_to_Nc_in_cloud, & + Nc_in_cloud_to_Ncnm, & + Ncnm_to_Ncm, & + Ncm_to_Ncnm + + private :: bivar_NL_chi_Ncn_mean, & + bivar_Ncnm_eqn_comp + +contains + + !============================================================================= + function Ncnm_to_Nc_in_cloud( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac, & + cloud_frac_1, cloud_frac_2 ) & + result( Nc_in_cloud ) + + ! Description: + ! The in-cloud mean of cloud droplet concentration is calculated from the + ! PDF parameters involving simplified cloud nuclei concentration, Ncn, and + ! cloud fraction. At any point, cloud droplet concentration, Nc, is given + ! by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is calculated from + ! the PDF parameters involving Ncn. The in-cloud mean of cloud droplet + ! concentration is calculated from and cloud fraction. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + cloud_frac_min + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF comp.) [num/kg] + sigma_Ncn_2, & ! Standard deviation of Ncn (2nd PDF comp.) [num/kg] + sigma_Ncn_1_n, & ! Standard deviation of ln Ncn (1st PDF component) [-] + sigma_Ncn_2_n, & ! Standard deviation of ln Ncn (2nd PDF component) [-] + corr_chi_Ncn_1_n, & ! Correlation of chi and ln Ncn (1st PDF comp.) [-] + corr_chi_Ncn_2_n, & ! Correlation of chi and ln Ncn (2nd PDF comp.) [-] + mixt_frac, & ! Mixture fraction [-] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2 ! Cloud fraction (2nd PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Nc_in_cloud ! Mean cloud droplet concentration (in-cloud) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + Ncm, & ! Mean cloud droplet concentration (overall) [num/kg] + cloud_frac ! Cloud fraction [-] + + + ! Calculate overall cloud fraction as calculated by the PDF. + ! The variable cloud_frac is not used here because it is altered by factors + ! such as the trapezoidal rule calculation. + ! Cloud fraction can be recalculated here from cloud_frac_1 and cloud_frac_2 + ! as long neither of these variables are altered by any factor. They can + ! only be calculated from PDF. + cloud_frac = mixt_frac * cloud_frac_1 + ( one - mixt_frac ) * cloud_frac_2 + + if ( cloud_frac > cloud_frac_min ) then + + ! There is cloud found at this grid level. Calculate Nc_in_cloud. + Ncm = Ncnm_to_Ncm( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac ) + + Nc_in_cloud = Ncm / cloud_frac + + else ! cloud_frac <= cloud_frac_min + + ! This level is entirely clear. Set Nc_in_cloud to . + ! Since = mu_Ncn_1 = mu_Ncn_2, use mu_Ncn_1 here. + Nc_in_cloud = mu_Ncn_1 + + endif + + + return + + end function Ncnm_to_Nc_in_cloud + + !============================================================================= + function Nc_in_cloud_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, & + sigma_chi_2, mixt_frac, Nc_in_cloud, & + cloud_frac_1, cloud_frac_2, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) & + result( Ncnm ) + + ! Description: + ! The overall mean of simplified cloud nuclei concentration, , is + ! calculated from the in-cloud mean of cloud droplet concentration, , + ! cloud fraction, and some of the PDF parameters. + ! + ! At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is calculated from + ! Nc_in_cloud and cloud fraction. The value of is calculated from + ! and PDF parameters. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + cloud_frac_min + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + Nc_in_cloud, & ! Mean cloud droplet conc. (in-cloud) [num/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn ! Prescribed correlation of chi and Ncn [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncnm ! Mean simplified cloud nuclei concentration (overall) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + Ncm, & ! Mean cloud droplet concentration (overall) [num/kg] + cloud_frac ! Cloud fraction [-] + + + ! Calculate overall cloud fraction as calculated by the PDF. + ! The variable cloud_frac is not used here because it is altered by factors + ! such as the trapezoidal rule calculation. + ! Cloud fraction can be recalculated here from cloud_frac_1 and cloud_frac_2 + ! as long neither of these variables are altered by any factor. They can + ! only be calculated from the PDF. + cloud_frac = mixt_frac * cloud_frac_1 + ( one - mixt_frac ) * cloud_frac_2 + + if ( cloud_frac > cloud_frac_min & + .and. const_corr_chi_Ncn * const_Ncnp2_on_Ncnm2 /= zero ) then + + ! There is cloud found at this grid level. Additionally, Ncn varies. + ! Calculate Nc_in_cloud. + Ncm = Nc_in_cloud * cloud_frac + + Ncnm = Ncm_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, sigma_chi_2, & + mixt_frac, Ncm, const_Ncnp2_on_Ncnm2, & + const_corr_chi_Ncn, Nc_in_cloud ) + + else ! cloud_frac <= cloud_frac_min .or. const_Ncnp2_on_Ncnm2 = 0 + + ! When Ncn is constant a a grid level, it is equal to Nc_in_cloud. + ! Additionally, when a level is entirely clear, , which is based on + ! Nc_in_cloud, here, must be set to something. Set to Nc_in_cloud. + Ncnm = Nc_in_cloud + + endif + + + return + + end function Nc_in_cloud_to_Ncnm + + !============================================================================= + function Ncnm_to_Ncm( mu_chi_1, mu_chi_2, mu_Ncn_1, mu_Ncn_2, & + sigma_chi_1, sigma_chi_2, sigma_Ncn_1, & + sigma_Ncn_2, sigma_Ncn_1_n, sigma_Ncn_2_n, & + corr_chi_Ncn_1_n, corr_chi_Ncn_2_n, mixt_frac ) & + result( Ncm ) + + ! Description: + ! The overall mean of cloud droplet concentration, , is calculated from + ! the PDF parameters involving the simplified cloud nuclei concentration, + ! Ncn. At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is found by + ! integrating over the PDF of chi and Ncn, such that: + ! + ! = INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P(chi,Ncn) dNcn dchi; + ! + ! which can also be written as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! where n is the number of multivariate joint PDF components, mixt_frac_i is + ! the weight of the ith PDF component, and P_i is the functional form of the + ! multivariate joint PDF in the ith PDF component. + ! + ! This equation is rewritten as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF comp.) [num/kg] + sigma_Ncn_2, & ! Standard deviation of Ncn (2nd PDF comp.) [num/kg] + sigma_Ncn_1_n, & ! Standard deviation of ln Ncn (1st PDF component) [-] + sigma_Ncn_2_n, & ! Standard deviation of ln Ncn (2nd PDF component) [-] + corr_chi_Ncn_1_n, & ! Correlation of chi and ln Ncn (1st PDF comp.) [-] + corr_chi_Ncn_2_n, & ! Correlation of chi and ln Ncn (2nd PDF comp.) [-] + mixt_frac ! Mixture fraction [-] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncm ! Mean cloud droplet concentration (overall) [num/kg] + + + ! Calculate mean cloud droplet concentration (overall), . + Ncm & + = mixt_frac & + * bivar_NL_chi_Ncn_mean( mu_chi_1, mu_Ncn_1, sigma_chi_1, & + sigma_Ncn_1, sigma_Ncn_1_n, corr_chi_Ncn_1_n ) & + + ( one - mixt_frac ) & + * bivar_NL_chi_Ncn_mean( mu_chi_2, mu_Ncn_2, sigma_chi_2, & + sigma_Ncn_2, sigma_Ncn_2_n, corr_chi_Ncn_2_n ) + + + return + + end function Ncnm_to_Ncm + + !============================================================================= + function Ncm_to_Ncnm( mu_chi_1, mu_chi_2, sigma_chi_1, sigma_chi_2, & + mixt_frac, Ncm, const_Ncnp2_on_Ncnm2, & + const_corr_chi_Ncn, Ncnm_val_denom_0 ) & + result( Ncnm ) + + ! Description: + ! The overall mean of simplified cloud nuclei concentration, , is + ! calculated from the overall mean of cloud droplet concentration, , and + ! some of the PDF parameters. + ! + ! At any point, cloud droplet concentration, Nc, is given by: + ! + ! Nc = Ncn * H(chi); + ! + ! where extended liquid water mixing ratio, chi, is equal to cloud water + ! ratio, rc, when positive. When the atmosphere is saturated at this point, + ! cloud water is found, and Nc = Ncn. Otherwise, only clear air is found, + ! and Nc = 0. + ! + ! The overall mean of cloud droplet concentration, , is found by + ! integrating over the PDF of chi and Ncn, such that: + ! + ! = INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P(chi,Ncn) dNcn dchi; + ! + ! which can also be written as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! where n is the number of multivariate joint PDF components, mixt_frac_i is + ! the weight of the ith PDF component, and P_i is the functional form of the + ! multivariate joint PDF in the ith PDF component. + ! + ! This equation is rewritten as: + ! + ! = SUM(i=1,n) mixt_frac_i + ! * INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! + ! Solving for + ! ================= + ! + ! The individual marginal for simplified cloud nuclei concentration, Ncn, is + ! a single lognormal distribution over the entire horizontal domain. In + ! order to accomplish this in a two-component PDF structure, the PDF + ! parameters involving Ncn are set equal between the two components. This + ! results in: + ! + ! mu_Ncn_1 = mu_Ncn_2 = mu_Ncn_i = ; + ! mu_Ncn_1_n = mu_Ncn_2_n = mu_Ncn_i_n; + ! sigma_Ncn_1 = sigma_Ncn_2 = sigma_Ncn_i = sqrt( ); + ! sigma_Ncn_1_n = sigma_Ncn_2_n = sigma_Ncn_i_n; + ! rho_chi_Ncn_1 = rho_chi_Ncn_2 = rho_chi_Ncn_i = rho_chi_Ncn; and + ! rho_chi_Ncn_1_n = rho_chi_Ncn_2_n = rho_chi_Ncn_i_n. + ! + ! Additionally, the equation for sigma_Ncn_i_n is: + ! + ! sigma_Ncn_i_n = sqrt( ln( 1 + ( sigma_Ncn_i^2 / mu_Ncn_i^2 ) ) ); + ! + ! and the equation for rho_chi_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( exp{ sigma_Ncn_i_n^2 } - 1 ) / sigma_Ncn_i_n. + ! + ! The product of rho_chi_Ncn_i_n and sigma_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( exp{ sigma_Ncn_i_n^2 } - 1 ). + ! + ! After substituting for sigma_Ncn_i_n^2, the equation for the product of + ! rho_chi_Ncn_i_n and sigma_Ncn_i_n is: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn_i * sqrt( sigma_Ncn_i^2 / mu_Ncn_i^2 ); + ! + ! which can be rewritten as: + ! + ! rho_chi_Ncn_i_n * sigma_Ncn_i_n + ! = rho_chi_Ncn * sqrt( / ^2 ). + ! + ! Substituting all of this into the equation for , the equation for + ! becomes: + ! + ! = + ! * SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt(/^2) ) ); + ! | where sigma_chi_i > 0 and > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0. + ! --- + ! + ! In order to isolate , the value of /^2 is set to a + ! constant value, const_Ncn. The value of this constant does not depend on + ! . Likewise, the value of rho_chi_Ncn does not depend on . + ! Solving for , the equation becomes: + ! + ! + ! = / ( SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt( const_Ncn ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0 ). + ! --- + ! + ! When the denominator term is 0, there is only clear air. Both the + ! numerator () and the denominator have a value of 0, and is set + ! to an appropriate value. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + Ncm, & ! Mean cloud droplet conc. (overall) [num/kg] + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn, & ! Prescribed correlation of chi and Ncn [-] + Ncnm_val_denom_0 ! Ncnm value -- denominator in eqn. is 0 [num/kg] + + ! Return Variable + real( kind = core_rknd ) :: & + Ncnm ! Mean simplified cloud nuclei concentration (overall) [num/kg] + + ! Local Variable + real( kind = core_rknd ) :: & + denominator_term ! Denominator in the equation for [-] + + + denominator_term & + = mixt_frac & + * bivar_Ncnm_eqn_comp( mu_chi_1, sigma_chi_1, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) & + + ( one - mixt_frac ) & + * bivar_Ncnm_eqn_comp( mu_chi_2, sigma_chi_2, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + + if ( denominator_term > zero ) then + + Ncnm = Ncm / denominator_term + + else ! denominator_term = 0 + + ! When the denominator is 0, it is usually because there is only clear + ! air. In that scenario, Ncm should also be 0. Set Ncnm to a value that + ! is usual or typical + Ncnm = Ncnm_val_denom_0 + + endif ! denominator_term > 0 + + + return + + end function Ncm_to_Ncnm + + !============================================================================= + function bivar_NL_chi_Ncn_mean( mu_chi_i, mu_Ncn_i, sigma_chi_i, & + sigma_Ncn_i, sigma_Ncn_i_n, corr_chi_Ncn_i_n ) + + ! Description: + ! The double integral over Ncn * H(chi) multiplied by the + ! bivariate normal-lognormal joint PDF of chi and Ncn is evaluated. The + ! integral is given by: + ! + ! INT(-inf:inf) INT(0:inf) Ncn * H(chi) * P_i(chi,Ncn) dNcn dchi; + ! + ! which reduces to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi; + ! + ! where the individual marginal distribution of chi is normal in the ith PDF + ! component and the individual marginal distribution of Ncn is lognormal in + ! the ith PDF component. + ! + ! When both chi and Ncn vary in the ith PDF component, the integral is + ! evaluated and the result is: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * exp{ mu_Ncn_i_n + (1/2) * sigma_Ncn_i_n^2 } + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ); + ! + ! which can be reduced to: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = (1/2) * mu_Ncn_i + ! * erfc( - ( 1 / sqrt(2) ) * ( ( mu_chi_i / sigma_chi_i ) + ! + rho_chi_Ncn_i_n * sigma_Ncn_i_n ) ). + ! + ! When chi is constant, but Ncn varies, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + ! + ! When chi varies, but Ncn is constant, in the ith PDF component, the + ! integral is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi + ! = mu_Ncn_i * (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ). + ! + ! When both chi and Ncn are constant in the ith PDF component, the integral + ! is evaluated and results in: + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = mu_Ncn_i; + ! + ! when mu_chi_i > 0; and + ! + ! INT(0:inf) INT(0:inf) Ncn * P_i(chi,Ncn) dNcn dchi = 0; + ! + ! when mu_chi_i <= 0. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + sqrt_2, & ! Constant(s) + one, & + one_half, & + zero, & + chi_tol, & + Ncn_tol + + use anl_erf, only: & + erfc ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + mu_Ncn_i, & ! Mean of Ncn (ith PDF component) [num/kg] + sigma_chi_i, & ! Standard deviation of chi (ith PDF comp.) [kg/kg] + sigma_Ncn_i, & ! Standard deviation of Ncn (ith PDF comp.) [num/kg] + sigma_Ncn_i_n, & ! Standard deviation of ln Ncn (ith PDF component) [-] + corr_chi_Ncn_i_n ! Correlation of chi and ln Ncn (ith PDF comp.) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + bivar_NL_chi_Ncn_mean + + + if ( sigma_chi_i <=chi_tol .and. sigma_Ncn_i <= Ncn_tol ) then + + ! The ith PDF component variances of both chi and Ncn are 0. + + if ( mu_chi_i > zero ) then + + bivar_NL_chi_Ncn_mean = mu_Ncn_i + + else ! mu_chi_i <= 0 + + bivar_NL_chi_Ncn_mean = zero + + endif + + + elseif ( sigma_chi_i <= chi_tol ) then + + ! The ith PDF component variance of chi is 0. + + if ( mu_chi_i > zero ) then + + bivar_NL_chi_Ncn_mean = mu_Ncn_i + + else ! mu_chi_i <= 0 + + bivar_NL_chi_Ncn_mean = zero + + endif + + + elseif ( sigma_Ncn_i <= Ncn_tol ) then + + ! The ith PDF component variance of Ncn is 0. + + bivar_NL_chi_Ncn_mean & + = mu_Ncn_i * one_half * erfc( - ( mu_chi_i / ( sqrt_2 * sigma_chi_i ) ) ) + + + else + + ! Both chi and Ncn vary in the ith PDF component. + + bivar_NL_chi_Ncn_mean & + = one_half * mu_Ncn_i & + * erfc( - ( one / sqrt_2 ) & + * ( ( mu_chi_i / sigma_chi_i ) & + + corr_chi_Ncn_i_n * sigma_Ncn_i_n ) ) + + + endif + + + return + + end function bivar_NL_chi_Ncn_mean + + !============================================================================= + function bivar_Ncnm_eqn_comp( mu_chi_i, sigma_chi_i, & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + ! Description: + ! When is found based on the value of , the following equation is + ! used: + ! + ! + ! = / ( SUM(i=1,n) mixt_frac_i + ! --- + ! | (1/2) * erfc( - ( 1 / sqrt(2) ) + ! | * ( ( mu_chi_i / sigma_chi_i ) + ! | + rho_chi_Ncn * sqrt( const_Ncn ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn > 0; + ! | + ! * | (1/2) * erfc( - ( mu_chi_i / ( sqrt(2) * sigma_chi_i ) ) ); + ! | where sigma_chi_i > 0 and const_Ncn = 0; + ! | + ! | 1; where sigma_chi_i = 0 and mu_chi_i > 0; + ! | + ! | 0; where sigma_chi_i = 0 and mu_chi_i <= 0 ). + ! --- + ! + ! In the above equation, const_Ncn = / ^2. It is a constant, + ! prescribed parameter. Likewise, rho_chi_Ncn is a parameter that is not + ! based on the value of . + ! + ! When the denominator term is 0, there is only clear air. Both the + ! numerator () and the denominator have a value of 0, and is set + ! to an appropriate value. + ! + ! The contribution of the ith PDF component to the denominator term in the + ! equation is calculated here. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + sqrt_2, & ! Constant(s) + one, & + one_half, & + zero, & + chi_tol + + use anl_erf, only: & + erfc ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + sigma_chi_i ! Standard deviation of chi (ith PDF component) [kg/kg] + + real( kind = core_rknd ), intent(in) :: & + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn ! Prescribed correlation of chi and Ncn [-] + + ! Return Variable + real( kind = core_rknd ) :: & + bivar_Ncnm_eqn_comp + + + if ( sigma_chi_i <= chi_tol ) then + + ! The ith PDF component variances of chi is 0. The value of the ith PDF + ! component variance of Ncn does not matter in this scenario. + + if ( mu_chi_i > zero ) then + + bivar_Ncnm_eqn_comp = one + + else ! mu_chi_i <= 0 + + bivar_Ncnm_eqn_comp = zero + + endif + + + elseif ( const_Ncnp2_on_Ncnm2 == zero ) then + + ! The ith PDF component variance of Ncn is 0. + + bivar_Ncnm_eqn_comp & + = one_half * erfc( - ( mu_chi_i / ( sqrt_2 * sigma_chi_i ) ) ) + + + else + + ! Both chi and Ncn vary in the ith PDF component. + + bivar_Ncnm_eqn_comp & + = one_half & + * erfc( - ( one / sqrt_2 ) & + * ( ( mu_chi_i / sigma_chi_i ) & + + const_corr_chi_Ncn * sqrt( const_Ncnp2_on_Ncnm2 ) ) ) + + + endif + + + return + + end function bivar_Ncnm_eqn_comp + +!=============================================================================== + +end module Nc_Ncn_eqns diff --git a/src/physics/clubb/Skx_module.F90 b/src/physics/clubb/Skx_module.F90 new file mode 100644 index 0000000000..353a938d4c --- /dev/null +++ b/src/physics/clubb/Skx_module.F90 @@ -0,0 +1,133 @@ +!------------------------------------------------------------------------- +!$Id: Skx_module.F90 77826 2016-04-07 23:05:53Z cacraig@ucar.edu $ +!=============================================================================== +module Skx_module + + implicit none + + private ! Default Scope + + public :: Skx_func, LG_2005_ansatz + + contains + +!------------------------------------------------------------------------------- + elemental function Skx_func( xp2, xp3, x_tol ) & + result( Skx ) + +! Description: +! Calculate the skewness of x + +! References: +! None +!------------------------------------------------------------------------------- + + use constants_clubb, only: & + Skw_max_mag ! Max magnitude of skewness + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use parameters_tunable, only: & + Skw_denom_coef + + implicit none + + ! External + intrinsic :: min, max + + ! Parameter Constants + ! Whether to apply clipping to the final result + logical, parameter :: & + l_clipping_kluge = .false. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + xp2, & ! x'^2 + xp3, & ! x'^3 + x_tol ! x tolerance value + + ! Output Variable + real( kind = core_rknd ) :: & + Skx ! Result Skw [-] + + ! ---- Begin Code ---- + + !Skw = xp3 / ( max( xp2, x_tol**two ) )**1.5_core_rknd + ! Calculation of skewness to help reduce the sensitivity of this value to + ! small values of xp2. + Skx = xp3 / ( xp2 + Skw_denom_coef * x_tol**2 )**1.5_core_rknd + + ! This is no longer needed since clipping is already + ! imposed on wp2 and wp3 elsewhere in the code + + ! I turned clipping on in this local copy since thlp3 and rtp3 are not clipped + if ( l_clipping_kluge ) then + Skx = min( max( Skx, -Skw_max_mag ), Skw_max_mag ) + end if + + return + end function Skx_func +!----------------------------------------------------------------------- + +!------------------------------------------------------------------------------- + elemental function LG_2005_ansatz( Skw, wpxp, wp2, xp2, beta, sigma_sqd_w, x_tol ) & + result( Skx ) + +! Description: +! Calculate the skewness of x using the diagnostic ansatz of Larson and Golaz (2005) + +! References: +! Vincent E. Larson and Jean-Christophe Golaz, 2005: Using Probability Density +! Functions to Derive Consistent Closure Relationships among Higher-Order Moments. +! Mon. Wea. Rev., 133, 1023–1042. +!------------------------------------------------------------------------------- + + use constants_clubb, only: & + one, & + w_tol_sqd, & + eps + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: sqrt + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Skw, & ! Normalized Skewness of w [-] + wpxp,& ! Turbulent flux of x + wp2, & ! Variance of w [m^2/s^2] + xp2, & ! Variance of x + beta,& ! Tunable parameter + sigma_sqd_w,& ! Normalized variance of w [-] + x_tol + + ! Output Variable + real( kind = core_rknd ) :: & + Skx ! Result Skw [-] + + real( kind = core_rknd ) :: & + nlzd_corr_wx, & ! Normalized correlation of w and x + nlzd_Skw ! Normalized skewness of w + + ! ---- Begin Code ---- + ! weberjk, 8-July 2015. Commented this out for now. cgils was failing during some tests. + + nlzd_corr_wx = ( wpxp / ( sqrt(max(wp2,w_tol_sqd)) * sqrt( max(xp2,x_tol**2) ) ) ) & + / sqrt( one - sigma_sqd_w ) + + nlzd_Skw = Skw * ( one - sigma_sqd_w) ** (-3.0_core_rknd / 2.0_core_rknd) + + ! Larson and Golaz (2005) eq. 33 + Skx = nlzd_Skw * nlzd_corr_wx * ( beta + (one - beta) * nlzd_corr_wx**2 ) + + Skx = 0._core_rknd + + return + end function LG_2005_ansatz +!----------------------------------------------------------------------- +end module Skx_module diff --git a/src/physics/clubb/T_in_K_module.F90 b/src/physics/clubb/T_in_K_module.F90 new file mode 100644 index 0000000000..17c040fbc1 --- /dev/null +++ b/src/physics/clubb/T_in_K_module.F90 @@ -0,0 +1,87 @@ +!------------------------------------------------------------------------- +! $Id: T_in_K_module.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module T_in_K_module + + implicit none + + private ! Default scope + + public :: thlm2T_in_K, T_in_K2thlm + + contains + +!------------------------------------------------------------------------------- + elemental function thlm2T_in_K( thlm, exner, rcm ) & + result( T_in_K ) + +! Description: +! Calculates absolute temperature from liquid water potential +! temperature. (Does not include ice.) + +! References: +! Cotton and Anthes (1989), "Storm and Cloud Dynamics", Eqn. (2.51). +!------------------------------------------------------------------------------- + use constants_clubb, only: & + ! Variable(s) + Cp, & ! Dry air specific heat at constant p [J/kg/K] + Lv ! Latent heat of vaporization [J/kg] + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + thlm, & ! Liquid potential temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + T_in_K ! Result temperature [K] + + ! ---- Begin Code ---- + + T_in_K = thlm * exner + Lv * rcm / Cp + + return + end function thlm2T_in_K +!------------------------------------------------------------------------------- + elemental function T_in_K2thlm( T_in_K, exner, rcm ) & + result( thlm ) + +! Description: +! Calculates liquid water potential temperature from absolute temperature + +! References: +! None +!------------------------------------------------------------------------------- + use constants_clubb, only: & + ! Variable(s) + Cp, & ! Dry air specific heat at constant p [J/kg/K] + Lv ! Latent heat of vaporization [J/kg] + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + T_in_K, &! Result temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + thlm ! Liquid potential temperature [K] + + ! ---- Begin Code ---- + + thlm = ( T_in_K - Lv/Cp * rcm ) / exner + + return + end function T_in_K2thlm +!------------------------------------------------------------------------------- + +end module T_in_K_module diff --git a/src/physics/clubb/advance_clubb_core_module.F90 b/src/physics/clubb/advance_clubb_core_module.F90 new file mode 100644 index 0000000000..e42f42169b --- /dev/null +++ b/src/physics/clubb/advance_clubb_core_module.F90 @@ -0,0 +1,3535 @@ +!----------------------------------------------------------------------- +! $Id: advance_clubb_core_module.F90 7416 2014-12-04 20:16:51Z schemena@uwm.edu $ +!----------------------------------------------------------------------- +module advance_clubb_core_module + +! Description: +! The module containing the `core' of the CLUBB parameterization. +! A host model implementing CLUBB should only require this subroutine +! and the functions and subroutines it calls. +! +! References: +! ``A PDF-Based Model for Boundary Layer Clouds. Part I: +! Method and Model Description'' Golaz, et al. (2002) +! JAS, Vol. 59, pp. 3540--3551. +! +! Copyright Notice: +! +! This code and the source code it references are (C) 2006-2014 +! Jean-Christophe Golaz, Vincent E. Larson, Brian M. Griffin, +! David P. Schanen, Adam J. Smith, and Michael J. Falk. +! +! The distribution of this code and derived works thereof +! should include this notice. +! +! Portions of this code derived from other sources (Hugh Morrison, +! ACM TOMS, Numerical Recipes, et cetera) are the intellectual +! property of their respective authors as noted and are also subject +! to copyright. +! +! +! +! Cloud Layers Unified By Binormals (CLUBB) user license +! agreement. +! +! Thank you for your interest in CLUBB. We work hard to create a +! code that implements the best software engineering practices, +! is supported to the extent allowed by our limited resources, +! and is available without cost to non-commercial users. You may +! use CLUBB if, in return, you abide by these conditions: +! +! 1. Please cite CLUBB in presentations and publications that +! contain results obtained using CLUBB. +! +! 2. You may not use any part of CLUBB to create or modify +! another single-column (1D) model that is not called CLUBB. +! However, you may modify or augment CLUBB or parts of CLUBB if +! you include "CLUBB" in the name of the resulting single-column +! model. For example, a user at MIT might modify CLUBB and call +! the modified version "CLUBB-MIT." Or, for example, a user of +! the CLM land-surface model might interface CLM to CLUBB and +! call it "CLM-CLUBB." This naming convention recognizes the +! contributions of both sets of developers. +! +! 3. You may implement CLUBB as a parameterization in a large- +! scale host model that has 2 or 3 spatial dimensions without +! including "CLUBB" in the combined model name, but please +! acknowledge in presentations and publications that CLUBB has +! been included as a parameterization. +! +! 4. You may not provide all or part of CLUBB to anyone without +! prior permission from Vincent Larson (vlarson@uwm.edu). If +! you wish to share CLUBB with your collaborators without +! seeking permission, please ask your collaborators to register +! as CLUBB users at http://clubb.larson-group.com and to +! download CLUBB from there. +! +! 5. You may not use CLUBB for commercial purposes unless you +! receive permission from Vincent Larson. +! +! 6. You may not re-license all or any part of CLUBB. +! +! 7. CLUBB is provided "as is" and without warranty. +! +! We hope that CLUBB will develop into a community resource. We +! encourage users to contribute their CLUBB modifications or +! extensions to the CLUBB development group. We will then +! consider them for inclusion in CLUBB. Such contributions will +! benefit all CLUBB users. We would be pleased to acknowledge +! contributors and list their CLUBB-related papers on our "About +! CLUBB" webpage (http://clubb.larson-group.com/about.php) for +! those contributors who so desire. +! +! Thanks so much and best wishes for your research! +! +! The CLUBB Development Group +! (Present and past contributors to the source code include +! Vincent Larson, Chris Golaz, David Schanen, Brian Griffin, +! Joshua Fasching, Adam Smith, and Michael Falk). +!----------------------------------------------------------------------- + + implicit none + + public :: & + setup_clubb_core, & + advance_clubb_core, & + cleanup_clubb_core, & + set_Lscale_max, & + calculate_thlp2_rad + + private ! Default Scope + + contains + + !----------------------------------------------------------------------- + + !####################################################################### + !####################################################################### + ! If you change the argument list of advance_clubb_core you also have to + ! change the calls to this function in the host models CAM, WRF, SAM + ! and GFDL. + !####################################################################### + !####################################################################### + subroutine advance_clubb_core & + ( l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf, & +#ifdef CLUBBND_CAM + varmu, & ! intent(in) +#endif + wphydrometp, wp2hmp, rtphmp_zt, thlphmp_zt, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, rtp3, thlp2, thlp3, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, thlprcp_out, & ! intent(out) +#endif + pdf_params ) ! intent(out) + + ! Description: + ! Subroutine to advance the model one timestep + + ! References: + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !----------------------------------------------------------------------- + + ! Modules to be included + + use constants_clubb, only: & + em_min, & + thl_tol, & + rt_tol, & + w_tol, & + w_tol_sqd, & + ep2, & + Cp, & + Lv, & + Ls, & + ep1, & + p0, & + kappa, & + fstderr, & + zero_threshold, & + three_halves, & + zero, & + unused_var + + use parameters_tunable, only: & + gamma_coefc, & ! Variable(s) + gamma_coefb, & + gamma_coef, & + taumax, & + c_K, & + mu, & + Lscale_mu_coef, & + Lscale_pert_coef, & + c_K10, & + c_K10h, & + beta, C1, C14 + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim, & + sclr_tol, & + ts_nudge, & + rtm_min, & + rtm_nudge_max_altitude + + use model_flags, only: & + l_tke_aniso, & ! Variable(s) + l_gamma_Skw, & + l_trapezoidal_rule_zt, & + l_trapezoidal_rule_zm, & + l_call_pdf_closure_twice, & + l_host_applies_sfc_fluxes, & + l_use_cloud_cover, & + l_rtm_nudge, & + l_use_3D_closure, & + l_stability_correct_tau_zm, & + l_do_expldiff_rtm_thlm, & + l_Lscale_plume_centered, & + l_use_ice_latent, & + l_damp_wp2_using_em + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm, & + ddzm + + use numerical_check, only: & + parameterization_check, & ! Procedure(s) + calculate_spurious_source + + use variables_diagnostic_module, only: & + Skw_zt, & ! Variable(s) + Skw_zm, & + Skthl_zt, & + Skthl_zm, & + Skrt_zt, & + Skrt_zm, & + sigma_sqd_w_zt, & + wp4, & + thlpthvp, & + rtpthvp, & + rtprcp, & + thlprcp, & + rcp2, & + rsat, & + pdf_params_zm, & + wprtp2, & + wp2rtp, & + wpthlp2, & + wp2thlp, & + wprtpthlp, & + wpthvp, & + wp2thvp, & + wp2rcp + + use variables_diagnostic_module, only: & + thvm, & + em, & + Lscale, & + Lscale_up, & + Lscale_down, & + tau_zm, & + tau_zt, & + Kh_zm, & + Kh_zt, & + vg, & + ug, & + um_ref, & + vm_ref + use variables_diagnostic_module, only: & + wp2_zt, & + thlp2_zt, & + wpthlp_zt, & + wprtp_zt, & + rtp2_zt, & + rtpthlp_zt, & + up2_zt, & + vp2_zt, & + upwp_zt, & + vpwp_zt, & + rtm_ref, & + thlm_ref + + use variables_diagnostic_module, only: & + wpedsclrp, & + sclrpthvp, & ! sclr'th_v' + sclrprcp, & ! sclr'rc' + wp2sclrp, & ! w'^2 sclr' + wpsclrp2, & ! w'sclr'^2 + wpsclrprtp, & ! w'sclr'rt' + wpsclrpthlp, & ! w'sclr'thl' + wp3_zm, & ! wp3 interpolated to momentum levels + thlp3_zm, & ! thlp3 interpolated to momentum levels + rtp3_zm, & ! rtp3 interpolated to momentum levels + Skw_velocity, & ! Skewness velocity [m/s] + a3_coef, & ! The a3 coefficient [-] + a3_coef_zt ! The a3 coefficient interp. to the zt grid [-] + + use variables_diagnostic_module, only: & + wp3_on_wp2, & ! Variable(s) + wp3_on_wp2_zt + + use pdf_parameter_module, only: & + pdf_parameter ! Type + +#ifdef GFDL + use advance_sclrm_Nd_module, only: & ! h1g, 2010-06-16 begin mod + advance_sclrm_Nd_diffusion_OG, & + advance_sclrm_Nd_upwind, & + advance_sclrm_Nd_semi_implicit ! h1g, 2010-06-16 end mod +#endif + + use advance_xm_wpxp_module, only: & + ! Variable(s) + advance_xm_wpxp ! Compute mean/flux terms + + use advance_xp2_xpyp_module, only: & + ! Variable(s) + advance_xp2_xpyp ! Computes variance terms + + use surface_varnce_module, only: & + surface_varnce ! Procedure + + use pdf_closure_module, only: & + ! Procedure + pdf_closure, & ! Prob. density function + calc_vert_avg_cf_component + + use mixing_length, only: & + compute_length ! Procedure + + use advance_windm_edsclrm_module, only: & + advance_windm_edsclrm ! Procedure(s) + + use saturation, only: & + ! Procedure + sat_mixrat_liq ! Saturation mixing ratio + + use advance_wp2_wp3_module, only: & + advance_wp2_wp3 ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only : & + clubb_at_least_debug_level, & ! Procedure(s) + report_error, & + fatal_error + + use Skx_module, only: & + Skx_func, & + LG_2005_ansatz + + use clip_explicit, only: & + clip_covars_denom ! Procedure(s) + + use T_in_K_module, only: & + ! Read values from namelist + thlm2T_in_K ! Procedure + + use stats_clubb_utilities, only: & + stats_accumulate ! Procedure + + use stats_type_utilities, only: & + stat_update_var_pt, & ! Procedure(s) + stat_update_var, & + stat_begin_update, & + stat_begin_update_pt, & + stat_end_update, & + stat_end_update_pt + + use stats_variables, only: & + irtp2_bt, & ! Variable(s) + ithlp2_bt, & + irtpthlp_bt, & + iwp2_bt, & + iwp3_bt, & + ivp2_bt, & + iup2_bt, & + iwprtp_bt, & + iwpthlp_bt, & + irtm_bt, & + ithlm_bt, & + ivm_bt, & + ium_bt, & + ircp2, & + iwp4, & + irsat, & + irvm, & + irel_humidity, & + iwpthlp_zt, & + iSkw_zt, & + iSkw_zm, & + iSkthl_zt, & + iSkthl_zm, & + iSkrt_zt, & + iSkrt_zm + + use stats_variables, only: & + iwprtp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt, & + ithlp2_sf, & + irtp2_sf, & + irtpthlp_sf, & + iup2_sf, & + ivp2_sf, & + iwp2_sf, & + l_stats_samp, & + l_stats, & + stats_zt, & + stats_zm, & + stats_sfc, & + irtm_spur_src, & + ithlm_spur_src + + use stats_variables, only: & + irfrzm, & ! Variable(s) + icloud_frac_refined, & + istability_correction, & + ircm_refined + + use stats_variables, only: & + iSkw_velocity, & ! Variable(s) + igamma_Skw_fnc, & + iLscale_pert_1, & + iLscale_pert_2 + + use fill_holes, only: & + vertical_integral, & ! Procedure(s) + fill_holes_vertical + + use sigma_sqd_w_module, only: & + compute_sigma_sqd_w ! Procedure(s) + + use array_index, only: & + iirrm ! Variable + + use pdf_utilities, only: & + compute_mean_binormal + + use advance_helper_module, only: & + calc_stability_correction ! Procedure(s) + + use interpolation, only: & + pvertinterp + + implicit none + + !!! External + intrinsic :: sqrt, min, max, exp, mod, real + + ! Constant Parameters + logical, parameter :: & + l_avg_Lscale = .false. ! Lscale is calculated in subroutine compute_length; if l_avg_Lscale + ! is true, compute_length is called two additional times with + ! perturbed values of rtm and thlm. An average value of Lscale + ! from the three calls to compute_length is then calculated. + ! This reduces temporal noise in RICO, BOMEX, LBA, and other cases. + + logical, parameter :: & + l_iter_xp2_xpyp = .true. ! Set to true when rtp2/thlp2/rtpthlp, et cetera are prognostic + + logical, parameter :: & + l_refine_grid_in_cloud = .false., & ! Compute cloud_frac and rcm on a refined grid + + l_interactive_refined = .false. ! Should the refined grid code feed into the model? + ! Only has meaning if l_refined_grid_in_cloud is .true. + + real( kind = core_rknd ), parameter :: & + chi_at_liq_sat = 0._core_rknd ! Value of chi(s) at saturation with respect to ice + ! (zero for liquid) + !!! Input Variables + logical, intent(in) :: & + l_implemented ! Is this part of a larger host model (T/F) ? + + real( kind = core_rknd ), intent(in) :: & + dt ! Current timestep duration [s] + + real( kind = core_rknd ), intent(in) :: & + fcor, & ! Coriolis forcing [s^-1] + sfc_elevation ! Elevation of ground level [m AMSL] + + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeors [#] + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] + vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [K*(kg/kg)/s] + wm_zm, & ! w mean wind component on momentum levels [m/s] + wm_zt, & ! w mean wind component on thermo. levels [m/s] + p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] + rho_zm, & ! Air density on momentum levels [kg/m^3] + rho, & ! Air density on thermodynamic levels [kg/m^3] + exner, & ! Exner function (thermodynamic levels) [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] + rfrzm ! Total ice-phase water mixing ratio [kg/kg] + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! Collection of hydrometeors [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + radf ! Buoyancy production at the CL top due to LW radiative cooling [m^2/s^3] + +#ifdef CLUBBND_CAM + real( kind = core_rknd ), intent(in) :: & + varmu +#endif + + real( kind = core_rknd ), dimension(gr%nz, hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third-order moment: < w'^2 hm' > [(m/s)^2 ] + rtphmp_zt, & ! Covariance of rt and hm (on t-levs.) [(kg/kg) ] + thlphmp_zt ! Covariance of thl and hm (on t-levs.) [K ] + + real( kind = core_rknd ), intent(in) :: & + wpthlp_sfc, & ! w' theta_l' at surface [(m K)/s] + wprtp_sfc, & ! w' r_t' at surface [(kg m)/( kg s)] + upwp_sfc, & ! u'w' at surface [m^2/s^2] + vpwp_sfc ! v'w' at surface [m^2/s^2] + + ! Passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm_forcing ! Passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] + + ! Eddy passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm_forcing ! Eddy passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & + wpedsclrp_sfc ! Eddy-Scalar flux at surface [{units vary} m/s] + + ! Host model horizontal grid spacing, if part of host model. + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! East-West horizontal grid spacing [m] + host_dy ! North-South horizontal grid spacing [m] + + !!! Input/Output Variables + ! These are prognostic or are planned to be in the future + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + um, & ! u mean wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] + wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] + thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] + wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + rtp3, & ! r_t'^3 (thermodynamic levels) [(kg/kg)^3] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + thlp3, & ! th_l'^3 (thermodynamic levels) [K^3] + rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! Passive scalar variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! Passive scalar mean (thermo. levels) [units vary] + wpsclrp, & ! w'sclr' (momentum levels) [{units vary} m/s] + sclrp2, & ! sclr'^2 (momentum levels) [{units vary}^2] + sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + sclrpthlp ! sclr'thl' (momentum levels) [{units vary} K] + +#ifdef GFDL + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & ! h1g, 2010-06-16 + sclrm_trsport_only ! Passive scalar concentration due to pure transport [{units vary}/s] +#endif + + ! Eddy passive scalar variable + real( kind = core_rknd ), intent(inout), dimension(gr%nz,edsclr_dim) :: & + edsclrm ! Eddy passive scalar mean (thermo. levels) [units vary] + + ! Variables that need to be output for use in other parts of the CLUBB + ! code, such as microphysics (rcm, pdf_params), forcings (rcm), and/or + ! BUGSrad (cloud_cover). + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + rcm, & ! cloud water mixing ratio, r_c (thermo. levels) [kg/kg] + rcm_in_layer, & ! rcm in cloud layer [kg/kg] + cloud_cover ! cloud cover [-] + + type(pdf_parameter), dimension(gr%nz), intent(out) :: & + pdf_params ! PDF parameters [units vary] + + ! Variables that need to be output for use in host models + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + wprcp, & ! w'r_c' (momentum levels) [(kg/kg) m/s] + cloud_frac, & ! cloud fraction (thermodynamic levels) [-] + ice_supersat_frac ! ice cloud fraction (thermodynamic levels) [-] + + ! Eric Raut declared this variable solely for output to disk + real( kind = core_rknd ), dimension(gr%nz) :: & + rc_coef ! Coefficient of X' R_l' in Eq. (34) [-] + +#if defined(CLUBB_CAM) || defined(GFDL) + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + khzt, & ! eddy diffusivity on thermo levels + khzm ! eddy diffusivity on momentum levels +#endif + +#ifdef CLUBB_CAM + real( kind = core_rknd), intent(out), dimension(gr%nz) :: & + qclvar, & ! cloud water variance + thlprcp_out +#endif + + real( kind = core_rknd ), dimension(gr%nz) :: & + Km_zm, Kmh_zm, RH_postPDF + + !!! Output Variable + ! Diagnostic, for if some calculation goes amiss. + integer, intent(inout) :: err_code + +#ifdef GFDL + ! hlg, 2010-06-16 + real( kind = core_rknd ), intent(inOUT), dimension(gr%nz, min(1,sclr_dim) , 2) :: & + RH_crit ! critical relative humidity for droplet and ice nucleation +! ---> h1g, 2012-06-14 + logical, intent(in) :: do_liquid_only_in_clubb +! <--- h1g, 2012-06-14 +#endif + + !!! Local Variables + integer :: i, k, & +#ifdef CLUBB_CAM + ixind, & +#endif + err_code_pdf_closure, err_code_surface + + real( kind = core_rknd ), dimension(gr%nz) :: & + sigma_sqd_w, & ! PDF width parameter (momentum levels) [-] + sqrt_em_zt, & ! sqrt( em ) on zt levels; where em is TKE [m/s] + gamma_Skw_fnc, & ! Gamma as a function of skewness [???] + Lscale_pert_1, Lscale_pert_2, & ! For avg. calculation of Lscale [m] + thlm_pert_1, thlm_pert_2, & ! For avg. calculation of Lscale [K] + rtm_pert_1, rtm_pert_2, & ! For avg. calculation of Lscale [kg/kg] + thlm_pert_pos_rt, thlm_pert_neg_rt, & ! For avg. calculation of Lscale [K] + rtm_pert_pos_rt, rtm_pert_neg_rt ! For avg. calculation of Lscale [kg/kg] + !Lscale_weight Uncomment this if you need to use this vairable at some point. + + ! For pdf_closure + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrp_zt, & ! w' sclr' on thermo. levels + sclrp2_zt, & ! sclr'^2 on thermo. levels + sclrprtp_zt, & ! sclr' r_t' on thermo. levels + sclrpthlp_zt ! sclr' th_l' on thermo. levels + + real( kind = core_rknd ), dimension(gr%nz) :: & + p_in_Pa_zm, & ! Pressure interpolated to momentum levels [Pa] + exner_zm, & ! Exner interpolated to momentum levels [-] + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim) :: & + wphydrometp_zt, & ! Covariance of w and hm (on t-levs.) [(m/s) ] + wp2hmp_zm, & ! Moment (on m-levs.) [(m/s)^2 ] + rtphmp, & ! Covariance of rt and hm [(kg/kg) ] + thlphmp ! Covariance of thl and hm [K ] + + integer :: & + wprtp_cl_num, & ! Instance of w'r_t' clipping (1st or 3rd). + wpthlp_cl_num, & ! Instance of w'th_l' clipping (1st or 3rd). + wpsclrp_cl_num, & ! Instance of w'sclr' clipping (1st or 3rd). + upwp_cl_num, & ! Instance of u'w' clipping (1st or 2nd). + vpwp_cl_num ! Instance of v'w' clipping (1st or 2nd). + + ! These local variables are declared because they originally belong on the momentum + ! grid levels, but pdf_closure outputs them on the thermodynamic grid levels. + real( kind = core_rknd ), dimension(gr%nz) :: & + wp4_zt, & ! w'^4 (on thermo. grid) [m^4/s^4] + wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] + rtpthvp_zt, & ! r_t' th_v' (on thermo. grid) [(kg K)/kg] + thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] + wprcp_zt, & ! w' r_c' (on thermo. grid) [(m kg)/(s kg)] + rtprcp_zt, & ! r_t' r_c' (on thermo. grid) [(kg^2)/(kg^2)] + thlprcp_zt, & ! th_l' r_c' (on thermo. grid) [(K kg)/kg] + rcp2_zt, & ! r_c'^2 (on thermo. grid) [(kg^2)/(kg^2)] + rc_coef_zt ! X'R_l' coef. (on thermo. grid) [-] + + real( kind = core_rknd ), dimension(gr%nz, sclr_dim) :: & + sclrpthvp_zt, & ! sclr'th_v' (on thermo. grid) + sclrprcp_zt ! sclr'rc' (on thermo. grid) + + real( kind = core_rknd ), dimension(gr%nz) :: & + wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] + wp2rtp_zm, & ! w'^2 rt' on momentum grid [m^2 kg/kg] + wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] + wp2thlp_zm, & ! w'^2 thl' on momentum grid [m^2 K/s^2] + wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] + cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] + ice_supersat_frac_zm, & ! Ice Cloud Fraction on momentum grid [-] + rtm_zm, & ! Total water mixing ratio [kg/kg] + thlm_zm, & ! Liquid potential temperature [kg/kg] + rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] + wp2thvp_zm, & ! w'^2 th_v' on momentum grid [m^2 K/s^2] + wp2rcp_zm, & ! w'^2 rc' on momentum grid [m^2 kg/kg s^2] + sign_rtpthlp ! sign of the covariance rtpthlp [-] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid + wpsclrp2_zm, & ! w'sclr'^2 on momentum grid + wpsclrpthlp_zm, & ! w'sclr'thl' on momentum grid + wp2sclrp_zm, & ! w'^2 sclr' on momentum grid + sclrm_zm ! Passive scalar mean on momentum grid + + real( kind = core_rknd ) :: & + rtm_integral_before, & + rtm_integral_after, & + rtm_integral_forcing, & + rtm_flux_top, & + rtm_flux_sfc, & + rtm_spur_src, & + thlm_integral_before, & + thlm_integral_after, & + thlm_integral_forcing, & + thlm_flux_top, & + thlm_flux_sfc, & + thlm_spur_src, & + mu_pert_1, mu_pert_2, & ! For l_avg_Lscale + mu_pert_pos_rt, mu_pert_neg_rt ! For l_Lscale_plume_centered + + !The following variables are defined for use when l_use_ice_latent = .true. + type(pdf_parameter), dimension(gr%nz) :: & + pdf_params_frz, & + pdf_params_zm_frz + + + real( kind = core_rknd ), dimension(gr%nz) :: & + rtm_frz, & + thlm_frz, & + wp4_zt_frz, & + wprtp2_frz, & + wp2rtp_frz, & + wpthlp2_frz, & + wp2thlp_frz, & + wprtpthlp_frz, & + cloud_frac_frz, & + ice_supersat_frac_frz, & + rcm_frz, & + wpthvp_frz, & + wpthvp_zt_frz, & + wp2thvp_frz, & + wp2thvp_zm_frz, & + rtpthvp_frz, & + rtpthvp_zt_frz, & + thlpthvp_frz, & + thlpthvp_zt_frz, & + wprcp_zt_frz, & + wp2rcp_frz + + real( kind = core_rknd ), dimension(gr%nz) :: & + rtprcp_zt_frz, & + thlprcp_zt_frz, & + rcp2_zt_frz, & + rc_coef_zt_frz, & + wp4_frz, & + wprtp2_zm_frz, & + wp2rtp_zm_frz, & + wpthlp2_zm_frz, & + wp2thlp_zm_frz, & + wprtpthlp_zm_frz, & + cloud_frac_zm_frz, & + ice_supersat_frac_zm_frz, & + rcm_zm_frz, & + wprcp_frz, & + wp2rcp_zm_frz, & + rtprcp_frz, & + thlprcp_frz, & + rcp2_frz, & + rtm_zm_frz, & + thlm_zm_frz, & + rc_coef_frz + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrprtp_frz, & + wpsclrp2_frz, & + sclrpthvp_zt_frz, & + wpsclrpthlp_frz, & + sclrprcp_zt_frz, & + wp2sclrp_frz, & + wpsclrprtp_zm_frz, & + wpsclrp2_zm_frz, & + sclrpthvp_frz, & + wpsclrpthlp_zm_frz, & + sclrprcp_frz, & + wp2sclrp_zm_frz + + real( kind = core_rknd ) :: & + cloud_frac_1_refined, & ! cloud_frac_1 computed on refined grid + cloud_frac_2_refined, & ! cloud_frac_2 computed on refined grid + rc_1_refined, & ! rc_1 computed on refined grid + rc_2_refined, & ! rc_2 computed on refined grid + cloud_frac_refined, & ! cloud_frac gridbox mean on refined grid + rcm_refined, & ! rcm gridbox mean on refined grid + thlm1000, & + thlm700 + + real( kind = core_rknd ), dimension(gr%nz) :: & + rrm ! Rain water mixing ratio + + real( kind = core_rknd ), dimension(gr%nz) :: & + stability_correction, & ! Stability correction factor + tau_N2_zm, & ! Tau with a static stability correction applied to it [s] + tau_C6_zm, & ! Tau values used for the C6 (pr1) term in wpxp [s] + tau_C1_zm ! Tau values used for the C1 (dp1) term in wp2 [s] + + real( kind = core_rknd ) :: Lscale_max + + real( kind = core_rknd ) :: newmu + + !----- Begin Code ----- + + ! Sanity checks + if ( clubb_at_least_debug_level( 1 ) ) then + + if ( l_Lscale_plume_centered .and. .not. l_avg_Lscale ) then + write(fstderr,*) "l_Lscale_plume_centered requires l_avg_Lscale" + stop "Fatal error in advance_clubb_core" + end if + + if ( l_damp_wp2_using_em .and. (C1 /= C14 .or. l_stability_correct_tau_zm) ) then + write(fstderr,*) "l_damp_wp2_using_em requires C1=C14 and l_stability_correct_tau_zm = F" + stop "Fatal error in advance_clubb_core" + end if + + end if + + ! Determine the maximum allowable value for Lscale (in meters). + call set_Lscale_max( l_implemented, host_dx, host_dy, & ! intent(in) + Lscale_max ) ! intent(out) + + if ( l_stats .and. l_stats_samp ) then + ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. + ! Therefore, wm must be zero or l_implemented must be true. + if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & + all( wm_zm == 0._core_rknd ) ) ) then + ! Get the vertical integral of rtm and thlm before this function begins + ! so that spurious source can be calculated + rtm_integral_before & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_integral_before & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + end if + end if + + !---------------------------------------------------------------- + ! Test input variables + !---------------------------------------------------------------- + if ( clubb_at_least_debug_level( 2 ) ) then + call parameterization_check & + ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + um, upwp, vm, vpwp, up2, vp2, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(in) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) + "beginning of ", & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) + sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) + err_code ) ! intent(inout) + end if + !----------------------------------------------------------------------- + + if ( l_stats_samp ) then + call stat_update_var( irfrzm, rfrzm, & ! intent(in) + stats_zt ) ! intent(inout) + end if + + ! Set up budget stats variables. + if ( l_stats_samp ) then + + call stat_begin_update( iwp2_bt, wp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( ivp2_bt, vp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iup2_bt, up2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( irtp2_bt, rtp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( ithlp2_bt, thlp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update( irtpthlp_bt, rtpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + + call stat_begin_update( irtm_bt, rtm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ithlm_bt, thlm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ium_bt, um / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( ivm_bt, vm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_begin_update( iwp3_bt, wp3 / dt, & ! intent(in) + stats_zt ) ! intent(inout) + + end if + + ! SET SURFACE VALUES OF FLUXES (BROUGHT IN) + ! We only do this for host models that do not apply the flux + ! elsewhere in the code (e.g. WRF). In other cases the _sfc variables will + ! only be used to compute the variance at the surface. -dschanen 8 Sept 2009 + if ( .not. l_host_applies_sfc_fluxes ) then + + wpthlp(1) = wpthlp_sfc + wprtp(1) = wprtp_sfc + upwp(1) = upwp_sfc + vpwp(1) = vpwp_sfc + + ! Set fluxes for passive scalars (if enabled) + if ( sclr_dim > 0 ) then + wpsclrp(1,1:sclr_dim) = wpsclrp_sfc(1:sclr_dim) + end if + + if ( edsclr_dim > 0 ) then + wpedsclrp(1,1:edsclr_dim) = wpedsclrp_sfc(1:edsclr_dim) + end if + + else + + wpthlp(1) = 0.0_core_rknd + wprtp(1) = 0.0_core_rknd + upwp(1) = 0.0_core_rknd + vpwp(1) = 0.0_core_rknd + + ! Set fluxes for passive scalars (if enabled) + if ( sclr_dim > 0 ) then + wpsclrp(1,1:sclr_dim) = 0.0_core_rknd + end if + + if ( edsclr_dim > 0 ) then + wpedsclrp(1,1:edsclr_dim) = 0.0_core_rknd + end if + + end if ! ~l_host_applies_sfc_fluxes + +#ifdef CLUBBND_CAM + newmu = varmu +#else + newmu = mu +#endif + + !--------------------------------------------------------------------------- + ! Interpolate wp3 to momentum levels, and wp2 to thermodynamic levels + ! and then compute Skw for m & t grid + !--------------------------------------------------------------------------- + + wp2_zt = max( zm2zt( wp2 ), w_tol_sqd ) ! Positive definite quantity + wp3_zm = zt2zm( wp3 ) + thlp3_zm = zt2zm( thlp3 ) + rtp3_zm = zt2zm( rtp3 ) + + ! To calculate Skewness of thl, rt, will need interpolated values. + wpthlp_zt = zm2zt( wpthlp ) + wprtp_zt = zm2zt( wprtp ) + thlp2_zt = zm2zt( thlp2 ) + rtp2_zt = zm2zt( rtp2 ) + sigma_sqd_w = zt2zm(sigma_sqd_w_zt) + + Skw_zt(1:gr%nz) = Skx_func( wp2_zt(1:gr%nz), wp3(1:gr%nz), w_tol ) + Skw_zm(1:gr%nz) = Skx_func( wp2(1:gr%nz), wp3_zm(1:gr%nz), w_tol ) + + if(l_use_3D_closure) then + + Skthl_zt(1:gr%nz) = Skx_func( thlp2_zt(1:gr%nz), thlp3(1:gr%nz), thl_tol ) + Skthl_zm(1:gr%nz) = Skx_func( thlp2(1:gr%nz), thlp3_zm(1:gr%nz), thl_tol ) + + Skrt_zt(1:gr%nz) = Skx_func( rtp2_zt(1:gr%nz), rtp3(1:gr%nz), rt_tol ) + Skrt_zm(1:gr%nz) = Skx_func( rtp2(1:gr%nz), rtp3_zm(1:gr%nz), rt_tol ) + + else + + Skthl_zt(1:gr%nz) = LG_2005_ansatz( Skw_zt(1:gr%nz), wpthlp_zt(1:gr%nz), wp2_zt(1:gr%nz), & + thlp2_zt(1:gr%nz), beta, sigma_sqd_w_zt(1:gr%nz), thl_tol ) + + Skthl_zm(1:gr%nz) = LG_2005_ansatz( Skw_zm(1:gr%nz), wpthlp(1:gr%nz), wp2(1:gr%nz), & + thlp2(1:gr%nz), beta, sigma_sqd_w(1:gr%nz), thl_tol ) + + Skrt_zt(1:gr%nz) = LG_2005_ansatz( Skw_zt(1:gr%nz), wprtp_zt(1:gr%nz), wp2_zt(1:gr%nz), & + rtp2_zt(1:gr%nz), beta, sigma_sqd_w_zt(1:gr%nz), rt_tol ) + + Skrt_zm(1:gr%nz) = LG_2005_ansatz( Skw_zm(1:gr%nz), wprtp(1:gr%nz), wp2(1:gr%nz), & + rtp2(1:gr%nz), beta, sigma_sqd_w(1:gr%nz),rt_tol ) + + endif ! if(l_use_3D_closure) + + if ( l_stats_samp ) then + call stat_update_var( iSkw_zt, Skw_zt, & ! In + stats_zt ) ! In/Out + call stat_update_var( iSkw_zm, Skw_zm, & + stats_zm ) ! In/Out + call stat_update_var( iSkthl_zt, Skthl_zt, & + stats_zt ) ! In/Out + call stat_update_var( iSkthl_zm, Skthl_zm, & + stats_zm ) ! In/Out + call stat_update_var( iSkrt_zt, Skrt_zt, & + stats_zt ) ! In/Out + call stat_update_var( iSkrt_zm, Skrt_zm, & + stats_zm ) ! In/Out + endif + + ! The right hand side of this conjunction is only for reducing cpu time, + ! since the more complicated formula is mathematically equivalent + if ( l_gamma_Skw .and. ( gamma_coef /= gamma_coefb ) ) then + !---------------------------------------------------------------- + ! Compute gamma as a function of Skw - 14 April 06 dschanen + !---------------------------------------------------------------- + + gamma_Skw_fnc = gamma_coefb + (gamma_coef-gamma_coefb) & + *exp( -(1.0_core_rknd/2.0_core_rknd) * (Skw_zm/gamma_coefc)**2 ) + + else + + gamma_Skw_fnc = gamma_coef + + end if + + ! Compute sigma_sqd_w (dimensionless PDF width parameter) + sigma_sqd_w = compute_sigma_sqd_w( gamma_Skw_fnc, wp2, thlp2, rtp2, wpthlp, wprtp ) + + if ( l_stats_samp ) then + call stat_update_var( igamma_Skw_fnc, gamma_Skw_fnc, & ! intent(in) + stats_zm ) ! intent(inout) + endif + + ! Smooth in the vertical using interpolation + sigma_sqd_w = zt2zm( zm2zt( sigma_sqd_w ) ) + + ! Interpolate the the stats_zt grid + sigma_sqd_w_zt = max( zm2zt( sigma_sqd_w ), zero_threshold ) ! Pos. def. quantity + + ! Compute the a3 coefficient (formula 25 in `Equations for CLUBB') +! a3_coef = 3.0_core_rknd * sigma_sqd_w*sigma_sqd_w & +! + 6.0_core_rknd*(1.0_core_rknd-sigma_sqd_w)*sigma_sqd_w & +! + (1.0_core_rknd-sigma_sqd_w)*(1.0_core_rknd-sigma_sqd_w) & +! - 3.0_core_rknd + + ! This is a simplified version of the formula above. + a3_coef = -2._core_rknd * ( 1._core_rknd - sigma_sqd_w )**2 + + ! We found we obtain fewer spikes in wp3 when we clip a3 to be no greater + ! than -1.4 -dschanen 4 Jan 2011 + a3_coef = max( a3_coef, -1.4_core_rknd ) ! Known magic number + + a3_coef_zt = zm2zt( a3_coef ) + + !--------------------------------------------------------------------------- + ! Interpolate thlp2, rtp2, and rtpthlp to thermodynamic levels, + !--------------------------------------------------------------------------- + + ! Interpolate variances to the stats_zt grid (statistics and closure) + thlp2_zt = max( zm2zt( thlp2 ), thl_tol**2 ) ! Positive def. quantity + rtp2_zt = max( zm2zt( rtp2 ), rt_tol**2 ) ! Positive def. quantity + rtpthlp_zt = zm2zt( rtpthlp ) + + ! Compute skewness velocity for stats output purposes + if ( iSkw_velocity > 0 ) then + Skw_velocity = ( 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w(1:gr%nz) ) ) & + * ( wp3_zm(1:gr%nz) / max( wp2(1:gr%nz), w_tol_sqd ) ) + end if + + ! Compute wp3 / wp2 on zt levels. Always use the interpolated value in the + ! denominator since it's less likely to create spikes + wp3_on_wp2_zt = ( wp3(1:gr%nz) / max( wp2_zt(1:gr%nz), w_tol_sqd ) ) + + ! Clip wp3_on_wp2_zt if it's too large + do k=1, gr%nz + if( wp3_on_wp2_zt(k) < 0._core_rknd ) then + wp3_on_wp2_zt = max( -1000._core_rknd, wp3_on_wp2_zt ) + else + wp3_on_wp2_zt = min( 1000._core_rknd, wp3_on_wp2_zt ) + end if + end do + + ! Compute wp3_on_wp2 by interpolating wp3_on_wp2_zt + wp3_on_wp2 = zt2zm( wp3_on_wp2_zt ) + + ! Smooth again as above + wp3_on_wp2_zt = zm2zt( wp3_on_wp2 ) + + !---------------------------------------------------------------- + ! Call closure scheme + !---------------------------------------------------------------- + + ! Put passive scalar input on the t grid for the PDF + do i = 1, sclr_dim, 1 + wpsclrp_zt(:,i) = zm2zt( wpsclrp(:,i) ) + sclrp2_zt(:,i) = max( zm2zt( sclrp2(:,i) ), zero_threshold ) ! Pos. def. quantity + sclrprtp_zt(:,i) = zm2zt( sclrprtp(:,i) ) + sclrpthlp_zt(:,i) = zm2zt( sclrpthlp(:,i) ) + end do ! i = 1, sclr_dim, 1 + + ! Interpolate hydrometeor mixed moments to momentum levels. + do i = 1, hydromet_dim, 1 + wphydrometp_zt(:,i) = zm2zt( wphydrometp(:,i) ) + enddo ! i = 1, hydromet_dim, 1 + + + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa(k), exner(k), thv_ds_zt(k), wm_zt(k), & ! intent(in) + wp2_zt(k), wp3(k), sigma_sqd_w_zt(k), & ! intent(in) + Skw_zt(k), Skthl_zt(k), Skrt_zt(k), rtm(k), rtp2_zt(k), & ! intent(in) + zm2zt( wprtp, k ), thlm(k), thlp2_zt(k), & ! intent(in) + zm2zt( wpthlp, k ), rtpthlp_zt(k), sclrm(k,:), & ! intent(in) + wpsclrp_zt(k,:), sclrp2_zt(k,:), sclrprtp_zt(k,:), & ! intent(in) + sclrpthlp_zt(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp_zt(k,:), wp2hmp(k,:), & ! intent(in) + rtphmp_zt(k,:), thlphmp_zt(k,:), & ! intent(in) + wp4_zt(k), wprtp2(k), wp2rtp(k), & ! intent(out) + wpthlp2(k), wp2thlp(k), wprtpthlp(k), & ! intent(out) + cloud_frac(k), ice_supersat_frac(k), & ! intent(out) + rcm(k), wpthvp_zt(k), wp2thvp(k), rtpthvp_zt(k), & ! intent(out) + thlpthvp_zt(k), wprcp_zt(k), wp2rcp(k), rtprcp_zt(k), & ! intent(out) + thlprcp_zt(k), rcp2_zt(k), pdf_params(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp(k,:), wpsclrp2(k,:), sclrpthvp_zt(k,:), & ! intent(out) + wpsclrpthlp(k,:), sclrprcp_zt(k,:), wp2sclrp(k,:), & ! intent(out) + rc_coef_zt(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + + if ( l_refine_grid_in_cloud ) then + + ! Compute cloud_frac and rcm on a refined grid to improve parameterization + ! of subgrid clouds + do k=1, gr%nz + + if ( pdf_params(k)%chi_1/pdf_params(k)%stdev_chi_1 > -1._core_rknd ) then + + ! Recalculate cloud_frac and r_c for each PDF component + + call calc_vert_avg_cf_component & + ( gr%nz, k, gr%zt, pdf_params%chi_1, & ! Intent(in) + pdf_params%stdev_chi_1, (/(chi_at_liq_sat,i=1,gr%nz)/), & ! Intent(in) + cloud_frac_1_refined, rc_1_refined ) ! Intent(out) + + call calc_vert_avg_cf_component & + ( gr%nz, k, gr%zt, pdf_params%chi_2, & ! Intent(in) + pdf_params%stdev_chi_2, (/(chi_at_liq_sat,i=1,gr%nz)/), & ! Intent(in) + cloud_frac_2_refined, rc_2_refined ) ! Intent(out) + + cloud_frac_refined = compute_mean_binormal & + ( cloud_frac_1_refined, cloud_frac_2_refined, & + pdf_params(k)%mixt_frac ) + + rcm_refined = compute_mean_binormal & + ( rc_1_refined, rc_2_refined, pdf_params(k)%mixt_frac ) + + if ( l_interactive_refined ) then + ! I commented out the lines that modify the values in pdf_params, as it seems that + ! these values need to remain consistent with the rest of the PDF. + ! Eric Raut Jun 2014 + ! Replace pdf_closure estimates with refined estimates + ! pdf_params(k)%rc_1 = rc_1_refined + ! pdf_params(k)%rc_2 = rc_2_refined + rcm(k) = rcm_refined + + ! pdf_params(k)%cloud_frac_1 = cloud_frac_1_refined + ! pdf_params(k)%cloud_frac_2 = cloud_frac_2_refined + cloud_frac(k) = cloud_frac_refined + end if + + else + ! Set these equal to the non-refined values so we have something to + ! output to stats! + cloud_frac_refined = cloud_frac(k) + rcm_refined = rcm(k) + end if ! pdf_params(k)%chi_1/pdf_params(k)%stdev_chi_1 > -1._core_rknd + + ! Stats output + if ( l_stats_samp ) then + call stat_update_var_pt( icloud_frac_refined, k, cloud_frac_refined, stats_zt ) + call stat_update_var_pt( ircm_refined, k, rcm_refined, stats_zt ) + end if + + end do ! k=1, gr%nz + + end if ! l_refine_grid_in_cloud + + if( l_rtm_nudge ) then + ! Nudge rtm to prevent excessive drying + where( rtm < rtm_min .and. gr%zt < rtm_nudge_max_altitude ) + rtm = rtm + (rtm_ref - rtm) * ( dt / ts_nudge ) + end where + end if + + + if ( l_call_pdf_closure_twice ) then + ! Call pdf_closure a second time on momentum levels, to + ! output (rather than interpolate) the variables which + ! belong on the momentum levels. + + ! Interpolate sclrm to the momentum level for use in + ! the second call to pdf_closure + do i = 1, sclr_dim + sclrm_zm(:,i) = zt2zm( sclrm(:,i) ) + ! Clip if extrap. causes sclrm_zm to be less than sclr_tol + sclrm_zm(gr%nz,i) = max( sclrm_zm(gr%nz,i), sclr_tol(i) ) + end do ! i = 1, sclr_dim + + ! Interpolate pressure, p_in_Pa, to momentum levels. + ! The pressure at thermodynamic level k = 1 has been set to be the surface + ! (or model lower boundary) pressure. Since the surface (or model lower + ! boundary) is located at momentum level k = 1, the pressure there is + ! p_sfc, which is p_in_Pa(1). Thus, p_in_Pa_zm(1) = p_in_Pa(1). + p_in_Pa_zm(:) = zt2zm( p_in_Pa ) + p_in_Pa_zm(1) = p_in_Pa(1) + + ! Clip pressure if the extrapolation leads to a negative value of pressure + p_in_Pa_zm(gr%nz) = max( p_in_Pa_zm(gr%nz), 0.5_core_rknd*p_in_Pa(gr%nz) ) + ! Set exner at momentum levels, exner_zm, based on p_in_Pa_zm. + exner_zm(:) = (p_in_Pa_zm(:)/p0)**kappa + + rtm_zm = zt2zm( rtm ) + ! Clip if extrapolation at the top level causes rtm_zm to be < rt_tol + rtm_zm(gr%nz) = max( rtm_zm(gr%nz), rt_tol ) + thlm_zm = zt2zm( thlm ) + ! Clip if extrapolation at the top level causes thlm_zm to be < thl_tol + thlm_zm(gr%nz) = max( thlm_zm(gr%nz), thl_tol ) + + ! Interpolate hydrometeor mixed moments to momentum levels. + do i = 1, hydromet_dim, 1 + rtphmp(:,i) = zt2zm( rtphmp_zt(:,i) ) + thlphmp(:,i) = zt2zm( thlphmp_zt(:,i) ) + wp2hmp_zm(:,i) = zt2zm( wp2hmp(:,i) ) + enddo ! i = 1, hydromet_dim, 1 + + ! Call pdf_closure to output the variables which belong on the momentum grid. + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa_zm(k), exner_zm(k), thv_ds_zm(k), wm_zm(k), & ! intent(in) + wp2(k), wp3_zm(k), sigma_sqd_w(k), & ! intent(in) + Skw_zm(k), Skthl_zm(k), Skrt_zm(k), rtm_zm(k), rtp2(k), & ! intent(in) + wprtp(k), thlm_zm(k), thlp2(k), & ! intent(in) + wpthlp(k), rtpthlp(k), sclrm_zm(k,:), & ! intent(in) + wpsclrp(k,:), sclrp2(k,:), sclrprtp(k,:), & ! intent(in) + sclrpthlp(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp(k,:), wp2hmp_zm(k,:), & ! intent(in) + rtphmp(k,:), thlphmp(k,:), & ! intent(in) + wp4(k), wprtp2_zm(k), wp2rtp_zm(k), & ! intent(out) + wpthlp2_zm(k), wp2thlp_zm(k), wprtpthlp_zm(k), & ! intent(out) + cloud_frac_zm(k), ice_supersat_frac_zm(k), & ! intent(out) + rcm_zm(k), wpthvp(k), wp2thvp_zm(k), rtpthvp(k), & ! intent(out) + thlpthvp(k), wprcp(k), wp2rcp_zm(k), rtprcp(k), & ! intent(out) + thlprcp(k), rcp2(k), pdf_params_zm(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_zm(k,:), wpsclrp2_zm(k,:), sclrpthvp(k,:), & ! intent(out) + wpsclrpthlp_zm(k,:), sclrprcp(k,:), wp2sclrp_zm(k,:), & ! intent(out) + rc_coef(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + + else ! l_call_pdf_closure_twice is false + + ! Interpolate momentum variables output from the first call to + ! pdf_closure back to momentum grid. + ! Since top momentum level is higher than top thermo level, + ! Set variables at top momentum level to 0. + + ! Only do this for wp4 and rcp2 if we're saving stats, since they are not + ! used elsewhere in the parameterization + if ( iwp4 > 0 ) then + wp4 = max( zt2zm( wp4_zt ), zero_threshold ) ! Pos. def. quantity + wp4(gr%nz) = 0.0_core_rknd + end if + +#ifndef CLUBB_CAM + ! CAM-CLUBB needs cloud water variance thus always compute this + if ( ircp2 > 0 ) then +#endif + rcp2 = max( zt2zm( rcp2_zt ), zero_threshold ) ! Pos. def. quantity +#ifndef CLUBB_CAM + rcp2(gr%nz) = 0.0_core_rknd + end if +#endif + + wpthvp = zt2zm( wpthvp_zt ) + wpthvp(gr%nz) = 0.0_core_rknd + thlpthvp = zt2zm( thlpthvp_zt ) + thlpthvp(gr%nz) = 0.0_core_rknd + rtpthvp = zt2zm( rtpthvp_zt ) + rtpthvp(gr%nz) = 0.0_core_rknd + wprcp = zt2zm( wprcp_zt ) + wprcp(gr%nz) = 0.0_core_rknd + rc_coef = zt2zm( rc_coef_zt ) + rc_coef(gr%nz) = 0.0_core_rknd + rtprcp = zt2zm( rtprcp_zt ) + rtprcp(gr%nz) = 0.0_core_rknd + thlprcp = zt2zm( thlprcp_zt ) + thlprcp(gr%nz) = 0.0_core_rknd + + ! Interpolate passive scalars back onto the m grid + do i = 1, sclr_dim + sclrpthvp(:,i) = zt2zm( sclrpthvp_zt(:,i) ) + sclrpthvp(gr%nz,i) = 0.0_core_rknd + sclrprcp(:,i) = zt2zm( sclrprcp_zt(:,i) ) + sclrprcp(gr%nz,i) = 0.0_core_rknd + end do ! i=1, sclr_dim + + end if ! l_call_pdf_closure_twice + + ! If l_trapezoidal_rule_zt is true, call trapezoidal_rule_zt for + ! thermodynamic-level variables output from pdf_closure. + ! ldgrant June 2009 + if ( l_trapezoidal_rule_zt ) then + call trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2, wpthlp2, & ! intent(inout) + wprtpthlp, cloud_frac, ice_supersat_frac, & ! intent(inout) + rcm, wp2thvp, wpsclrprtp, wpsclrp2, & ! intent(inout) + wpsclrpthlp, pdf_params, & ! intent(inout) + wprtp2_zm, wpthlp2_zm, & ! intent(inout) + wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) + ice_supersat_frac_zm, rcm_zm, wp2thvp_zm, & ! intent(inout) + wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) + pdf_params_zm ) ! intent(inout) + end if ! l_trapezoidal_rule_zt + + ! If l_trapezoidal_rule_zm is true, call trapezoidal_rule_zm for + ! the important momentum-level variabes output from pdf_closure. + ! ldgrant Feb. 2010 + if ( l_trapezoidal_rule_zm ) then + call trapezoidal_rule_zm & + ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) + wpthvp, thlpthvp, rtpthvp ) ! intent(inout) + end if ! l_trapezoidal_rule_zm + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. + ! Code is duplicated from below to ensure that relative humidity + ! is calculated properly. 3 Sep 2009 + call clip_rcm( rtm, 'rtm < rcm after pdf_closure', & ! intent (in) + rcm ) ! intent (inout) + + ! Compute variables cloud_cover and rcm_in_layer. + ! Added July 2009 + call compute_cloud_cover & + ( pdf_params, cloud_frac, rcm, & ! intent(in) + cloud_cover, rcm_in_layer ) ! intent(out) + + ! Use cloud_cover and rcm_in_layer to help boost cloud_frac and rcm to help + ! increase cloudiness at coarser grid resolutions. + if ( l_use_cloud_cover ) then + cloud_frac = cloud_cover + rcm = rcm_in_layer + end if + + ! Clip cloud fraction here if it still exceeds 1.0 due to round off + cloud_frac = min( 1.0_core_rknd, cloud_frac ) + ! Ditto with ice cloud fraction + ice_supersat_frac = min( 1.0_core_rknd, ice_supersat_frac ) + + if (l_use_ice_latent) then + !A third call to pdf_closure, with terms modified to include the effects + !of latent heating due to ice. Thlm and rtm add the effects of ice, and + !the terms are all renamed with "_frz" appended. The modified terms will + !be fed into the calculations of the turbulence terms. storer-3/14/13 + + !Also added rain for completeness. storer-3/4/14 + + if ( iirrm > 0 ) then + rrm = hydromet(:,iirrm) + else + rrm = zero + end if + + thlm_frz = thlm - (Lv / (Cp*exner) ) * rrm - (Ls / (Cp*exner) ) * rfrzm + rtm_frz = rtm + rrm + rfrzm + + + do k = 1, gr%nz, 1 + + call pdf_closure & + ( hydromet_dim, p_in_Pa(k), exner(k), thv_ds_zt(k), wm_zt(k), & ! intent(in) + wp2_zt(k), wp3(k), sigma_sqd_w_zt(k), & ! intent(in) + Skw_zt(k), Skthl_zt(k), Skrt_zt(k), rtm_frz(k), rtp2_zt(k), & ! intent(in) + zm2zt( wprtp, k ), thlm_frz(k), thlp2_zt(k), & ! intent(in) + zm2zt( wpthlp, k ), rtpthlp_zt(k), sclrm(k,:), & ! intent(in) + wpsclrp_zt(k,:), sclrp2_zt(k,:), sclrprtp_zt(k,:), & ! intent(in) + sclrpthlp_zt(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp_zt(k,:), wp2hmp(k,:), & ! intent(in) + rtphmp_zt(k,:), thlphmp_zt(k,:), & ! intent(in) + wp4_zt_frz(k), wprtp2_frz(k), wp2rtp_frz(k), & ! intent(out) + wpthlp2_frz(k), wp2thlp_frz(k), wprtpthlp_frz(k), & ! intent(out) + cloud_frac_frz(k), ice_supersat_frac_frz(k), & ! intent(out) + rcm_frz(k), wpthvp_zt_frz(k), wp2thvp_frz(k), rtpthvp_zt_frz(k), & ! intent(out) + thlpthvp_zt_frz(k), wprcp_zt_frz(k), wp2rcp_frz(k), rtprcp_zt_frz(k), & ! intent(out) + thlprcp_zt_frz(k), rcp2_zt_frz(k), pdf_params_frz(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_frz(k,:), wpsclrp2_frz(k,:), sclrpthvp_zt_frz(k,:), & ! intent(out) + wpsclrpthlp_frz(k,:), sclrprcp_zt_frz(k,:), wp2sclrp_frz(k,:), & ! intent(out) + rc_coef_zt_frz(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit gracefully. + ! Joshua Fasching March 2008 + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level ( 1 ) )then + write(fstderr,*) "At grid level = ", k + end if + + err_code = err_code_pdf_closure + end if + + end do !k=1, gr%nz, 1 + + + if( l_rtm_nudge ) then + ! Nudge rtm to prevent excessive drying + where( rtm < rtm_min .and. gr%zt < rtm_nudge_max_altitude ) + rtm = rtm + (rtm_ref - rtm) * ( dt / ts_nudge ) + end where + end if + + rtm_zm_frz = zt2zm( rtm_frz ) + ! Clip if extrapolation at the top level causes rtm_zm to be < rt_tol + rtm_zm_frz(gr%nz) = max( rtm_zm_frz(gr%nz), rt_tol ) + thlm_zm_frz = zt2zm( thlm_frz ) + ! Clip if extrapolation at the top level causes thlm_zm to be < thl_tol + thlm_zm_frz(gr%nz) = max( thlm_zm_frz(gr%nz), thl_tol ) + + if ( l_call_pdf_closure_twice ) then + ! Call pdf_closure again to output the variables which belong on the momentum grid. + do k=1, gr%nz, 1 + call pdf_closure & + ( hydromet_dim, p_in_Pa_zm(k), exner_zm(k), thv_ds_zm(k), wm_zm(k), & ! intent(in) + wp2(k), wp3_zm(k), sigma_sqd_w(k), & ! intent(in) + Skw_zm(k), Skthl_zm(k), Skrt_zm(k), rtm_zm_frz(k), rtp2(k), & ! intent(in) + wprtp(k), thlm_zm_frz(k), thlp2(k), & ! intent(in) + wpthlp(k), rtpthlp(k), sclrm_zm(k,:), & ! intent(in) + wpsclrp(k,:), sclrp2(k,:), sclrprtp(k,:), & ! intent(in) + sclrpthlp(k,:), k, & ! intent(in) +#ifdef GFDL + RH_crit(k, : , :), do_liquid_only_in_clubb, & ! intent(in) +#endif + wphydrometp(k,:), wp2hmp_zm(k,:), & ! intent(in) + rtphmp(k,:), thlphmp(k,:), & ! intent(in) + wp4_frz(k), wprtp2_zm_frz(k), wp2rtp_zm_frz(k), & ! intent(out) + wpthlp2_zm_frz(k), wp2thlp_zm_frz(k), wprtpthlp_zm_frz(k), & ! intent(out) + cloud_frac_zm_frz(k), ice_supersat_frac_zm_frz(k), & ! intent(out) + rcm_zm_frz(k), wpthvp_frz(k), wp2thvp_zm_frz(k), rtpthvp_frz(k), & ! intent(out) + thlpthvp_frz(k), wprcp_frz(k), wp2rcp_zm_frz(k), rtprcp_frz(k), & ! intent(out) + thlprcp_frz(k), rcp2_frz(k), pdf_params_zm_frz(k), & ! intent(out) + err_code_pdf_closure, & ! intent(out) + wpsclrprtp_zm_frz(k,:), wpsclrp2_zm_frz(k,:), sclrpthvp_frz(k,:), & ! intent(out) + wpsclrpthlp_zm_frz(k,:), sclrprcp_frz(k,:), wp2sclrp_zm_frz(k,:), & ! intent(out) + rc_coef_frz(k) ) ! intent(out) + + ! Subroutine may produce NaN values, and if so, exit + ! gracefully. + ! Joshua Fasching March 2008 + + + if ( fatal_error( err_code_pdf_closure ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "At grid level = ",k + end if + + err_code = err_code_pdf_closure + end if + + end do ! k = 1, gr%nz, 1 + else ! l_call_pdf_closure_twice is false + + wpthvp_frz = zt2zm( wpthvp_zt_frz ) + wpthvp_frz(gr%nz) = 0.0_core_rknd + thlpthvp_frz = zt2zm( thlpthvp_zt_frz ) + thlpthvp_frz(gr%nz) = 0.0_core_rknd + rtpthvp_frz = zt2zm( rtpthvp_zt_frz ) + rtpthvp_frz(gr%nz) = 0.0_core_rknd + + end if ! l_call_pdf_closure_twice + + if ( l_trapezoidal_rule_zt ) then + call trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2_frz, wpthlp2_frz, & ! intent(inout) + wprtpthlp_frz, cloud_frac_frz, ice_supersat_frac_frz, & ! intent(inout) + rcm_frz, wp2thvp_frz, wpsclrprtp_frz, wpsclrp2_frz, & ! intent(inout) + wpsclrpthlp_frz, pdf_params_frz, & ! intent(inout) + wprtp2_zm_frz, wpthlp2_zm_frz, & ! intent(inout) + wprtpthlp_zm_frz, cloud_frac_zm_frz, & ! intent(inout) + ice_supersat_frac_zm_frz, rcm_zm_frz, wp2thvp_zm_frz, & ! intent(inout) + wpsclrprtp_zm_frz, wpsclrp2_zm_frz, wpsclrpthlp_zm_frz, & ! intent(inout) + pdf_params_zm_frz ) ! intent(inout) + end if ! l_trapezoidal_rule_zt + + ! If l_trapezoidal_rule_zm is true, call trapezoidal_rule_zm for + ! the important momentum-level variabes output from pdf_closure. + ! ldgrant Feb. 2010 + if ( l_trapezoidal_rule_zm ) then + call trapezoidal_rule_zm & + ( wpthvp_zt_frz, thlpthvp_zt_frz, rtpthvp_zt_frz, & ! intent(in) + wpthvp_frz, thlpthvp_frz, rtpthvp_frz ) ! intent(inout) + end if ! l_trapezoidal_rule_zm + + wpthvp = wpthvp_frz + wp2thvp = wp2thvp_frz + thlpthvp = thlpthvp_frz + rtpthvp = rtpthvp_frz + + end if ! l_use_ice_latent = .true. + +#ifdef CLUBB_CAM + ! +PAB mods, take remaining supersaturation that may exist + ! after CLUBB PDF call and add it to rcm. Supersaturation + ! may exist after PDF call due to issues with calling PDF on the + ! thermo grid and momentum grid and the interpolation between the two + rsat = sat_mixrat_liq( p_in_Pa, thlm2T_in_K( thlm, exner, rcm ) ) + + RH_postPDF = (rtm - rcm)/rsat + + do k = 2, gr%nz + if (RH_postPDF(k) > 1.0_core_rknd) then + rcm(k) = rcm(k) + ((rtm(k) - rcm(k)) - rsat(k)) + end if + enddo +#endif + + !---------------------------------------------------------------- + ! Compute thvm + !---------------------------------------------------------------- + + thvm = thlm + ep1 * thv_ds_zt * rtm & + + ( Lv/(Cp*exner) - ep2 * thv_ds_zt ) * rcm + + !---------------------------------------------------------------- + ! Compute tke (turbulent kinetic energy) + !---------------------------------------------------------------- + + if ( .not. l_tke_aniso ) then + ! tke is assumed to be 3/2 of wp2 + em = three_halves * wp2 ! Known magic number + else + em = 0.5_core_rknd * ( wp2 + vp2 + up2 ) + end if + + !---------------------------------------------------------------- + ! Compute mixing length + !---------------------------------------------------------------- + + if ( l_avg_Lscale .and. .not. l_Lscale_plume_centered ) then + ! Call compute length two additional times with perturbed values + ! of rtm and thlm so that an average value of Lscale may be calculated. + if ( l_use_ice_latent ) then + !Include the effects of ice in the length scale calculation + + thlm_pert_1 = thlm_frz + Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_1 = rtm_frz + Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_1 = newmu / Lscale_mu_coef + + thlm_pert_2 = thlm_frz - Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_2 = rtm_frz - Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_2 = newmu * Lscale_mu_coef + else + thlm_pert_1 = thlm + Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_1 = rtm + Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_1 = newmu / Lscale_mu_coef + + thlm_pert_2 = thlm - Lscale_pert_coef * sqrt( max( thlp2, thl_tol**2 ) ) + rtm_pert_2 = rtm - Lscale_pert_coef * sqrt( max( rtp2, rt_tol**2 ) ) + mu_pert_2 = newmu * Lscale_mu_coef + end if + + call compute_length( thvm, thlm_pert_1, rtm_pert_1, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_1, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale_pert_1, Lscale_up, Lscale_down ) ! intent(out) + + call compute_length( thvm, thlm_pert_2, rtm_pert_2, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_2, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale_pert_2, Lscale_up, Lscale_down ) ! intent(out) + + else if ( l_avg_Lscale .and. l_Lscale_plume_centered ) then + ! Take the values of thl and rt based one 1st or 2nd plume + + do k = 1, gr%nz, 1 + sign_rtpthlp(k) = sign(1.0_core_rknd, rtpthlp(k)) + end do + + if ( l_use_ice_latent ) then + where ( pdf_params_frz%rt_1 > pdf_params_frz%rt_2 ) + rtm_pert_pos_rt = pdf_params_frz%rt_1 & + + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_1, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params_frz%thl_1 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_1, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params_frz%thl_2 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_2, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params_frz%rt_2 & + - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_2, rt_tol**2 ) ) + !Lscale_weight = pdf_params%mixt_frac + else where + rtm_pert_pos_rt = pdf_params_frz%rt_2 & + + Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_2, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params_frz%thl_2 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_2, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params_frz%thl_1 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params_frz%varnce_thl_1, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params_frz%rt_1 & + - Lscale_pert_coef * sqrt( max( pdf_params_frz%varnce_rt_1, rt_tol**2 ) ) + !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac + end where + else + where ( pdf_params%rt_1 > pdf_params%rt_2 ) + rtm_pert_pos_rt = pdf_params%rt_1 & + + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params%thl_1 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_1, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params%thl_2 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_2, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params%rt_2 & + - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2, rt_tol**2 ) ) + !Lscale_weight = pdf_params%mixt_frac + else where + rtm_pert_pos_rt = pdf_params%rt_2 & + + Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_2, rt_tol**2 ) ) + thlm_pert_pos_rt = pdf_params%thl_2 + ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_2, thl_tol**2 ) ) ) + thlm_pert_neg_rt = pdf_params%thl_1 - ( sign_rtpthlp * Lscale_pert_coef & + * sqrt( max( pdf_params%varnce_thl_1, thl_tol**2 ) ) ) + rtm_pert_neg_rt = pdf_params%rt_1 & + - Lscale_pert_coef * sqrt( max( pdf_params%varnce_rt_1, rt_tol**2 ) ) + !Lscale_weight = 1.0_core_rknd - pdf_params%mixt_frac + end where + end if + mu_pert_pos_rt = newmu / Lscale_mu_coef + mu_pert_neg_rt = newmu * Lscale_mu_coef + + ! Call length with perturbed values of thl and rt + call compute_length( thvm, thlm_pert_pos_rt, rtm_pert_pos_rt, em, Lscale_max, &!intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_pos_rt, l_implemented, & !intent(in) + err_code, & ! intent(inout) + Lscale_pert_1, Lscale_up, Lscale_down ) ! intent(out) + + call compute_length( thvm, thlm_pert_neg_rt, rtm_pert_neg_rt, em, Lscale_max, &!intent(in) + p_in_Pa, exner, thv_ds_zt, mu_pert_neg_rt, l_implemented, & !intent(in) + err_code, & ! intent(inout) + Lscale_pert_2, Lscale_up, Lscale_down ) ! intent(out) + else + Lscale_pert_1 = unused_var ! Undefined + Lscale_pert_2 = unused_var ! Undefined + + end if ! l_avg_Lscale + + if ( l_stats_samp ) then + call stat_update_var( iLscale_pert_1, Lscale_pert_1, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_update_var( iLscale_pert_2, Lscale_pert_2, & ! intent(in) + stats_zt ) ! intent(inout) + end if ! l_stats_samp + + ! ********** NOTE: ********** + ! This call to compute_length must be last. Otherwise, the values of + ! Lscale_up and Lscale_down in stats will be based on perturbation length scales + ! rather than the mean length scale. + call compute_length( thvm, thlm, rtm, em, Lscale_max, & ! intent(in) + p_in_Pa, exner, thv_ds_zt, newmu, l_implemented, & ! intent(in) + err_code, & ! intent(inout) + Lscale, Lscale_up, Lscale_down ) ! intent(out) + + if ( l_avg_Lscale ) then + if ( l_Lscale_plume_centered ) then + ! Weighted average of mean, pert_1, & pert_2 +! Lscale = 0.5_core_rknd * ( Lscale + Lscale_weight*Lscale_pert_1 & +! + (1.0_core_rknd-Lscale_weight)*Lscale_pert_2 ) + + ! Weighted average of just the perturbed values +! Lscale = Lscale_weight*Lscale_pert_1 + (1.0_core_rknd-Lscale_weight)*Lscale_pert_2 + + ! Un-weighted average of just the perturbed values + Lscale = 0.5_core_rknd*( Lscale_pert_1 + Lscale_pert_2 ) + else + Lscale = (1.0_core_rknd/3.0_core_rknd) * ( Lscale + Lscale_pert_1 + Lscale_pert_2 ) + end if + end if + + !---------------------------------------------------------------- + ! Dissipation time + !---------------------------------------------------------------- +! Vince Larson replaced the cutoff of em_min by w_tol**2. 7 Jul 2007 +! This is to prevent tau from being too large (producing little damping) +! in stably stratified layers with little turbulence. +! sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) +! tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) +! tau_zm & +! = MIN( ( zt2zm( Lscale ) / SQRT( MAX( em_min, em ) ) ), taumax ) +! Addition by Brian: Model constant em_min is now set to (3/2)*w_tol_sqd. +! Thus, em_min can replace w_tol_sqd here. + sqrt_em_zt = SQRT( MAX( em_min, zm2zt( em ) ) ) + + tau_zt = MIN( Lscale / sqrt_em_zt, taumax ) + tau_zm = MIN( ( MAX( zt2zm( Lscale ), zero_threshold ) & + / SQRT( MAX( em_min, em ) ) ), taumax ) +! End Vince Larson's replacement. + + ! Modification to damp noise in stable region +! Vince Larson commented out because it may prevent turbulence from +! initiating in unstable regions. 7 Jul 2007 +! do k = 1, gr%nz +! if ( wp2(k) <= 0.005_core_rknd ) then +! tau_zt(k) = taumin +! tau_zm(k) = taumin +! end if +! end do +! End Vince Larson's commenting. + + !---------------------------------------------------------------- + ! Eddy diffusivity coefficient + !---------------------------------------------------------------- + ! c_K is 0.548 usually (Duynkerke and Driedonks 1987) + ! CLUBB uses a smaller value to better fit empirical data. + + Kh_zt = c_K * Lscale * sqrt_em_zt + Kh_zm = c_K * max( zt2zm( Lscale ), zero_threshold ) & + * sqrt( max( em, em_min ) ) + +#if defined(CLUBB_CAM) || defined(GFDL) + khzt(:) = Kh_zt(:) + khzm(:) = Kh_zm(:) +#endif + +#ifdef CLUBB_CAM + qclvar(:) = rcp2_zt(:) + thlprcp_out(:) = thlprcp(:) +#endif + + !---------------------------------------------------------------- + ! Set Surface variances + !---------------------------------------------------------------- + + ! Surface variances should be set here, before the call to either + ! advance_xp2_xpyp or advance_wp2_wp3. + ! Surface effects should not be included with any case where the lowest + ! level is not the ground level. Brian Griffin. December 22, 2005. + if ( gr%zm(1) == sfc_elevation ) then + + ! Reflect surface varnce changes in budget + if ( l_stats_samp ) then + call stat_begin_update_pt( ithlp2_sf, 1, & ! intent(in) + thlp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( irtp2_sf, 1, & ! intent(in) + rtp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( irtpthlp_sf, 1, & ! intent(in) + rtpthlp(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( iup2_sf, 1, & ! intent(in) + up2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( ivp2_sf, 1, & ! intent(in) + vp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_begin_update_pt( iwp2_sf, 1, & ! intent(in) + wp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + end if + + call surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & ! intent(in) + um(2), vm(2), Lscale_up(2), wpsclrp_sfc, & ! intent(in) + wp2(1), up2(1), vp2(1), & ! intent(out) + thlp2(1), rtp2(1), rtpthlp(1), err_code_surface,& ! intent(out) + sclrp2(1,1:sclr_dim), & ! intent(out) + sclrprtp(1,1:sclr_dim), & ! intent(out) + sclrpthlp(1,1:sclr_dim) ) ! intent(out) + + if ( fatal_error( err_code_surface ) ) then + call report_error( err_code_surface ) ! intent(in) + err_code = err_code_surface + end if + + ! Update surface stats + if ( l_stats_samp ) then + call stat_end_update_pt( ithlp2_sf, 1, & ! intent(in) + thlp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( irtp2_sf, 1, & ! intent(in) + rtp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( irtpthlp_sf, 1, & ! intent(in) + rtpthlp(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( iup2_sf, 1, & ! intent(in) + up2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( ivp2_sf, 1, & ! intent(in) + vp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update_pt( iwp2_sf, 1, & ! intent(in) + wp2(1) / dt, & ! intent(in) + stats_zm ) ! intent(inout) + end if + + else + + ! Variances for cases where the lowest level is not at the surface. + ! Eliminate surface effects on lowest level variances. + wp2(1) = w_tol_sqd + up2(1) = w_tol_sqd + vp2(1) = w_tol_sqd + thlp2(1) = thl_tol**2 + rtp2(1) = rt_tol**2 + rtpthlp(1) = 0.0_core_rknd + + do i = 1, sclr_dim, 1 + sclrp2(1,i) = 0.0_core_rknd + sclrprtp(1,i) = 0.0_core_rknd + sclrpthlp(1,i) = 0.0_core_rknd + end do + + end if ! gr%zm(1) == sfc_elevation + + + !####################################################################### + !############## ADVANCE PROGNOSTIC VARIABLES ONE TIMESTEP ############## + !####################################################################### + + ! Store the saturation mixing ratio for output purposes. Brian + ! Compute rsat if either rsat or rel_humidity is to be saved. ldgrant + if ( ( irsat > 0 ) .or. ( irel_humidity > 0 ) ) then + rsat = sat_mixrat_liq( p_in_Pa, thlm2T_in_K( thlm, exner, rcm ) ) + end if + + + if ( l_stats_samp ) then + call stat_update_var( irvm, rtm - rcm, & !intent(in) + stats_zt ) !intent(inout) + + ! Output relative humidity (q/q∗ where q∗ is the saturation mixing ratio over liquid) + ! Added an extra check for irel_humidity > 0; otherwise, if both irsat = 0 and + ! irel_humidity = 0, rsat is not computed, leading to a floating-point exception + ! when stat_update_var is called for rel_humidity. ldgrant + if ( irel_humidity > 0 ) then + call stat_update_var( irel_humidity, (rtm - rcm) / rsat, & !intent(in) + stats_zt) !intent(inout) + end if ! irel_humidity > 0 + end if ! l_stats_samp + + !---------------------------------------------------------------- + ! Advance rtm/wprtp and thlm/wpthlp one time step + !---------------------------------------------------------------- + if ( l_call_pdf_closure_twice ) then + w_1_zm = pdf_params_zm%w_1 + w_2_zm = pdf_params_zm%w_2 + varnce_w_1_zm = pdf_params_zm%varnce_w_1 + varnce_w_2_zm = pdf_params_zm%varnce_w_2 + mixt_frac_zm = pdf_params_zm%mixt_frac + else + w_1_zm = zt2zm( pdf_params%w_1 ) + w_2_zm = zt2zm( pdf_params%w_2 ) + varnce_w_1_zm = zt2zm( pdf_params%varnce_w_1 ) + varnce_w_2_zm = zt2zm( pdf_params%varnce_w_2 ) + mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) + end if + + ! Determine stability correction factor + stability_correction = calc_stability_correction( thlm, Lscale, em, exner, rtm, rcm, & ! In + p_in_Pa, cloud_frac ) ! In + if ( l_stats_samp ) then + call stat_update_var( istability_correction, stability_correction, & ! In + stats_zm ) ! In/Out + end if + + ! Here we determine if we're using tau_zm or tau_N2_zm, which is tau + ! that has been stability corrected for stably stratified regions. + ! -dschanen 7 Nov 2014 + if ( l_stability_correct_tau_zm ) then + ! Determine the static stability corrected version of tau_zm + ! Create a damping time scale that is more strongly damped at the + ! altitudes where the Brunt-Vaisala frequency (N^2) is large. + tau_N2_zm = tau_zm / stability_correction + tau_C6_zm = tau_N2_zm + tau_C1_zm = tau_N2_zm + + else + tau_N2_zm = unused_var + tau_C6_zm = tau_zm + tau_C1_zm = tau_zm + + end if ! l_stability_correction + + call advance_xm_wpxp( dt, sigma_sqd_w, um, vm, wm_zm, wm_zt, wp2, & ! intent(in) + Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, Kh_zm, & ! intent(in) + tau_C6_zm, Skw_zm, rtpthvp, rtm_forcing, & ! intent(in) + wprtp_forcing, rtm_ref, thlpthvp, & ! intent(in) + thlm_forcing, wpthlp_forcing, thlm_ref, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, & ! intent(in) + w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! intent(in) + mixt_frac_zm, l_implemented, em, & ! intent(in) + sclrpthvp, sclrm_forcing, sclrp2, exner, rcm, & ! intent(in) + p_in_Pa, cloud_frac, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(inout) + err_code, & ! intent(inout) + sclrm, wpsclrp ) ! intent(inout) + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 + call clip_rcm( rtm, 'rtm < rcm in advance_xm_wpxp', & ! intent(in) + rcm ) ! intent(inout) + +#ifdef GFDL + call advance_sclrm_Nd_diffusion_OG( dt, & ! h1g, 2012-06-16 ! intent(in) + sclrm, sclrm_trsport_only, & ! intent(inout) + Kh_zm, cloud_frac, & ! intent(in) + err_code ) ! intent(out) +#endif + + !---------------------------------------------------------------- + ! Compute some of the variances and covariances. These include the variance of + ! total water (rtp2), liquid potential termperature (thlp2), their + ! covariance (rtpthlp), and the variance of horizontal wind (up2 and vp2). + ! The variance of vertical velocity is computed later. + !---------------------------------------------------------------- + + ! We found that certain cases require a time tendency to run + ! at shorter timesteps so these are prognosed now. + + ! We found that if we call advance_xp2_xpyp first, we can use a longer timestep. + call advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, thlm, & ! intent(in) + wpthlp, wpthvp, um, vm, wp2, wp2_zt, & ! intent(in) + wp3, upwp, vpwp, sigma_sqd_w, Skw_zm, & ! intent(in) + Kh_zt, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, rho_ds_zm, rho_ds_zt, & ! intent(in) + invrs_rho_ds_zm, thv_ds_zm, & ! intent(in) + Lscale, wp3_on_wp2, wp3_on_wp2_zt, & ! intent(in) + l_iter_xp2_xpyp, dt, & ! intent(in) + sclrm, wpsclrp, & ! intent(in) + rtp2, thlp2, rtpthlp, up2, vp2, & ! intent(inout) + err_code, & ! intent(inout) + sclrp2, sclrprtp, sclrpthlp ) ! intent(inout) + + !---------------------------------------------------------------- + ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp + ! after subroutine advance_xp2_xpyp updated xp2. + !---------------------------------------------------------------- + + wprtp_cl_num = 2 ! Second instance of w'r_t' clipping. + wpthlp_cl_num = 2 ! Second instance of w'th_l' clipping. + wpsclrp_cl_num = 2 ! Second instance of w'sclr' clipping. + upwp_cl_num = 1 ! First instance of u'w' clipping. + vpwp_cl_num = 1 ! First instance of v'w' clipping. + + call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) + sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) + wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) + wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) + + + !---------------------------------------------------------------- + ! Advance 2nd and 3rd order moment of vertical velocity (wp2 / wp3) + ! by one timestep + !---------------------------------------------------------------- + + call advance_wp2_wp3 & + ( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! intent(in) + a3_coef, a3_coef_zt, wp3_on_wp2, & ! intent(in) + wpthvp, wp2thvp, um, vm, upwp, vpwp, & ! intent(in) + up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, tau_C1_zm, & ! intent(in) + Skw_zm, Skw_zt, rho_ds_zm, rho_ds_zt, & ! intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, & ! intent(in) + thv_ds_zm, thv_ds_zt, pdf_params%mixt_frac, & ! intent(in) + wp2, wp3, wp3_zm, wp2_zt, err_code ) ! intent(inout) + + !---------------------------------------------------------------- + ! Covariance clipping for wprtp, wpthlp, wpsclrp, upwp, and vpwp + ! after subroutine advance_wp2_wp3 updated wp2. + !---------------------------------------------------------------- + + wprtp_cl_num = 3 ! Third instance of w'r_t' clipping. + wpthlp_cl_num = 3 ! Third instance of w'th_l' clipping. + wpsclrp_cl_num = 3 ! Third instance of w'sclr' clipping. + upwp_cl_num = 2 ! Second instance of u'w' clipping. + vpwp_cl_num = 2 ! Second instance of v'w' clipping. + + call clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & ! intent(in) + sclrp2, wprtp_cl_num, wpthlp_cl_num, & ! intent(in) + wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & ! intent(in) + wprtp, wpthlp, upwp, vpwp, wpsclrp ) ! intent(inout) + + !---------------------------------------------------------------- + ! Advance the horizontal mean of the wind in the x-y directions + ! (i.e. um, vm) and the mean of the eddy-diffusivity scalars + ! (i.e. edsclrm) by one time step + !----------------------------------------------------------------i + + Km_zm = Kh_zm * c_K10 ! Coefficient for momentum + Kmh_zm = Kh_zm * c_K10h ! Coefficient for thermo + + if ( l_do_expldiff_rtm_thlm ) then + edsclrm(:,edsclr_dim-1)=thlm(:) + edsclrm(:,edsclr_dim)=rtm(:) + endif + + call advance_windm_edsclrm( dt, wm_zt, Km_zm, Kmh_zm, ug, vg, um_ref, vm_ref, & ! intent(in) + wp2, up2, vp2, um_forcing, vm_forcing, & ! intent(in) + edsclrm_forcing, & ! intent(in) + rho_ds_zm, invrs_rho_ds_zt, & ! intent(in) + fcor, l_implemented, & ! intent(in) + um, vm, edsclrm, & ! intent(inout) + upwp, vpwp, wpedsclrp, & ! intent(inout) + err_code ) ! intent(inout) + + if ( l_do_expldiff_rtm_thlm ) then + call pvertinterp(gr%nz, p_in_Pa, 70000.0_core_rknd, thlm, thlm700) + call pvertinterp(gr%nz, p_in_Pa, 100000.0_core_rknd, thlm, thlm1000) + if ( thlm700 - thlm1000 < 20.0_core_rknd ) then + thlm(:) = edsclrm(:,edsclr_dim-1) + rtm(:) = edsclrm(:,edsclr_dim) + end if + end if + + ! Eric Raut: this seems dangerous to call without any attached flag. + ! Hence the preprocessor. +#ifdef CLUBB_CAM + do ixind=1,edsclr_dim + call fill_holes_vertical(2,0.0_core_rknd,"zt",rho_ds_zt,rho_ds_zm,edsclrm(:,ixind)) + enddo +#endif + + !####################################################################### + !############# ACCUMULATE STATISTICS ############# + !####################################################################### + + if ( l_stats_samp ) then + + call stat_end_update( iwp2_bt, wp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( ivp2_bt, vp2 / dt,& ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iup2_bt, up2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( irtp2_bt, rtp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( ithlp2_bt, thlp2 / dt, & ! intent(in) + stats_zm ) ! intent(inout) + call stat_end_update( irtpthlp_bt, rtpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + + call stat_end_update( irtm_bt, rtm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ithlm_bt, thlm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ium_bt, um / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( ivm_bt, vm / dt, & ! intent(in) + stats_zt ) ! intent(inout) + call stat_end_update( iwp3_bt, wp3 / dt, & ! intent(in) + stats_zt ) ! intent(inout) + + end if ! l_stats_samp + + + if ( iwpthlp_zt > 0 ) then + wpthlp_zt = zm2zt( wpthlp ) + end if + + if ( iwprtp_zt > 0 ) then + wprtp_zt = zm2zt( wprtp ) + end if + + if ( iup2_zt > 0 ) then + up2_zt = max( zm2zt( up2 ), w_tol_sqd ) + end if + + if (ivp2_zt > 0 ) then + vp2_zt = max( zm2zt( vp2 ), w_tol_sqd ) + end if + + if ( iupwp_zt > 0 ) then + upwp_zt = zm2zt( upwp ) + end if + + if ( ivpwp_zt > 0 ) then + vpwp_zt = zm2zt( vpwp ) + end if + + call stats_accumulate & + ( um, vm, upwp, vpwp, up2, vp2, & ! intent(in) + thlm, rtm, wprtp, wpthlp, & ! intent(in) + wp2, wp3, rtp2, rtp3, thlp2, thlp3, rtpthlp, & ! intent(in) + p_in_Pa, exner, rho, rho_zm, & ! intent(in) + rho_ds_zm, rho_ds_zt, thv_ds_zm, & ! intent(in) + thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, rc_coef, & ! intent(in) + rcm_zm, rtm_zm, thlm_zm, cloud_frac, ice_supersat_frac,& ! intent(in) + cloud_frac_zm, ice_supersat_frac_zm, rcm_in_layer, & ! intent(in) + cloud_cover, sigma_sqd_w, pdf_params, & ! intent(in) + sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & ! intent(in) + wpsclrp, edsclrm, edsclrm_forcing ) ! intent(in) + + + if ( clubb_at_least_debug_level( 2 ) ) then + call parameterization_check & + ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + um, upwp, vm, vpwp, up2, vp2, & ! intent(in) + rtm, wprtp, thlm, wpthlp, & ! intent(in) + wp2, wp3, rtp2, thlp2, rtpthlp, & ! intent(in) + "end of ", & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & ! intent(in) + sclrm_forcing, edsclrm, edsclrm_forcing, & ! intent(in) + err_code ) ! intent(inout) + end if + + if ( l_stats .and. l_stats_samp ) then + ! Spurious source will only be calculated if rtm_ma and thlm_ma are zero. + ! Therefore, wm must be zero or l_implemented must be true. + if ( l_implemented .or. ( all( wm_zt == 0._core_rknd ) .and. & + all( wm_zm == 0._core_rknd ) ) ) then + ! Calculate the spurious source for rtm + rtm_flux_top = rho_ds_zm(gr%nz) * wprtp(gr%nz) + + if ( .not. l_host_applies_sfc_fluxes ) then + rtm_flux_sfc = rho_ds_zm(1) * wprtp_sfc + else + rtm_flux_sfc = 0.0_core_rknd + end if + + rtm_integral_after & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + rtm_integral_forcing & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rtm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + rtm_spur_src & + = calculate_spurious_source( rtm_integral_after, & + rtm_integral_before, & + rtm_flux_top, rtm_flux_sfc, & + rtm_integral_forcing, & + dt ) + + ! Calculate the spurious source for thlm + thlm_flux_top = rho_ds_zm(gr%nz) * wpthlp(gr%nz) + + if ( .not. l_host_applies_sfc_fluxes ) then + thlm_flux_sfc = rho_ds_zm(1) * wpthlp_sfc + else + thlm_flux_sfc = 0.0_core_rknd + end if + + thlm_integral_after & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_integral_forcing & + = vertical_integral( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + thlm_forcing(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + thlm_spur_src & + = calculate_spurious_source( thlm_integral_after, & + thlm_integral_before, & + thlm_flux_top, thlm_flux_sfc, & + thlm_integral_forcing, & + dt ) + else ! If l_implemented is false, we don't want spurious source output + rtm_spur_src = -9999.0_core_rknd + thlm_spur_src = -9999.0_core_rknd + end if + + ! Write the var to stats + call stat_update_var_pt( irtm_spur_src, 1, rtm_spur_src, & ! intent(in) + stats_sfc ) ! intent(inout) + call stat_update_var_pt( ithlm_spur_src, 1, thlm_spur_src, & ! intent(in) + stats_sfc ) ! intent(inout) + end if + + return + end subroutine advance_clubb_core + + !----------------------------------------------------------------------- + subroutine setup_clubb_core & + ( nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + ! + ! Description: + ! Subroutine to set up the model for execution. + ! + ! References: + ! None + !------------------------------------------------------------------------- + use grid_class, only: & + setup_grid, & ! Procedure + gr ! Variable(s) + + use parameter_indices, only: & + nparams ! Variable(s) + + use parameters_tunable, only: & + setup_parameters ! Procedure + + use parameters_model, only: & + setup_parameters_model ! Procedure + + use variables_diagnostic_module, only: & + setup_diagnostic_variables ! Procedure + + use variables_prognostic_module, only: & + setup_prognostic_variables ! Procedure + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_no_error ! Constant(s) + + use model_flags, only: & + setup_model_flags ! Subroutine + +#ifdef MKL + use csr_matrix_module, only: & + initialize_csr_matrix, & ! Subroutine + intlc_5d_5d_ja_size ! Variable + + use gmres_wrap, only: & + gmres_init ! Subroutine + + use gmres_cache, only: & + gmres_cache_temp_init, &! Subroutine + gmres_idx_wp2wp3 ! Variable +#endif /* MKL */ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + ! Only true when used in a host model + ! CLUBB determines what nzmax should be + ! given zm_init and zm_top when + ! running in standalone mode. + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an + ! evenly-spaced grid (grid_type = 1), it needs the vertical + ! grid spacing, momentum-level starting altitude, and maximum + ! altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Change in altitude per level [m] + zm_init, & ! Initial grid altitude (momentum level) [m] + zm_top ! Maximum grid altitude (momentum level) [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Model parameters + real( kind = core_rknd ), intent(in) :: & + T0_in, ts_nudge_in + + integer, intent(in) :: & + hydromet_dim_in, & ! Number of hydrometeor species + sclr_dim_in, & ! Number of passive scalars + edsclr_dim_in ! Number of eddy-diff. passive scalars + + real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & + sclr_tol_in ! Thresholds for passive scalars + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Including C1, nu1, nu2, etc. + + ! Flags + logical, intent(in) :: & + l_uv_nudge, & ! Wind nudging + l_host_applies_sfc_fluxes ! Whether to apply for the surface flux + + character(len=*), intent(in) :: & + saturation_formula ! Approximation for saturation vapor pressure + +#ifdef GFDL + logical, intent(in) :: & ! h1g, 2010-06-16 begin mod + I_sat_sphum + + real( kind = core_rknd ), intent(in) :: & + cloud_frac_min ! h1g, 2010-06-16 end mod +#endif + + ! Output variables + integer, intent(out) :: & + err_code ! Diagnostic for a problem with the setup + + ! Local variables + integer :: begin_height, end_height + + !----- Begin Code ----- + + ! Sanity check for the saturation formula + select case ( trim( saturation_formula ) ) + case ( "bolton", "Bolton" ) + ! Using the Bolton 1980 approximations for SVP over vapor/ice + + case ( "flatau", "Flatau" ) + ! Using the Flatau, et al. polynomial approximation for SVP over vapor/ice + + case ( "gfdl", "GFDL" ) ! h1g, 2010-06-16 + ! Using the GFDL SVP formula (Goff-Gratch) + + ! Add new saturation formulas after this + + case default + write(fstderr,*) "Error in setup_clubb_core." + write(fstderr,*) "Unknown approx. of saturation vapor pressure: "// & + trim( saturation_formula ) + stop + end select + + ! Setup grid + call setup_grid( nzmax, sfc_elevation, l_implemented, & ! intent(in) + grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + begin_height, end_height ) ! intent(out) + + ! Setup flags +#ifdef GFDL + call setup_model_flags & + ( l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) + I_sat_sphum ) ! intent(in) h1g, 2010-06-16 + +#else + call setup_model_flags & + ( l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula ) ! intent(in) +#endif + + + ! Define model constant parameters +#ifdef GFDL + call setup_parameters_model( T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, & ! intent(in) + sclr_dim_in, sclr_tol_in, edsclr_dim_in, & ! intent(in) + cloud_frac_min ) ! intent(in) h1g, 2010-06-16 +#else + call setup_parameters_model( T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, & ! intent(in) + sclr_dim_in, sclr_tol_in, edsclr_dim_in ) ! intent(in) +#endif + + ! Define tunable constant parameters + call setup_parameters & + ( deltaz, params, gr%nz, & ! intent(in) + grid_type, momentum_heights(begin_height:end_height), & ! intent(in) + thermodynamic_heights(begin_height:end_height), & ! intent(in) + err_code ) ! intent(out) + + ! Error Report + ! Joshua Fasching February 2008 + if ( err_code /= clubb_no_error ) then + + write(fstderr,*) "Error in setup_clubb_core" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "deltaz = ", deltaz + write(fstderr,*) "zm_init = ", zm_init + write(fstderr,*) "zm_top = ", zm_top + write(fstderr,*) "momentum_heights = ", momentum_heights + write(fstderr,*) "thermodynamic_heights = ", & + thermodynamic_heights + write(fstderr,*) "T0_in = ", T0_in + write(fstderr,*) "ts_nudge_in = ", ts_nudge_in + write(fstderr,*) "params = ", params + + return + + end if + +#ifdef GFDL +! setup prognostic_variables + call setup_prognostic_variables( gr%nz ) ! intent(in) h1g, 2010-06-16 +#else + if ( .not. l_implemented ) then + call setup_prognostic_variables( gr%nz ) ! intent(in) + end if +#endif + + ! The diagnostic variables need to be + ! declared, allocated, initialized, and deallocated whether CLUBB + ! is part of a larger model or not. + call setup_diagnostic_variables( gr%nz ) ! intent(in) + +#ifdef MKL + ! Initialize the CSR matrix class. + if ( l_gmres ) then + call initialize_csr_matrix + end if + + if ( l_gmres ) then + call gmres_cache_temp_init( gr%nz ) ! intent(in) + call gmres_init( (2 * gr%nz), intlc_5d_5d_ja_size ) ! intent(in) + end if +#endif /* MKL */ + + return + end subroutine setup_clubb_core + + !---------------------------------------------------------------------------- + subroutine cleanup_clubb_core( l_implemented ) + ! + ! Description: + ! Frees memory used by the model itself. + ! + ! References: + ! None + !--------------------------------------------------------------------------- + use parameters_model, only: sclr_tol ! Variable + + use variables_diagnostic_module, only: & + cleanup_diagnostic_variables ! Procedure + + use variables_prognostic_module, only: & + cleanup_prognostic_variables ! Procedure + + use grid_class, only: & + cleanup_grid ! Procedure + + use parameters_tunable, only: & + cleanup_nu ! Procedure + + implicit none + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + !----- Begin Code ----- +#ifdef GFDL + ! cleanup prognostic_variables + call cleanup_prognostic_variables( ) ! h1g, 2010-06-16 +#else + if ( .not. l_implemented ) then + call cleanup_prognostic_variables( ) + end if +#endif + + ! The diagnostic variables need to be + ! declared, allocated, initialized, and deallocated whether CLUBB + ! is part of a larger model or not. + call cleanup_diagnostic_variables( ) + + ! De-allocate the array for the passive scalar tolerances + deallocate( sclr_tol ) + + ! De-allocate the arrays for the grid + call cleanup_grid( ) + + ! De-allocate the arrays for nu + call cleanup_nu( ) + + return + end subroutine cleanup_clubb_core + + !----------------------------------------------------------------------- + subroutine trapezoidal_rule_zt & + ( l_call_pdf_closure_twice, & ! intent(in) + wprtp2, wpthlp2, & ! intent(inout) + wprtpthlp, cloud_frac, ice_supersat_frac, & ! intent(inout) + rcm, wp2thvp, wpsclrprtp, wpsclrp2, & ! intent(inout) + wpsclrpthlp, pdf_params, & ! intent(inout) + wprtp2_zm, wpthlp2_zm, & ! intent(inout) + wprtpthlp_zm, cloud_frac_zm, & ! intent(inout) + ice_supersat_frac_zm, rcm_zm, wp2thvp_zm, & ! intent(inout) + wpsclrprtp_zm, wpsclrp2_zm, wpsclrpthlp_zm, & ! intent(inout) + pdf_params_zm ) ! intent(inout) + ! + ! Description: + ! This subroutine takes the output variables on the thermo. + ! grid and either: interpolates them to the momentum grid, or uses the + ! values output from the second call to pdf_closure on momentum levels if + ! l_call_pdf_closure_twice is true. It then calls the function + ! trapezoid_zt to recompute the variables on the thermo. grid. + ! + ! ldgrant June 2009 + ! + ! Note: + ! The argument variables in the last 5 lines of the subroutine + ! (wprtp2_zm through pdf_params_zm) are declared intent(inout) because + ! if l_call_pdf_closure_twice is true, these variables will already have + ! values from pdf_closure on momentum levels and will not be altered in + ! this subroutine. However, if l_call_pdf_closure_twice is false, these + ! variables will not have values yet and will be interpolated to + ! momentum levels in this subroutine. + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + iwprtp2, & ! Varibles + iwprtpthlp, & + iwpthlp2, & + iwprtp2, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + l_stats + + use grid_class, only: & + gr, & ! Variable + zt2zm ! Procedure + + use parameters_model, only: & + sclr_dim ! Number of passive scalar variables + + use pdf_parameter_module, only: & + pdf_parameter ! Derived data type + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + logical, parameter :: & + l_apply_rule_to_pdf_params = .false. ! Apply the trapezoidal rule to pdf_params + + ! Input variables + logical, intent(in) :: l_call_pdf_closure_twice + + ! Input/Output variables + ! Thermodynamic level variables output from the first call to pdf_closure + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wprtp2, & ! w'rt'^2 [m kg^2/kg^2] + wpthlp2, & ! w'thl'^2 [m K^2/s] + wprtpthlp, & ! w'rt'thl' [m kg K/kg s] + cloud_frac, & ! Cloud Fraction [-] + ice_supersat_frac, & ! Ice Cloud Fraction [-] + rcm, & ! Liquid water mixing ratio [kg/kg] + wp2thvp ! w'^2 th_v' [m^2 K/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & + wpsclrprtp, & ! w'sclr'rt' + wpsclrp2, & ! w'sclr'^2 + wpsclrpthlp ! w'sclr'thl' + + type (pdf_parameter), dimension(gr%nz), intent(inout) :: & + pdf_params ! PDF parameters [units vary] + + ! Thermo. level variables brought to momentum levels either by + ! interpolation (in subroutine trapezoidal_rule_zt) or by + ! the second call to pdf_closure (in subroutine advance_clubb_core) + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wprtp2_zm, & ! w'rt'^2 on momentum grid [m kg^2/kg^2] + wpthlp2_zm, & ! w'thl'^2 on momentum grid [m K^2/s] + wprtpthlp_zm, & ! w'rt'thl' on momentum grid [m kg K/kg s] + cloud_frac_zm, & ! Cloud Fraction on momentum grid [-] + ice_supersat_frac_zm, & ! Ice Cloud Fraction on momentum grid [-] + rcm_zm, & ! Liquid water mixing ratio on momentum grid [kg/kg] + wp2thvp_zm ! w'^2 th_v' on momentum grid [m^2 K/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & + wpsclrprtp_zm, & ! w'sclr'rt' on momentum grid + wpsclrp2_zm, & ! w'sclr'^2 on momentum grid + wpsclrpthlp_zm ! w'sclr'thl' on momentum grid + + type (pdf_parameter), dimension(gr%nz), intent(inout) :: & + pdf_params_zm ! PDF parameters on momentum grid [units vary] + + ! Local variables + + ! Components of PDF_parameters on the momentum grid (_zm) and on the thermo. grid (_zt) + real( kind = core_rknd ), dimension(gr%nz) :: & + w_1_zt, & ! Mean of w for 1st normal distribution [m/s] + w_1_zm, & ! Mean of w for 1st normal distribution [m/s] + w_2_zm, & ! Mean of w for 2nd normal distribution [m/s] + w_2_zt, & ! Mean of w for 2nd normal distribution [m/s] + varnce_w_1_zm, & ! Variance of w for 1st normal distribution [m^2/s^2] + varnce_w_1_zt, & ! Variance of w for 1st normal distribution [m^2/s^2] + varnce_w_2_zm, & ! Variance of w for 2nd normal distribution [m^2/s^2] + varnce_w_2_zt, & ! Variance of w for 2nd normal distribution [m^2/s^2] + rt_1_zm, & ! Mean of r_t for 1st normal distribution [kg/kg] + rt_1_zt, & ! Mean of r_t for 1st normal distribution [kg/kg] + rt_2_zm, & ! Mean of r_t for 2nd normal distribution [kg/kg] + rt_2_zt, & ! Mean of r_t for 2nd normal distribution [kg/kg] + varnce_rt_1_zm, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] + varnce_rt_1_zt, & ! Variance of r_t for 1st normal distribution [kg^2/kg^2] + varnce_rt_2_zm, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] + varnce_rt_2_zt, & ! Variance of r_t for 2nd normal distribution [kg^2/kg^2] + crt_1_zm, & ! Coefficient for s' [-] + crt_1_zt, & ! Coefficient for s' [-] + crt_2_zm ! Coefficient for s' [-] + + real( kind = core_rknd ), dimension(gr%nz) :: & + crt_2_zt, & ! Coefficient for s' [-] + cthl_1_zm, & ! Coefficient for s' [1/K] + cthl_1_zt, & ! Coefficient for s' [1/K] + cthl_2_zm, & ! Coefficient for s' [1/K] + cthl_2_zt, & ! Coefficient for s' [1/K] + thl_1_zm, & ! Mean of th_l for 1st normal distribution [K] + thl_1_zt, & ! Mean of th_l for 1st normal distribution [K] + thl_2_zm, & ! Mean of th_l for 2nd normal distribution [K] + thl_2_zt, & ! Mean of th_l for 2nd normal distribution + varnce_thl_1_zm, & ! Variance of th_l for 1st normal distribution [K^2] + varnce_thl_1_zt, & ! Variance of th_l for 1st normal distribution [K^2] + varnce_thl_2_zm, & ! Variance of th_l for 2nd normal distribution [K^2] + varnce_thl_2_zt ! Variance of th_l for 2nd normal distribution [K^2] + + real( kind = core_rknd ), dimension(gr%nz) :: & + mixt_frac_zm, & ! Weight of 1st normal distribution (Sk_w dependent) [-] + mixt_frac_zt, & ! Weight of 1st normal distribution (Sk_w dependent) [-] + rc_1_zm, & ! Mean of r_c for 1st normal distribution [kg/kg] + rc_1_zt, & ! Mean of r_c for 1st normal distribution [kg/kg] + rc_2_zm, & ! Mean of r_c for 2nd normal distribution [kg/kg] + rc_2_zt, & ! Mean of r_c for 2nd normal distribution [kg/kg] + rsatl_1_zm, & ! Mean of r_sl for 1st normal distribution [kg/kg] + rsatl_1_zt, & ! Mean of r_sl for 1st normal distribution [kg/kg] + rsatl_2_zm, & ! Mean of r_sl for 2nd normal distribution [kg/kg] + rsatl_2_zt, & ! Mean of r_sl for 2nd normal distribution [kg/kg] + cloud_frac_1_zm, & ! Cloud fraction for 1st normal distribution [-] + cloud_frac_1_zt, & ! Cloud fraction for 1st normal distribution [-] + cloud_frac_2_zm, & ! Cloud fraction for 2nd normal distribution [-] + cloud_frac_2_zt, & ! Cloud fraction for 2nd normal distribution [-] + chi_1_zm, & ! Mean of chi(s) for 1st normal distribution [kg/kg] + chi_1_zt, & ! Mean of chi(s) for 1st normal distribution [kg/kg] + chi_2_zm, & ! Mean of chi(s) for 2nd normal distribution [kg/kg] + chi_2_zt, & ! Mean of chi(s) for 2nd normal distribution [kg/kg] + stdev_chi_1_zm ! Standard deviation of chi(s) for 1st normal distribution [kg/kg] + + real( kind = core_rknd ), dimension(gr%nz) :: & + stdev_chi_1_zt, & ! Standard deviation of chi(s) for 1st normal distribution [kg/kg] + stdev_chi_2_zm, & ! Standard deviation of chi(s) for 2nd normal distribution [kg/kg] + stdev_chi_2_zt, & ! Standard deviation of chi(s) for 2nd normal distribution [kg/kg] + stdev_eta_1_zm, & ! Standard deviation of eta(t) for 1st normal distribution [kg/kg] + stdev_eta_1_zt, & ! Standard deviation of eta(t) for 1st normal distribution [kg/kg] + stdev_eta_2_zm, & ! Standard deviation of eta(t) for 2nd normal distribution [kg/kg] + stdev_eta_2_zt, & ! Standard deviation of eta(t) for 2nd normal distribution [kg/kg] + rrtthl_zm, & ! Within-a-normal correlation of r_t and th_l [-] + rrtthl_zt, & ! Within-a-normal correlation of r_t and th_l [-] + alpha_thl_zm, & ! Factor relating to normalized variance for th_l [-] + alpha_thl_zt, & ! Factor relating to normalized variance for th_l [-] + alpha_rt_zm, & ! Factor relating to normalized variance for r_t [-] + alpha_rt_zt ! Factor relating to normalized variance for r_t [-] + + integer :: i + + !----------------------- Begin Code ----------------------------- + + ! Store components of pdf_params in the locally declared variables + ! We only apply the trapezoidal rule to these when + ! l_apply_rule_to_pdf_params is true. This is because when we apply the + ! rule to the final result of pdf_closure rather than the intermediate + ! results it can lead to an inconsistency in how we determine which + ! PDF component a point is in and whether the point is in or out of cloud, + ! which is turn will break the latin hypercube code that samples + ! preferentially in cloud. -dschanen 13 Feb 2012 + + if ( l_apply_rule_to_pdf_params ) then + w_1_zt = pdf_params%w_1 + w_2_zt = pdf_params%w_2 + varnce_w_1_zt = pdf_params%varnce_w_1 + varnce_w_2_zt = pdf_params%varnce_w_2 + rt_1_zt = pdf_params%rt_1 + rt_2_zt = pdf_params%rt_2 + varnce_rt_1_zt = pdf_params%varnce_rt_1 + varnce_rt_2_zt = pdf_params%varnce_rt_2 + crt_1_zt = pdf_params%crt_1 + crt_2_zt = pdf_params%crt_2 + cthl_1_zt = pdf_params%cthl_1 + cthl_2_zt = pdf_params%cthl_2 + thl_1_zt = pdf_params%thl_1 + thl_2_zt = pdf_params%thl_2 + varnce_thl_1_zt = pdf_params%varnce_thl_1 + varnce_thl_2_zt = pdf_params%varnce_thl_2 + mixt_frac_zt = pdf_params%mixt_frac + rc_1_zt = pdf_params%rc_1 + rc_2_zt = pdf_params%rc_2 + rsatl_1_zt = pdf_params%rsatl_1 + rsatl_2_zt = pdf_params%rsatl_2 + cloud_frac_1_zt = pdf_params%cloud_frac_1 + cloud_frac_2_zt = pdf_params%cloud_frac_2 + chi_1_zt = pdf_params%chi_1 + chi_2_zt = pdf_params%chi_2 + stdev_chi_1_zt = pdf_params%stdev_chi_1 + stdev_chi_2_zt = pdf_params%stdev_chi_2 + stdev_eta_1_zt = pdf_params%stdev_eta_1 + stdev_eta_2_zt = pdf_params%stdev_eta_2 + rrtthl_zt = pdf_params%rrtthl + alpha_thl_zt = pdf_params%alpha_thl + alpha_rt_zt = pdf_params%alpha_rt + end if + + ! If l_call_pdf_closure_twice is true, the _zm variables already have + ! values from the second call to pdf_closure in advance_clubb_core. + ! If it is false, the variables are interpolated to the _zm levels. + if ( l_call_pdf_closure_twice ) then + + ! Store, in locally declared variables, the pdf_params output + ! from the second call to pdf_closure + if ( l_apply_rule_to_pdf_params ) then + w_1_zm = pdf_params_zm%w_1 + w_2_zm = pdf_params_zm%w_2 + varnce_w_1_zm = pdf_params_zm%varnce_w_1 + varnce_w_2_zm = pdf_params_zm%varnce_w_2 + rt_1_zm = pdf_params_zm%rt_1 + rt_2_zm = pdf_params_zm%rt_2 + varnce_rt_1_zm = pdf_params_zm%varnce_rt_1 + varnce_rt_2_zm = pdf_params_zm%varnce_rt_2 + crt_1_zm = pdf_params_zm%crt_1 + crt_2_zm = pdf_params_zm%crt_2 + cthl_1_zm = pdf_params_zm%cthl_1 + cthl_2_zm = pdf_params_zm%cthl_2 + thl_1_zm = pdf_params_zm%thl_1 + thl_2_zm = pdf_params_zm%thl_2 + varnce_thl_1_zm = pdf_params_zm%varnce_thl_1 + varnce_thl_2_zm = pdf_params_zm%varnce_thl_2 + mixt_frac_zm = pdf_params_zm%mixt_frac + rc_1_zm = pdf_params_zm%rc_1 + rc_2_zm = pdf_params_zm%rc_2 + rsatl_1_zm = pdf_params_zm%rsatl_1 + rsatl_2_zm = pdf_params_zm%rsatl_2 + cloud_frac_1_zm = pdf_params_zm%cloud_frac_1 + cloud_frac_2_zm = pdf_params_zm%cloud_frac_2 + chi_1_zm = pdf_params_zm%chi_1 + chi_2_zm = pdf_params_zm%chi_2 + stdev_chi_1_zm = pdf_params_zm%stdev_chi_1 + stdev_chi_2_zm = pdf_params_zm%stdev_chi_2 + stdev_eta_1_zm = pdf_params_zm%stdev_eta_1 + stdev_eta_2_zm = pdf_params_zm%stdev_eta_2 + rrtthl_zm = pdf_params_zm%rrtthl + alpha_thl_zm = pdf_params_zm%alpha_thl + alpha_rt_zm = pdf_params_zm%alpha_rt + end if + + else + + ! Interpolate thermodynamic variables to the momentum grid. + ! Since top momentum level is higher than top thermo. level, + ! set variables at top momentum level to 0. + wprtp2_zm = zt2zm( wprtp2 ) + wprtp2_zm(gr%nz) = 0.0_core_rknd + wpthlp2_zm = zt2zm( wpthlp2 ) + wpthlp2_zm(gr%nz) = 0.0_core_rknd + wprtpthlp_zm = zt2zm( wprtpthlp ) + wprtpthlp_zm(gr%nz) = 0.0_core_rknd + cloud_frac_zm = zt2zm( cloud_frac ) + cloud_frac_zm(gr%nz) = 0.0_core_rknd + ice_supersat_frac_zm = zt2zm( ice_supersat_frac ) + ice_supersat_frac_zm(gr%nz) = 0.0_core_rknd + rcm_zm = zt2zm( rcm ) + rcm_zm(gr%nz) = 0.0_core_rknd + wp2thvp_zm = zt2zm( wp2thvp ) + wp2thvp_zm(gr%nz) = 0.0_core_rknd + + do i = 1, sclr_dim + wpsclrprtp_zm(:,i) = zt2zm( wpsclrprtp(:,i) ) + wpsclrprtp_zm(gr%nz,i) = 0.0_core_rknd + wpsclrp2_zm(:,i) = zt2zm( wpsclrp2(:,i) ) + wpsclrp2_zm(gr%nz,i) = 0.0_core_rknd + wpsclrpthlp_zm(:,i) = zt2zm( wpsclrpthlp(:,i) ) + wpsclrpthlp_zm(gr%nz,i) = 0.0_core_rknd + end do ! i = 1, sclr_dim + + if ( l_apply_rule_to_pdf_params ) then + w_1_zm = zt2zm( pdf_params%w_1 ) + w_1_zm(gr%nz) = 0.0_core_rknd + w_2_zm = zt2zm( pdf_params%w_2 ) + w_2_zm(gr%nz) = 0.0_core_rknd + varnce_w_1_zm = zt2zm( pdf_params%varnce_w_1 ) + varnce_w_1_zm(gr%nz) = 0.0_core_rknd + varnce_w_2_zm = zt2zm( pdf_params%varnce_w_2 ) + varnce_w_2_zm(gr%nz) = 0.0_core_rknd + rt_1_zm = zt2zm( pdf_params%rt_1 ) + rt_1_zm(gr%nz) = 0.0_core_rknd + rt_2_zm = zt2zm( pdf_params%rt_2 ) + rt_2_zm(gr%nz) = 0.0_core_rknd + varnce_rt_1_zm = zt2zm( pdf_params%varnce_rt_1 ) + varnce_rt_1_zm(gr%nz) = 0.0_core_rknd + varnce_rt_2_zm = zt2zm( pdf_params%varnce_rt_2 ) + varnce_rt_2_zm(gr%nz) = 0.0_core_rknd + crt_1_zm = zt2zm( pdf_params%crt_1 ) + crt_1_zm(gr%nz) = 0.0_core_rknd + crt_2_zm = zt2zm( pdf_params%crt_2 ) + crt_2_zm(gr%nz) = 0.0_core_rknd + cthl_1_zm = zt2zm( pdf_params%cthl_1 ) + cthl_1_zm(gr%nz) = 0.0_core_rknd + cthl_2_zm = zt2zm( pdf_params%cthl_2 ) + cthl_2_zm(gr%nz) = 0.0_core_rknd + thl_1_zm = zt2zm( pdf_params%thl_1 ) + thl_1_zm(gr%nz) = 0.0_core_rknd + thl_2_zm = zt2zm( pdf_params%thl_2 ) + thl_2_zm(gr%nz) = 0.0_core_rknd + varnce_thl_1_zm = zt2zm( pdf_params%varnce_thl_1 ) + varnce_thl_1_zm(gr%nz) = 0.0_core_rknd + varnce_thl_2_zm = zt2zm( pdf_params%varnce_thl_2 ) + varnce_thl_2_zm(gr%nz) = 0.0_core_rknd + mixt_frac_zm = zt2zm( pdf_params%mixt_frac ) + mixt_frac_zm(gr%nz) = 0.0_core_rknd + rc_1_zm = zt2zm( pdf_params%rc_1 ) + rc_1_zm(gr%nz) = 0.0_core_rknd + rc_2_zm = zt2zm( pdf_params%rc_2 ) + rc_2_zm(gr%nz) = 0.0_core_rknd + rsatl_1_zm = zt2zm( pdf_params%rsatl_1 ) + rsatl_1_zm(gr%nz) = 0.0_core_rknd + rsatl_2_zm = zt2zm( pdf_params%rsatl_2 ) + rsatl_2_zm(gr%nz) = 0.0_core_rknd + cloud_frac_1_zm = zt2zm( pdf_params%cloud_frac_1 ) + cloud_frac_1_zm(gr%nz) = 0.0_core_rknd + cloud_frac_2_zm = zt2zm( pdf_params%cloud_frac_2 ) + cloud_frac_2_zm(gr%nz) = 0.0_core_rknd + chi_1_zm = zt2zm( pdf_params%chi_1 ) + chi_1_zm(gr%nz) = 0.0_core_rknd + chi_2_zm = zt2zm( pdf_params%chi_2 ) + chi_2_zm(gr%nz) = 0.0_core_rknd + stdev_chi_1_zm = zt2zm( pdf_params%stdev_chi_1 ) + stdev_chi_1_zm(gr%nz) = 0.0_core_rknd + stdev_chi_2_zm = zt2zm( pdf_params%stdev_chi_2 ) + stdev_chi_2_zm(gr%nz) = 0.0_core_rknd + stdev_eta_1_zm = zt2zm( pdf_params%stdev_eta_1 ) + stdev_eta_1_zm(gr%nz) = 0.0_core_rknd + stdev_eta_2_zm = zt2zm( pdf_params%stdev_eta_2 ) + stdev_eta_2_zm(gr%nz) = 0.0_core_rknd + rrtthl_zm = zt2zm( pdf_params%rrtthl ) + rrtthl_zm(gr%nz) = 0.0_core_rknd + alpha_thl_zm = zt2zm( pdf_params%alpha_thl ) + alpha_thl_zm(gr%nz) = 0.0_core_rknd + alpha_rt_zm = zt2zm( pdf_params%alpha_rt ) + alpha_rt_zm(gr%nz) = 0.0_core_rknd + end if + end if ! l_call_pdf_closure_twice + + if ( l_stats ) then + ! Use the trapezoidal rule to recompute the variables on the stats_zt level + if ( iwprtp2 > 0 ) then + wprtp2 = trapezoid_zt( wprtp2, wprtp2_zm ) + end if + if ( iwpthlp2 > 0 ) then + wpthlp2 = trapezoid_zt( wpthlp2, wpthlp2_zm ) + end if + if ( iwprtpthlp > 0 ) then + wprtpthlp = trapezoid_zt( wprtpthlp, wprtpthlp_zm ) + end if + + do i = 1, sclr_dim + if ( iwpsclrprtp(i) > 0 ) then + wpsclrprtp(:,i) = trapezoid_zt( wpsclrprtp(:,i), wpsclrprtp_zm(:,i) ) + end if + if ( iwpsclrpthlp(i) > 0 ) then + wpsclrpthlp(:,i) = trapezoid_zt( wpsclrpthlp(:,i), wpsclrpthlp_zm(:,i) ) + end if + if ( iwpsclrp2(i) > 0 ) then + wpsclrp2(:,i) = trapezoid_zt( wpsclrp2(:,i), wpsclrp2_zm(:,i) ) + end if + end do ! i = 1, sclr_dim + end if ! l_stats + + cloud_frac = trapezoid_zt( cloud_frac, cloud_frac_zm ) + ice_supersat_frac = trapezoid_zt( ice_supersat_frac, ice_supersat_frac_zm ) + rcm = trapezoid_zt( rcm, rcm_zm ) + + wp2thvp = trapezoid_zt( wp2thvp, wp2thvp_zm ) + + if ( l_apply_rule_to_pdf_params ) then + ! Note: this code makes PDF component cloud water mixing ratios and + ! cloud fractions inconsistent with the PDF. Other parts of + ! CLUBB require PDF component cloud fractions to remain + ! consistent with the PDF. This code needs to be refactored + ! so that cloud_frac_1 and cloud_frac_2 are preserved. + write(fstderr,*) "The code in l_apply_rule_to_pdf_params does not " & + // "preserve cloud_frac_1 and cloud_frac_2 in a " & + // "manner consistent with the PDF as required " & + // "by other parts of CLUBB." + stop "Please refactor before continuing." + pdf_params%w_1 = trapezoid_zt( w_1_zt, w_1_zm ) + pdf_params%w_2 = trapezoid_zt( w_2_zt, w_2_zm ) + pdf_params%varnce_w_1 = trapezoid_zt( varnce_w_1_zt, varnce_w_1_zm ) + pdf_params%varnce_w_2 = trapezoid_zt( varnce_w_2_zt, varnce_w_2_zm ) + pdf_params%rt_1 = trapezoid_zt( rt_1_zt, rt_1_zm ) + pdf_params%rt_2 = trapezoid_zt( rt_2_zt, rt_2_zm ) + pdf_params%varnce_rt_1 = trapezoid_zt( varnce_rt_1_zt, varnce_rt_1_zm ) + pdf_params%varnce_rt_2 = trapezoid_zt( varnce_rt_2_zt, varnce_rt_2_zm ) + pdf_params%crt_1 = trapezoid_zt( crt_1_zt, crt_1_zm ) + pdf_params%crt_2 = trapezoid_zt( crt_2_zt, crt_2_zm ) + pdf_params%cthl_1 = trapezoid_zt( cthl_1_zt, cthl_1_zm ) + pdf_params%cthl_2 = trapezoid_zt( cthl_2_zt, cthl_2_zm ) + pdf_params%thl_1 = trapezoid_zt( thl_1_zt, thl_1_zm ) + pdf_params%thl_2 = trapezoid_zt( thl_2_zt, thl_2_zm ) + pdf_params%varnce_thl_1 = trapezoid_zt( varnce_thl_1_zt, varnce_thl_1_zm ) + pdf_params%varnce_thl_2 = trapezoid_zt( varnce_thl_2_zt, varnce_thl_2_zm ) + pdf_params%mixt_frac = trapezoid_zt( mixt_frac_zt, mixt_frac_zm ) + pdf_params%rc_1 = trapezoid_zt( rc_1_zt, rc_1_zm ) + pdf_params%rc_2 = trapezoid_zt( rc_2_zt, rc_2_zm ) + pdf_params%rsatl_1 = trapezoid_zt( rsatl_1_zt, rsatl_1_zm ) + pdf_params%rsatl_2 = trapezoid_zt( rsatl_2_zt, rsatl_2_zm ) + pdf_params%cloud_frac_1 = trapezoid_zt( cloud_frac_1_zt, cloud_frac_1_zm ) + pdf_params%cloud_frac_2 = trapezoid_zt( cloud_frac_2_zt, cloud_frac_2_zm ) + pdf_params%chi_1 = trapezoid_zt( chi_1_zt, chi_1_zm ) + pdf_params%chi_2 = trapezoid_zt( chi_2_zt, chi_2_zm ) + pdf_params%rrtthl = trapezoid_zt( rrtthl_zt, rrtthl_zm ) + pdf_params%alpha_thl = trapezoid_zt( alpha_thl_zt, alpha_thl_zm ) + pdf_params%alpha_rt = trapezoid_zt( alpha_rt_zt, alpha_rt_zm ) + pdf_params%stdev_chi_1 = trapezoid_zt( stdev_chi_1_zt, stdev_chi_1_zm ) + pdf_params%stdev_chi_2 = trapezoid_zt( stdev_chi_2_zt, stdev_chi_2_zm ) + pdf_params%stdev_eta_1 = trapezoid_zt( stdev_eta_1_zt, stdev_eta_1_zm ) + pdf_params%stdev_eta_2 = trapezoid_zt( stdev_eta_2_zt, stdev_eta_2_zm ) + end if + + ! End of trapezoidal rule + + return + end subroutine trapezoidal_rule_zt + + !----------------------------------------------------------------------- + subroutine trapezoidal_rule_zm & + ( wpthvp_zt, thlpthvp_zt, rtpthvp_zt, & ! intent(in) + wpthvp, thlpthvp, rtpthvp ) ! intent(inout) + ! + ! Description: + ! This subroutine recomputes three variables on the + ! momentum grid from pdf_closure -- wpthvp, thlpthvp, and + ! rtpthvp -- by calling the function trapezoid_zm. Only these three + ! variables are used in this subroutine because they are the only + ! pdf_closure momentum variables used elsewhere in CLUBB. + ! + ! The _zt variables are output from the first call to pdf_closure. + ! The _zm variables are output from the second call to pdf_closure + ! on the momentum levels. + ! This is done before the call to this subroutine. + ! + ! ldgrant Feb. 2010 + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! variable(s) + + implicit none + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wpthvp_zt, & ! Buoyancy flux (on thermo. grid) [(K m)/s] + thlpthvp_zt, & ! th_l' th_v' (on thermo. grid) [K^2] + rtpthvp_zt ! r_t' th_v' (on thermo. grid) [(kg K)/kg] + + ! Input/Output variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wpthvp, & ! Buoyancy flux [(K m)/s] + thlpthvp, & ! th_l' th_v' [K^2] + rtpthvp ! r_t' th_v' [(kg K)/kg] + + !----------------------- Begin Code ----------------------------- + + ! Use the trapezoidal rule to recompute the variables on the zm level + wpthvp = trapezoid_zm( wpthvp, wpthvp_zt ) + thlpthvp = trapezoid_zm( thlpthvp, thlpthvp_zt ) + rtpthvp = trapezoid_zm( rtpthvp, rtpthvp_zt ) + + return + end subroutine trapezoidal_rule_zm + + !----------------------------------------------------------------------- + pure function trapezoid_zt( variable_zt, variable_zm ) + ! + ! Description: + ! Function which uses the trapezoidal rule from calculus + ! to recompute the values for the variables on the thermo. grid which + ! are output from the first call to pdf_closure in module clubb_core. + ! + ! ldgrant June 2009 + !-------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + variable_zt, & ! Variable on the zt grid + variable_zm ! Variable on the zm grid + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zt + + ! Local Variable + integer :: k ! Loop index + + !------------ Begin Code -------------- + + ! Boundary condition: trapezoidal rule not valid at zt level 1 + trapezoid_zt(1) = variable_zt(1) + + do k = 2, gr%nz + ! Trapezoidal rule from calculus + trapezoid_zt(k) = 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & + * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzt(k) & + + 0.5_core_rknd * ( variable_zt(k) + variable_zm(k-1) ) & + * ( gr%zt(k) - gr%zm(k-1) ) * gr%invrs_dzt(k) + end do ! k = 2, gr%nz + + return + end function trapezoid_zt + + !----------------------------------------------------------------------- + pure function trapezoid_zm( variable_zm, variable_zt ) + ! + ! Description: + ! Function which uses the trapezoidal rule from calculus + ! to recompute the values for the important variables on the momentum + ! grid which are output from pdf_closure in module clubb_core. + ! These momentum variables only include wpthvp, thlpthvp, and rtpthvp. + ! + ! ldgrant Feb. 2010 + !-------------------------------------------------------------------- + + use grid_class, only: gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + variable_zm, & ! Variable on the zm grid + variable_zt ! Variable on the zt grid + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: trapezoid_zm + + ! Local Variable + integer :: k ! Loop index + + !------------ Begin Code -------------- + + ! Boundary conditions: trapezoidal rule not valid at top zm level, nzmax. + ! Trapezoidal rule also not used at zm level 1. + trapezoid_zm(1) = variable_zm(1) + trapezoid_zm(gr%nz) = variable_zm(gr%nz) + + do k = 2, gr%nz-1 + ! Trapezoidal rule from calculus + trapezoid_zm(k) = 0.5_core_rknd * ( variable_zt(k+1) + variable_zm(k) ) & + * ( gr%zt(k+1) - gr%zm(k) ) * gr%invrs_dzm(k) & + + 0.5_core_rknd * ( variable_zm(k) + variable_zt(k) ) & + * ( gr%zm(k) - gr%zt(k) ) * gr%invrs_dzm(k) + end do ! k = 2, gr%nz-1 + + return + end function trapezoid_zm + + !----------------------------------------------------------------------- + subroutine compute_cloud_cover & + ( pdf_params, cloud_frac, rcm, & ! intent(in) + cloud_cover, rcm_in_layer ) ! intent(out) + ! + ! Description: + ! Subroutine to compute cloud cover (the amount of sky + ! covered by cloud) and rcm in layer (liquid water mixing ratio in + ! the portion of the grid box filled by cloud). + ! + ! References: + ! Definition of 's' comes from: + ! ``The Gaussian Cloud Model Relations'' G. L. Mellor (1977) + ! JAS, Vol. 34, pp. 356--358. + ! + ! Notes: + ! Added July 2009 + !--------------------------------------------------------------------- + + use constants_clubb, only: & + rc_tol, & ! Variable(s) + fstderr + + use grid_class, only: gr ! Variable + + use pdf_parameter_module, only: & + pdf_parameter ! Derived data type + + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External functions + intrinsic :: abs, min, max + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + cloud_frac, & ! Cloud fraction [-] + rcm ! Liquid water mixing ratio [kg/kg] + + type (pdf_parameter), dimension(gr%nz), intent(in) :: & + pdf_params ! PDF Parameters [units vary] + + ! Output variables + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + cloud_cover, & ! Cloud cover [-] + rcm_in_layer ! Liquid water mixing ratio in cloud layer [kg/kg] + + ! Local variables + real( kind = core_rknd ), dimension(gr%nz) :: & + chi_mean, & ! Mean extended cloud water mixing ratio of the + ! two Gaussian distributions + vert_cloud_frac_upper, & ! Fraction of cloud in top half of grid box + vert_cloud_frac_lower, & ! Fraction of cloud in bottom half of grid box + vert_cloud_frac ! Fraction of cloud filling the grid box in the vertical + + integer :: k + + ! ------------ Begin code --------------- + + do k = 1, gr%nz + + chi_mean(k) = pdf_params(k)%mixt_frac * pdf_params(k)%chi_1 + & + (1.0_core_rknd-pdf_params(k)%mixt_frac) * pdf_params(k)%chi_2 + + end do + + do k = 2, gr%nz-1, 1 + + if ( rcm(k) < rc_tol ) then ! No cloud at this level + + cloud_cover(k) = cloud_frac(k) + rcm_in_layer(k) = rcm(k) + + else if ( ( rcm(k+1) >= rc_tol ) .and. ( rcm(k-1) >= rc_tol ) ) then + ! There is cloud above and below, + ! so assume cloud fills grid box from top to bottom + + cloud_cover(k) = cloud_frac(k) + rcm_in_layer(k) = rcm(k) + + else if ( ( rcm(k+1) < rc_tol ) .or. ( rcm(k-1) < rc_tol) ) then + ! Cloud may fail to reach gridbox top or base or both + + ! First let the cloud fill the entire grid box, then overwrite + ! vert_cloud_frac_upper(k) and/or vert_cloud_frac_lower(k) + ! for a cloud top, cloud base, or one-point cloud. + vert_cloud_frac_upper(k) = 0.5_core_rknd + vert_cloud_frac_lower(k) = 0.5_core_rknd + + if ( rcm(k+1) < rc_tol ) then ! Cloud top + + vert_cloud_frac_upper(k) = & + ( ( 0.5_core_rknd / gr%invrs_dzm(k) ) / ( gr%zm(k) - gr%zt(k) ) ) & + * ( rcm(k) / ( rcm(k) + abs( chi_mean(k+1) ) ) ) + + vert_cloud_frac_upper(k) = min( 0.5_core_rknd, vert_cloud_frac_upper(k) ) + + ! Make the transition in cloudiness more gradual than using + ! the above min statement alone. + vert_cloud_frac_upper(k) = vert_cloud_frac_upper(k) + & + ( ( rcm(k+1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_upper(k) ) ) + + else + + vert_cloud_frac_upper(k) = 0.5_core_rknd + + end if + + if ( rcm(k-1) < rc_tol ) then ! Cloud base + + vert_cloud_frac_lower(k) = & + ( ( 0.5_core_rknd / gr%invrs_dzm(k-1) ) / ( gr%zt(k) - gr%zm(k-1) ) ) & + * ( rcm(k) / ( rcm(k) + abs( chi_mean(k-1) ) ) ) + + vert_cloud_frac_lower(k) = min( 0.5_core_rknd, vert_cloud_frac_lower(k) ) + + ! Make the transition in cloudiness more gradual than using + ! the above min statement alone. + vert_cloud_frac_lower(k) = vert_cloud_frac_lower(k) + & + ( ( rcm(k-1)/rc_tol )*( 0.5_core_rknd -vert_cloud_frac_lower(k) ) ) + + else + + vert_cloud_frac_lower(k) = 0.5_core_rknd + + end if + + vert_cloud_frac(k) = & + vert_cloud_frac_upper(k) + vert_cloud_frac_lower(k) + + vert_cloud_frac(k) = & + max( cloud_frac(k), min( 1.0_core_rknd, vert_cloud_frac(k) ) ) + + cloud_cover(k) = cloud_frac(k) / vert_cloud_frac(k) + rcm_in_layer(k) = rcm(k) / vert_cloud_frac(k) + + else + + if ( clubb_at_least_debug_level( 1 ) ) then + + write(fstderr,*) & + "Error: Should not arrive here in computation of cloud_cover" + + write(fstderr,*) "At grid level k = ", k + write(fstderr,*) "pdf_params(k)%mixt_frac = ", pdf_params(k)%mixt_frac + write(fstderr,*) "pdf_params(k)%chi_1 = ", pdf_params(k)%chi_1 + write(fstderr,*) "pdf_params(k)%chi_2 = ", pdf_params(k)%chi_2 + write(fstderr,*) "cloud_frac(k) = ", cloud_frac(k) + write(fstderr,*) "rcm(k) = ", rcm(k) + write(fstderr,*) "rcm(k+1) = ", rcm(k+1) + write(fstderr,*) "rcm(k-1) = ", rcm(k-1) + + end if + + return + + end if ! rcm(k) < rc_tol + + end do ! k = 2, gr%nz-1, 1 + + cloud_cover(1) = cloud_frac(1) + cloud_cover(gr%nz) = cloud_frac(gr%nz) + + rcm_in_layer(1) = rcm(1) + rcm_in_layer(gr%nz) = rcm(gr%nz) + + return + end subroutine compute_cloud_cover + !----------------------------------------------------------------------- + subroutine clip_rcm & + ( rtm, message, & ! intent(in) + rcm ) ! intent(inout) + ! + ! Description: + ! Subroutine that reduces cloud water (rcm) whenever + ! it exceeds total water (rtm = vapor + liquid). + ! This avoids negative values of rvm = water vapor mixing ratio. + ! However, it will not ensure that rcm <= rtm if rtm <= 0. + ! + ! References: + ! None + !--------------------------------------------------------------------- + + + use grid_class, only: gr ! Variable + + use error_code, only : & + clubb_at_least_debug_level ! Procedure(s) + + use constants_clubb, only: & + fstderr, & ! Variable(s) + zero_threshold + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External functions + intrinsic :: max, epsilon + + ! Input variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rtm ! Total water mixing ratio [kg/kg] + + character(len= * ), intent(in) :: message + + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + rcm ! Cloud water mixing ratio [kg/kg] + + integer :: k + + ! ------------ Begin code --------------- + + ! Vince Larson clipped rcm in order to prevent rvm < 0. 5 Apr 2008. + ! This code won't work unless rtm >= 0 !!! + ! We do not clip rcm_in_layer because rcm_in_layer only influences + ! radiation, and we do not want to bother recomputing it. 6 Aug 2009 + do k = 1, gr%nz + if ( rtm(k) < rcm(k) ) then + + if ( clubb_at_least_debug_level(1) ) then + write(fstderr,*) message, ' at k=', k, 'rcm(k) = ', rcm(k), & + 'rtm(k) = ', rtm(k), '.', ' Clipping rcm.' + + end if ! clubb_at_least_debug_level(1) + + rcm(k) = max( zero_threshold, rtm(k) - epsilon( rtm(k) ) ) + + end if ! rtm(k) < rcm(k) + + end do ! k=1..gr%nz + + return + end subroutine clip_rcm + + !----------------------------------------------------------------------------- + subroutine set_Lscale_max( l_implemented, host_dx, host_dy, & + Lscale_max ) + + ! Description: + ! This subroutine sets the value of Lscale_max, which is the maximum + ! allowable value of Lscale. For standard CLUBB, it is set to a very large + ! value so that Lscale will not be limited. However, when CLUBB is running + ! as part of a host model, the value of Lscale_max is dependent on the size + ! of the host model's horizontal grid spacing. The smaller the host model's + ! horizontal grid spacing, the smaller the value of Lscale_max. When Lscale + ! is limited to a small value, the value of time-scale Tau is reduced, which + ! in turn produces greater damping on CLUBB's turbulent parameters. This + ! is the desired effect on turbulent parameters for a host model with small + ! horizontal grid spacing, for small areas usually contain much less + ! variation in meteorological quantities than large areas. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + logical, intent(in) :: & + l_implemented ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! Host model's east-west horizontal grid spacing [m] + host_dy ! Host model's north-south horizontal grid spacing [m] + + ! Output Variable + real( kind = core_rknd ), intent(out) :: & + Lscale_max ! Maximum allowable value for Lscale [m] + + ! ---- Begin Code ---- + + ! Determine the maximum allowable value for Lscale (in meters). + if ( l_implemented ) then + Lscale_max = 0.25_core_rknd * min( host_dx, host_dy ) + else + Lscale_max = 1.0e5_core_rknd + end if + + return + end subroutine set_Lscale_max + +!=============================================================================== + pure subroutine calculate_thlp2_rad & + ( nz, rcm_zm, thlprcp, radht_zm, & ! Intent(in) + thlp2_forcing ) ! Intent(inout) + + ! Description: + ! Computes the contribution of radiative cooling to thlp2 + + ! References: + ! See clubb:ticket:632 + !---------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant(s) + + use grid_class, only: & + zt2zm ! Procedure + + use constants_clubb, only: & + two, & + rc_tol + + use parameters_tunable, only: & + thlp2_rad_coef ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of vertical levels [-] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rcm_zm, & ! Cloud water mixing ratio on momentum grid [kg/kg] + thlprcp, & ! thl'rc' [K kg/kg] + radht_zm ! SW + LW heating rate (on momentum grid) [K/s] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + thlp2_forcing ! forcing (momentum levels) [K^2/s] + + ! Local Variables + integer :: & + k ! Loop iterator [-] + + !---------------------------------------------------------------------- + + + do k = 1, nz + + if ( rcm_zm(k) > rc_tol ) then + + thlp2_forcing(k) = thlp2_forcing(k) + & + thlp2_rad_coef * ( two ) * radht_zm(k) / rcm_zm(k) * thlprcp(k) + + end if + + end do + + + return + end subroutine calculate_thlp2_rad + + + !----------------------------------------------------------------------- + +end module advance_clubb_core_module diff --git a/src/physics/clubb/advance_helper_module.F90 b/src/physics/clubb/advance_helper_module.F90 new file mode 100644 index 0000000000..f1fe7959c7 --- /dev/null +++ b/src/physics/clubb/advance_helper_module.F90 @@ -0,0 +1,315 @@ +!------------------------------------------------------------------------- +! $Id: advance_helper_module.F90 7381 2014-11-11 23:59:39Z schemena@uwm.edu $ +!=============================================================================== +module advance_helper_module + +! Description: +! This module contains helper methods for the advance_* modules. +!------------------------------------------------------------------------ + + implicit none + + public :: & + set_boundary_conditions_lhs, & + set_boundary_conditions_rhs, & + calc_stability_correction, & + calc_brunt_vaisala_freq_sqd + + private ! Set Default Scope + + contains + + !--------------------------------------------------------------------------- + subroutine set_boundary_conditions_lhs( diag_index, low_bound, high_bound, lhs, & + diag_index2, low_bound2, high_bound2 ) + + ! Description: + ! Sets the boundary conditions for a left-hand side LAPACK matrix. + ! + ! References: + ! none + !--------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Exernal + intrinsic :: present + + ! Input Variables + integer, intent(in) :: & + diag_index, low_bound, high_bound ! boundary indexes for the first variable + + ! Input / Output Variables + real( kind = core_rknd ), dimension(:,:), intent(inout) :: & + lhs ! left hand side of the LAPACK matrix equation + + ! Optional Input Variables + integer, intent(in), optional :: & + diag_index2, low_bound2, high_bound2 ! boundary indexes for the second variable + + ! --------------------- BEGIN CODE ---------------------- + + if ( ( present( low_bound2 ) .or. present( high_bound2 ) ) .and. & + ( .not. present( diag_index2 ) ) ) then + + stop "Boundary index provided without diag_index." + + end if + + ! Set the lower boundaries for the first variable + lhs(:,low_bound) = 0.0_core_rknd + lhs(diag_index,low_bound) = 1.0_core_rknd + + ! Set the upper boundaries for the first variable + lhs(:,high_bound) = 0.0_core_rknd + lhs(diag_index,high_bound) = 1.0_core_rknd + + ! Set the lower boundaries for the second variable, if it is provided + if ( present( low_bound2 ) ) then + + lhs(:,low_bound2) = 0.0_core_rknd + lhs(diag_index2,low_bound2) = 1.0_core_rknd + + end if + + ! Set the upper boundaries for the second variable, if it is provided + if ( present( high_bound2 ) ) then + + lhs(:,high_bound2) = 0.0_core_rknd + lhs(diag_index2,high_bound2) = 1.0_core_rknd + + end if + + return + end subroutine set_boundary_conditions_lhs + + !-------------------------------------------------------------------------- + subroutine set_boundary_conditions_rhs( & + low_value, low_bound, high_value, high_bound, & + rhs, & + low_value2, low_bound2, high_value2, high_bound2 ) + + ! Description: + ! Sets the boundary conditions for a right-hand side LAPACK vector. + ! + ! References: + ! none + !--------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Exernal + intrinsic :: present + + ! Input Variables + + ! The values for the first variable + real( kind = core_rknd ), intent(in) :: low_value, high_value + + ! The bounds for the first variable + integer, intent(in) :: low_bound, high_bound + + ! Input / Output Variables + + ! The right-hand side vector + real( kind = core_rknd ), dimension(:), intent(inout) :: rhs + + ! Optional Input Variables + + ! The values for the second variable + real( kind = core_rknd ), intent(in), optional :: low_value2, high_value2 + + ! The bounds for the second variable + integer, intent(in), optional :: low_bound2, high_bound2 + + + ! -------------------- BEGIN CODE ------------------------ + + ! Stop execution if a boundary was provided without a value + if ( (present( low_bound2 ) .and. (.not. present( low_value2 ))) .or. & + (present( high_bound2 ) .and. (.not. present( high_value2 ))) ) then + + stop "Boundary condition provided without value." + + end if + + ! Set the lower and upper bounds for the first variable + rhs(low_bound) = low_value + rhs(high_bound) = high_value + + ! If a lower bound was given for the second variable, set it + if ( present( low_bound2 ) ) then + rhs(low_bound2) = low_value2 + end if + + ! If an upper bound was given for the second variable, set it + if ( present( high_bound2 ) ) then + rhs(high_bound2) = high_value2 + end if + + return + end subroutine set_boundary_conditions_rhs + + !=============================================================================== + function calc_stability_correction( thlm, Lscale, em, exner, rtm, rcm, p_in_Pa, cloud_frac ) & + result ( stability_correction ) + ! + ! Description: + ! Stability Factor + ! + ! References: + ! + !-------------------------------------------------------------------- + + use parameters_tunable, only: & + lambda0_stability_coef ! Variable(s) + + use constants_clubb, only: & + zero ! Constant(s) + + use grid_class, only: & + gr, & ! Variable(s) + zt2zm ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + thlm, & ! th_l (thermo. levels) [K] + exner, & ! Exner function [-] + rtm, & ! total water mixing ratio, r_t [kg/kg] + rcm, & ! cloud water mixing ratio, r_c [kg/kg] + p_in_Pa, & ! Air pressure [Pa] + cloud_frac ! Cloud fraction [-] + + ! Result + real( kind = core_rknd ), dimension(gr%nz) :: & + stability_correction + + real( kind = core_rknd ), dimension(gr%nz) :: & + brunt_vaisala_freq_sqd, & ! [] + lambda0_stability + + !------------ Begin Code -------------- + brunt_vaisala_freq_sqd = calc_brunt_vaisala_freq_sqd( thlm, exner, rtm, rcm, p_in_Pa, & + cloud_frac ) + lambda0_stability = merge( lambda0_stability_coef, zero, brunt_vaisala_freq_sqd > zero ) + + stability_correction = 1.0_core_rknd & + + min( lambda0_stability * brunt_vaisala_freq_sqd * zt2zm( Lscale )**2 / em, 3.0_core_rknd ) + + return + end function calc_stability_correction + + !=============================================================================== + function calc_brunt_vaisala_freq_sqd( thlm, exner, rtm, rcm, p_in_Pa, cloud_frac ) & + result( brunt_vaisala_freq_sqd ) + + ! Description: + ! Calculate the Brunt-Vaisala frequency squared, N^2. + + ! References: + ! ? + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Konstant + + use constants_clubb, only: & + grav, & ! Constant(s) + cloud_frac_min, & + Lv, Cp, Rd, ep, & + one + + use parameters_model, only: & + T0 ! Variable! + + use grid_class, only: & + gr, & ! Variable + ddzt, & ! Procedure(s) + zt2zm + + use T_in_K_module, only: & + thlm2T_in_K ! Procedure + + use saturation, only: & + sat_mixrat_liq ! Procedure + + use model_flags, only: & + l_brunt_vaisala_freq_moist ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + thlm, & ! th_l (thermo. levels) [K] + exner, & ! Exner function [-] + rtm, & ! total water mixing ratio, r_t [kg/kg] + rcm, & ! cloud water mixing ratio, r_c [kg/kg] + p_in_Pa, & ! Air pressure [Pa] + cloud_frac ! Cloud fraction [-] + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + brunt_vaisala_freq_sqd ! Brunt-Vaisala frequency squared, N^2 [1/s^2] + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + T_in_K, T_in_K_zm, rsat, rsat_zm, thm, thm_zm, ddzt_thlm, & + ddzt_thm, ddzt_rsat, ddzt_rtm + + integer :: k + + !--------------------------------------------------------------------- + !----- Begin Code ----- + ddzt_thlm = ddzt( thlm ) + + if ( l_brunt_vaisala_freq_moist ) then + ! These parameters are needed to compute the moist Brunt-Vaisala + ! frequency. + T_in_K = thlm2T_in_K( thlm, exner, rcm ) + T_in_K_zm = zt2zm( T_in_K ) + rsat = sat_mixrat_liq( p_in_Pa, T_in_K ) + rsat_zm = zt2zm( rsat ) + ddzt_rsat = ddzt( rsat ) + thm = thlm + Lv/(Cp*exner) * rcm + thm_zm = zt2zm( thm ) + ddzt_thm = ddzt( thm ) + ddzt_rtm = ddzt( rtm ) + end if + + do k=1, gr%nz + + if ( .not. l_brunt_vaisala_freq_moist .or. cloud_frac(k) < cloud_frac_min ) then + + ! Dry Brunt-Vaisala frequency + brunt_vaisala_freq_sqd(k) = ( grav / T0 ) * ddzt_thlm(k) + + else ! l_brunt_vaisala_freq_moist .and. cloud_frac(k) >= cloud_frac_min + + ! In-cloud Brunt-Vaisala frequency. This is Eq. (36) of Durran and Klemp (1982) + brunt_vaisala_freq_sqd(k) = & + grav * ( ((one + Lv*rsat_zm(k) / (Rd*T_in_K_zm(k))) / & + (one + ep*(Lv**2)*rsat_zm(k)/(Cp*Rd*T_in_K_zm(k)**2))) * & + ( (one/thm_zm(k) * ddzt_thm(k)) + (Lv/(Cp*T_in_K_zm(k)))*ddzt_rsat(k)) - & + ddzt_rtm(k) ) + + end if + + end do ! k=1, gr%nz + + return + end function calc_brunt_vaisala_freq_sqd + +end module advance_helper_module diff --git a/src/physics/clubb/advance_windm_edsclrm_module.F90 b/src/physics/clubb/advance_windm_edsclrm_module.F90 new file mode 100644 index 0000000000..38666caf9d --- /dev/null +++ b/src/physics/clubb/advance_windm_edsclrm_module.F90 @@ -0,0 +1,1899 @@ +!------------------------------------------------------------------------ +! $Id: advance_windm_edsclrm_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module advance_windm_edsclrm_module + + implicit none + + private ! Set Default Scope + + public :: advance_windm_edsclrm, xpwp_fnc + + private :: windm_edsclrm_solve, & + compute_uv_tndcy, & + windm_edsclrm_lhs, & + windm_edsclrm_rhs + + + ! Private named constants to avoid string comparisons + integer, parameter, private :: & + windm_edsclrm_um = 1, & ! Named constant to handle um solves + windm_edsclrm_vm = 2, & ! Named constant to handle vm solves + windm_edsclrm_scalar = 3, & ! Named constant to handle scalar solves + clip_upwp = 10, & ! Named constant for upwp clipping + ! NOTE: This must be the same as the clip_upwp + ! declared in clip_explicit! + clip_vpwp = 11 ! Named constant for vpwp clipping + ! NOTE: This must be the same as the clip_vpwp + ! declared in clip_explicit! + + contains + + !============================================================================= + subroutine advance_windm_edsclrm & + ( dt, wm_zt, Km_zm, Kmh_zm, ug, vg, um_ref, vm_ref, & + wp2, up2, vp2, um_forcing, vm_forcing, & + edsclrm_forcing, & + rho_ds_zm, invrs_rho_ds_zt, & + fcor, l_implemented, & + um, vm, edsclrm, & + upwp, vpwp, wpedsclrp, err_code ) + + ! Description: + ! Solves for both mean horizontal wind components, um and vm, and for the + ! eddy-scalars (passive scalars that don't use the high-order closure). + + ! Uses the LAPACK tridiagonal solver subroutine with 2 + # of scalar(s) + ! back substitutions (since the left hand side matrix is the same for all + ! input variables). + + ! References: + ! Eqn. 8 & 9 on p. 3545 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variables(s) + + use parameters_model, only: & + ts_nudge, & ! Variable(s) + edsclr_dim + + use parameters_tunable, only: & + nu10_vert_res_dep ! Constant + + use model_flags, only: & + l_uv_nudge, & ! Variable(s) + l_tke_aniso + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Subroutines + stat_end_update, & + stat_update_var + + use stats_variables, only: & + ium_ref, & ! Variables + ivm_ref, & + ium_sdmp, & + ivm_sdmp, & + ium_ndg, & + ivm_ndg, & + iwindm_matrix_condt_num, & + stats_zt, & + l_stats_samp + + use clip_explicit, only: & + clip_covar ! Procedure(s) + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + fatal_error + + use error_code, only: & + clubb_no_error ! Constant(s) + + use constants_clubb, only: & + fstderr, & ! Constant(s) + eps + + use sponge_layer_damping, only: & + uv_sponge_damp_settings, & + uv_sponge_damp_profile, & + sponge_damp_xm ! Procedure(s) + + implicit none + + ! External + intrinsic :: real + + ! Constant Parameters + real( kind = core_rknd ), dimension(gr%nz) :: & + dummy_nu ! Used to feed zero values into function calls + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wm_zt, & ! w wind component on thermodynamic levels [m/s] + Km_zm, & ! Eddy diffusivity of winds on momentum levels [m^2/s] + Kmh_zm, & ! Eddy diffusivity of themo on momentum levels [m^s/s] + ug, & ! u (west-to-east) geostrophic wind comp. [m/s] + vg, & ! v (south-to-north) geostrophic wind comp. [m/s] + um_ref, & ! Reference u wind component for nudging [m/s] + vm_ref, & ! Reference v wind component for nudging [m/s] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + um_forcing, & ! u forcing [m/s/s] + vm_forcing, & ! v forcing [m/s/s] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] + + real( kind = core_rknd ), dimension(gr%nz,edsclr_dim), intent(in) :: & + edsclrm_forcing ! Eddy scalar large-scale forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in) :: & + fcor ! Coriolis parameter [s^-1] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + um, & ! Mean u (west-to-east) wind component [m/s] + vm ! Mean v (south-to-north) wind component [m/s] + + ! Input/Output Variable for eddy-scalars + real( kind = core_rknd ), dimension(gr%nz,edsclr_dim), intent(inout) :: & + edsclrm ! Mean eddy scalar quantity [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vpwp ! v'w' (momentum levels) [m^2/s^2] + + ! Output Variable for eddy-scalars + real( kind = core_rknd ), dimension(gr%nz,edsclr_dim), intent(inout) :: & + wpedsclrp ! w'edsclr' (momentum levels) [units vary] + + integer, intent(inout) :: & + err_code ! clubb_singular_matrix when matrix is singular + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + um_tndcy, & ! u wind component tendency [m/s^2] + vm_tndcy ! v wind component tendency [m/s^2] + + real( kind = core_rknd ), dimension(gr%nz) :: & + upwp_chnge, & ! Net change of u'w' due to clipping [m^2/s^2] + vpwp_chnge ! Net change of v'w' due to clipping [m^2/s^2] + + real( kind = core_rknd ), dimension(3,gr%nz) :: & + lhs ! The implicit part of the tridiagonal matrix [units vary] + + real( kind = core_rknd ), dimension(gr%nz,max(2,edsclr_dim)) :: & + rhs, &! The explicit part of the tridiagonal matrix [units vary] + solution ! The solution to the tridiagonal matrix [units vary] + + real( kind = core_rknd ), dimension(gr%nz) :: & + wind_speed ! wind speed; sqrt(u^2 + v^2) [m/s] + + real( kind = core_rknd ) :: & + u_star_sqd ! Surface friction velocity, u_star, squared [m/s] + + logical :: & + l_imp_sfc_momentum_flux ! Flag for implicit momentum surface fluxes. + + integer :: & + err_code_windm, err_code_edsclrm, & ! Error code for each LAPACK solve + nrhs ! Number of right hand side terms + + integer :: i ! Array index + + logical :: l_first_clip_ts, l_last_clip_ts ! flags for clip_covar + + !--------------------------- Begin Code ------------------------------------ + + ! Initialize to no errors + err_code_windm = clubb_no_error + err_code_edsclrm = clubb_no_error + + dummy_nu = 0._core_rknd + + !---------------------------------------------------------------- + ! Prepare tridiagonal system for horizontal winds, um and vm + !---------------------------------------------------------------- + + ! Compute Coriolis, geostrophic, and other prescribed wind forcings for um. + call compute_uv_tndcy( windm_edsclrm_um, fcor, vm, vg, um_forcing, & ! in + l_implemented, & ! in + um_tndcy ) ! out + + ! Compute Coriolis, geostrophic, and other prescribed wind forcings for vm. + call compute_uv_tndcy( windm_edsclrm_vm, fcor, um, ug, vm_forcing, & ! in + l_implemented, & ! in + vm_tndcy ) ! out + + ! Momentum surface fluxes, u'w'|_sfc and v'w'|_sfc, are applied to through + ! an implicit method, such that: + ! x'w'|_sfc = - ( u_star(t)^2 / wind_speed(t) ) * xm(t+1). + l_imp_sfc_momentum_flux = .true. + ! Compute wind speed (use threshold "eps" to prevent divide-by-zero error). + wind_speed = max( sqrt( um**2 + vm**2 ), eps ) + ! Compute u_star_sqd according to the definition of u_star. + u_star_sqd = sqrt( upwp(1)**2 + vpwp(1)**2 ) + + ! Compute the explicit portion of the um equation. + ! Build the right-hand side vector. + rhs(1:gr%nz,windm_edsclrm_um) & + = windm_edsclrm_rhs( windm_edsclrm_um, dt, nu10_vert_res_dep, Km_zm, um, & ! in + um_tndcy, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_imp_sfc_momentum_flux, upwp(1) ) ! in + + ! Compute the explicit portion of the vm equation. + ! Build the right-hand side vector. + rhs(1:gr%nz,windm_edsclrm_vm) & + = windm_edsclrm_rhs( windm_edsclrm_vm, dt, nu10_vert_res_dep, Km_zm, vm, & ! in + vm_tndcy, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_imp_sfc_momentum_flux, vpwp(1) ) ! in + + + ! Store momentum flux (explicit component) + + ! The surface flux, x'w'(1) = x'w'|_sfc, is set elsewhere in the model. +! upwp(1) = upwp_sfc +! vpwp(1) = vpwp_sfc + + ! Solve for x'w' at all intermediate model levels. + ! A Crank-Nicholson timestep is used. + + upwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+ & + nu10_vert_res_dep(2:gr%nz-1), & ! in + um(2:gr%nz-1), um(3:gr%nz), & ! in + gr%invrs_dzm(2:gr%nz-1) ) + + vpwp(2:gr%nz-1) = - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+ & + nu10_vert_res_dep(2:gr%nz-1), & ! in + vm(2:gr%nz-1), vm(3:gr%nz), & ! in + gr%invrs_dzm(2:gr%nz-1) ) + + ! A zero-flux boundary condition at the top of the model, d(xm)/dz = 0, + ! means that x'w' at the top model level is 0, + ! since x'w' = - K_zm * d(xm)/dz. + upwp(gr%nz) = 0._core_rknd + vpwp(gr%nz) = 0._core_rknd + + + ! Compute the implicit portion of the um and vm equations. + ! Build the left-hand side matrix. + call windm_edsclrm_lhs( dt, nu10_vert_res_dep, wm_zt, Km_zm, wind_speed, u_star_sqd, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_implemented, l_imp_sfc_momentum_flux, & ! in + lhs ) ! out + + ! Decompose and back substitute for um and vm + nrhs = 2 + call windm_edsclrm_solve( nrhs, iwindm_matrix_condt_num, & ! in + lhs, rhs, & ! in/out + solution, err_code_windm ) ! out + + !---------------------------------------------------------------- + ! Update zonal (west-to-east) component of mean wind, um + !---------------------------------------------------------------- + um(1:gr%nz) = solution(1:gr%nz,windm_edsclrm_um) + + !---------------------------------------------------------------- + ! Update meridional (south-to-north) component of mean wind, vm + !---------------------------------------------------------------- + vm(1:gr%nz) = solution(1:gr%nz,windm_edsclrm_vm) + + if ( l_stats_samp ) then + + ! Implicit contributions to um and vm + call windm_edsclrm_implicit_stats( windm_edsclrm_um, um ) ! in + + call windm_edsclrm_implicit_stats( windm_edsclrm_vm, vm ) ! in + + endif ! l_stats_samp + + ! The values of um(1) and vm(1) are located below the model surface and do + ! not effect the rest of the model. The values of um(1) or vm(1) are simply + ! set to the values of um(2) and vm(2), respectively, after the equation + ! matrices has been solved. Even though um and vm would sharply decrease + ! to a value of 0 at the surface, this is done to avoid confusion on plots + ! of the vertical profiles of um and vm. + um(1) = um(2) + vm(1) = vm(2) + + + if ( uv_sponge_damp_settings%l_sponge_damping ) then + if( l_stats_samp ) then + call stat_begin_update( ium_sdmp, um/dt, stats_zt ) + call stat_begin_update( ivm_sdmp, vm/dt, stats_zt ) + endif + + um(1:gr%nz) = sponge_damp_xm( dt, um_ref(1:gr%nz), um(1:gr%nz), & + uv_sponge_damp_profile ) + vm(1:gr%nz) = sponge_damp_xm( dt, vm_ref(1:gr%nz), vm(1:gr%nz), & + uv_sponge_damp_profile ) + if( l_stats_samp ) then + call stat_end_update( ium_sdmp, um/dt, stats_zt ) + call stat_end_update( ivm_sdmp, vm/dt, stats_zt ) + endif + + endif + + ! Second part of momentum (implicit component) + + ! Solve for x'w' at all intermediate model levels. + ! A Crank-Nicholson timestep is used. + + upwp(2:gr%nz-1) = upwp(2:gr%nz-1) & + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & + um(2:gr%nz-1), um(3:gr%nz), gr%invrs_dzm(2:gr%nz-1) ) !in + + vpwp(2:gr%nz-1) = vpwp(2:gr%nz-1) & + - 0.5_core_rknd * xpwp_fnc( Km_zm(2:gr%nz-1)+nu10_vert_res_dep(2:gr%nz-1), & + vm(2:gr%nz-1), vm(3:gr%nz), gr%invrs_dzm(2:gr%nz-1) ) !in + + + ! Adjust um and vm if nudging is turned on. + if ( l_uv_nudge ) then + + ! Reflect nudging in budget + if( l_stats_samp ) then + call stat_begin_update( ium_ndg, um / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + call stat_begin_update( ivm_ndg, vm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + end if + + um(1:gr%nz) = um(1:gr%nz) & + - ((um(1:gr%nz) - um_ref(1:gr%nz)) * (dt/ts_nudge)) + vm(1:gr%nz) = vm(1:gr%nz) & + - ((vm(1:gr%nz) - vm_ref(1:gr%nz)) * (dt/ts_nudge)) + endif + + if( l_stats_samp ) then + + ! Reflect nudging in budget + if ( l_uv_nudge ) then + call stat_end_update( ium_ndg, um / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + call stat_end_update( ivm_ndg, vm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + end if + + call stat_update_var( ium_ref, um_ref, stats_zt ) + call stat_update_var( ivm_ref, vm_ref, stats_zt ) + end if + + if ( l_tke_aniso ) then + + ! Clipping for u'w' + ! + ! Clipping u'w' at each vertical level, based on the + ! correlation of u and w at each vertical level, such that: + ! corr_(u,w) = u'w' / [ sqrt(u'^2) * sqrt(w'^2) ]; + ! -1 <= corr_(u,w) <= 1. + ! + ! Since u'^2, w'^2, and u'w' are each advanced in different subroutines from + ! each other in advance_clubb_core, clipping for u'w' has to be done three + ! times during each timestep (once after each variable has been updated). + ! This is the third instance of u'w' clipping. + l_first_clip_ts = .false. + l_last_clip_ts = .true. + call clip_covar( clip_upwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, up2, & ! intent(in) + upwp, upwp_chnge ) ! intent(inout) + + ! Clipping for v'w' + ! + ! Clipping v'w' at each vertical level, based on the + ! correlation of v and w at each vertical level, such that: + ! corr_(v,w) = v'w' / [ sqrt(v'^2) * sqrt(w'^2) ]; + ! -1 <= corr_(v,w) <= 1. + ! + ! Since v'^2, w'^2, and v'w' are each advanced in different subroutines from + ! each other in advance_clubb_core, clipping for v'w' has to be done three + ! times during each timestep (once after each variable has been updated). + ! This is the third instance of v'w' clipping. + l_first_clip_ts = .false. + l_last_clip_ts = .true. + call clip_covar( clip_vpwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, vp2, & ! intent(in) + vpwp, vpwp_chnge ) ! intent(inout) + + else + + ! In this case, it is assumed that + ! u'^2 == v'^2 == w'^2, and the variables `up2' and `vp2' do not interact with + ! any other variables. + l_first_clip_ts = .false. + l_last_clip_ts = .true. + call clip_covar( clip_upwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, wp2, & ! intent(in) + upwp, upwp_chnge ) ! intent(inout) + + call clip_covar( clip_vpwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, wp2, & ! intent(in) + vpwp, vpwp_chnge ) ! intent(inout) + + endif ! l_tke_aniso + + + !---------------------------------------------------------------- + ! Prepare tridiagonal system for eddy-scalars + !---------------------------------------------------------------- + + if ( edsclr_dim > 0 ) then + + ! Eddy-scalar surface fluxes, x'w'|_sfc, are applied through an explicit + ! method. + l_imp_sfc_momentum_flux = .false. + + ! Compute the explicit portion of eddy scalar equation. + ! Build the right-hand side vector. + ! Because of statistics, we have to use a DO rather than a FORALL here + ! -dschanen 7 Oct 2008 +!HPF$ INDEPENDENT + do i = 1, edsclr_dim + rhs(1:gr%nz,i) & + = windm_edsclrm_rhs( windm_edsclrm_scalar, dt, dummy_nu, Kmh_zm, & ! in + edsclrm(:,i), edsclrm_forcing, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_imp_sfc_momentum_flux, wpedsclrp(1,i) ) ! in + enddo + + + ! Store momentum flux (explicit component) + + ! The surface flux, x'w'(1) = x'w'|_sfc, is set elsewhere in the model. +! wpedsclrp(1,1:edsclr_dim) = wpedsclrp_sfc(1:edsclr_dim) + + ! Solve for x'w' at all intermediate model levels. + ! A Crank-Nicholson timestep is used. + ! Here we use a forall and high performance fortran directive to try to + ! parallelize this computation. Note that FORALL is more restrictive than DO. +!HPF$ INDEPENDENT, REDUCTION(wpedsclrp) + forall( i = 1:edsclr_dim ) + wpedsclrp(2:gr%nz-1,i) = & + - 0.5_core_rknd * xpwp_fnc( Kmh_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in + edsclrm(3:gr%nz,i), gr%invrs_dzm(2:gr%nz-1) ) ! in + end forall + + ! A zero-flux boundary condition at the top of the model, d(xm)/dz = 0, + ! means that x'w' at the top model level is 0, + ! since x'w' = - K_zm * d(xm)/dz. + wpedsclrp(gr%nz,1:edsclr_dim) = 0._core_rknd + + + ! Compute the implicit portion of the xm (eddy-scalar) equations. + ! Build the left-hand side matrix. + call windm_edsclrm_lhs( dt, dummy_nu, wm_zt, Kmh_zm, wind_speed, u_star_sqd, & ! in + rho_ds_zm, invrs_rho_ds_zt, & ! in + l_implemented, l_imp_sfc_momentum_flux, & ! in + lhs ) ! out + + ! Decompose and back substitute for all eddy-scalar variables + call windm_edsclrm_solve( edsclr_dim, 0, & ! in + lhs, rhs, & ! in/out + solution, err_code_edsclrm ) ! out + + !---------------------------------------------------------------- + ! Update Eddy-diff. Passive Scalars + !---------------------------------------------------------------- + edsclrm(1:gr%nz,1:edsclr_dim) = solution(1:gr%nz,1:edsclr_dim) + + ! The value of edsclrm(1) is located below the model surface and does not + ! effect the rest of the model. The value of edsclrm(1) is simply set to + ! the value of edsclrm(2) after the equation matrix has been solved. + forall( i=1:edsclr_dim ) + edsclrm(1,i) = edsclrm(2,i) + end forall + + ! Second part of momentum (implicit component) + + ! Solve for x'w' at all intermediate model levels. + ! A Crank-Nicholson timestep is used. +!HPF$ INDEPENDENT, REDUCTION(wpedsclrp) + forall( i = 1:edsclr_dim ) + wpedsclrp(2:gr%nz-1,i) = wpedsclrp(2:gr%nz-1,i) & + - 0.5_core_rknd * xpwp_fnc( Kmh_zm(2:gr%nz-1), edsclrm(2:gr%nz-1,i), & ! in + edsclrm(3:gr%nz,i), gr%invrs_dzm(2:gr%nz-1) ) ! in + end forall + + ! Note that the w'edsclr' terms are not clipped, since we don't compute the + ! variance of edsclr anywhere. -dschanen 7 Oct 2008 + + endif + + ! Check for singular matrices and bad LAPACK arguments + if ( fatal_error( err_code_windm ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "Fatal error solving for um/vm" + end if + err_code = err_code_windm + end if + + if ( fatal_error( err_code_edsclrm ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "Fatal error solving for eddsclrm" + end if + err_code = err_code_edsclrm + end if + + ! Error report + ! Joshua Fasching February 2008 + if ( ( fatal_error( err_code_windm ) .or. fatal_error( err_code_edsclrm ) ) .and. & + clubb_at_least_debug_level( 1 ) ) then + + write(fstderr,*) "Error in advance_windm_edsclrm" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "dt = ", dt + write(fstderr,*) "wm_zt = ", wm_zt + write(fstderr,*) "Km_zm = ", Km_zm + write(fstderr,*) "ug = ", ug + write(fstderr,*) "vg = ", vg + write(fstderr,*) "um_ref = ", um_ref + write(fstderr,*) "vm_ref = ", vm_ref + write(fstderr,*) "wp2 = ", wp2 + write(fstderr,*) "up2 = ", up2 + write(fstderr,*) "vp2 = ", vp2 + write(fstderr,*) "um_forcing = ", um_forcing + write(fstderr,*) "vm_forcing = ", vm_forcing + do i = 1, edsclr_dim + write(fstderr,*) "edsclrm_forcing # = ", i, edsclrm_forcing + end do + write(fstderr,*) "fcor = ", fcor + write(fstderr,*) "l_implemented = ", l_implemented + + write(fstderr,*) "Intent(inout)" + + write(fstderr,*) "um = ", um + write(fstderr,*) "vm = ", vm + do i = 1, edsclr_dim + write(fstderr,*) "edsclrm # ", i, "=", edsclrm(:,i) + end do + write(fstderr,*) "upwp = ", upwp + write(fstderr,*) "vpwp = ", vpwp + write(fstderr,*) "wpedsclrp = ", wpedsclrp + + !write(fstderr,*) "Intent(out)" + + return + + end if + + return + end subroutine advance_windm_edsclrm + + !============================================================================= + subroutine windm_edsclrm_solve( nrhs, ixm_matrix_condt_num, & + lhs, rhs, solution, err_code ) + + ! Note: In the "Description" section of this subroutine, the variable + ! "invrs_dzm" will be written as simply "dzm", and the variable + ! "invrs_dzt" will be written as simply "dzt". This is being done as + ! as device to save space and to make some parts of the description + ! more readable. This change does not pertain to the actual code. + + ! Description: + ! Solves the horizontal wind or eddy-scalar time-tendency equation, and + ! diagnoses the turbulent flux. A Crank-Nicholson time-stepping algorithm + ! is used in solving the turbulent advection term and in diagnosing the + ! turbulent flux. + ! + ! The rate of change of an eddy-scalar quantity, xm, is: + ! + ! d(xm)/dt = - w * d(xm)/dz - (1/rho_ds) * d( rho_ds * x'w' )/dz + ! + xm_forcings. + ! + ! + ! The Turbulent Advection Term + ! ---------------------------- + ! + ! The above equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * x'w' )/dz; + ! + ! where the momentum flux, x'w', is closed using a down gradient approach: + ! + ! x'w' = - K_zm * d(xm)/dz. + ! + ! The turbulent advection term becomes: + ! + ! + (1/rho_ds) * d [ rho_ds * K_zm * d(xm)/dz ] / dz; + ! + ! which is the same as a standard eddy-diffusion term (if "rho_ds * K_zm" in + ! the term above is substituted for "K_zm" in a standard eddy-diffusion + ! term, and if the standard eddy-diffusion term is multiplied by + ! "1/rho_ds"). Thus, the turbulent advection term is treated and solved in + ! the same way that a standard eddy-diffusion term would be solved. The + ! term is discretized as follows: + ! + ! The values of xm are found on the thermodynamic levels, while the values + ! of K_zm are found on the momentum levels. Additionally, the values of + ! rho_ds_zm are found on the momentum levels, and the values of + ! invrs_rho_ds_zt are found on the thermodynamic levels. The + ! derivatives (d/dz) of xm are taken over the intermediate momentum levels. + ! At the intermediate momentum levels, d(xm)/dz is multiplied by K_zm and by + ! rho_ds_zm. Then, the derivative of the whole mathematical expression is + ! taken over the central thermodynamic level, where it is multiplied by + ! invrs_rho_ds_zt, which yields the desired result. + ! + ! ---xm(kp1)----------------------------------------------------- t(k+1) + ! + ! ===========d(xm)/dz===K_zm(k)=====rho_ds_zm(k)================= m(k) + ! + ! ---xm(k)---invrs_rho_ds_zt---d[rho_ds_zm*K_zm*d(xm)/dz]/dz----- t(k) + ! + ! ===========d(xm)/dz===K_zm(km1)===rho_ds_zm(km1)=============== m(k-1) + ! + ! ---xm(km1)----------------------------------------------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! dzt(k) = 1 / ( zm(k) - zm(k-1) ) + ! dzm(k) = 1 / ( zt(k+1) - zt(k) ) + ! dzm(k-1) = 1 / ( zt(k) - zt(k-1) ) + ! + ! The vertically discretized form of the turbulent advection term (treated + ! as an eddy diffusion term) is written out as: + ! + ! + invrs_rho_ds_zt(k) + ! * dzt(k) + ! * [ rho_ds_zm(k) * K_zm(k) * dzm(k) * ( xm(k+1) - xm(k) ) + ! - rho_ds_zm(k-1) * K_zm(k-1) * dzm(k-1) * ( xm(k) - xm(k-1) ) ]. + ! + ! For this equation, a Crank-Nicholson (semi-implicit) diffusion scheme is + ! used to solve the (1/rho_ds) * d [ rho_ds * K_zm * d(xm)/dz ] / dz + ! eddy-diffusion term. The discretized implicit portion of the term is + ! written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(k) + ! * dzt(k) + ! * [ rho_ds_zm(k) * K_zm(k) + ! * dzm(k) * ( xm(k+1,) - xm(k,) ) + ! - rho_ds_zm(k-1) * K_zm(k-1) + ! * dzm(k-1) * ( xm(k,) - xm(k-1,) ) ]. + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "+" in front of the term + ! is changed to a "-". + ! + ! The discretized explicit portion of the term is written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(k) + ! * dzt(k) + ! * [ rho_ds_zm(k) * K_zm(k) + ! * dzm(k) * ( xm(k+1,) - xm(k,) ) + ! - rho_ds_zm(k-1) * K_zm(k-1) + ! * dzm(k-1) * ( xm(k,) - xm(k-1,) ) ]. + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(xm)/dt equation. + ! + ! + ! Boundary Conditions: + ! + ! An eddy-scalar quantity is not allowed to flux out the upper boundary. + ! Thus, a zero-flux boundary condition is used for the upper boundary in the + ! eddy-diffusion equation. + ! + ! The lower boundary condition is much more complicated. It is neither a + ! zero-flux nor a fixed-point boundary condition. Rather, it is a + ! fixed-flux boundary condition. This term is a turbulent advection term, + ! but with the eddy-scalars, the only value of x'w' relevant in solving the + ! d(xm)/dt equation is the value of x'w' at the surface (the first momentum + ! level), which is written as x'w'|_sfc. + ! + ! 1) x'w' surface flux; generalized explicit form + ! + ! The x'w' surface flux is applied to the d(xm)/dt equation through the + ! turbulent advection term, which is: + ! + ! - (1/rho_ds) * d( rho_ds * x'w' )/dz. + ! + ! At most vertical levels, a substitution can be made for x'w', such + ! that: + ! + ! x'w' = - K_zm * d(xm)/dz. + ! + ! However, the same substitution cannot be made at the surface (momentum + ! level 1), as x'w'|_sfc is a surface flux that is explicitly computed + ! elsewhere in the model code. + ! + ! The lower boundary condition, which in this case needs to be applied to + ! the d(xm)/dt equation at level 2, is discretized as follows: + ! + ! --xm(3)------------------------------------------------------- t(3) + ! + ! ========[x'w'(2) = -K_zm(2)*d(xm)/dz]===rho_ds_zm(2)========== m(2) + ! + ! --xm(2)---invrs_rho_ds_zt(2)---d[rho_ds_zm*K_zm*d(xm)/dz]/dz-- t(2) + ! + ! ========[x'w'|_sfc]=====================rho_ds_zm(1)========== m(1) sfc + ! + ! --xm(1)-------(below surface; not applicable)----------------- t(1) + ! + ! where "sfc" is the level of the model surface or lower boundary. + ! + ! The vertically discretized form of the turbulent advection term + ! (treated as an eddy diffusion term), with the explicit surface flux, + ! x'w'|_sfc, in place, is written out as: + ! + ! - invrs_rho_ds_zt(2) + ! * dzt(2) * [ rho_ds_zm(2) * x'w'(2) - rho_ds_zm(1) * x'w'|_sfc ]; + ! + ! which can be re-written as: + ! + ! + invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) * K_zm(2) * dzm(2) * ( xm(3) - xm(2) ) + ! + rho_ds_zm(1) * x'w'|_sfc ]; + ! + ! which can be re-written again as: + ! + ! + invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(2) * K_zm(2) * dzm(2) * ( xm(3) - xm(2) ) + ! + invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(1) * x'w'|_sfc. + ! + ! For this equation, a Crank-Nicholson (semi-implicit) diffusion scheme + ! is used to solve the (1/rho_ds) * d [ rho_ds * K_zm * d(xm)/dz ] / dz + ! eddy-diffusion term. The discretized implicit portion of the term is + ! written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) * K_zm(2) + ! * dzm(2) * ( xm(3,) - xm(2,) ) ]. + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "+" in front of the term + ! is changed to a "-". + ! + ! The discretized explicit portion of the term is written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) * K_zm(2) + ! * dzm(2) * ( xm(3,) - xm(2,) ) ] + ! + invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(1) * x'w'|_sfc. + ! + ! Note: The x'w'|_sfc portion of the term written above has been pulled + ! away from the rest of the explicit form written above because + ! the (1/2) factor due to Crank-Nicholson time_stepping does not + ! apply to it, as there isn't an implicit portion for x'w'|_sfc. + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which + ! is being advanced to in solving the d(xm)/dt equation. + ! + ! 2) x'w' surface flux; implicit form for momentum fluxes u'w' and v'w' + ! + ! The x'w' surface flux is applied to the d(xm)/dt equation through the + ! turbulent advection term, which is: + ! + ! - (1/rho_ds) * d( rho_ds * x'w' )/dz. + ! + ! At most vertical levels, a substitution can be made for x'w', such + ! that: + ! + ! x'w' = - K_zm * d(xm)/dz. + ! + ! However, the same substitution cannot be made at the surface (momentum + ! level 1), as x'w'|_sfc is a surface momentum flux that is found by the + ! following equation: + ! + ! x'w'|_sfc = - [ u_star^2 / sqrt( um^2 + vm^2 ) ] * xm; + ! + ! where x'w'|_sfc and xm are either u'w'|_sfc and um, respectively, or + ! v'w'|_sfc and vm, respectively (um and vm are located at the first + ! thermodynamic level above the surface, which is thermodynamic level 2), + ! sqrt( um^2 + vm^2 ) is the wind speed (also at thermodynamic level 2), + ! and u_star is defined as: + ! + ! u_star = ( u'w'|_sfc^2 + v'w'|_sfc^2 )^(1/4); + ! + ! and thus u_star^2 is defined as: + ! + ! u_star^2 = sqrt( u'w'|_sfc^2 + v'w'|_sfc^2 ). + ! + ! The value of u_star is either set to a constant value or computed + ! (through function diag_ustar) based on the surface wind speed, the + ! height above surface of the surface wind speed (as compared to the + ! roughness height), and the buoyancy flux at the surface. Either way, + ! u_star is computed elsewhere in the model, and the values of u'w'|_sfc + ! and v'w'|_sfc are based on it and computed along with it. The values + ! of u'w'|_sfc and v'w'|_sfc are then passed into advance_clubb_core, + ! and are eventually passed into advance_windm_edsclrm. In subroutine + ! advance_windm_edsclrm, the value of u_star_sqd is then recomputed + ! based on u'w'|_sfc and v'w'|_sfc. The value of sqrt( u_star_sqd ) is + ! consistent with the value of the original computation of u_star. + ! + ! The equation listed above is substituted for x'w'|_sfc. The lower + ! boundary condition, which in this case needs to be applied to the + ! d(xm)/dt equation at level 2, is discretized as follows: + ! + ! --xm(3)------------------------------------------------------- t(3) + ! + ! ===[x'w'(2) = -K_zm(2)*d(xm)/dz]=================rho_ds_zm(2)= m(2) + ! + ! --xm(2)---invrs_rho_ds_zt(2)---d[rho_ds_zm*K_zm*d(xm)/dz]/dz-- t(2) + ! + ! ===[x'w'|_sfc = -[u_star^2/sqrt(um^2+vm^2)]*xm]==rho_ds_zm(1)= m(1) sfc + ! + ! --xm(1)-------(below surface; not applicable)----------------- t(1) + ! + ! where "sfc" is the level of the model surface or lower boundary. + ! + ! The vertically discretized form of the turbulent advection term + ! (treated as an eddy diffusion term), with the implicit surface momentum + ! flux in place, is written out as: + ! + ! - invrs_rho_ds_zt(2) + ! * dzt(2) * [ rho_ds_zm(2) * x'w'(2) - rho_ds_zm(1) * x'w'|_sfc ]; + ! + ! which can be re-written as: + ! + ! - invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) + ! * { - K_zm(2) * dzm(2) * ( xm(3) - xm(2) ) } + ! - rho_ds_zm(1) + ! * { - [ u_star^2 / sqrt( um(2)^2 + vm(2)^2 ) ] * xm(2) } ]; + ! + ! which can be re-written as: + ! + ! + invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(2) * K_zm(2) * dzm(2) * ( xm(3) - xm(2) ) + ! - invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(1) * [ u_star^2 / sqrt( um(2)^2 + vm(2)^2 ) ] * xm(2). + ! + ! For this equation, a Crank-Nicholson (semi-implicit) diffusion scheme + ! is used to solve the (1/rho_ds) * d [ rho_ds * K_zm * d(xm)/dz ] / dz + ! eddy-diffusion term. The discretized implicit portion of the term is + ! written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) * K_zm(2) + ! * dzm(2) * ( xm(3,) - xm(2,) ) ] + ! - invrs_rho_ds_zt(2) + ! * dzt(2) + ! * rho_ds_zm(1) + ! * [u_star^2/sqrt( um(2,)^2 + vm(2,)^2 )] * xm(2,). + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the signs are reversed and the leading "+" in front of the first + ! part of the term is changed to a "-", while the leading "-" in + ! front of the second part of the term is changed to a "+". + ! + ! Note: The x'w'|_sfc portion of the term written above has been pulled + ! away from the rest of the implicit form written above because + ! the (1/2) factor due to Crank-Nicholson time_stepping does not + ! apply to it. The x'w'|_sfc portion of the term is treated + ! completely implicitly in order to enhance numerical stability. + ! + ! The discretized explicit portion of the term is written out as: + ! + ! + (1/2) * invrs_rho_ds_zt(2) + ! * dzt(2) + ! * [ rho_ds_zm(2) * K_zm(2) + ! * dzm(2) * ( xm(3,) - xm(2,) ) ]. + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which + ! is being advanced to in solving the d(xm)/dt equation. + ! + ! + ! The lower boundary condition for the implicit and explicit portions of the + ! turbulent advection term, without the x'w'|_sfc portion of the term, can + ! easily be invoked by using the zero-flux boundary conditions found in the + ! generalized diffusion function (function diffusion_zt_lhs), which is used + ! for many other equations in this model. Either the generalized explicit + ! surface flux needs to be added onto the explicit term after the diffusion + ! function has been called from subroutine windm_edsclrm_rhs, or the + ! implicit momentum surface flux needs to be added onto the implicit term + ! after the diffusion function has been called from subroutine + ! windm_edsclrm_lhs. However, all other equations in this model that use + ! zero-flux diffusion have level 1 as the level to which the lower boundary + ! condition needs to be applied. Thus, an adjuster will have to be used at + ! level 2 to call diffusion_zt_lhs with level 1 as the input level (the last + ! variable being passed in during the function call). However, the other + ! variables passed in (rho_ds_zm*K_zm, gr%dzt, and gr%dzm variables) will + ! have to be passed in as solving for level 2. + ! + ! The value of xm(1) is located below the model surface and does not effect + ! the rest of the model. Since xm can be either a horizontal wind component + ! or a generic eddy scalar quantity, the value of xm(1) is simply set to the + ! value of xm(2) after the equation matrix has been solved. + ! + ! + ! Conservation Properties: + ! + ! When a fixed-flux lower boundary condition is used (combined with a + ! zero-flux upper boundary condition), this technique of discretizing the + ! turbulent advection term (treated as an eddy-diffusion term) leads to + ! conservative differencing. When the implicit momentum surface flux is + ! either zero or not used, the column totals for each column in the + ! left-hand side matrix (for the turbulent advection term) should be equal + ! to 0. Otherwise, the column total for the second column will be equal to + ! rho_ds_zm(1) * x'w'|_sfc. When the generalized explicit surface + ! flux is either zero or not used, the column total for the right-hand side + ! vector (for the turbulent advection term) should be equal to 0. + ! Otherwise, the column total for the right-hand side vector (for the + ! turbulent advection term) will be equal to rho_ds_zm(1) * x'w'|_sfc. + ! This ensures that the total amount of quantity xm over the entire vertical + ! domain is only changed by the surface flux (neglecting any forcing terms). + ! The total amount of change is equal to rho_ds_zm(1) * x'w'|_sfc. + ! + ! To see that this conservation law is satisfied by the left-hand side + ! matrix, compute the turbulent advection (treated as eddy diffusion) of xm, + ! neglecting any implicit momentum surface flux, multiply by rho_ds_zt, and + ! integrate vertically. In discretized matrix notation (where "i" stands + ! for the matrix column and "j" stands for the matrix row): + ! + ! 0 = Sum_j Sum_i + ! (rho_ds_zt)_i ( 1/dzt )_i + ! ( 0.5_core_rknd * (1/rho_ds_zt) * dzt * (rho_ds_zm*K_zm*dzm) )_ij (xm)_j. + ! + ! The left-hand side matrix, + ! ( 0.5_core_rknd * (1/rho_ds_zt) * dzt * (rho_ds_zm*K_zm*dzm) )_ij, is partially + ! written below. The sum over i in the above equation removes (1/rho_ds_zt) + ! and dzt everywhere from the matrix below. The sum over j leaves the + ! column totals that are desired, which are 0. + ! + ! Left-hand side matrix contributions from the turbulent advection term + ! (treated as an eddy-diffusion term using a Crank-Nicholson timestep); + ! first five vertical levels: + ! + ! -------------------------------------------------------------------------------> + !k=1 | 0 0 0 0 + ! | + !k=2 | 0 +0.5* -0.5* 0 + ! | (1/rho_ds_zt(k))* (1/rho_ds_zt(k))* + ! | dzt(k)* dzt(k)* + ! | rho_ds_zm(k)* rho_ds_zm(k)* + ! | K_zm(k)*dzm(k) K_zm(k)*dzm(k) + ! | + !k=3 | 0 -0.5* +0.5* -0.5* + ! | (1/rho_ds_zt(k))* (1/rho_ds_zt(k))* (1/rho_ds_zt(k))* + ! | dzt(k)* dzt(k)* dzt(k)* + ! | rho_ds_zm(k-1)* [ rho_ds_zm(k)* rho_ds_zm(k)* + ! | K_zm(k-1)*dzm(k-1) K_zm(k)*dzm(k) K_zm(k)*dzm(k) + ! | +rho_ds_zm(k-1)* + ! | K_zm(k-1)*dzm(k-1) ] + ! | + !k=4 | 0 0 -0.5* +0.5* + ! | (1/rho_ds_zt(k))* (1/rho_ds_zt(k))* + ! | dzt(k)* dzt(k)* + ! | rho_ds_zm(k-1)* [ rho_ds_zm(k)* + ! | K_zm(k-1)*dzm(k-1) K_zm(k)*dzm(k) + ! | +rho_ds_zm(k-1)* + ! | K_zm(k-1)*dzm(k-1) ] + ! | + !k=5 | 0 0 0 -0.5* + ! | (1/rho_ds_zt(k))* + ! | dzt(k)* + ! | rho_ds_zm(k-1)* + ! | K_zm(k-1)*dzm(k-1) + ! \ / + ! + ! Note: The superdiagonal term from level 4 and both the main diagonal and + ! superdiagonal terms from level 5 are not shown on this diagram. + ! + ! Note: If an implicit momentum surface flux is used, an additional term, + ! + (1/rho_ds_zt(2)) * dzt(2) * rho_ds_zm(1) + ! * [ u_star^2 / sqrt( um(2,)^2 + vm(2,)^2 ) ], is added to + ! row 2 (k=2), column 2. + ! + ! To see that the above conservation law is satisfied by the right-hand side + ! vector, compute the turbulent advection (treated as eddy diffusion) of xm, + ! neglecting any generalized explicit surface flux, multiply by rho_ds_zt, + ! and integrate vertically. In discretized matrix notation (where "i" + ! stands for the matrix column and "j" stands for the matrix row): + ! + ! 0 = Sum_j Sum_i (rho_ds_zt)_i ( 1/dzt )_i ( rhs_vector )_j. + ! + ! The right-hand side vector, ( rhs_vector )_j, is partially written below. + ! The sum over i in the above equation removes (1/rho_ds_zt) and dzt + ! everywhere from the vector below. The sum over j leaves the column total + ! that is desired, which is 0. + ! + ! Right-hand side vector contributions from the turbulent advection term + ! (treated as an eddy-diffusion term using a Crank-Nicholson timestep); + ! first five vertical levels: + ! + ! -------------------------------------------- + !k=1 | 0 | + ! | | + ! | | + !k=2 | +0.5*(1/rho_ds_zt(k))* | + ! | dzt(k)* | + ! | [ rho_ds_zm(k)*K_zm(k)* | + ! | dzm(k)*(xm(k+1,)-xm(k,)) ] | + ! | | + !k=3 | +0.5*(1/rho_ds_zt(k))* | + ! | dzt(k)* | + ! | [ rho_ds_zm(k)*K_zm(k)* | + ! | dzm(k)*(xm(k+1,)-xm(k,)) | + ! | -rho_ds_zm(k-1)*K_zm(k-1)* | + ! | dzm(k-1)*(xm(k,)-xm(k-1,)) ] | + ! | | + !k=4 | +0.5*(1/rho_ds_zt(k))* | + ! | dzt(k)* | + ! | [ rho_ds_zm(k)*K_zm(k)* | + ! | dzm(k)*(xm(k+1,)-xm(k,)) | + ! | -rho_ds_zm(k-1)*K_zm(k-1)* | + ! | dzm(k-1)*(xm(k,)-xm(k-1,)) ] | + ! | | + !k=5 | +0.5*(1/rho_ds_zt(k))* | + ! | dzt(k)* | + ! | [ rho_ds_zm(k)*K_zm(k)* | + ! | dzm(k)*(xm(k+1,)-xm(k,)) | + ! | -rho_ds_zm(k-1)*K_zm(k-1)* | + ! | dzm(k-1)*(xm(k,)-xm(k-1,)) ] | + ! \ / \ / + ! + ! Note: If a generalized explicit surface flux is used, an additional term, + ! + (1/rho_ds_zt(2)) * dzt(2) * rho_ds_zm(1) * x'w'|_sfc, is added to + ! row 2 (k=2). + ! + ! Note: Only the contributions by the turbulent advection term are shown + ! for both the left-hand side matrix and the right-hand side vector. + ! There are more terms in the equation, and thus more factors to be + ! added to both the left-hand side matrix (such as time tendency and + ! mean advection) and the right-hand side vector (such as xm + ! forcings). The left-hand side matrix is set-up so that a singular + ! matrix is not encountered. + + ! References: + ! Eqn. 8 & 9 on p. 3545 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use lapack_wrap, only: & + tridag_solve, & ! Procedure(s) + tridag_solvex + + use stats_variables, only: & + stats_sfc, & ! Variable(s) + l_stats_samp + + use stats_type_utilities, only: & + stat_update_var_pt ! Subroutine + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + + integer, intent(in) :: & + nrhs ! Number of right-hand side (explicit) vectors & Number of solution vectors. + + integer, intent(in) :: & + ixm_matrix_condt_num ! Stats index of the condition numbers + + real( kind = core_rknd ), dimension(3,gr%nz), intent(inout) :: & + lhs ! Implicit contributions to um, vm, and eddy scalars [units vary] + + real( kind = core_rknd ), dimension(gr%nz,nrhs), intent(inout) :: & + rhs ! Right-hand side (explicit) contributions. + + real( kind = core_rknd ), dimension(gr%nz,nrhs), intent(out) :: & + solution ! Solution to the system of equations [units vary] + + integer, intent(out) :: & + err_code ! clubb_singular_matrix when matrix is singular + + ! Local variables + real( kind = core_rknd ) :: & + rcond ! Estimate of the reciprocal of the condition number on the LHS matrix + + ! Solve tridiagonal system for xm. + if ( l_stats_samp .and. ixm_matrix_condt_num > 0 ) then + call tridag_solvex & + ( "windm_edsclrm", gr%nz, nrhs, & ! Intent(in) + lhs(kp1_tdiag,:), lhs(k_tdiag,:), lhs(km1_tdiag,:), rhs, & ! Intent(inout) + solution, rcond, err_code ) ! Intent(out) + + ! Est. of the condition number of the variance LHS matrix + call stat_update_var_pt( ixm_matrix_condt_num, 1, 1.0_core_rknd/rcond, & ! Intent(in) + stats_sfc ) ! Intent(inout) + else + + call tridag_solve( "windm_edsclrm", gr%nz, nrhs, & ! In + lhs(kp1_tdiag,:), lhs(k_tdiag,:), lhs(km1_tdiag,:), rhs, & ! Inout + solution, err_code ) ! Out + end if + + return + end subroutine windm_edsclrm_solve + + !============================================================================= + subroutine windm_edsclrm_implicit_stats( solve_type, xm ) + + ! Description: + ! Compute implicit contributions to um and vm + + ! References: + ! None + !----------------------------------------------------------------------- + + use stats_variables, only: & + ium_ma, & ! Variables + ium_ta, & + ivm_ma, & + ivm_ta, & + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + stats_zt + + use stats_type_utilities, only: & + stat_end_update_pt, & ! Subroutines + stat_update_var_pt + + use clubb_precision, only: & + core_rknd + + use grid_class, only: & + gr ! Derived type variable + + implicit none + + ! Input variables + integer, intent(in) :: & + solve_type ! Desc. of what is being solved for + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm ! Computed value um or vm at [m/s] + + ! Local variables + integer :: k, kp1, km1 ! Array indices + + ! Budget indices + integer :: ixm_ma, ixm_ta + + select case ( solve_type ) + case ( windm_edsclrm_um ) + ixm_ma = ium_ma + ixm_ta = ium_ta + + case ( windm_edsclrm_vm ) + ixm_ma = ivm_ma + ixm_ta = ivm_ta + + case default + ixm_ma = 0 + ixm_ta = 0 + + end select + + + ! Finalize implicit contributions for xm + + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! xm mean advection + ! xm term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixm_ma, k, & + ztscr01(k) * xm(km1) & + + ztscr02(k) * xm(k) & + + ztscr03(k) * xm(kp1), stats_zt ) + + ! xm turbulent transport (implicit component) + ! xm term ta has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( ixm_ta, k, & + ztscr04(k) * xm(km1) & + + ztscr05(k) * xm(k) & + + ztscr06(k) * xm(kp1), stats_zt ) + + enddo + + + ! Upper boundary conditions + k = gr%nz + km1 = max( k-1, 1 ) + + ! xm mean advection + ! xm term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixm_ma, k, & + ztscr01(k) * xm(km1) & + + ztscr02(k) * xm(k), stats_zt ) + + ! xm turbulent transport (implicit component) + ! xm term ta has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( ixm_ta, k, & + ztscr04(k) * xm(km1) & + + ztscr05(k) * xm(k), stats_zt ) + + + return + end subroutine windm_edsclrm_implicit_stats + + !============================================================================= + subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forcing, & + l_implemented, xm_tndcy ) + + ! Description: + ! Computes the explicit tendency for the um and vm wind components. + ! + ! The only explicit tendency that is involved in the d(um)/dt or d(vm)/dt + ! equations is the Coriolis tendency. + ! + ! The d(um)/dt equation contains the term: + ! + ! - f * ( v_g - vm ); + ! + ! where f is the Coriolis parameter and v_g is the v component of the + ! geostrophic wind. + ! + ! Likewise, the d(vm)/dt equation contains the term: + ! + ! + f * ( u_g - um ); + ! + ! where u_g is the u component of the geostrophic wind. + ! + ! This term is treated completely explicitly. The values of um, vm, u_g, + ! and v_g are all found on the thermodynamic levels. + ! + ! Wind forcing from the GCSS cases is also added here. + ! + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr + + use stats_type_utilities, only: & + stat_update_var + + use stats_variables, only: & + ium_gf, & + ium_cf, & + ivm_gf, & + ivm_cf, & + ium_f, & + ivm_f, & + stats_zt, & + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type ! Description of what is being solved for + + real( kind = core_rknd ), intent(in) :: & + fcor ! Coriolis parameter [s^-1] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + perp_wind_m, & ! Perpendicular component of the mean wind (e.g. v, for the u-eqn) [m/s] + perp_wind_g, & ! Perpendicular component of the geostropic wind (e.g. vg) [m/s] + xm_forcing ! Prescribed wind forcing [m/s/s] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + xm_tndcy ! xm tendency [m/s^2] + + ! Local Variables + integer :: & + ixm_gf, & + ixm_cf, & + ixm_f + + real( kind = core_rknd ), dimension(gr%nz) :: & + xm_gf, & + xm_cf + + ! --- Begin Code --- + + if ( .not. l_implemented ) then + ! Only compute the Coriolis term if the model is running on it's own, + ! and is not part of a larger, host model. + + select case ( solve_type ) + + case ( windm_edsclrm_um ) + + ixm_gf = ium_gf + ixm_cf = ium_cf + ixm_f = ium_f + + xm_gf = - fcor * perp_wind_g(1:gr%nz) + + xm_cf = fcor * perp_wind_m(1:gr%nz) + + case ( windm_edsclrm_vm ) + + ixm_gf = ivm_gf + ixm_cf = ivm_cf + ixm_f = ivm_f + + xm_gf = fcor * perp_wind_g(1:gr%nz) + + xm_cf = -fcor * perp_wind_m(1:gr%nz) + + case default + + ixm_gf = 0 + ixm_cf = 0 + ixm_f = 0 + + xm_gf = 0._core_rknd + + + xm_cf = 0._core_rknd + + end select + + xm_tndcy(1:gr%nz) = xm_gf(1:gr%nz) + xm_cf(1:gr%nz) & + + xm_forcing(1:gr%nz) + + if ( l_stats_samp ) then + + ! xm term gf is completely explicit; call stat_update_var. + call stat_update_var( ixm_gf, xm_gf, stats_zt ) + + ! xm term cf is completely explicit; call stat_update_var. + call stat_update_var( ixm_cf, xm_cf, stats_zt ) + + ! xm term F + call stat_update_var( ixm_f, xm_forcing, stats_zt ) + endif + + else ! implemented in a host model. + + xm_tndcy = 0.0_core_rknd + + endif + + + return + end subroutine compute_uv_tndcy + +!=============================================================================== + subroutine windm_edsclrm_lhs( dt, nu, wm_zt, Km_zm, wind_speed, u_star_sqd, & + rho_ds_zm, invrs_rho_ds_zt, & + l_implemented, l_imp_sfc_momentum_flux, & + lhs ) + + ! Description: + ! Calculate the implicit portion of the horizontal wind or eddy-scalar + ! time-tendency equation. See the description in subroutine + ! windm_edsclrm_solve for more details. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use diffusion, only: & + diffusion_zt_lhs ! Procedure(s) + + use mean_adv, only: & + term_ma_zt_lhs ! Procedures + + use stats_variables, only: & + ium_ma, & ! Variable(s) + ium_ta, & + ivm_ma, & + ivm_ta, & + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + l_stats_samp + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + nu ! Background constant coef. of eddy diffusivity [m^2/s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wm_zt, & ! w wind component on thermodynamic levels [m/s] + Km_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + wind_speed, & ! wind speed; sqrt( u^2 + v^2 ) [m/s] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] + + real( kind = core_rknd ), intent(in) :: & + u_star_sqd ! Surface friction velocity, u_*, squared [m/s] + + logical, intent(in) :: & + l_implemented, & ! Flag for CLUBB being implemented in a larger model. + l_imp_sfc_momentum_flux ! Flag for implicit momentum surface fluxes. + + ! Output Variable + real( kind = core_rknd ), dimension(3,gr%nz), intent(out) :: & + lhs ! Implicit contributions to xm (tridiagonal matrix) + + ! Local Variables + integer :: k, km1 ! Array indices + integer :: diff_k_in + + real( kind = core_rknd ), dimension(3) :: tmp + + ! --- Begin Code --- + + ! Initialize the LHS array to zero. + lhs = 0.0_core_rknd + + do k = 2, gr%nz, 1 + + ! Define index + km1 = max( k-1, 1 ) + + ! LHS mean advection term. + if ( .not. l_implemented ) then + + lhs(kp1_tdiag:km1_tdiag,k) & + = lhs(kp1_tdiag:km1_tdiag,k) & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + + else + ! The host model is assumed to apply the advection term to the mean elsewhere in this case. + lhs(kp1_tdiag:km1_tdiag,k) & + = lhs(kp1_tdiag:km1_tdiag,k) + 0.0_core_rknd + + endif + + ! LHS turbulent advection term (solved as an eddy-diffusion term). + if ( k == 2 ) then + ! The lower boundary condition needs to be applied here at level 2. + ! The lower boundary condition is a "fixed flux" boundary condition. + ! The coding is the same as for a zero-flux boundary condition, but with + ! an extra term added on the right-hand side at the boundary level. For + ! the rest of the model code, a zero-flux boundary condition is applied + ! at level 1, and thus subroutine diffusion_zt_lhs is set-up to do that. + ! In order to apply the same boundary condition code here at level 2, an + ! adjuster needs to be used to tell diffusion_zt_lhs to use the code at + ! level 2 that it normally uses at level 1. + diff_k_in = 1 + else + diff_k_in = k + endif + lhs(kp1_tdiag:km1_tdiag,k) & + = lhs(kp1_tdiag:km1_tdiag,k) & + + 0.5_core_rknd * invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), diff_k_in ) + + ! LHS time tendency. + lhs(k_tdiag,k) & + = lhs(k_tdiag,k) + 1.0_core_rknd / dt + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for um or vm. + ! Note: we don't track these budgets for the eddy scalar variables + + if ( ium_ma + ivm_ma > 0 ) then + if ( .not. l_implemented ) then + tmp(1:3) & + = term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + ztscr01(k) = -tmp(3) + ztscr02(k) = -tmp(2) + ztscr03(k) = -tmp(1) + else + ztscr01(k) = 0.0_core_rknd + ztscr02(k) = 0.0_core_rknd + ztscr03(k) = 0.0_core_rknd + endif + endif + + if ( ium_ta + ivm_ta > 0 ) then + tmp(1:3) & + = 0.5_core_rknd * invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), diff_k_in ) + ztscr04(k) = -tmp(3) + ztscr05(k) = -tmp(2) + ztscr06(k) = -tmp(1) + endif + + endif ! l_stats_samp + + enddo ! k = 2 .. gr%nz + + + ! Boundary Conditions + + ! Lower Boundary + + ! The lower boundary condition is a fixed-flux boundary condition, which + ! gets added into the time-tendency equation at level 2. + ! The value of xm(1) is located below the model surface and does not effect + ! the rest of the model. Since xm can be either a horizontal wind component + ! or a generic eddy scalar quantity, the value of xm(1) is simply set to the + ! value of xm(2) after the equation matrix has been solved. + + ! k = 1 + lhs(k_tdiag,1) = 1.0_core_rknd + + ! k = 2; add implicit momentum surface flux. + if ( l_imp_sfc_momentum_flux ) then + + ! LHS momentum surface flux. + lhs(k_tdiag,2) & + = lhs(k_tdiag,2) & + + invrs_rho_ds_zt(2) & + * gr%invrs_dzt(2) & + * rho_ds_zm(1) * ( u_star_sqd / wind_speed(2) ) + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for um or vm. + + ! xm term ta is modified at level 2 to include the effects of the + ! surface flux. In this case, this effects the implicit portion of + ! the term (after zmscr05, which handles the main diagonal for the + ! turbulent advection term, has already been called at level 2). + ! Modify zmscr05 accordingly. + if ( ium_ta + ivm_ta > 0 ) then + ztscr05(2) & + = ztscr05(2) & + - invrs_rho_ds_zt(2) & + * gr%invrs_dzt(2) & + * rho_ds_zm(1) * ( u_star_sqd / wind_speed(2) ) + endif + + endif ! l_stats_samp + + endif ! l_imp_sfc_momentum_flux + + + return + end subroutine windm_edsclrm_lhs + + !============================================================================= + function windm_edsclrm_rhs( solve_type, dt, nu, Km_zm, xm, xm_tndcy, & + rho_ds_zm, invrs_rho_ds_zt, & + l_imp_sfc_momentum_flux, xpwp_sfc ) & + result( rhs ) + + ! Description: + ! Calculate the explicit portion of the horizontal wind or eddy-scalar + ! time-tendency equation. See the description in subroutine + ! windm_edsclrm_solve for more details. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use diffusion, only: & + diffusion_zt_lhs ! Procedure(s) + + use stats_variables, only: & + ium_ta, & ! Variable(s) + ivm_ta, & + stats_zt, & + l_stats_samp + + use stats_type_utilities, only: & + stat_begin_update_pt, & ! Procedure(s) + stat_modify_pt + + use grid_class, only: & + gr ! Variable(s) + + implicit none + + ! External + intrinsic :: max, min, real, trim + + ! Input Variables + integer, intent(in) :: & + solve_type ! Description of what is being solved for + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + nu ! Background constant coef. of eddy diffusivity [m^2/s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + Km_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + xm, & ! Eddy-scalar variable, xm (thermo. levels) [units vary] + xm_tndcy, & ! The explicit time-tendency acting on xm [units vary] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt ! Inv. dry, static density at thermo. levels [m^3/kg] + + real( kind = core_rknd ), intent(in) :: & + xpwp_sfc ! x'w' at the surface [units vary] + + logical, intent(in) :: & + l_imp_sfc_momentum_flux ! Flag for implicit momentum surface fluxes. + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + rhs ! Right-hand side (explicit) contributions. + + ! Local Variables + integer :: k, kp1, km1 ! Array indices + integer :: diff_k_in + + ! For use in Crank-Nicholson eddy diffusion. + real( kind = core_rknd ), dimension(3) :: rhs_diff + + integer :: ixm_ta + + ! --- Begin Code --- + + select case ( solve_type ) + case ( windm_edsclrm_um ) + ixm_ta = ium_ta + case ( windm_edsclrm_vm ) + ixm_ta = ivm_ta + case default ! Eddy scalars + ixm_ta = 0 + end select + + + ! Initialize the RHS vector. + rhs = 0.0_core_rknd + + do k = 2, gr%nz-1, 1 + + ! Define indices + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! RHS turbulent advection term (solved as an eddy-diffusion term). + if ( k == 2 ) then + ! The lower boundary condition needs to be applied here at level 2. + ! The lower boundary condition is a "fixed flux" boundary condition. + ! The coding is the same as for a zero-flux boundary condition, but with + ! an extra term added on the right-hand side at the boundary level. For + ! the rest of the model code, a zero-flux boundary condition is applied + ! at level 1, and thus subroutine diffusion_zt_lhs is set-up to do that. + ! In order to apply the same boundary condition code here at level 2, an + ! adjuster needs to be used to tell diffusion_zt_lhs to use the code at + ! level 2 that it normally uses at level 1. + diff_k_in = 1 + else + diff_k_in = k + endif + rhs_diff(1:3) & + = 0.5_core_rknd * invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), diff_k_in ) + rhs(k) = rhs(k) & + - rhs_diff(3) * xm(km1) & + - rhs_diff(2) * xm(k) & + - rhs_diff(1) * xm(kp1) + + ! RHS forcings. + rhs(k) = rhs(k) + xm_tndcy(k) + + ! RHS time tendency + rhs(k) = rhs(k) + 1.0_core_rknd / dt * xm(k) + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for um or vm. + + ! xm term ta has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on right-hand side + ! turbulent advection component. + if ( ixm_ta > 0 ) then + call stat_begin_update_pt( ixm_ta, k, & + rhs_diff(3) * xm(km1) & + + rhs_diff(2) * xm(k) & + + rhs_diff(1) * xm(kp1), stats_zt ) + endif + + endif ! l_stats_samp + + enddo ! 2..gr%nz-1 + + + ! Boundary Conditions + + ! Lower Boundary + + ! The lower boundary condition is a fixed-flux boundary condition, which + ! gets added into the time-tendency equation at level 2. + ! The value of xm(1) is located below the model surface and does not effect + ! the rest of the model. Since xm can be either a horizontal wind component + ! or a generic eddy scalar quantity, the value of xm(1) is simply set to the + ! value of xm(2) after the equation matrix has been solved. For purposes of + ! the matrix equation, rhs(1) is simply set to 0. + + ! k = 1 + rhs(1) = 0.0_core_rknd + + ! k = 2; add generalized explicit surface flux. + if ( .not. l_imp_sfc_momentum_flux ) then + + ! RHS generalized surface flux. + rhs(2) & + = rhs(2) & + + invrs_rho_ds_zt(2) & + * gr%invrs_dzt(2) & + * rho_ds_zm(1) * xpwp_sfc + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for um or vm. + + ! xm term ta is modified at level 2 to include the effects of the + ! surface flux. In this case, this effects the explicit portion of + ! the term (after stat_begin_update_pt has already been called at + ! level 2); call stat_modify_pt. + if ( ixm_ta > 0 ) then + call stat_modify_pt( ixm_ta, 2, & + + invrs_rho_ds_zt(2) & + * gr%invrs_dzt(2) & + * rho_ds_zm(1) * xpwp_sfc, & + stats_zt ) + endif + + endif ! l_stats_samp + + endif ! l_imp_sfc_momentum_flux + + ! Upper Boundary + + ! A zero-flux boundary condition is used at the upper boundary, meaning that + ! xm is not allowed to exit the model through the upper boundary. This + ! boundary condition is invoked by calling diffusion_zt_lhs at the uppermost + ! level. + k = gr%nz + km1 = max( k-1, 1 ) + + ! RHS turbulent advection term (solved as an eddy-diffusion term) at the + ! upper boundary. + rhs_diff(1:3) & + = 0.5_core_rknd * invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * Km_zm(k), & + rho_ds_zm(km1) * Km_zm(km1), nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + rhs(k) = rhs(k) & + - rhs_diff(3) * xm(km1) & + - rhs_diff(2) * xm(k) + + ! RHS forcing term at the upper boundary. + rhs(k) = rhs(k) + xm_tndcy(k) + + ! RHS time tendency term at the upper boundary. + rhs(k) = rhs(k) + 1.0_core_rknd / dt * xm(k) + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for um or vm. + + ! xm term ta has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on right-hand side + ! turbulent advection component. + if ( ixm_ta > 0 ) then + call stat_begin_update_pt( ixm_ta, k, & + rhs_diff(3) * xm(km1) & + + rhs_diff(2) * xm(k), stats_zt ) + endif + + endif ! l_stats_samp + + + return + end function windm_edsclrm_rhs + +!=============================================================================== + elemental function xpwp_fnc( Km_zm, xm, xmp1, invrs_dzm ) + + ! Description: + ! Compute x'w' from x, x, Kh and invrs_dzm + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + Km_zm, & ! Eddy diff. (k momentum level) [m^2/s] + xm, & ! x (k thermo level) [units vary] + xmp1, & ! x (k+1 thermo level) [units vary] + invrs_dzm ! Inverse of the grid spacing (k thermo level) [1/m] + + ! Output variable + real( kind = core_rknd ) :: & + xpwp_fnc ! x'w' [(units vary)(m/s)] + + !----------------------------------------------------------------------- + ! --- Begin Code --- + + ! Solve for x'w' at all intermediate model levels. + xpwp_fnc = Km_zm * invrs_dzm * ( xmp1 - xm ) + + return + end function xpwp_fnc + +!=============================================================================== + +end module advance_windm_edsclrm_module diff --git a/src/physics/clubb/advance_wp2_wp3_module.F90 b/src/physics/clubb/advance_wp2_wp3_module.F90 new file mode 100644 index 0000000000..4dbc9b603e --- /dev/null +++ b/src/physics/clubb/advance_wp2_wp3_module.F90 @@ -0,0 +1,4253 @@ +!------------------------------------------------------------------------ +! $Id: advance_wp2_wp3_module.F90 7380 2014-11-11 20:34:25Z schemena@uwm.edu $ +!=============================================================================== +module advance_wp2_wp3_module + + implicit none + + private ! Default Scope + + public :: advance_wp2_wp3 + + private :: wp23_solve, & + wp23_lhs, & + wp23_rhs, & + wp2_term_ta_lhs, & + wp2_terms_ac_pr2_lhs, & + wp2_term_dp1_lhs, & + wp2_term_pr1_lhs, & + wp2_terms_bp_pr2_rhs, & + wp2_term_dp1_rhs, & + wp2_term_pr3_rhs, & + wp2_term_pr1_rhs, & + wp3_terms_ta_tp_lhs, & + wp3_terms_ac_pr2_lhs, & + wp3_term_pr1_lhs, & + wp3_terms_bp1_pr2_rhs, & + wp3_term_pr1_rhs, & + wp3_term_bp2_rhs + +! private :: wp3_terms_ta_tp_rhs + + ! Private named constants to avoid string comparisons + integer, parameter, private :: & + clip_wp2 = 12 ! Named constant for wp2 clipping. + ! NOTE: This must be the same as the clip_wp2 declared in + ! clip_explicit! + + contains + + !============================================================================= + subroutine advance_wp2_wp3( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & + a3, a3_zt, wp3_on_wp2, & + wpthvp, wp2thvp, um, vm, upwp, vpwp, & + up2, vp2, Kh_zm, Kh_zt, tau_zm, tau_zt, tau_C1_zm, & + Skw_zm, Skw_zt, rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, & + thv_ds_zm, thv_ds_zt, mixt_frac, & + wp2, wp3, wp3_zm, wp2_zt, err_code ) + + ! Description: + ! Advance w'^2 and w'^3 one timestep. + + ! References: + ! Eqn. 12 & 18 on p. 3545--3546 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + + ! See also + ! ``Equations for CLUBB'', Section 6: + ! /Implict solution for the vertical velocity moments/ + !------------------------------------------------------------------------ + + use grid_class, only: & + gr, & ! Variable(s) + zt2zm, & ! Procedure(s) + zm2zt + + use parameters_tunable, only: & + C11c, & ! Variable(s) + C11b, & + C11, & + C1c, & + C1b, & + C1, & + c_K1, & + c_K8 + + use stats_type_utilities, only: & + stat_update_var + + use stats_variables, only: & + iC1_Skw_fnc, & + iC11_Skw_fnc, & + stats_zm, & + stats_zt, & + l_stats_samp + + use constants_clubb, only: & + fstderr, & ! Variables + one_third + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + fatal_error, & ! Procedure(s) + clubb_at_least_debug_level + + use error_code, only: & + clubb_var_out_of_range ! Constant(s) + + use model_flags, only: & + l_damp_wp2_using_em ! Logical + + + implicit none + + intrinsic :: exp + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + sigma_sqd_w, & ! sigma_sqd_w (momentum levels) [-] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + a3, & ! a_3 (momentum levels); See eqn. 25 in `Equations for CLUBB' [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + wpthvp, & ! w'th_v' (momentum levels) [K m/s] + wp2thvp, & ! w'^2th_v' (thermodynamic levels) [K m^2/s^2] + um, & ! u wind component (thermodynamic levels) [m/s] + vm, & ! v wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] + tau_zm, & ! Time-scale tau on momentum levels [s] + tau_zt, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + Skw_zm, & ! Skewness of w on momentum levels [-] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at the CL top [m^2/s^3] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] + mixt_frac ! Weight of 1st normal distribution [-] + + ! Input/Output + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3, & ! w'^3 (thermodynamic levels) [m^3/s^3] + wp3_zm ! w'^3 interpolated to momentum levels [m^3/s^3] + + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp2_zt ! w'^2 interpolated to thermodyamic levels [m^2/s^2] + + integer, intent(inout) :: err_code ! Diagnostic + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + tauw3t ! Currently just tau_zt [s] + + ! Eddy Diffusion for w'^2 and w'^3. + real( kind = core_rknd ), dimension(gr%nz) :: Kw1 ! w'^2 coef. eddy diff. [m^2/s] + real( kind = core_rknd ), dimension(gr%nz) :: Kw8 ! w'^3 coef. eddy diff. [m^2/s] + + ! Internal variables for C11 function, Vince Larson 13 Mar 2005 + ! Brian added C1 function. + real( kind = core_rknd ), dimension(gr%nz) :: & + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc ! C_11 parameter with Sk_w applied [-] + ! End Vince Larson's addition. + + integer :: & + nsub, & ! Number of subdiagonals in the LHS matrix. + nsup ! Number of superdiagonals in the LHS matrix. + + integer :: k ! Array indices + + integer :: wp2_wp3_err_code ! Error code from solving for wp2/wp3 + + + !----------------------------------------------------------------------- + + + +! Define tauw + +! tauw3t = tau_zt +! . / ( 1. +! . + 3.0_core_rknd * max( +! . min(1.-(mixt_frac-0.01_core_rknd)/(0.05_core_rknd-0.01_core_rknd) +! . ,1.) +! . ,0.) +! . + 3.0_core_rknd * max( +! . min(1.-(mixt_frac-0.99_core_rknd)/(0.95_core_rknd-0.99_core_rknd) +! . ,1.) +! . ,0.) +! . ) + +! do k=1,gr%nz +! +! Skw = abs( wp3(k)/max(wp2(k),1.e-8)**1.5_core_rknd ) +! Skw = min( 5.0_core_rknd, Skw ) +! tauw3t(k) = tau_zt(k) / ( 0.005_core_rknd*Skw**4 + 1.0_core_rknd ) +! +! end do + + tauw3t = tau_zt + + ! Vince Larson added code to make C11 function of Skw. 13 Mar 2005 + ! If this code is used, C11 is no longer relevant, i.e. constants + ! are hardwired. + + ! Calculate C_{1} and C_{11} as functions of skewness of w. + ! The if..then here is only for computational efficiency -dschanen 2 Sept 08 + if ( C11 /= C11b ) then + C11_Skw_fnc(1:gr%nz) = & + C11b + (C11-C11b)*EXP( -(1.0_core_rknd/2.0_core_rknd) * (Skw_zt(1:gr%nz)/C11c)**2 ) + else + C11_Skw_fnc(1:gr%nz) = C11b + end if + + ! The if..then here is only for computational efficiency -dschanen 2 Sept 08 + if ( C1 /= C1b ) then + C1_Skw_fnc(1:gr%nz) = & + C1b + (C1-C1b)*EXP( -(1.0_core_rknd/2.0_core_rknd) * (Skw_zm(1:gr%nz)/C1c)**2 ) + else + C1_Skw_fnc(1:gr%nz) = C1b + end if + + if ( l_damp_wp2_using_em ) then + ! Insert 1/3 here to account for the fact that in the dissipation term, + ! (2/3)*em = (2/3)*(1/2)*(wp2+up2+vp2). Then we can insert wp2, up2, + ! and vp2 directly into the dissipation subroutines without prefixing them by (1/3). + C1_Skw_fnc(1:gr%nz) = one_third * C1_Skw_fnc(1:gr%nz) + end if + + !C11_Skw_fnc = C11 + !C1_Skw_fnc = C1 + + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C11_Skw_fnc + if ( any( C11_Skw_fnc(:) > 1._core_rknd ) .or. any( C11_Skw_fnc(:) < 0._core_rknd ) ) then + write(fstderr,*) "The C11_Skw_fnc is outside the valid range for this variable" + err_code = clubb_var_out_of_range + return + end if + end if + + if ( l_stats_samp ) then + call stat_update_var( iC11_Skw_fnc, C11_Skw_fnc, stats_zt ) + call stat_update_var( iC1_Skw_fnc, C1_Skw_fnc, stats_zm ) + endif + + ! Define the Coefficent of Eddy Diffusivity for the wp2 and wp3. + do k = 1, gr%nz, 1 + + ! Kw1 is used for wp2, which is located on momentum levels. + ! Kw1 is located on thermodynamic levels. + ! Kw1 = c_K1 * Kh_zt + Kw1(k) = c_K1 * Kh_zt(k) + + ! Kw8 is used for wp3, which is located on thermodynamic levels. + ! Kw8 is located on momentum levels. + ! Note: Kw8 is usually defined to be 1/2 of Kh_zm. + ! Kw8 = c_K8 * Kh_zm + Kw8(k) = c_K8 * Kh_zm(k) + + enddo + + ! There are five overall diagonals (including two subdiagonals + ! and two superdiagonals). + nsub = 2 + nsup = 2 + + + ! Solve semi-implicitly + call wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & ! Intent(in) + a3, a3_zt, wp3_on_wp2, & ! Intent(in) + wpthvp, wp2thvp, um, vm, upwp, vpwp, & ! Intent(in) + up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau_zm, tauw3t, tau_C1_zm, & ! Intent(in) + C1_Skw_fnc, C11_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, thv_ds_zm, & ! Intent(in) + thv_ds_zt, nsub, nsup, & ! Intent(in) + wp2, wp3, wp3_zm, wp2_zt, wp2_wp3_err_code ) ! Intent(inout) + +! Error output +! Joshua Fasching Feb 2008 + if ( fatal_error( wp2_wp3_err_code ) ) then + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "Errors in advance_wp2_wp3" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "dt = ", dt + write(fstderr,*) "sfc_elevation = ", sfc_elevation + write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w + write(fstderr,*) "wm_zm = ", wm_zm + write(fstderr,*) "wm_zt = ", wm_zt + write(fstderr,*) "wpthvp = ", wpthvp + write(fstderr,*) "wp2thvp = ", wp2thvp + write(fstderr,*) "um = ", um + write(fstderr,*) "vm = ", vm + write(fstderr,*) "upwp = ", upwp + write(fstderr,*) "vpwp = ", vpwp + write(fstderr,*) "up2 = ", up2 + write(fstderr,*) "vp2 = ", vp2 + write(fstderr,*) "Kh_zm = ", Kh_zm + write(fstderr,*) "Kh_zt = ", Kh_zt + write(fstderr,*) "tau_zm = ", tau_zm + write(fstderr,*) "tau_zt = ", tau_zt + write(fstderr,*) "Skw_zm = ", Skw_zm + write(fstderr,*) "Skw_zt = ", Skw_zt + write(fstderr,*) "mixt_frac = ", mixt_frac + write(fstderr,*) "wp2zt = ", wp2_zt + + write(fstderr,*) "Intent(in/out)" + + write(fstderr,*) "wp2 = ", wp2 + write(fstderr,*) "wp3 = ", wp3 + + end if + + err_code = wp2_wp3_err_code + end if ! fatal error + + return + + end subroutine advance_wp2_wp3 + + !============================================================================= + subroutine wp23_solve( dt, sfc_elevation, sigma_sqd_w, wm_zm, wm_zt, & + a3, a3_zt, wp3_on_wp2, & + wpthvp, wp2thvp, um, vm, upwp, vpwp, & + up2, vp2, Kw1, Kw8, Kh_zt, Skw_zt, tau1m, tauw3t, tau_C1_zm, & + C1_Skw_fnc, C11_Skw_fnc, rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, radf, thv_ds_zm, & + thv_ds_zt, nsub, nsup, & + wp2, wp3, wp3_zm, wp2_zt, err_code ) + + ! Description: + ! Decompose, and back substitute the matrix for wp2/wp3 + + ! References: + ! _Equations for CLUBB_ section 6.3 + !------------------------------------------------------------------------ + + use grid_class, only: & + gr ! Variable(s) + + use grid_class, only: & + zm2zt, & ! Function(s) + zt2zm, & + ddzt + + use constants_clubb, only: & + w_tol_sqd, & ! Variables(s) + zero_threshold + + use model_flags, only: & + l_tke_aniso, & ! Variable(s) + l_hole_fill, & + l_gmres + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use lapack_wrap, only: & + band_solve, & ! Procedure(s) + band_solvex + + use fill_holes, only: & + fill_holes_vertical + + use clip_explicit, only: & + clip_variance, & ! Procedure(s) + clip_skewness + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_update_var_pt, & + stat_end_update, & + stat_end_update_pt + + use stats_variables, only: & + stats_zm, & ! Variable(s) + stats_zt, & + stats_sfc, & + l_stats_samp, & + iwp2_ta, & + iwp2_ma, & + iwp2_pd, & + iwp2_ac, & + iwp2_dp1, & + iwp2_dp2, & + iwp2_pr1, & + iwp2_pr2, & + iwp3_ta, & + iwp3_ma, & + iwp3_tp, & + iwp3_ac, & + iwp3_dp1, & + iwp3_pr1, & + iwp3_pr2, & + iwp23_matrix_condt_num + + use stats_variables, only: & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + ztscr01, & + ztscr02 + + use stats_variables, only: & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16 + + implicit none + + ! External + intrinsic :: max, min, sqrt + + ! Parameter Constants + integer, parameter :: & + nrhs = 1 ! Number of RHS vectors + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + sigma_sqd_w, & ! sigma_sqd_w (momentum levels) [-] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + a3, & ! a_3 (momentum levels); See eqn. 25 in `Equations for CLUBB' [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + wpthvp, & ! w'th_v' (momentum levels) [K m/s] + wp2thvp, & ! w'^2th_v' (thermodynamic levels) [K m^2/s^2] + um, & ! u wind component (thermodynamic levels) [m/s] + vm, & ! v wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + Kw1, & ! Coefficient of eddy diffusivity for w'^2 [m^2/s] + Kw8, & ! Coefficient of eddy diffusivity for w'^3 [m^2/s] + Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + tau1m, & ! Time-scale tau on momentum levels [s] + tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at CL top [m^2/s^3] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] + + integer, intent(in) :: & + nsub, & ! Number of subdiagonals in the LHS matrix. + nsup ! Number of superdiagonals in the LHS matrix. + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3, & ! w'^3 (thermodynamic levels) [m^3/s^3] + wp3_zm ! w'^3 interpolated to momentum levels [m^3/s^3] + + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp2_zt ! w'^2 interpolated to thermodyamic levels [m^2/s^2] + + integer, intent(inout) :: err_code ! Have any errors occured? + + ! Local Variables + real( kind = core_rknd ), dimension(nsup+nsub+1,2*gr%nz) :: & + lhs ! Implicit contributions to wp2/wp3 (band diag. matrix) + + real( kind = core_rknd ), dimension(2*gr%nz) :: & + rhs ! RHS of band matrix + +! real, target, dimension(2*gr%nz) :: + real( kind = core_rknd ), dimension(2*gr%nz) :: & + solut ! Solution to band diagonal system. + + real( kind = core_rknd ), dimension(gr%nz) :: & + a1, & ! a_1 (momentum levels); See eqn. 23 in `Equations for CLUBB' [-] + a1_zt ! a_1 interpolated to thermodynamic levels [-] + +! real, dimension(gr%nz) :: & +! wp2_n ! w'^2 at the previous timestep [m^2/s^2] + + real( kind = core_rknd ) :: & + rcond ! Est. of the reciprocal of the condition # + + ! Array indices + integer :: k, km1, kp1, k_wp2, k_wp3 + + ! Set logical to true for Crank-Nicholson diffusion scheme + ! or to false for completely implicit diffusion scheme. + ! Note: Although Crank-Nicholson diffusion has usually been used for wp2 + ! and wp3 in the past, we found that using completely implicit + ! diffusion stabilized the deep convective cases more while having + ! almost no effect on the boundary layer cases. Brian; 1/4/2008. +! logical, parameter :: l_crank_nich_diff = .true. + logical, parameter :: l_crank_nich_diff = .false. + + ! Define a_1 and a_3 (both are located on momentum levels). + ! They are variables that are both functions of sigma_sqd_w (where + ! sigma_sqd_w is located on momentum levels). + + a1 = 1.0_core_rknd / ( 1.0_core_rknd - sigma_sqd_w ) + + ! Interpolate a_1 from momentum levels to thermodynamic + ! levels. This will be used for the w'^3 turbulent advection + ! (ta) and turbulent production (tp) combined term. + a1_zt = max( zm2zt( a1 ), zero_threshold ) ! Positive definite quantity + + ! Compute the explicit portion of the w'^2 and w'^3 equations. + ! Build the right-hand side vector. + call wp23_rhs( dt, wp2, wp3, a1, a1_zt, & + a3, a3_zt, wp3_on_wp2, wpthvp, wp2thvp, um, vm, & + upwp, vpwp, up2, vp2, Kw1, Kw8, Kh_zt, & + Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, radf, & + thv_ds_zm, thv_ds_zt, l_crank_nich_diff, & + rhs ) + + if (l_gmres) then + call wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsup, nsub, nrhs, & + rhs, & + solut, err_code ) + else + ! Compute the implicit portion of the w'^2 and w'^3 equations. + ! Build the left-hand side matrix. + call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & + lhs ) + + ! Solve the system with LAPACK + if ( l_stats_samp .and. iwp23_matrix_condt_num > 0 ) then + + ! Perform LU decomp and solve system (LAPACK with diagnostics) + ! Note that this can change the answer slightly + call band_solvex( "wp2_wp3", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solut, rcond, err_code ) + + ! Est. of the condition number of the w'^2/w^3 LHS matrix + call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, stats_sfc ) + + else + ! Perform LU decomp and solve system (LAPACK) + call band_solve( "wp2_wp3", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solut, err_code ) + end if + + end if ! l_gmres + + ! Copy result into output arrays and clip + + do k = 1, gr%nz + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + ! wp2_n(k) = wp2(k) ! For the positive definite scheme + + wp2(k) = solut(k_wp2) + wp3(k) = solut(k_wp3) + + end do + + if ( l_stats_samp ) then + + ! Finalize implicit contributions for wp2 + + do k = 2, gr%nz-1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! w'^2 term dp1 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp2_dp1, k, & + zmscr01(k) * wp2(k), stats_zm ) + + ! w'^2 term dp2 has both implicit and explicit components (if the + ! Crank-Nicholson scheme is selected); call stat_end_update_pt. + ! If Crank-Nicholson diffusion is not selected, then w'^3 term dp1 is + ! completely implicit; call stat_update_var_pt. + if ( l_crank_nich_diff ) then + call stat_end_update_pt( iwp2_dp2, k, & + zmscr02(k) * wp2(km1) & + + zmscr03(k) * wp2(k) & + + zmscr04(k) * wp2(kp1), stats_zm ) + else + call stat_update_var_pt( iwp2_dp2, k, & + zmscr02(k) * wp2(km1) & + + zmscr03(k) * wp2(k) & + + zmscr04(k) * wp2(kp1), stats_zm ) + endif + + ! w'^2 term ta is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwp2_ta, k, & + zmscr05(k) * wp3(k) & + + zmscr06(k) * wp3(kp1), stats_zm ) + + ! w'^2 term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwp2_ma, k, & + zmscr07(k) * wp2(km1) & + + zmscr08(k) * wp2(k) & + + zmscr09(k) * wp2(kp1), stats_zm ) + + ! w'^2 term ac is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwp2_ac, k, & + zmscr10(k) * wp2(k), stats_zm ) + + ! w'^2 term pr1 has both implicit and explicit components; + ! call stat_end_update_pt. + if ( l_tke_aniso ) then + call stat_end_update_pt( iwp2_pr1, k, & + zmscr12(k) * wp2(k), stats_zm ) + endif + + ! w'^2 term pr2 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp2_pr2, k, & + zmscr11(k) * wp2(k), stats_zm ) + + enddo + + ! Finalize implicit contributions for wp3 + + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! w'^3 term pr1 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp3_pr1, k, & + ztscr01(k) * wp3(k), stats_zt ) + + ! w'^3 term dp1 has both implicit and explicit components (if the + ! Crank-Nicholson scheme is selected); call stat_end_update_pt. + ! If Crank-Nicholson diffusion is not selected, then w'^3 term dp1 is + ! completely implicit; call stat_update_var_pt. + if ( l_crank_nich_diff ) then + call stat_end_update_pt( iwp3_dp1, k, & + ztscr02(k) * wp3(km1) & + + ztscr03(k) * wp3(k) & + + ztscr04(k) * wp3(kp1), stats_zt ) + else + call stat_update_var_pt( iwp3_dp1, k, & + ztscr02(k) * wp3(km1) & + + ztscr03(k) * wp3(k) & + + ztscr04(k) * wp3(kp1), stats_zt ) + endif + + ! w'^3 term ta has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp3_ta, k, & + ztscr05(k) * wp3(km1) & + + ztscr06(k) * wp2(km1) & + + ztscr07(k) * wp3(k) & + + ztscr08(k) * wp2(k) & + + ztscr09(k) * wp3(kp1), stats_zt ) + + ! w'^3 term tp has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp3_tp, k, & + ztscr10(k) * wp2(km1) & + + ztscr11(k) * wp2(k), stats_zt ) + + ! w'^3 term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwp3_ma, k, & + ztscr12(k) * wp3(km1) & + + ztscr13(k) * wp3(k) & + + ztscr14(k) * wp3(kp1), stats_zt ) + + ! w'^3 term ac is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwp3_ac, k, & + ztscr15(k) * wp3(k), stats_zt ) + + ! w'^3 term pr2 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwp3_pr2, k, & + ztscr16(k) * wp3(k), stats_zt ) + + enddo + + endif ! l_stats_samp + + + if ( l_stats_samp ) then + ! Store previous value for effect of the positive definite scheme + call stat_begin_update( iwp2_pd, wp2 / dt, stats_zm ) + endif + + if ( l_hole_fill .and. any( wp2 < w_tol_sqd ) ) then + + ! Use a simple hole filling algorithm + call fill_holes_vertical( 2, w_tol_sqd, "zm", & + rho_ds_zt, rho_ds_zm, & + wp2 ) + + endif ! wp2 + + ! Here we attempt to clip extreme values of wp2 to prevent a crash of the + ! type found on the Climate Process Team ticket #49. Chris Golaz found that + ! instability caused by large wp2 in CLUBB led unrealistic results in AM3. + ! -dschanen 11 Apr 2011 + where ( wp2 > 1000._core_rknd ) wp2 = 1000._core_rknd + + if ( l_stats_samp ) then + ! Store updated value for effect of the positive definite scheme + call stat_end_update( iwp2_pd, wp2 / dt, stats_zm ) + endif + + + ! Clip w'^2 at a minimum threshold. + call clip_variance( clip_wp2, dt, w_tol_sqd, wp2 ) + + ! Interpolate w'^2 from momentum levels to thermodynamic levels. + ! This is used for the clipping of w'^3 according to the value + ! of Sk_w now that w'^2 and w'^3 have been advanced one timestep. + wp2_zt = max( zm2zt( wp2 ), w_tol_sqd ) ! Positive definite quantity + + ! Clip w'^3 by limiting skewness. + call clip_skewness( dt, sfc_elevation, wp2_zt, wp3 ) + + ! Compute wp3_zm for output purposes + wp3_zm = zt2zm( wp3 ) + + return + end subroutine wp23_solve + + subroutine wp23_gmres( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsup, nsub, nrhs, & + rhs, & + solut, err_code ) + ! Description: + ! Perform all GMRES-specific matrix generation and solving for the + ! wp2/wp3 matrices. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + +#ifdef MKL + use error_code, only: & + fatal_error ! Procedure(s) + + use stats_variables, only: & + iwp23_matrix_condt_num, & ! Variable(s) + l_stats_samp, & + stats_sfc + + use constants_clubb, only: & + fstderr ! Variable(s) + + use lapack_wrap, only: & + band_solve, & ! Procedure(s) + band_solvex + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use csr_matrix_module, only: & + csr_intlc_5b_5b_ia, & ! Variables + csr_intlc_5b_5b_ja, & + intlc_5d_5d_ja_size + + use gmres_wrap, only: & + gmres_solve ! Subroutine + + use gmres_cache, only: & + gmres_cache_soln, & ! Subroutine + gmres_prev_soln, & ! Variables + gmres_prev_precond_a, & + l_gmres_soln_ok, & + gmres_idx_wp2wp3, & + gmres_temp_intlc, & + gmres_tempsize_intlc +#endif /* MKL */ + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2 ! w'^2 (momentum levels) [m^2/s^2] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + a1, & ! a_1 (momentum levels); See eqn. 23 in `Equations for CLUBB' [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + a3, & ! a_3 (momentum levels); See eqn. 25 in `Equations for CLUBB' [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + Kw1, & ! Coefficient of eddy diffusivity for w'^2 [m^2/s] + Kw8, & ! Coefficient of eddy diffusivity for w'^3 [m^2/s] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + tau1m, & ! Time-scale tau on momentum levels [s] + tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + logical, intent(in) :: & + l_crank_nich_diff ! Turns on/off Crank-Nicholson diffusion. + + integer, intent(in) :: & + nsub, & ! Number of subdiagonals in the LHS matrix. + nsup, & ! Number of superdiagonals in the LHS matrix. + nrhs ! Number of right-hand side vectors + ! (GMRES currently only supports 1) + + ! Input/Output variables + real( kind = core_rknd ), dimension(2*gr%nz), intent(inout) :: & + rhs ! Right hand side vector + + ! Output variables + real( kind = core_rknd ), dimension(2*gr%nz), intent(out) :: & + solut ! Solution to band diagonal system + + integer, intent(out) :: err_code ! Have any errors occured? + +#ifdef MKL + ! Local variables + real( kind = core_rknd ), dimension(nsup+nsub+1,2*gr%nz) :: & + lhs, & ! Implicit contributions to wp2/wp3 (band diag. matrix) + lhs_cache ! Backup cache of LHS matrix + + real( kind = core_rknd ), dimension(intlc_5d_5d_ja_size) :: & + lhs_a_csr ! Implicit contributions to wp2/wp3 (CSR format) + + real( kind = core_rknd ), dimension(2*gr%nz) :: & + rhs_cache ! Backup cache of RHS vector + + real( kind = core_rknd ):: & + rcond ! Est. of the reciprocal of the condition # + + ! Begin code + + call wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, & + lhs_a_csr ) + + if ( .not. l_gmres_soln_ok(gmres_idx_wp2wp3) ) then + call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & + lhs ) + + ! Solve system with LAPACK to give us our first solution vector + lhs_cache = lhs + rhs_cache = rhs + call band_solve( "wp2_wp3", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solut, err_code ) + + ! Use gmres_cache_wp2wp3_soln to set cache this solution for GMRES + call gmres_cache_soln( gr%nz * 2, gmres_idx_wp2wp3, solut ) + lhs = lhs_cache + rhs = rhs_cache + end if ! .not. l_gmres_soln_ok(gmres_idx_wp2wp3) + + call gmres_solve( intlc_5d_5d_ja_size, (gr%nz * 2), & + lhs_a_csr, csr_intlc_5b_5b_ia, csr_intlc_5b_5b_ja, & + gmres_tempsize_intlc, & + gmres_prev_soln(:,gmres_idx_wp2wp3), & + gmres_prev_precond_a(:,gmres_idx_wp2wp3), rhs, & + gmres_temp_intlc, & + solut, err_code ) + ! Fall back to LAPACK if GMRES returned any errors + if ( fatal_error( err_code ) ) then + write(fstderr,*) "Errors encountered in GMRES solve." + write(fstderr,*) "Falling back to LAPACK solver." + + ! Generate the LHS in LAPACK format + call wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & + lhs ) + + ! Note: The RHS does not need to be re-generated. + + ! Solve the system with LAPACK as a fall-back. + if ( l_stats_samp .and. iwp23_matrix_condt_num > 0 ) then + + ! Perform LU decomp and solve system (LAPACK with diagnostics) + ! Note that this can change the answer slightly + call band_solvex( "wp2_wp3", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solut, rcond, err_code ) + + ! Est. of the condition number of the w'^2/w^3 LHS matrix + call stat_update_var_pt( iwp23_matrix_condt_num, 1, 1.0_core_rknd / rcond, stats_sfc ) + + else + ! Perform LU decomp and solve system (LAPACK) + call band_solve( "wp2_wp3", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solut, err_code ) + end if + + end if ! fatal_error + +#else + stop "This build was not compiled with PARDISO/GMRES support." + + ! These prevent compiler warnings when -DMKL not set. + if ( l_crank_nich_diff .or. .true. ) print *, "This should be unreachable" + solut = rhs + solut(1:gr%nz) = a1 + solut(1:gr%nz) = a1_zt + solut(1:gr%nz) = a3 + solut(1:gr%nz) = a3_zt + solut(1:gr%nz) = C11_Skw_fnc + solut(1:gr%nz) = C1_Skw_fnc + solut(1:gr%nz) = invrs_rho_ds_zm + solut(1:gr%nz) = invrs_rho_ds_zt + solut(1:gr%nz) = rho_ds_zm + solut(1:gr%nz) = rho_ds_zt + solut(1:gr%nz) = Kw1 + solut(1:gr%nz) = Kw8 + solut(1:gr%nz) = Skw_zt + solut(1:gr%nz) = tau1m + solut(1:gr%nz) = tauw3t + solut(1:gr%nz) = tau_C1_zm + solut(1:gr%nz) = wm_zt + solut(1:gr%nz) = wm_zm + solut(1:gr%nz) = wp2 + solut(1:gr%nz) = wp3_on_wp2 + err_code = int( dt ) + err_code = nsup + err_code = nsub + err_code = nrhs + +#endif /* MKL */ + + end subroutine wp23_gmres + + !============================================================================= + subroutine wp23_lhs( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, nsub, nsup, & + lhs ) + + ! Description: + ! Compute LHS band diagonal matrix for w'^2 and w'^3. + ! This subroutine computes the implicit portion + ! of the w'^2 and w'^3 equations. + ! + ! NOTE: If changes are made to this subroutine, ensure that the CSR + ! version of the subroutine is updated as well! If the two are different, + ! the results will be inconsistent between LAPACK and PARDISO/GMRES! + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable + + use parameters_tunable, only: & + C4, & ! Variables + C5, & + C8, & + C8b, & + C12, & + nu1_vert_res_dep, & + nu8_vert_res_dep + + use constants_clubb, only: & + three_halves, & + gamma_over_implicit_ts + + use model_flags, only: & + l_tke_aniso ! Variable(s) + + use diffusion, only: & + diffusion_zm_lhs, & ! Procedures + diffusion_zt_lhs + + use mean_adv, only: & + term_ma_zm_lhs, & ! Procedures + term_ma_zt_lhs + + use clubb_precision, only: & + core_rknd + + use stats_variables, only: & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr11, & + zmscr10, & + zmscr12, & + ztscr01, & + ztscr02 + + use stats_variables, only: & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16 + + use stats_variables, only: & + l_stats_samp, & + iwp2_dp1, & + iwp2_dp2, & + iwp2_ta, & + iwp2_ma, & + iwp2_ac, & + iwp2_pr2, & + iwp2_pr1, & + iwp3_ta, & + iwp3_tp, & + iwp3_ma, & + iwp3_ac, & + iwp3_pr2, & + iwp3_pr1, & + iwp3_dp1 + + use advance_helper_module, only: set_boundary_conditions_lhs ! Procedure(s) + + implicit none + + ! Parameter Constants + ! Left-hand side matrix diagonal identifiers for + ! momentum-level variable, w'^2. + integer, parameter :: & + !m_kp2_tdiag = 2, & ! Thermodynamic super-super diagonal index for w'^2. + m_kp1_mdiag = 3, & ! Momentum super diagonal index for w'^2. + m_kp1_tdiag = 4, & ! Thermodynamic super diagonal index for w'^2. + m_k_mdiag = 5, & ! Momentum main diagonal index for w'^2. + m_k_tdiag = 6, & ! Thermodynamic sub diagonal index for w'^2. + m_km1_mdiag = 7 ! Momentum sub diagonal index for w'^2. + !m_km1_tdiag = 8, & ! Thermodynamic sub-sub diagonal index for w'^2. + + ! Left-hand side matrix diagonal identifiers for + ! thermodynamic-level variable, w'^3. + integer, parameter :: & + !t_kp1_mdiag = 2, & ! Momentum super-super diagonal index for w'^3. + t_kp1_tdiag = 3, & ! Thermodynamic super diagonal index for w'^3. + !t_k_mdiag = 4, & ! Momentum super diagonal index for w'^3. + t_k_tdiag = 5, & ! Thermodynamic main diagonal index for w'^3. + !t_km1_mdiag = 6, & ! Momentum sub diagonal index for w'^3. + t_km1_tdiag = 7 ! Thermodynamic sub diagonal index for w'^3. + !t_km2_mdiag = 8, & ! Momentum sub-sub diagonal index for w'^3. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + a3, & ! sigma_sqd_w term a_3 (momentum levels) [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + Kw1, & ! Coefficient of eddy diffusivity for w'^2 [m^2/s] + Kw8, & ! Coefficient of eddy diffusivity for w'^3 [m^2/s] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + tau1m, & ! Time-scale tau on momentum levels [s] + tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + logical, intent(in) :: & + l_crank_nich_diff ! Turns on/off Crank-Nicholson diffusion. + + integer, intent(in) :: & + nsub, & ! Number of subdiagonals in the LHS matrix. + nsup ! Number of superdiagonals in the LHS matrix. + ! Output Variable + real( kind = core_rknd ), dimension(5-nsup:5+nsub,2*gr%nz), intent(out) :: & + lhs ! Implicit contributions to wp2/wp3 (band diag. matrix) + + ! Local Variables + + ! Array indices + integer :: k, km1, kp1, k_wp2, k_wp3, k_wp2_low, k_wp2_high, & + k_wp3_low, k_wp3_high + + real( kind = core_rknd ), dimension(5) :: tmp + + + ! Initialize the left-hand side matrix to 0. + lhs = 0.0_core_rknd + + do k = 2, gr%nz-1, 1 + + ! Define indices + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + + !!!!!***** w'^2 *****!!!!! + + ! w'^2: Left-hand side (implicit w'^2 portion of the code). + ! + ! Momentum sub-sub diagonal (lhs index: m_km2_mdiag) + ! [ x wp2(k-2,) ] + ! Thermodynamic sub-sub diagonal (lhs index: m_km1_tdiag) + ! [ x wp3(k-1,) ] + ! Momentum sub diagonal (lhs index: m_km1_mdiag) + ! [ x wp2(k-1,) ] + ! Thermodynamic sub diagonal (lhs index: m_k_tdiag) + ! [ x wp3(k,) ] + ! Momentum main diagonal (lhs index: m_k_mdiag) + ! [ x wp2(k,) ] + ! Thermodynamic super diagonal (lhs index: m_kp1_tdiag) + ! [ x wp3(k+1,) ] + ! Momentum super diagonal (lhs index: m_kp1_mdiag) + ! [ x wp2(k+1,) ] + ! Thermodynamic super-super diagonal (lhs index: m_kp2_tdiag) + ! [ x wp3(k+2,) ] + ! Momentum super-super diagonal (lhs index: m_kp2_mdiag) + ! [ x wp2(k+2,) ] + ! LHS time tendency. + lhs(m_k_mdiag,k_wp2) & + = + 1.0_core_rknd / dt + + ! LHS mean advection (ma) term. + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + + ! LHS turbulent advection (ta) term. + lhs((/m_kp1_tdiag,m_k_tdiag/),k_wp2) & + = lhs((/m_kp1_tdiag,m_k_tdiag/),k_wp2) & + + wp2_term_ta_lhs( rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), gr%invrs_dzm(k) ) + + ! LHS accumulation (ac) term and pressure term 2 (pr2). + lhs(m_k_mdiag,k_wp2) & + = lhs(m_k_mdiag,k_wp2) & + + wp2_terms_ac_pr2_lhs( C5, wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + + ! LHS dissipation term 1 (dp1). + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the term + ! more numerically stable (see note below for w'^3 LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs(m_k_mdiag,k_wp2) & + = lhs(m_k_mdiag,k_wp2) & + + gamma_over_implicit_ts & + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + + ! LHS eddy diffusion term: dissipation term 2 (dp2). + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp2 using a Crank-Nicholson time step. + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + + (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + else + ! Eddy diffusion for wp2 using a completely implicit time step. + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wp2) & + + diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + endif + + ! LHS pressure term 1 (pr1). + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the term + ! more numerically stable (see note below for w'^3 LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( l_tke_aniso ) then + ! Add in this term if we're not assuming tke = 1.5 * wp2 + lhs(m_k_mdiag,k_wp2) & + = lhs(m_k_mdiag,k_wp2) & + + gamma_over_implicit_ts & + * wp2_term_pr1_lhs( C4, tau1m(k) ) + endif + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for wp2. + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 LHS + ! turbulent advection (ta) and turbulent production (tp) terms). + if ( iwp2_dp1 > 0 ) then + zmscr01(k) & + = - gamma_over_implicit_ts & + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + endif + + if ( iwp2_dp2 > 0 ) then + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp2 using a Crank-Nicholson time step. + tmp(1:3) & + = (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + else + ! Eddy diffusion for wp2 using a completely implicit time step. + tmp(1:3) & + = diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + endif + + zmscr02(k) = -tmp(3) + zmscr03(k) = -tmp(2) + zmscr04(k) = -tmp(1) + + endif + + if ( iwp2_ta > 0 ) then + tmp(1:2) = & + + wp2_term_ta_lhs( rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), gr%invrs_dzm(k) ) + zmscr05(k) = -tmp(2) + zmscr06(k) = -tmp(1) + endif + + if ( iwp2_ma > 0 ) then + tmp(1:3) = & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + zmscr07(k) = -tmp(3) + zmscr08(k) = -tmp(2) + zmscr09(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^2 term ac, substitute 0 for the + ! C_5 input to function wp2_terms_ac_pr2_lhs. + if ( iwp2_ac > 0 ) then + zmscr10(k) = & + - wp2_terms_ac_pr2_lhs( 0.0_core_rknd, wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + endif + + ! Note: To find the contribution of w'^2 term pr2, add 1 to the + ! C_5 input to function wp2_terms_ac_pr2_lhs. + if ( iwp2_pr2 > 0 ) then + zmscr11(k) = & + - wp2_terms_ac_pr2_lhs( (1.0_core_rknd+C5), wm_zt(kp1), wm_zt(k), & + gr%invrs_dzm(k) ) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 LHS + ! turbulent advection (ta) and turbulent production (tp) terms). + if ( iwp2_pr1 > 0 .and. l_tke_aniso ) then + zmscr12(k) & + = - gamma_over_implicit_ts & + * wp2_term_pr1_lhs( C4, tau1m(k) ) + endif + + endif + + + + !!!!!***** w'^3 *****!!!!! + + ! w'^3: Left-hand side (implicit w'^3 portion of the code). + ! + ! Thermodynamic sub-sub diagonal (lhs index: t_km2_tdiag) + ! [ x wp3(k-2,) ] + ! Momentum sub-sub diagonal (lhs index: t_km2_mdiag) + ! [ x wp2(k-2,) ] + ! Thermodynamic sub diagonal (lhs index: t_km1_tdiag) + ! [ x wp3(k-1,) ] + ! Momentum sub diagonal (lhs index: t_km1_mdiag) + ! [ x wp2(k-1,) ] + ! Thermodynamic main diagonal (lhs index: t_k_tdiag) + ! [ x wp3(k,) ] + ! Momentum super diagonal (lhs index: t_k_mdiag) + ! [ x wp2(k,) ] + ! Thermodynamic super diagonal (lhs index: t_kp1_tdiag) + ! [ x wp3(k+1,) ] + ! Momentum super-super diagonal (lhs index: t_kp1_mdiag) + ! [ x wp2(k+1,) ] + ! Thermodynamic super-super diagonal (lhs index: t_kp2_tdiag) + ! [ x wp3(k+2,) ] + + ! LHS time tendency. + lhs(t_k_tdiag,k_wp3) & + = + 1.0_core_rknd / dt + + ! LHS mean advection (ma) term. + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(k-1) ) + + ! LHS turbulent advection (ta) and turbulent production (tp) terms. + ! Note: An "over-implicit" weighted time step is applied to these terms. + ! The weight of the implicit portion of these terms is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (w'^3 in this case), y(t) is the linearized portion of + ! the terms that gets treated implicitly, and RHS is the portion of + ! the terms that is always treated explicitly. A weight of greater + ! than 1 can be applied to make the terms more numerically stable. + lhs(t_kp1_tdiag:t_km1_tdiag,k_wp3) & + = lhs(t_kp1_tdiag:t_km1_tdiag,k_wp3) & + + gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k), a3_zt(k), a3(km1), & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + + ! LHS accumulation (ac) term and pressure term 2 (pr2). + lhs(t_k_tdiag,k_wp3) & + = lhs(t_k_tdiag,k_wp3) & + + wp3_terms_ac_pr2_lhs( C11_Skw_fnc(k), & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + + ! LHS pressure term 1 (pr1). + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs(t_k_tdiag,k_wp3) & + = lhs(t_k_tdiag,k_wp3) & + + gamma_over_implicit_ts & + * wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + + ! LHS eddy diffusion term: dissipation term 1 (dp1). + ! Added a new constant, C12. + ! Initially, this new constant will be set to 1.0 -dschanen 9/19/05 + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp3 using a Crank-Nicholson time step. + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + + C12 * (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + else + ! Eddy diffusion for wp3 using a completely implicit time step. + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_wp3) & + + C12 & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + endif + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for wp3. + + ! Note: To find the contribution of w'^3 term ta, add 3 to all of + ! the a_3 inputs and substitute 0 for the three_halves input to + ! function wp3_terms_ta_tp_lhs. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_ta > 0 ) then + tmp(1:5) & + = gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k)+3.0_core_rknd, a3_zt(k)+3.0_core_rknd, & + a3(km1)+3.0_core_rknd, & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + 0.0_core_rknd, & + gr%invrs_dzt(k), k ) + ztscr05(k) = -tmp(5) + ztscr06(k) = -tmp(4) + ztscr07(k) = -tmp(3) + ztscr08(k) = -tmp(2) + ztscr09(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^3 term tp, substitute 0 for all + ! of the a_1 and a_3 inputs and subtract 3 from all of the a_3 + ! inputs to function wp3_terms_ta_tp_lhs. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_tp > 0 ) then + tmp(1:5) & + = gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + 0.0_core_rknd, 0.0_core_rknd, 0.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd, 0.0_core_rknd, & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + ztscr10(k) = -tmp(4) + ztscr11(k) = -tmp(2) + endif + + if ( iwp3_ma > 0 ) then + tmp(1:3) = & + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + ztscr12(k) = -tmp(3) + ztscr13(k) = -tmp(2) + ztscr14(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^3 term ac, substitute 0 for the + ! C_ll skewness function input to function wp3_terms_ac_pr2_lhs. + if ( iwp3_ac > 0 ) then + ztscr15(k) = & + - wp3_terms_ac_pr2_lhs( 0.0_core_rknd, & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + endif + + ! Note: To find the contribution of w'^3 term pr2, add 1 to the + ! C_ll skewness function input to function wp3_terms_ac_pr2_lhs. + if ( iwp3_pr2 > 0 ) then + ztscr16(k) = & + - wp3_terms_ac_pr2_lhs( (1.0_core_rknd+C11_Skw_fnc(k)), & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_pr1 > 0 ) then + ztscr01(k) & + = - gamma_over_implicit_ts & + * wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + endif + + if ( iwp3_dp1 > 0 ) then + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp3 using a Crank-Nicholson time step. + tmp(1:3) & + = C12 * (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + else + ! Eddy diffusion for wp3 using a completely implicit time step. + tmp(1:3) & + = C12 & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + endif + + ztscr02(k) = -tmp(3) + ztscr03(k) = -tmp(2) + ztscr04(k) = -tmp(1) + + endif + + endif + + enddo ! k = 2, gr%nz-1, 1 + + + ! Boundary conditions + + ! Both wp2 and wp3 used fixed-point boundary conditions. + ! Therefore, anything set in the above loop at both the upper + ! and lower boundaries would be overwritten here. However, the + ! above loop does not extend to the boundary levels. An array + ! with a value of 1 at the main diagonal on the left-hand side + ! and with values of 0 at all other diagonals on the left-hand + ! side will preserve the right-hand side value at that level. + ! + ! wp3(1) wp2(1) ... wp3(nzmax) wp2(nzmax) + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 1.0 1.0 ... 1.0 1.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + + ! Lower boundary + k = 1 + k_wp3_low = 2*k - 1 + k_wp2_low = 2*k + + ! Upper boundary + k = gr%nz + k_wp3_high = 2*k - 1 + k_wp2_high = 2*k + + ! t_k_tdiag and m_k_mdiag need to be adjusted because the dimensions of lhs + ! are offset + call set_boundary_conditions_lhs( t_k_tdiag - nsup, k_wp3_low, k_wp3_high, lhs, & + m_k_mdiag - nsup, k_wp2_low, k_wp2_high) + + return + + end subroutine wp23_lhs + +#ifdef MKL + !============================================================================= + subroutine wp23_lhs_csr( dt, wp2, wm_zm, wm_zt, a1, a1_zt, a3, a3_zt, & + wp3_on_wp2, & + Kw1, Kw8, Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, l_crank_nich_diff, & + lhs_a_csr ) + + ! Description: + ! Compute LHS band diagonal matrix for w'^2 and w'^3. + ! This subroutine computes the implicit portion + ! of the w'^2 and w'^3 equations. + ! + ! This version of the subroutine computes the LHS in CSR (compressed + ! sparse row) format. + ! NOTE: This subroutine must be kept up to date with the non CSR version + ! of the subroutine! If the two are different, the results will be + ! inconsistent between LAPACK and PARDISO/GMRES results! + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable + + use parameters_tunable, only: & + C4, & ! Variables + C5, & + C8, & + C8b, & + C12, & + nu1_vert_res_dep, & + nu8_vert_res_dep + + use constants_clubb, only: & + eps, & ! Variable(s) + three_halves, & + gamma_over_implicit_ts + + use model_flags, only: & + l_tke_aniso ! Variable(s) + + use diffusion, only: & + diffusion_zm_lhs, & ! Procedures + diffusion_zt_lhs + + use mean_adv, only: & + term_ma_zm_lhs, & ! Procedures + term_ma_zt_lhs + + use clubb_precision, only: & + core_rknd + + use stats_variables, only: & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr11, & + zmscr10, & + zmscr12, & + ztscr01, & + ztscr02 + + use stats_variables, only: & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16 + + use stats_variables, only: & + l_stats_samp, & + iwp2_dp1, & + iwp2_dp2, & + iwp2_ta, & + iwp2_ma, & + iwp2_ac, & + iwp2_pr2, & + iwp2_pr1, & + iwp3_ta, & + iwp3_tp, & + iwp3_ma, & + iwp3_ac, & + iwp3_pr2, & + iwp3_pr1, & + iwp3_dp1 + + use csr_matrix_module, only: & + intlc_5d_5d_ja_size ! Variable + + implicit none + + ! Left-hand side matrix diagonal identifiers for + ! momentum-level variable, w'^2. + ! These are updated for each diagonal of the matrix as the + ! LHS of the matrix is created. + integer :: & + !m_kp2_mdiag, & ! Momentum super-super diagonal index for w'^2. + !m_kp2_tdiag, & ! Thermodynamic super-super diagonal index for w'^2. + m_kp1_mdiag, & ! Momentum super diagonal index for w'^2. + m_kp1_tdiag, & ! Thermodynamic super diagonal index for w'^2. + m_k_mdiag , & ! Momentum main diagonal index for w'^2. + m_k_tdiag , & ! Thermodynamic sub diagonal index for w'^2. + m_km1_mdiag ! Momentum sub diagonal index for w'^2. + !m_km1_tdiag, & ! Thermodynamic sub-sub diagonal index for w'^2. + !m_km2_mdiag ! Momentum sub-sub diagonal index for w'^2. + + ! Left-hand side matrix diagonal identifiers for + ! thermodynamic-level variable, w'^3. + ! These are updated for each diagonal of the matrix as the + ! LHS of the matrix is created + integer :: & + !t_kp2_tdiag, & ! Thermodynamic super-super diagonal index for w'^3. + !t_kp1_mdiag, & ! Momentum super-super diagonal index for w'^3. + t_kp1_tdiag, & ! Thermodynamic super diagonal index for w'^3. + !t_k_mdiag , & ! Momentum super diagonal index for w'^3. + t_k_tdiag , & ! Thermodynamic main diagonal index for w'^3. + !t_km1_mdiag, & ! Momentum sub diagonal index for w'^3. + t_km1_tdiag ! Thermodynamic sub diagonal index for w'^3. + !t_km2_mdiag, & ! Momentum sub-sub diagonal index for w'^3. + !t_km2_tdiag ! Thermodynamic sub-sub diagonal index for w'^3. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + a3, & ! sigma_sqd_w term a_3 (momentum levels) [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + Kw1, & ! Coefficient of eddy diffusivity for w'^2 [m^2/s] + Kw8, & ! Coefficient of eddy diffusivity for w'^3 [m^2/s] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + tau1m, & ! Time-scale tau on momentum levels [s] + tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + logical, intent(in) :: & + l_crank_nich_diff ! Turns on/off Crank-Nicholson diffusion. + +! integer, intent(in) :: & +! nsub, & ! Number of subdiagonals in the LHS matrix. +! nsup ! Number of superdiagonals in the LHS matrix. + + ! Output Variable + real( kind = core_rknd ), dimension(intlc_5d_5d_ja_size), intent(out) :: & + lhs_a_csr ! Implicit contributions to wp2/wp3 (band diag. matrix) + + ! Local Variables + + ! Array indices + integer :: k, km1, kp1, k_wp2, k_wp3, wp2_cur_row, wp3_cur_row + + real( kind = core_rknd ), dimension(5) :: tmp + + + ! Initialize the left-hand side matrix to 0. + lhs_a_csr = 0.0_core_rknd + + do k = 2, gr%nz-1, 1 + + ! Define indices + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + wp2_cur_row = ((k_wp2 - 3) * 5) + 8 + wp3_cur_row = ((k_wp3 - 3) * 5) + 8 + + !!!!!***** w'^2 *****!!!!! + + ! w'^2: Left-hand side (implicit w'^2 portion of the code). + ! + ! Momentum sub-sub diagonal (lhs index: m_km2_mdiag) + ! [ x wp2(k-2,) ] + ! Thermodynamic sub-sub diagonal (lhs index: m_km1_tdiag) + ! [ x wp3(k-1,) ] + ! Momentum sub diagonal (lhs index: m_km1_mdiag) + ! [ x wp2(k-1,) ] + ! Thermodynamic sub diagonal (lhs index: m_k_tdiag) + ! [ x wp3(k,) ] + ! Momentum main diagonal (lhs index: m_k_mdiag) + ! [ x wp2(k,) ] + ! Thermodynamic super diagonal (lhs index: m_kp1_tdiag) + ! [ x wp3(k+1,) ] + ! Momentum super diagonal (lhs index: m_kp1_mdiag) + ! [ x wp2(k+1,) ] + ! Thermodynamic super-super diagonal (lhs index: m_kp2_tdiag) + ! [ x wp3(k+2,) ] + ! Momentum super-super diagonal (lhs index: m_kp2_mdiag) + ! [ x wp2(k+2,) ] + + ! NOTES FOR CSR-FORMAT MATRICES + ! The various diagonals are referenced through the following + ! array indices: + ! (m_kp1_mdiag, k_wp2) ==> (wp2_cur_row + 4) + ! (m_kp1_tdiag, k_wp2) ==> (wp2_cur_row + 3) + ! (m_k_mdiag, k_wp2) ==> (wp2_cur_row + 2) + ! (m_k_tdiag, k_wp2) ==> (wp2_cur_row + 1) + ! (m_km1_mdiag, k_wp2) ==> (wp2_cur_row) + ! For readability, these values are updated here. + ! This means that to update the CSR version of the LHS subroutine, + ! all that must be done is remove the ,k_wp2 from the array indices, + ! as the CSR-format matrix is one-dimensional. + + ! NOTE: All references to lhs will need to be changed to lhs_a_csr + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! WARNING: If you have array indices that go from m_kp1_mdiag to + ! m_km1_mdiag, you will need to set it to span by -1. This is because + ! in the CSR-format arrays, the indices descend as you go from m_kp1_mdiag + ! to m_km1_mdiag! + ! + ! EXAMPLE: lhs((m_kp1_mdiag:m_km1_mdiag),wp2) would become + ! lhs_a_csr((m_kp1_mdiag:m_km1_mdiag:-1)) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + m_kp1_mdiag = wp2_cur_row + 4 + m_kp1_tdiag = wp2_cur_row + 3 + m_k_mdiag = wp2_cur_row + 2 + m_k_tdiag = wp2_cur_row + 1 + m_km1_mdiag = wp2_cur_row + + ! LHS time tendency. + lhs_a_csr(m_k_mdiag) & + = real( + 1.0_core_rknd / dt ) + + ! LHS mean advection (ma) term. + lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + = lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + + ! LHS turbulent advection (ta) term. + lhs_a_csr((/m_kp1_tdiag,m_k_tdiag/)) & + = lhs_a_csr((/m_kp1_tdiag,m_k_tdiag/)) & + + wp2_term_ta_lhs( rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), gr%invrs_dzm(k) ) + + ! LHS accumulation (ac) term and pressure term 2 (pr2). + lhs_a_csr(m_k_mdiag) & + = lhs_a_csr(m_k_mdiag) & + + wp2_terms_ac_pr2_lhs( C5, wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + + ! LHS dissipation term 1 (dp1). + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the term + ! more numerically stable (see note below for w'^3 LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs_a_csr(m_k_mdiag) & + = lhs_a_csr(m_k_mdiag) & + + gamma_over_implicit_ts & + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + + ! LHS eddy diffusion term: dissipation term 2 (dp2). + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp2 using a Crank-Nicholson time step. + lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + = lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + + (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + else + ! Eddy diffusion for wp2 using a completely implicit time step. + lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + = lhs_a_csr((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/)) & + + diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + endif + + ! LHS pressure term 1 (pr1). + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the term + ! more numerically stable (see note below for w'^3 LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( l_tke_aniso ) then + ! Add in this term if we're not assuming tke = 1.5 * wp2 + lhs_a_csr(m_k_mdiag) & + = lhs_a_csr(m_k_mdiag) & + + gamma_over_implicit_ts & + * wp2_term_pr1_lhs( C4, tau1m(k) ) + endif + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for wp2. + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 LHS + ! turbulent advection (ta) and turbulent production (tp) terms). + if ( iwp2_dp1 > 0 ) then + zmscr01(k) & + = - gamma_over_implicit_ts & + * wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + endif + + if ( iwp2_dp2 > 0 ) then + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp2 using a Crank-Nicholson time step. + tmp(1:3) & + = (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + else + ! Eddy diffusion for wp2 using a completely implicit time step. + tmp(1:3) & + = diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + endif + + zmscr02(k) = -tmp(3) + zmscr03(k) = -tmp(2) + zmscr04(k) = -tmp(1) + + endif + + if ( iwp2_ta > 0 ) then + tmp(1:2) = & + + wp2_term_ta_lhs( rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), gr%invrs_dzm(k) ) + zmscr05(k) = -tmp(2) + zmscr06(k) = -tmp(1) + endif + + if ( iwp2_ma > 0 ) then + tmp(1:3) = & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + zmscr07(k) = -tmp(3) + zmscr08(k) = -tmp(2) + zmscr09(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^2 term ac, substitute 0 for the + ! C_5 input to function wp2_terms_ac_pr2_lhs. + if ( iwp2_ac > 0 ) then + zmscr10(k) = & + - wp2_terms_ac_pr2_lhs( 0.0_core_rknd, wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + endif + + ! Note: To find the contribution of w'^2 term pr2, add 1 to the + ! C_5 input to function wp2_terms_ac_pr2_lhs. + if ( iwp2_pr2 > 0 ) then + zmscr11(k) = & + - wp2_terms_ac_pr2_lhs( (1.0_core_rknd+C5), wm_zt(kp1), wm_zt(k), & + gr%invrs_dzm(k) ) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 LHS + ! turbulent advection (ta) and turbulent production (tp) terms). + if ( iwp2_pr1 > 0 .and. l_tke_aniso ) then + zmscr12(k) & + = - gamma_over_implicit_ts & + * wp2_term_pr1_lhs( C4, tau1m(k) ) + endif + + endif + + + + !!!!!***** w'^3 *****!!!!! + + ! w'^3: Left-hand side (implicit w'^3 portion of the code). + ! + ! Thermodynamic sub-sub diagonal (lhs index: t_km2_tdiag) + ! [ x wp3(k-2,) ] + ! Momentum sub-sub diagonal (lhs index: t_km2_mdiag) + ! [ x wp2(k-2,) ] + ! Thermodynamic sub diagonal (lhs index: t_km1_tdiag) + ! [ x wp3(k-1,) ] + ! Momentum sub diagonal (lhs index: t_km1_mdiag) + ! [ x wp2(k-1,) ] + ! Thermodynamic main diagonal (lhs index: t_k_tdiag) + ! [ x wp3(k,) ] + ! Momentum super diagonal (lhs index: t_k_mdiag) + ! [ x wp2(k,) ] + ! Thermodynamic super diagonal (lhs index: t_kp1_tdiag) + ! [ x wp3(k+1,) ] + ! Momentum super-super diagonal (lhs index: t_kp1_mdiag) + ! [ x wp2(k+1,) ] + ! Thermodynamic super-super diagonal (lhs index: t_kp2_tdiag) + ! [ x wp3(k+2,) ] + + ! NOTES FOR CSR-FORMAT MATRICES + ! The various diagonals are referenced through the following + ! array indices: + ! (t_kp1_tdiag, k_wp3) ==> (wp3_cur_row + 4) + ! (t_kp1_mdiag, k_wp3) ==> (wp3_cur_row + 3) + ! (t_k_tdiag, k_wp3) ==> (wp3_cur_row + 2) + ! (t_k_mdiag, k_wp3) ==> (wp3_cur_row + 1) + ! (t_km1_tdiag, k_wp3) ==> (wp3_cur_row) + ! For readability, these values are updated here. + ! This means that to update the CSR version of the LHS subroutine, + ! all that must be done is remove the ,k_wp2 from the array indices, + ! as the CSR-format matrix is one-dimensional. + + ! NOTE: All references to lhs will need to be changed to lhs_a_csr + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! WARNING: If you have array indices that go from t_kp1_tdiag to + ! t_km1_tdiag, you will need to set it to span by -1. This is because + ! in the CSR-format arrays, the indices descend as you go from t_kp1_tdiag + ! to t_km1_tdiag! + ! + ! EXAMPLE: lhs((t_kp1_tdiag:t_km1_tdiag),wp3) would become + ! lhs_a_csr((t_kp1_tdiag:t_km1_tdiag:-1)) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + t_kp1_tdiag = wp3_cur_row + 4 + !t_kp1_mdiag = wp3_cur_row + 3 + t_k_tdiag = wp3_cur_row + 2 + !t_k_mdiag = wp3_cur_row + 1 + t_km1_tdiag = wp3_cur_row + + ! LHS time tendency. + lhs_a_csr(t_k_tdiag) & + = real( + 1.0_core_rknd / dt ) + + ! LHS mean advection (ma) term. + lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + = lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + + ! LHS turbulent advection (ta) and turbulent production (tp) terms. + ! Note: An "over-implicit" weighted time step is applied to these terms. + ! The weight of the implicit portion of these terms is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (w'^3 in this case), y(t) is the linearized portion of + ! the terms that gets treated implicitly, and RHS is the portion of + ! the terms that is always treated explicitly. A weight of greater + ! than 1 can be applied to make the terms more numerically stable. + lhs_a_csr(t_kp1_tdiag:t_km1_tdiag:-1) & + = lhs_a_csr(t_kp1_tdiag:t_km1_tdiag:-1) & + + gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k), a3_zt(k), a3(km1), & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + + ! LHS accumulation (ac) term and pressure term 2 (pr2). + lhs_a_csr(t_k_tdiag) & + = lhs_a_csr(t_k_tdiag) & + + wp3_terms_ac_pr2_lhs( C11_Skw_fnc(k), & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + + ! LHS pressure term 1 (pr1). + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs_a_csr(t_k_tdiag) & + = lhs_a_csr(t_k_tdiag) & + + gamma_over_implicit_ts & + * wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + + ! LHS eddy diffusion term: dissipation term 1 (dp1). + ! Added a new constant, C12. + ! Initially, this new constant will be set to 1.0 -dschanen 9/19/05 + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp3 using a Crank-Nicholson time step. + lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + = lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + + C12 * (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + else + ! Eddy diffusion for wp3 using a completely implicit time step. + lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + = lhs_a_csr((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/)) & + + C12 & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + endif + + + if (l_stats_samp) then + + ! Statistics: implicit contributions for wp3. + + ! Note: To find the contribution of w'^3 term ta, add 3 to all of + ! the a_3 inputs and substitute 0 for the three_halves input to + ! function wp3_terms_ta_tp_lhs. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_ta > 0 ) then + tmp(1:5) & + = gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k)+3.0_core_rknd, a3_zt(k)+3.0_core_rknd, & + a3(km1)+3.0_core_rknd, & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + 0.0_core_rknd, & + gr%invrs_dzt(k), k ) + ztscr05(k) = -tmp(5) + ztscr06(k) = -tmp(4) + ztscr07(k) = -tmp(3) + ztscr08(k) = -tmp(2) + ztscr09(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^3 term tp, substitute 0 for all + ! of the a_1 and a_3 inputs and subtract 3 from all of the a_3 + ! inputs to function wp3_terms_ta_tp_lhs. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_tp > 0 ) then + tmp(1:5) & + = gamma_over_implicit_ts & + * wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + 0.0_core_rknd, 0.0_core_rknd, 0.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd, 0.0_core_rknd, & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + ztscr10(k) = -tmp(4) + ztscr11(k) = -tmp(2) + endif + + if ( iwp3_ma > 0 ) then + tmp(1:3) = & + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + ztscr12(k) = -tmp(3) + ztscr13(k) = -tmp(2) + ztscr14(k) = -tmp(1) + endif + + ! Note: To find the contribution of w'^3 term ac, substitute 0 for the + ! C_ll skewness function input to function wp3_terms_ac_pr2_lhs. + if ( iwp3_ac > 0 ) then + ztscr15(k) = & + - wp3_terms_ac_pr2_lhs( 0.0_core_rknd, & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + endif + + ! Note: To find the contribution of w'^3 term pr2, add 1 to the + ! C_ll skewness function input to function wp3_terms_ac_pr2_lhs. + if ( iwp3_pr2 > 0 ) then + ztscr16(k) = & + - wp3_terms_ac_pr2_lhs( (1.0_core_rknd+C11_Skw_fnc(k)), & + wm_zm(k), wm_zm(km1), gr%invrs_dzt(k) ) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) and turbulent production (tp) terms). + if ( iwp3_pr1 > 0 ) then + ztscr01(k) & + = - gamma_over_implicit_ts & + * wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + endif + + if ( iwp3_dp1 > 0 ) then + if ( l_crank_nich_diff ) then + ! Eddy diffusion for wp3 using a Crank-Nicholson time step. + tmp(1:3) & + = C12 * (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + else + ! Eddy diffusion for wp3 using a completely implicit time step. + tmp(1:3) & + = C12 & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + endif + + ztscr02(k) = -tmp(3) + ztscr03(k) = -tmp(2) + ztscr04(k) = -tmp(1) + + endif + + endif + + enddo ! k = 2, gr%nz-1, 1 + + + ! Boundary conditions + + ! Both wp2 and wp3 used fixed-point boundary conditions. + ! Therefore, anything set in the above loop at both the upper + ! and lower boundaries would be overwritten here. However, the + ! above loop does not extend to the boundary levels. An array + ! with a value of 1 at the main diagonal on the left-hand side + ! and with values of 0 at all other diagonals on the left-hand + ! side will preserve the right-hand side value at that level. + ! + ! wp3(1) wp2(1) ... wp3(nzmax) wp2(nzmax) + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 1.0 1.0 ... 1.0 1.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 0.0 ] + + ! Lower boundary + k = 1 + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + wp3_cur_row = 1 + wp2_cur_row = 4 + + ! w'^2 + lhs_a_csr(wp2_cur_row:wp2_cur_row + 3) = 0.0_core_rknd + lhs_a_csr(wp2_cur_row + 1) = 1.0_core_rknd + + ! w'^3 + lhs_a_csr(wp3_cur_row:wp3_cur_row + 2) = 0.0_core_rknd + lhs_a_csr(wp3_cur_row) = 1.0_core_rknd + + ! w'^2 + !lhs(:,k_wp2) = 0.0_core_rknd + !lhs(m_k_mdiag,k_wp2) = 1.0_core_rknd + ! w'^3 + !lhs(:,k_wp3) = 0.0_core_rknd + !lhs(t_k_tdiag,k_wp3) = 1.0_core_rknd + + ! Upper boundary + k = gr%nz + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + ! w'^2 + lhs_a_csr(intlc_5d_5d_ja_size - 2:intlc_5d_5d_ja_size) = 0.0_core_rknd + lhs_a_csr(intlc_5d_5d_ja_size) = 1.0_core_rknd + + ! w'^3 + lhs_a_csr(intlc_5d_5d_ja_size - 6:intlc_5d_5d_ja_size - 3) = 0.0_core_rknd + lhs_a_csr(intlc_5d_5d_ja_size - 4) = 1.0_core_rknd + + ! w'^2 + !lhs(:,k_wp2) = 0.0_core_rknd + !lhs(m_k_mdiag,k_wp2) = 1.0_core_rknd + ! w'^3 + !lhs(:,k_wp3) = 0.0_core_rknd + !lhs(t_k_tdiag,k_wp3) = 1.0_core_rknd + + + return + end subroutine wp23_lhs_csr +#endif /* MKL */ + + !============================================================================= + subroutine wp23_rhs( dt, wp2, wp3, a1, a1_zt, & + a3, a3_zt, wp3_on_wp2, wpthvp, wp2thvp, um, vm, & + upwp, vpwp, up2, vp2, Kw1, Kw8, Kh_zt, & + Skw_zt, tau1m, tauw3t, tau_C1_zm, C1_Skw_fnc, & + C11_Skw_fnc, rho_ds_zm, invrs_rho_ds_zt, radf, & + thv_ds_zm, thv_ds_zt, l_crank_nich_diff, & + rhs ) + + ! Description: + ! Compute RHS vector for w'^2 and w'^3. + ! This subroutine computes the explicit portion of + ! the w'^2 and w'^3 equations. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable + + use grid_class, only: & + ddzt ! Procedure + + use parameters_tunable, only: & + C4, & ! Variables + C5, & + C8, & + C8b, & + C12, & + C15, & + nu1_vert_res_dep, & + nu8_vert_res_dep + + use constants_clubb, only: & + w_tol_sqd, & ! Variable(s) + three_halves, & + gamma_over_implicit_ts + + use model_flags, only: & + l_tke_aniso ! Variable + + use diffusion, only: & + diffusion_zm_lhs, & ! Procedures + diffusion_zt_lhs + + use clubb_precision, only: & + core_rknd ! Variable + + use stats_variables, only: & + l_stats_samp, iwp2_dp1, iwp2_dp2, stats_zm, iwp2_bp, & ! Variable(s) + iwp2_pr1, iwp2_pr2, iwp2_pr3, iwp3_ta, stats_zt, & + iwp3_tp, iwp3_bp1, iwp3_pr2, iwp3_pr1, iwp3_dp1, iwp3_bp2 + + use stats_type_utilities, only: & + stat_update_var_pt, & ! Procedure(s) + stat_begin_update_pt, & + stat_modify_pt + + use advance_helper_module, only: set_boundary_conditions_rhs + + + implicit none + + ! Constant parameters + logical, parameter :: & + l_wp3_2nd_buoyancy_term = .true. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3, & ! w'^3 (thermodynamic levels) [m^3/s^3] + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + a3, & ! sigma_sqd_w term a_3 (momentum levels) [-] + a3_zt, & ! a_3 interpolated to thermodynamic levels [-] + wp3_on_wp2, & ! Smoothed version of wp3 / wp2 [m/s] + wpthvp, & ! w'th_v' (momentum levels) [K m/s] + wp2thvp, & ! w'^2th_v' (thermodynamic levels) [K m^2/s^2] + um, & ! u wind component (thermodynamic levels) [m/s] + vm, & ! v wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + Kw1, & ! Coefficient of eddy diffusivity for w'^2 [m^2/s] + Kw8, & ! Coefficient of eddy diffusivity for w'^3 [m^2/s] + Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + tau1m, & ! Time-scale tau on momentum levels [s] + tauw3t, & ! Time-scale tau on thermodynamic levels [s] + tau_C1_zm, & ! Tau values used for the C1 (dp1) term in wp2 [s] + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied [-] + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + radf, & ! Buoyancy production at the CL top [m^2/s^3] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] + + logical, intent(in) :: & + l_crank_nich_diff ! Turns on/off Crank-Nicholson diffusion. + + ! Output Variable + real( kind = core_rknd ), dimension(2*gr%nz), intent(out) :: & + rhs ! RHS of band matrix + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + dum_dz, dvm_dz ! Vertical derivatives of um and vm + + ! Array indices + integer :: k, km1, kp1, k_wp2, k_wp3, k_wp2_low, k_wp2_high, & + k_wp3_low, k_wp3_high + + ! For "over-implicit" weighted time step. + ! This vector holds output from the LHS (implicit) portion of a term at a + ! given vertical level. This output is weighted and applied to the RHS. + ! This is used if the implicit portion of the term is "over-implicit", which + ! means that the LHS contribution is given extra weight (>1) in order to + ! increase numerical stability. A weighted factor must then be applied to + ! the RHS in order to balance the weight. + real( kind = core_rknd ), dimension(5) :: lhs_fnc_output + + real( kind = core_rknd ), dimension(3) :: & + rhs_diff ! For use in Crank-Nicholson eddy diffusion. + + real( kind = core_rknd ) :: temp + + + ! Initialize the right-hand side vector to 0. + rhs = 0.0_core_rknd + + if ( l_wp3_2nd_buoyancy_term ) then + ! Compute the vertical derivative of the u and v winds + dum_dz = ddzt( um ) + dvm_dz = ddzt( vm ) + else + dum_dz = -999._core_rknd + dvm_dz = -999._core_rknd + end if + + do k = 2, gr%nz-1, 1 + + + ! Define indices + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + k_wp3 = 2*k - 1 + k_wp2 = 2*k + + + !!!!!***** w'^2 *****!!!!! + + ! w'^2: Right-hand side (explicit w'^2 portion of the code). + + ! RHS time tendency. + rhs(k_wp2) & + = + ( 1.0_core_rknd / dt ) * wp2(k) + + ! RHS buoyancy production (bp) term and pressure term 2 (pr2). + rhs(k_wp2) & + = rhs(k_wp2) & + + wp2_terms_bp_pr2_rhs( C5, thv_ds_zm(k), wpthvp(k) ) + + ! RHS buoyancy production at CL top due to LW radiative cooling + rhs(k_wp2) = rhs(k_wp2) + radf(k) + + ! RHS pressure term 3 (pr3). + rhs(k_wp2) & + = rhs(k_wp2) & + + wp2_term_pr3_rhs( C5, thv_ds_zm(k), wpthvp(k), upwp(k), um(kp1), & + um(k), vpwp(k), vm(kp1), vm(k), gr%invrs_dzm(k) ) + + ! RHS dissipation term 1 (dp1). + rhs(k_wp2) & + = rhs(k_wp2) & + + wp2_term_dp1_rhs( C1_Skw_fnc(k), tau_C1_zm(k), w_tol_sqd, up2(k), vp2(k) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS dissipation term 1 (dp1). + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the term + ! more numerically stable (see note below for w'^3 RHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1) & + = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + rhs(k_wp2) & + = rhs(k_wp2) & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp2(k) ) + + ! RHS eddy diffusion term: dissipation term 2 (dp2). + if ( l_crank_nich_diff ) then + ! These lines are for the diffusional term with a Crank-Nicholson + ! time step. They are not used for completely implicit diffusion. + rhs_diff(1:3) & + = (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zm_lhs( Kw1(k), Kw1(kp1), nu1_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + rhs(k_wp2) = rhs(k_wp2) & + - rhs_diff(3) * wp2(km1) & + - rhs_diff(2) * wp2(k) & + - rhs_diff(1) * wp2(kp1) + endif + + ! RHS pressure term 1 (pr1). + if ( l_tke_aniso ) then + + rhs(k_wp2) & + = rhs(k_wp2) & + + wp2_term_pr1_rhs( C4, up2(k), vp2(k), tau1m(k) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS dissipation term 1 (dp1). + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 RHS + ! turbulent advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1) & + = wp2_term_pr1_lhs( C4, tau1m(k) ) + rhs(k_wp2) & + = rhs(k_wp2) & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp2(k) ) + + endif + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for wp2. + + ! w'^2 term dp2 has both implicit and explicit components (if the + ! Crank-Nicholson scheme is selected); call stat_begin_update_pt. + ! Since stat_begin_update_pt automatically subtracts the value sent in, + ! reverse the sign on right-hand side diffusion component. If + ! Crank-Nicholson diffusion is not selected, the stat_begin_update_pt + ! will not be called. + if ( l_crank_nich_diff ) then + call stat_begin_update_pt( iwp2_dp2, k, & + rhs_diff(3) * wp2(km1) & + + rhs_diff(2) * wp2(k) & + + rhs_diff(1) * wp2(kp1), stats_zm ) + endif + + ! w'^2 term bp is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of w'^2 term bp, substitute 0 for the + ! C_5 input to function wp2_terms_bp_pr2_rhs. + call stat_update_var_pt( iwp2_bp, k, & + wp2_terms_bp_pr2_rhs( 0.0_core_rknd, thv_ds_zm(k), wpthvp(k) ), stats_zm ) + + ! w'^2 term pr1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp2_term_pr1_rhs. + if ( l_tke_aniso ) then + call stat_begin_update_pt( iwp2_pr1, k, & + -wp2_term_pr1_rhs( C4, up2(k), vp2(k), tau1m(k) ), stats_zm ) + + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note below for + ! w'^3 RHS turbulent advection (ta) and turbulent + ! production (tp) terms). + lhs_fnc_output(1) & + = wp2_term_pr1_lhs( C4, tau1m(k) ) + call stat_modify_pt( iwp2_pr1, k, & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp2(k) ), stats_zm ) + endif + + ! w'^2 term pr2 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp2_terms_bp_pr2_rhs. + ! Note: To find the contribution of w'^2 term pr2, add 1 to the + ! C_5 input to function wp2_terms_bp_pr2_rhs. + call stat_begin_update_pt( iwp2_pr2, k, & + -wp2_terms_bp_pr2_rhs( (1.0_core_rknd+C5), thv_ds_zm(k), wpthvp(k) ), stats_zm ) + + ! w'^2 term dp1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp2_term_dp1_rhs. + call stat_begin_update_pt( iwp2_dp1, k, & + -wp2_term_dp1_rhs( C1_Skw_fnc(k), tau_C1_zm(k), w_tol_sqd, up2(k), vp2(k) ), stats_zm ) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note below for w'^3 RHS + ! turbulent advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1) & + = wp2_term_dp1_lhs( C1_Skw_fnc(k), tau_C1_zm(k) ) + call stat_modify_pt( iwp2_dp1, k, & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp2(k) ), stats_zm ) + + ! w'^2 term pr3 is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( iwp2_pr3, k, & + wp2_term_pr3_rhs( C5, thv_ds_zm(k), wpthvp(k), upwp(k), um(kp1), & + um(k), vpwp(k), vm(kp1), vm(k), gr%invrs_dzm(k) ), & + stats_zm ) + + endif + + + + !!!!!***** w'^3 *****!!!!! + + ! w'^3: Right-hand side (explicit w'^3 portion of the code). + + ! RHS time tendency. + rhs(k_wp3) = & + + ( 1.0_core_rknd / dt * wp3(k) ) + + ! RHS turbulent advection (ta) and turbulent production (tp) terms. +! rhs(k_wp3) & +! = rhs(k_wp3) & +! + wp3_terms_ta_tp_rhs( wp3_zm(k), wp3_zm(km1), & +! wp2(k), wp2(km1), & +! a1(k), a1_zt(k), a1(km1), & +! a3(k), a3_zt(k), a3(km1), & +! wp3_on_wp2(k), wp3_on_wp2(km1), & +! rho_ds_zm(k), rho_ds_zm(km1), & +! invrs_rho_ds_zt(k), & +! three_halves, & +! gr%invrs_dzt(k) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS turbulent advection (ta) and turbulent production (tp) terms. + ! + ! Note: An "over-implicit" weighted time step is applied to these terms. + ! The weight of the implicit portion of these terms is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (w'^3 in this case), y(t) is the linearized portion of + ! the terms that gets treated implicitly, and RHS is the portion of + ! the terms that is always treated explicitly. A weight of greater + ! than 1 can be applied to make the terms more numerically stable. + lhs_fnc_output(1:5) & + = wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k), a3_zt(k), a3(km1), & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + rhs(k_wp3) & + = rhs(k_wp3) & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp3(kp1) & + - lhs_fnc_output(2) * wp2(k) & + - lhs_fnc_output(3) * wp3(k) & + - lhs_fnc_output(4) * wp2(km1) & + - lhs_fnc_output(5) * wp3(km1) ) + + ! RHS buoyancy production (bp) term and pressure term 2 (pr2). + rhs(k_wp3) & + = rhs(k_wp3) & + + wp3_terms_bp1_pr2_rhs( C11_Skw_fnc(k), thv_ds_zt(k), wp2thvp(k) ) + + ! RHS pressure term 1 (pr1). + rhs(k_wp3) & + = rhs(k_wp3) & + + wp3_term_pr1_rhs( C8, C8b, tauw3t(k), Skw_zt(k), wp3(k) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS pressure term 1 (pr1). + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs_fnc_output(1) & + = wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + rhs(k_wp3) & + = rhs(k_wp3) & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp3(k) ) + + ! RHS eddy diffusion term: dissipation term 1 (dp1). + if ( l_crank_nich_diff ) then + ! These lines are for the diffusional term with a Crank-Nicholson + ! time step. They are not used for completely implicit diffusion. + rhs_diff(1:3) & + = C12 * (1.0_core_rknd/2.0_core_rknd) & + * diffusion_zt_lhs( Kw8(k), Kw8(km1), nu8_vert_res_dep, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), & + gr%invrs_dzt(k), k ) + rhs(k_wp3) = rhs(k_wp3) & + - rhs_diff(3) * wp3(km1) & + - rhs_diff(2) * wp3(k) & + - rhs_diff(1) * wp3(kp1) + endif + + if ( l_wp3_2nd_buoyancy_term ) then + ! RHS 2nd bouyancy term + rhs(k_wp3) = rhs(k_wp3) & + + wp3_term_bp2_rhs( C15, Kh_zt(k), wpthvp(k), wpthvp(km1), & + dum_dz(k), dum_dz(km1), dvm_dz(k), dvm_dz(km1), & + upwp(k), upwp(km1), vpwp(k), vpwp(km1), & + thv_ds_zt(k), gr%invrs_dzt(k) ) + end if + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for wp3. + + ! w'^3 term ta has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp3_terms_ta_tp_rhs. + ! Note: To find the contribution of w'^3 term ta, add 3 to all of the + ! a_3 inputs and substitute 0 for the three_halves input to + ! function wp3_terms_ta_tp_rhs. +! call stat_begin_update_pt( iwp3_ta, k, & +! -wp3_terms_ta_tp_rhs( wp3_zm(k), wp3_zm(km1), & +! wp2(k), wp2(km1), & +! a1(k), a1_zt(k), a1(km1), & +! a3(k)+3.0_core_rknd, a3_zt(k)+3.0_core_rknd, +! a3(km1)+3.0_core_rknd, & +! wp3_on_wp2(k), wp3_on_wp2(km1), & +! rho_ds_zm(k), rho_ds_zm(km1), & +! invrs_rho_ds_zt(k), & +! 0.0_core_rknd, & +! gr%invrs_dzt(k) ), & +! stats_zt ) + call stat_begin_update_pt( iwp3_ta, k, 0.0_core_rknd, stats_zt ) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1:5) & + = wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + a1(k), a1_zt(k), a1(km1), & + a3(k)+3.0_core_rknd, a3_zt(k)+3.0_core_rknd, & + a3(km1)+3.0_core_rknd, & + wp3_on_wp2(k), wp3_on_wp2(km1), & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + 0.0_core_rknd, & + gr%invrs_dzt(k), k ) + call stat_modify_pt( iwp3_ta, k, & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp3(kp1) & + - lhs_fnc_output(2) * wp2(k) & + - lhs_fnc_output(3) * wp3(k) & + - lhs_fnc_output(4) * wp2(km1) & + - lhs_fnc_output(5) * wp3(km1) ), stats_zt ) + + ! w'^3 term tp has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp3_terms_ta_tp_rhs. + ! Note: To find the contribution of w'^3 term tp, substitute 0 for all + ! of the a_1 and a_3 inputs and subtract 3 from all of the a_3 + ! inputs to function wp3_terms_ta_tp_rhs. +! call stat_begin_update_pt( iwp3_tp, k, & +! -wp3_terms_ta_tp_rhs( wp3_zm(k), wp3_zm(km1), & +! wp2(k), wp2(km1), & +! 0.0_core_rknd, 0.0_core_rknd, 0.0_core_rknd, & +! 0.0_core_rknd-3.0_core_rknd, 0.0_core_rknd-3.0_core_rknd, +! 0.0_core_rknd-3.0_core_rknd, & +! 0.0_core_rknd, 0.0_core_rknd, & +! rho_ds_zm(k), rho_ds_zm(km1), & +! invrs_rho_ds_zt(k), & +! three_halves, & +! gr%invrs_dzt(k) ), & +! stats_zt ) + call stat_begin_update_pt( iwp3_tp, k, 0.0_core_rknd, stats_zt ) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1:5) & + = wp3_terms_ta_tp_lhs( wp2(k), wp2(km1), & + 0.0_core_rknd, 0.0_core_rknd, 0.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd-3.0_core_rknd, & + 0.0_core_rknd, 0.0_core_rknd, & + rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), & + three_halves, & + gr%invrs_dzt(k), k ) + call stat_modify_pt( iwp3_tp, k, & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(2) * wp2(k) & + - lhs_fnc_output(4) * wp2(km1) ), stats_zt ) + + ! w'^3 term bp is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of w'^3 term bp, substitute 0 for the + ! C_11 skewness function input to function wp3_terms_bp1_pr2_rhs. + call stat_update_var_pt( iwp3_bp1, k, & + wp3_terms_bp1_pr2_rhs( 0.0_core_rknd, thv_ds_zt(k), wp2thvp(k) ), stats_zt ) + + ! w'^3 term pr2 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp3_terms_bp1_pr2_rhs. + ! Note: To find the contribution of w'^3 term pr2, add 1 to the + ! C_11 skewness function input to function wp3_terms_bp1_pr2_rhs. + call stat_begin_update_pt( iwp3_pr2, k, & + -wp3_terms_bp1_pr2_rhs( (1.0_core_rknd+C11_Skw_fnc(k)), thv_ds_zt(k), & + wp2thvp(k) ), & + stats_zt ) + + ! w'^3 term pr1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on wp3_term_pr1_rhs. + call stat_begin_update_pt( iwp3_pr1, k, & + -wp3_term_pr1_rhs( C8, C8b, tauw3t(k), Skw_zt(k), wp3(k) ), & + stats_zt ) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) and turbulent production (tp) terms). + lhs_fnc_output(1) & + = wp3_term_pr1_lhs( C8, C8b, tauw3t(k), Skw_zt(k) ) + call stat_modify_pt( iwp3_pr1, k, & + + ( 1.0_core_rknd - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wp3(k) ), stats_zt ) + + ! w'^3 term dp1 has both implicit and explicit components (if the + ! Crank-Nicholson scheme is selected); call stat_begin_update_pt. + ! Since stat_begin_update_pt automatically subtracts the value sent in, + ! reverse the sign on right-hand side diffusion component. If + ! Crank-Nicholson diffusion is not selected, the stat_begin_update_pt + ! will not be called. + if ( l_crank_nich_diff ) then + call stat_begin_update_pt( iwp3_dp1, k, & + rhs_diff(3) * wp3(km1) & + + rhs_diff(2) * wp3(k) & + + rhs_diff(1) * wp3(kp1), stats_zt ) + endif + + if ( l_wp3_2nd_buoyancy_term ) then + temp = wp3_term_bp2_rhs( C15, Kh_zt(k), wpthvp(k), wpthvp(km1), & + dum_dz(k), dum_dz(km1), dvm_dz(k), dvm_dz(km1), & + upwp(k), upwp(km1), vpwp(k), vpwp(km1), & + thv_ds_zt(k), gr%invrs_dzt(k) ) + call stat_update_var_pt( iwp3_bp2, k, temp, stats_zt ) + end if + + endif ! l_stats_samp + + enddo ! k = 2..gr%nz-1 + + + ! Boundary conditions + + ! Both wp2 and wp3 used fixed-point boundary conditions. + ! Therefore, anything set in the above loop at both the upper + ! and lower boundaries would be overwritten here. However, the + ! above loop does not extend to the boundary levels. An array + ! with a value of 1 at the main diagonal on the left-hand side + ! and with values of 0 at all other diagonals on the left-hand + ! side will preserve the right-hand side value at that level. + + ! Lower boundary + k = 1 + k_wp3_low = 2*k - 1 + k_wp2_low = 2*k + + ! Upper boundary + k = gr%nz + k_wp3_high = 2*k - 1 + k_wp2_high = 2*k + + + ! The value of w'^2 at the lower boundary will remain the same. + ! When the lower boundary is at the surface, the surface value of + ! w'^2 is set in subroutine surface_varnce (surface_varnce_module.F). + + ! The value of w'^3 at the lower boundary will be 0. + + ! The value of w'^2 at the upper boundary will be set to the threshold + ! minimum value of w_tol_sqd. + + ! The value of w'^3 at the upper boundary will be set to 0. + call set_boundary_conditions_rhs( & + wp2(1), k_wp2_low, w_tol_sqd, k_wp2_high, & ! Intent(in) + rhs, & ! Intent(inout) + 0.0_core_rknd, k_wp3_low, 0.0_core_rknd, k_wp3_high ) + + return + + end subroutine wp23_rhs + + !============================================================================= + pure function wp2_term_ta_lhs( rho_ds_ztp1, rho_ds_zt, & + invrs_rho_ds_zm, invrs_dzm ) & + result( lhs ) + + ! Description: + ! Turbulent advection term for w'^2: implicit portion of the code. + ! + ! The d(w'^2)/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'^3 )/dz. + ! + ! The term is solved for completely implicitly, such that: + ! + ! - (1/rho_ds) * d( rho_ds * w'^3(t+1) )/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'^3 being used is from + ! the next timestep, which is being advanced to in solving the d(w'^2)/dt + ! and d(w'^3)/dt equations. + ! + ! This term is discretized as follows: + ! + ! While the values of w'^2 are found on the momentum levels, the values of + ! w'^3 are found on the thermodynamic levels. Additionally, the values of + ! rho_ds_zt are found on the thermodynamic levels, and the values of + ! invrs_rho_ds_zm are found on the momentum levels. On the thermodynamic + ! levels, the values of rho_ds_zt are multiplied by the values of w'^3. The + ! derivative of (rho_ds_zt * w'^3) is taken over the intermediate (central) + ! momentum level, where it is multiplied by invrs_rho_ds_zm, yielding the + ! desired results. + ! + ! -----rho_ds_ztp1--------wp3p1---------------------------- t(k+1) + ! + ! ========invrs_rho_ds_zm==========d(rho_ds*wp3)/dz======== m(k) + ! + ! -----rho_ds_zt----------wp3------------------------------ t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rho_ds_ztp1, & ! Dry, static density at thermo. level (k+1) [kg/m^3] + rho_ds_zt, & ! Dry, static density at thermo. level (k) [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. lev. (k) [m^3/kg] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ), dimension(2) :: lhs + + ! Thermodynamic superdiagonal: [ x wp3(k+1,) ] + lhs(kp1_tdiag) & + = + invrs_rho_ds_zm * invrs_dzm * rho_ds_ztp1 + + ! Thermodynamic subdiagonal: [ x wp3(k,) ] + lhs(k_tdiag) & + = - invrs_rho_ds_zm * invrs_dzm * rho_ds_zt + + return + + end function wp2_term_ta_lhs + + !============================================================================= + pure function wp2_terms_ac_pr2_lhs( C5, wm_ztp1, wm_zt, invrs_dzm ) & + result( lhs ) + + ! Description: + ! Accumulation of w'^2 and w'^2 pressure term 2: implicit portion of the + ! code. + ! + ! The d(w'^2)/dt equation contains an accumulation term: + ! + ! - 2 w'^2 dw/dz; + ! + ! and pressure term 2: + ! + ! - C_5 ( -2 w'^2 dw/dz + 2 (g/th_0) w'th_v' ). + ! + ! The w'^2 accumulation term is completely implicit, while w'^2 pressure + ! term 2 has both implicit and explicit components. The accumulation term + ! and the implicit portion of pressure term 2 are combined and solved + ! together as: + ! + ! + ( 1 - C_5 ) ( -2 w'^2(t+1) dw/dz ). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the "2" is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'^2 being used is from + ! the next timestep, which is being advanced to in solving the d(w'^2)/dt + ! equation. + ! + ! The terms are discretized as follows: + ! + ! The values of w'^2 are found on the momentum levels, while the values of + ! wm_zt (mean vertical velocity on thermodynamic levels) are found on the + ! thermodynamic levels. The vertical derivative of wm_zt is taken over the + ! intermediate (central) momentum level. It is then multiplied by w'^2 + ! (implicitly calculated at timestep (t+1)) and the coefficients to yield + ! the desired results. + ! + ! -------wm_ztp1------------------------------------------- t(k+1) + ! + ! ===============d(wm_zt)/dz============wp2================ m(k) + ! + ! -------wm_zt--------------------------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C5, & ! Model parameter C_5 [-] + wm_ztp1, & ! w wind component at t:hermodynamic levels (k+1) [m/s] + wm_zt, & ! w wind component at thermodynamic levels (k) [m/s] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Momentum main diagonal: [ x wp2(k,) ] + lhs & + = + ( 1.0_core_rknd - C5 ) * 2.0_core_rknd * invrs_dzm * ( wm_ztp1 - wm_zt ) + + return + + end function wp2_terms_ac_pr2_lhs + + !============================================================================= + pure function wp2_term_dp1_lhs( C1_Skw_fnc, tau1m ) & + result( lhs ) + + ! Description: + ! Dissipation term 1 for w'^2: implicit portion of the code. + ! + ! The d(w'^2)/dt equation contains dissipation term 1: + ! + ! - ( C_1 / tau_1m ) w'^2. + ! + ! Since w'^2 has a minimum threshold, the term should be damped only to that + ! threshold. The term becomes: + ! + ! - ( C_1 / tau_1m ) * ( w'^2 - threshold ). + ! + ! This term is broken into implicit and explicit portions. The implicit + ! portion of this term is: + ! + ! - ( C_1 / tau_1m ) w'^2(t+1). + ! + ! Note: When the implicit term is brought over to the left-hand side, the + ! sign is reversed and the leading "-" in front of the term is + ! changed to a "+". + ! + ! The timestep index (t+1) means that the value of w'^2 being used is from + ! the next timestep, which is being advanced to in solving the d(w'^2)/dt + ! equation. + ! + ! The values of w'^2 are found on the momentum levels. The values of the + ! C_1 skewness function and time-scale tau1m are also found on the momentum + ! levels. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied (k) [-] + tau1m ! Time-scale tau at momentum levels (k) [s] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Momentum main diagonal: [ x wp2(k,) ] + lhs & + = + C1_Skw_fnc / tau1m + + return + end function wp2_term_dp1_lhs + + !============================================================================= + pure function wp2_term_pr1_lhs( C4, tau1m ) & + result( lhs ) + + ! Description + ! Pressure term 1 for w'^2: implicit portion of the code. + ! + ! The d(w'^2)/dt equation contains pressure term 1: + ! + ! - ( C_4 / tau_1m ) * ( w'^2 - (2/3)*em ), + ! + ! where em = (1/2) * ( w'^2 + u'^2 + v'^2 ). + ! + ! This simplifies to: + ! + ! - ( C_4 / tau_1m ) * (2/3) * w'^2 + ! + ( C_4 / tau_1m ) * (1/3) * ( u'^2 + v'^2 ). + ! + ! Pressure term 1 has both implicit and explicit components. The implicit + ! portion is: + ! + ! - ( C_4 / tau_1m ) * (2/3) * w'^2(t+1); + ! + ! and is computed in this function. + ! + ! Note: When the implicit term is brought over to the left-hand side, the + ! sign is reversed and the leading "-" in front of the term is + ! changed to a "+". + ! + ! The timestep index (t+1) means that the value of w'^2 being used is from + ! the next timestep, which is being advanced to in solving the d(w'^2)/dt + ! equation. + ! + ! The values of w'^2 are found on momentum levels, as are the values of tau1m. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C4, & ! Model parameter C_4 [-] + tau1m ! Time-scale tau at momentum levels (k) [s] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Momentum main diagonal: [ x wp2(k,) ] + lhs & + = + ( 2.0_core_rknd * C4 ) / ( 3.0_core_rknd * tau1m ) + + return + end function wp2_term_pr1_lhs + + !============================================================================= + pure function wp2_terms_bp_pr2_rhs( C5, thv_ds_zm, wpthvp ) & + result( rhs ) + + ! Description: + ! Buoyancy production of w'^2 and w'^2 pressure term 2: explicit portion of + ! the code. + ! + ! The d(w'^2)/dt equation contains a buoyancy production term: + ! + ! + 2 (g/thv_ds) w'th_v'; + ! + ! and pressure term 2: + ! + ! - C_5 ( -2 w'^2 dw/dz + 2 (g/thv_ds) w'th_v' ). + ! + ! The w'^2 buoyancy production term is completely explicit, while w'^2 + ! pressure term 2 has both implicit and explicit components. The buoyancy + ! production term and the explicit portion of pressure term 2 are combined + ! and solved together as: + ! + ! + ( 1 - C_5 ) ( 2 (g/thv_ds) w'th_v' ). + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + ! Variable(s) + grav ! Gravitational acceleration [m/s^2] + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C5, & ! Model parameter C_5 [-] + thv_ds_zm, & ! Dry, base-state theta_v at momentum level (k) [K] + wpthvp ! w'th_v'(k) [K m/s] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = + ( 1.0_core_rknd - C5 ) * 2.0_core_rknd * ( grav / thv_ds_zm ) * wpthvp + + return + end function wp2_terms_bp_pr2_rhs + + !============================================================================= + pure function wp2_term_dp1_rhs( C1_Skw_fnc, tau1m, threshold, up2, vp2 ) & + result( rhs ) + + ! Description: + ! When l_damp_wp2_using_em == .false., then + ! Dissipation term 1 for w'^2: explicit portion of the code. + ! + ! The d(w'^2)/dt equation contains dissipation term 1: + ! + ! - ( C_1 / tau_1m ) w'^2. + ! + ! Since w'^2 has a minimum threshold, the term should be damped only to that + ! threshold. The term becomes: + ! + ! - ( C_1 / tau_1m ) * ( w'^2 - threshold ). + ! + ! This term is broken into implicit and explicit portions. The explicit + ! portion of this term is: + ! + ! + ( C_1 / tau_1m ) * threshold. + ! + ! The values of the C_1 skewness function, time-scale tau1m, and the + ! threshold are found on the momentum levels. + + ! if l_damp_wp2_using_em == .true., then + ! we damp wp2 using a more standard turbulence closure, -(2/3)*em/tau + ! This only works if C1=C14 and l_stability_correct_tau_zm =.false. + ! A factor of (1/3) is absorbed into C1. + ! The threshold is implicitly set to 0. + + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_damp_wp2_using_em ! Logical + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C1_Skw_fnc, & ! C_1 parameter with Sk_w applied (k) [-] + tau1m, & ! Time-scale tau at momentum levels (k) [s] + threshold, & ! Minimum allowable value of w'^2 [m^2/s^2] + up2, & ! Horizontal (east-west) velocity variance, u'^2 [m^2/s^2] + vp2 ! Horizontal (north-south) velocity variance, v'^2 [m^2/s^2] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + + if ( l_damp_wp2_using_em ) then + + rhs & + = - ( C1_Skw_fnc / tau1m ) * ( up2 + vp2 ) + + else + + rhs & + = + ( C1_Skw_fnc / tau1m ) * threshold + + end if + + return + end function wp2_term_dp1_rhs + + !============================================================================= + pure function wp2_term_pr3_rhs( C5, thv_ds_zm, wpthvp, upwp, ump1, & + um, vpwp, vmp1, vm, invrs_dzm ) & + result( rhs ) + + ! Description: + ! Pressure term 3 for w'^2: explicit portion of the code. + ! + ! The d(w'^2)/dt equation contains pressure term 3: + ! + ! + (2/3) C_5 [ (g/thv_ds) w'th_v' - u'w' du/dz - v'w' dv/dz ]. + ! + ! This term is solved for completely explicitly and is discretized as + ! follows: + ! + ! The values of w'th_v', u'w', and v'w' are found on the momentum levels, + ! whereas the values of um and vm are found on the thermodynamic levels. + ! Additionally, the values of thv_ds_zm are found on the momentum levels. + ! The derivatives of both um and vm are taken over the intermediate + ! (central) momentum level. All the remaining mathematical operations take + ! place at the central momentum level, yielding the desired result. + ! + ! -----ump1------------vmp1-------------------------------------- t(k+1) + ! + ! =upwp====d(um)/dz========d(vm)/dz==vpwp===thv_ds_zm==wpthvp==== m(k) + ! + ! -----um--------------vm---------------------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & ! Variables + grav, & ! Gravitational acceleration [m/s^2] + zero_threshold + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C5, & ! Model parameter C_5 [-] + thv_ds_zm, & ! Dry, base-state theta_v at momentum level (k) [K] + wpthvp, & ! w'th_v'(k) [K m/s] + upwp, & ! u'w'(k) [m^2/s^2] + ump1, & ! um(k+1) [m/s] + um, & ! um(k) [m/s] + vpwp, & ! v'w'(k) [m^2/s^2] + vmp1, & ! vm(k+1) [m/s] + vm, & ! vm(k) [m/s] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + ! Michael Falk, 2 August 2007 + ! Use the following code for standard mixing, with c_k=0.548: + = + (2.0_core_rknd/3.0_core_rknd) * C5 & + * ( ( grav / thv_ds_zm ) * wpthvp & + - upwp * invrs_dzm * ( ump1 - um ) & + - vpwp * invrs_dzm * ( vmp1 - vm ) & + ) + ! Use the following code for alternate mixing, with c_k=0.1 or 0.2 +! = + (2.0_core_rknd/3.0_core_rknd) * C5 & +! * ( ( grav / thv_ds_zm ) * wpthvp & +! - 0. * upwp * invrs_dzm * ( ump1 - um ) & +! - 0. * vpwp * invrs_dzm * ( vmp1 - vm ) & +! ) +! eMFc + + ! Added by dschanen for ticket #36 + ! We have found that when shear generation is zero this term will only be + ! offset by hole-filling (wp2_pd) and reduces turbulence + ! unrealistically at lower altitudes to make up the difference. + rhs = max( rhs, zero_threshold ) + + return + end function wp2_term_pr3_rhs + + !============================================================================= + pure function wp2_term_pr1_rhs( C4, up2, vp2, tau1m ) & + result( rhs ) + + ! Description: + ! Pressure term 1 for w'^2: explicit portion of the code. + ! + ! The d(w'^2)/dt equation contains pressure term 1: + ! + ! - ( C_4 / tau_1m ) * ( w'^2 - (2/3)*em ); + ! + ! where em = (1/2) * ( w'^2 + u'^2 + v'^2 ). + ! + ! This simplifies to: + ! + ! - ( C_4 / tau_1m ) * (2/3) * w'^2 + ! + ( C_4 / tau_1m ) * (1/3) * ( u'^2 + v'^2 ). + ! + ! Pressure term 1 has both implicit and explicit components. + ! The explicit portion is: + ! + ! + ( C_4 / tau_1m ) * (1/3) * ( u'^2 + v'^2 ); + ! + ! and is computed in this function. + ! + ! The values of u'^2 and v'^2 are found on momentum levels, as are the + ! values of tau1m. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C4, & ! Model parameter C_4 [-] + up2, & ! u'^2(k) [m^2/s^2] + vp2, & ! v'^2(k) [m^2/s^2] + tau1m ! Time-scale tau at momentum levels (k) [s] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = + ( C4 * ( up2 + vp2 ) ) / ( 3.0_core_rknd * tau1m ) + + return + end function wp2_term_pr1_rhs + + !============================================================================= + pure function wp3_terms_ta_tp_lhs( wp2, wp2m1, & + a1, a1_zt, a1m1, & + a3, a3_zt, a3m1, & + wp3_on_wp2, wp3_on_wp2_m1, & + rho_ds_zm, rho_ds_zmm1, & + invrs_rho_ds_zt, & + const_three_halves, & + invrs_dzt, level ) & + result( lhs ) + + ! Description: + ! Turbulent advection and turbulent production of w'^3: implicit portion of + ! the code. + ! + ! The d(w'^3)/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'^4 )/dz; + ! + ! and a turbulent production term: + ! + ! + 3 * ( w'^2 / rho_ds ) * d( rho_ds * w'^2 )/dz. + ! + ! A substitution is made in order to close the turbulent advection term, + ! such that: + ! + ! w'^4 = coef_sig_sqd_w * (w'^2)^2 + a_1 * ( (w'^3)^2 / w'^2 ); + ! + ! where both a_1 and coef_sig_sqd_w are variables that are functions of + ! sigma_sqd_w, such that: + ! + ! coef_sig_sqd_w = 3*(sigma_sqd_w)^2 + 6*(1 - sigma_sqd_w)*sigma_sqd_w + ! + (1 - sigma_sqd_w)^2; and + ! + ! a_1 = 1 / (1 - sigma_sqd_w). + ! + ! Since the turbulent advection and turbulent production terms are being + ! combined, a further substitution is made, such that: + ! + ! a_3 = coef_sig_sqd_w - 3; + ! + ! and thus: + ! + ! w'^4 = (a_3 + 3) * (w'^2)^2 + a_1 * ( (w'^3)^2 / w'^2 ). + ! + ! The turbulent production term is rewritten as: + ! + ! + 3 * ( w'^2 / rho_ds ) * d[ rho_ds * w'^2 ]/dz + ! = + (3/rho_ds) * d[ rho_ds * (w'^2)^2 ]/dz - (3/2) * d[ (w'^2)^2 ]/dz. + ! + ! The turbulent advection and turbulent production terms are combined as: + ! + ! - (1/rho_ds) * d [ rho_ds * a_3 * (w'^2)^2 ] / dz + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( (w'^3)^2 / w'^2 ) ] / dz + ! - (3/2) * d [ (w'^2)^2 ] / dz. + ! + ! The (w'^2)^2 and (w'^3)^2 terms are both linearized, such that: + ! + ! ( w'^2(t+1) )^2 = - ( w'^2(t) )^2 + 2 * w'^2(t) * w'^2(t+1); + ! ( w'^3(t+1) )^2 = - ( w'^3(t) )^2 + 2 * w'^3(t) * w'^3(t+1); + ! + ! which produces implicit and explicit portions of these terms. The + ! implicit portion of these terms is: + ! + ! - (1/rho_ds) * d [ rho_ds * a_3 * 2 * w'^2(t) * w'^2(t+1) ] / dz + ! - (1/rho_ds) * d [ rho_ds * a_1 + ! * ( 2 * w'^3(t) * w'^3(t+1) ) / w'^2(t) ] / dz + ! - (3/2) * d [ 2 * w'^2(t) * w'^2(t+1) ] /dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign is + ! reversed and the leading "-" in front of all d[ ] / dz terms is + ! changed to a "+". + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(w'^3)/dt and d(w'^2)/dt equations. + ! + ! The implicit portion of these terms is discretized as follows: + ! + ! The values of w'^3 are found on the thermodynamic levels, while the values + ! of w'^2, a_1, and a_3 are found on the momentum levels. Additionally, the + ! values of rho_ds_zm are found on the momentum levels, and the values of + ! invrs_rho_ds_zt are found on the thermodynamic levels. The variable w'^3 + ! is interpolated to the intermediate momentum levels. The values of the + ! mathematical expressions (called F, G, and H here) within the dF/dz, + ! dG/dz, and dH/dz terms are computed on the momentum levels. Then, the + ! derivatives (d/dz) of the expressions (F, G, and H) are taken over the + ! central thermodynamic level, where dF/dz and dG/dz are multiplied by + ! invrs_rho_ds_zt, and where dH/dz is multiplied by 3/2. This yields the + ! desired results. In this function, the values of F, G, and H are as + ! follows: + ! + ! F = rho_ds_zm * a_3(t) * 2 * w'^2(t) * w'^2(t+1); + ! + ! G = rho_ds_zm * a_1(t) * ( 2 * w'^3(t) * w'^3(t+1) ) / w'^2(t); and + ! + ! H = 2 * w'^2(t) * w'^2(t+1). + ! + ! + ! ------------------------------------------------wp3p1-------------- t(k+1) + ! + ! ===a3====wp2====rho_ds_zm====a1======================wp3(interp)=== m(k) + ! + ! ---dH/dz---dF/dz----invrs_rho_ds_zt----dG/dz----wp3---------------- t(k) + ! + ! ===a3m1==wp2m1==rho_ds_zmm1==a1m1====================wp3(interp)=== m(k-1) + ! + ! ------------------------------------------------wp3m1-------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is + ! used for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use grid_class, only: & + gr ! Variable gr%weights_zt2zm + + use model_flags, only: & + l_standard_term_ta + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_mdiag = 2, & ! Momentum superdiagonal index. + k_tdiag = 3, & ! Thermodynamic main diagonal index. + km1_mdiag = 4, & ! Momentum subdiagonal index. + km1_tdiag = 5 ! Thermodynamic subdiagonal index. + + integer, parameter :: & + t_above = 1, & ! Index for upper thermodynamic level grid weight. + t_below = 2 ! Index for lower thermodynamic level grid weight. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wp2, & ! w'^2(k) [m^2/s^2] + wp2m1, & ! w'^2(k-1) [m^2/s^2] + a1, & ! a_1(k) [-] + a1_zt, & ! a_1 interpolated to thermo. level (k) [-] + a1m1, & ! a_1(k-1) [-] + a3, & ! a_3(k) [-] + a3_zt, & ! a_3 interpolated to thermo. level (k) [-] + a3m1, & ! a_3(k-1) [-] + wp3_on_wp2, & ! wp3 / wp2 (k) [m/s] + wp3_on_wp2_m1, & ! wp3 / wp2 (k-1) [m/s] + rho_ds_zm, & ! Dry, static density at moment. lev (k) [kg/m^3] + rho_ds_zmm1, & ! Dry, static density at moment. lev (k-1) [kg/m^3] + invrs_rho_ds_zt, & ! Inv dry, static density @ thermo lev (k) [m^3/kg] + const_three_halves, & ! "3/2" ("0" is sent in for wp3_ta budget) [-] + invrs_dzt ! Inverse of grid spacing (k) [1/m] + + integer, intent(in) :: & + level ! Central thermodynamic level (on which calculation occurs). + + ! Return Variable + real( kind = core_rknd ), dimension(5) :: lhs + + ! Local Variables + integer :: & + mk, & ! Momentum level directly above central thermodynamic level. + mkm1 ! Momentum level directly below central thermodynamic level. + + + ! Momentum level (k) is between thermodynamic level (k+1) + ! and thermodynamic level (k). + mk = level + + ! Momentum level (k-1) is between thermodynamic level (k) + ! and thermodynamic level (k-1). + mkm1 = level - 1 + + if ( l_standard_term_ta ) then + + ! The turbulent advection term is discretized normally, in accordance + ! with the model equations found in the documentation and the description + ! listed above. + + ! Thermodynamic superdiagonal: [ x wp3(k+1,) ] + lhs(kp1_tdiag) & + = + invrs_rho_ds_zt & + * invrs_dzt & + * rho_ds_zm * a1 & + * wp3_on_wp2 & + * gr%weights_zt2zm(t_above,mk) + + ! Momentum superdiagonal: [ x wp2(k,) ] + lhs(k_mdiag) & + = + invrs_rho_ds_zt & + * invrs_dzt * rho_ds_zm * a3 * wp2 & + + const_three_halves & + * invrs_dzt * wp2 + + ! Thermodynamic main diagonal: [ x wp3(k,) ] + lhs(k_tdiag) & + = + invrs_rho_ds_zt & + * invrs_dzt & + * ( rho_ds_zm * a1 & + * wp3_on_wp2 & + * gr%weights_zt2zm(t_below,mk) & + - rho_ds_zmm1 * a1m1 & + * wp3_on_wp2_m1 & + * gr%weights_zt2zm(t_above,mkm1) & + ) + + ! Momentum subdiagonal: [ x wp2(k-1,) ] + lhs(km1_mdiag) & + = - invrs_rho_ds_zt & + * invrs_dzt * rho_ds_zmm1 * a3m1 * wp2m1 & + - const_three_halves & + * invrs_dzt * wp2m1 + + ! Thermodynamic subdiagonal: [ x wp3(k-1,) ] + lhs(km1_tdiag) & + = - invrs_rho_ds_zt & + * invrs_dzt & + * rho_ds_zmm1 * a1m1 & + * wp3_on_wp2_m1 & + * gr%weights_zt2zm(t_below,mkm1) + + else + + ! Brian tried a new discretization for the turbulent advection term, + ! which contains the term: + ! - (1/rho_ds) * d [ rho_ds * a_1 * (w'^3)^2 / w'^2 ] / dz. In order + ! to help stabilize w'^3, a_1 has been pulled outside of the derivative. + ! On the left-hand side of the equation, this effects the thermodynamic + ! superdiagonal (kp1_tdiag), the thermodynamic main diagonal (k_tdiag), + ! and the thermodynamic subdiagonal (km1_tdiag). + + ! Additionally, the discretization of the turbulent advection term, which + ! contains the term: + ! - (1/rho_ds) * d [ rho_ds * (a_3 + 3) * (w'^2)^2 ] / dz, has been + ! altered to pull (a_3 + 3) outside of the derivative. This was done in + ! order to help stabilize w'^3. On the left-hand side of the equation, + ! this effects the momentum superdiagonal (k_mdiag) and the momentum + ! subdiagonal (km1_mdiag). + + ! Thermodynamic superdiagonal: [ x wp3(k+1,) ] + lhs(kp1_tdiag) & + = + invrs_rho_ds_zt & + * a1_zt * invrs_dzt & + * rho_ds_zm & + * wp3_on_wp2 & + * gr%weights_zt2zm(t_above,mk) + + ! Momentum superdiagonal: [ x wp2(k,) ] + lhs(k_mdiag) & + = + invrs_rho_ds_zt & + * a3_zt * invrs_dzt * rho_ds_zm * wp2 & + + const_three_halves & + * invrs_dzt * wp2 + + ! Thermodynamic main diagonal: [ x wp3(k,) ] + lhs(k_tdiag) & + = + invrs_rho_ds_zt & + * a1_zt * invrs_dzt & + * ( rho_ds_zm & + * wp3_on_wp2 & + * gr%weights_zt2zm(t_below,mk) & + - rho_ds_zmm1 & + * wp3_on_wp2_m1 & + * gr%weights_zt2zm(t_above,mkm1) & + ) + + ! Momentum subdiagonal: [ x wp2(k-1,) ] + lhs(km1_mdiag) & + = - invrs_rho_ds_zt & + * a3_zt * invrs_dzt * rho_ds_zmm1 * wp2m1 & + - const_three_halves & + * invrs_dzt * wp2m1 + + ! Thermodynamic subdiagonal: [ x wp3(k-1,) ] + lhs(km1_tdiag) & + = - invrs_rho_ds_zt & + * a1_zt * invrs_dzt & + * rho_ds_zmm1 & + * wp3_on_wp2_m1 & + * gr%weights_zt2zm(t_below,mkm1) + + ! End of code that pulls out a3. + ! End of Brian's a1 change. Feb. 14, 2008. + + end if ! l_standard_term_ta + + + return + end function wp3_terms_ta_tp_lhs + + !============================================================================= + pure function wp3_terms_ac_pr2_lhs( C11_Skw_fnc, & + wm_zm, wm_zmm1, invrs_dzt ) & + result( lhs ) + + ! Description: + ! Accumulation of w'^3 and w'^3 pressure term 2: implicit portion of the + ! code. + ! + ! The d(w'^3)/dt equation contains an accumulation term: + ! + ! - 3 w'^3 dw/dz; + ! + ! and pressure term 2: + ! + ! - C_11 ( -3 w'^3 dw/dz + 3 (g/th_0) w'^2th_v' ). + ! + ! The w'^3 accumulation term is completely implicit, while w'^3 pressure + ! term 2 has both implicit and explicit components. The accumulation term + ! and the implicit portion of pressure term 2 are combined and solved + ! together as: + ! + ! + ( 1 - C_11 ) ( -3 w'^3(t+1) dw/dz ). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the "3" is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'^3 being used is from + ! the next timestep, which is being advanced to in solving the d(w'^3)/dt + ! equation. + ! + ! The terms are discretized as follows: + ! + ! The values of w'^3 are found on thermodynamic levels, while the values of + ! wm_zm (mean vertical velocity on momentum levels) are found on momentum + ! levels. The vertical derivative of wm_zm is taken over the intermediate + ! (central) thermodynamic level. It is then multiplied by w'^3 (implicitly + ! calculated at timestep (t+1)) and the coefficients to yield the desired + ! results. + ! + ! =======wm_zm============================================= m(k) + ! + ! ---------------d(wm_zm)/dz------------wp3---------------- t(k) + ! + ! =======wm_zmm1=========================================== m(k-1) + ! + ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes + ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied (k) [-] + wm_zm, & ! w wind component at momentum levels (k) [m/s] + wm_zmm1, & ! w wind component at momentum levels (k-1) [m/s] + invrs_dzt ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Thermodynamic main diagonal: [ x wp3(k,) ] + lhs & + = + ( 1.0_core_rknd - C11_Skw_fnc ) & + * 3.0_core_rknd * invrs_dzt * ( wm_zm - wm_zmm1 ) + + return + end function wp3_terms_ac_pr2_lhs + + !============================================================================= + pure function wp3_term_pr1_lhs( C8, C8b, tauw3t, Skw_zt ) & + result( lhs ) + + ! Description: + ! Pressure term 1 for w'^3: implicit portion of the code. + ! + ! Pressure term 1 is the term: + ! + ! - (C_8/tau_w3t) * ( C_8b * Sk_wt^4 + 1 ) * w'^3; + ! + ! where Sk_wt = w'^3 / (w'^2)^(3/2). + ! + ! This term needs to be linearized, so function L(w'^3) is defined to be + ! equal to this term (pressure term 1), such that: + ! + ! L(w'^3) = - (C_8/tau_w3t) * ( C_8b * (w'^3)^5 / (w'^2)^6 + w'^3 ). + ! + ! A Taylor Series expansion (truncated after the first derivative term) of + ! L(w'^3) around w'^3 = w'^3(t) is used to linearize pressure term 1. + ! Evaluating L(w'^3) at w'^3(t+1): + ! + ! L( w'^3(t+1) ) = L( w'^3(t) ) + ! + ( d L(w'^3) / d w'^3 )|_(w'^3=w'^3(t)) + ! * ( w'^3(t+1) - w'^3(t) ). + ! + ! After evaluating the expression above, the term has become linearized. It + ! is broken down into implicit (LHS) and explicit (RHS) components. + ! The implicit portion is: + ! + ! - (C_8/tau_w3t) * ( 5 * C_8b * Sk_wt^4 + 1 ) * w'^3(t+1). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(w'^3)/dt equation. + ! + ! The values of w'^3 are found on the thermodynamic levels, as are the + ! values of tau_w3t and Sk_wt (in Sk_wt, w'^3 is found on thermodynamic + ! levels and w'^2 is interpolated to thermodynamic levels). + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C8, & ! Model parameter C_8 [-] + C8b, & ! Model parameter C_8b [-] + tauw3t, & ! Time-scale tau at thermodynamic levels (k) [s] + Skw_zt ! Skewness of w at thermodynamic levels (k) [-] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Thermodynamic main diagonal: [ x wp3(k,) ] + lhs & + = + ( C8 / tauw3t ) * ( 5.0_core_rknd * C8b * Skw_zt**4 + 1.0_core_rknd ) + + return + end function wp3_term_pr1_lhs + + !============================================================================= +! pure function wp3_terms_ta_tp_rhs( wp3_zm, wp3_zmm1, & +! wp2, wp2m1, & +! a1, a1_zt, a1m1, & +! a3, a3_zt, a3m1, & +! wp3_on_wp2, wp3_on_wp2_m1, & +! rho_ds_zm, rho_ds_zmm1, & +! invrs_rho_ds_zt, & +! const_three_halves, & +! invrs_dzt ) & +! result( rhs ) + + ! Description: + ! Turbulent advection and turbulent production of wp3: explicit portion of + ! the code. + ! + ! The d(w'^3)/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'^4 )/dz; + ! + ! and a turbulent production term: + ! + ! + 3 * ( w'^2 / rho_ds ) * d( rho_ds * w'^2 )/dz. + ! + ! A substitution is made in order to close the turbulent advection term, + ! such that: + ! + ! w'^4 = coef_sig_sqd_w * (w'^2)^2 + a_1 * ( (w'^3)^2 / w'^2 ); + ! + ! where both a_1 and coef_sig_sqd_w are variables that are functions of + ! sigma_sqd_w, such that: + ! + ! coef_sig_sqd_w = 3*(sigma_sqd_w)^2 + 6*(1 - sigma_sqd_w)*sigma_sqd_w + ! + (1 - sigma_sqd_w)^2; and + ! + ! a_1 = 1 / (1 - sigma_sqd_w). + ! + ! Since the turbulent advection and turbulent production terms are being + ! combined, a further substitution is made, such that: + ! + ! a_3 = coef_sig_sqd_w - 3; + ! + ! and thus: + ! + ! w'^4 = (a_3 + 3) * (w'^2)^2 + a_1 * ( (w'^3)^2 / w'^2 ). + ! + ! The turbulent production term is rewritten as: + ! + ! + 3 * ( w'^2 / rho_ds ) * d[ rho_ds * w'^2 ]/dz + ! = + (3/rho_ds) * d[ rho_ds * (w'^2)^2 ]/dz - (3/2) * d[ (w'^2)^2 ]/dz. + ! + ! The turbulent advection and turbulent production terms are combined as: + ! + ! - (1/rho_ds) * d [ rho_ds * a_3 * (w'^2)^2 ] / dz + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( (w'^3)^2 / w'^2 ) ] / dz + ! - (3/2) * d [ (w'^2)^2 ] / dz. + ! + ! The (w'^2)^2 and (w'^3)^2 terms are both linearized, such that: + ! + ! ( w'^2(t+1) )^2 = - ( w'^2(t) )^2 + 2 * w'^2(t) * w'^2(t+1); + ! ( w'^3(t+1) )^2 = - ( w'^3(t) )^2 + 2 * w'^3(t) * w'^3(t+1); + ! + ! which produces implicit and explicit portions of these terms. The + ! explicit portion of these terms is: + ! + ! + (1/rho_ds) * d [ rho_ds * a_3 * ( w'^2(t) )^2 ] / dz + ! + (1/rho_ds) * d [ rho_ds * a_1 * ( w'^3(t) )^2 / w'^2(t) ] / dz + ! + (3/2) * d [ ( w'^2(t) )^2 ] / dz. + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(w'^3)/dt and d(w'^2)/dt equations. + ! + ! The explicit portion of these terms is discretized as follows: + ! + ! The values of w'^3 are found on the thermodynamic levels, while the values + ! of w'^2, a_1, and a_3 are found on the momentum levels. Additionally, the + ! values of rho_ds_zm are found on the momentum levels, and the values of + ! invrs_rho_ds_zt are found on the thermodynamic levels. The variable w'^3 + ! is interpolated to the intermediate momentum levels. The values of the + ! mathematical expressions (called F, G, and H here) within the dF/dz, + ! dG/dz, and dH/dz terms are computed on the momentum levels. Then, the + ! derivatives (d/dz) of the expressions (F, G, and H) are taken over the + ! central thermodynamic level, where dF/dz and dG/dz are multiplied by + ! invrs_rho_ds_zt, and where dH/dz is multiplied by 3/2. This yields the + ! desired results. In this function, the values of F, G, and H are as + ! follows: + ! + ! F = rho_ds_zm * a_3(t) * ( w'^2(t) )^2; + ! + ! G = rho_ds_zm * a_1(t) * ( w'^3(t) )^2 / w'^2(t); and + ! + ! H = ( w'^2(t) )^2. + ! + ! + ! ------------------------------------------------wp3p1-------------- t(k+1) + ! + ! ===a3====wp2====rho_ds_zm====a1======================wp3(interp)=== m(k) + ! + ! ---dH/dz---dF/dz----invrs_rho_ds_zt----dG/dz----wp3---------------- t(k) + ! + ! ===a3m1==wp2m1==rho_ds_zmm1==a1m1====================wp3(interp)=== m(k-1) + ! + ! ------------------------------------------------wp3m1-------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + + ! References: + !----------------------------------------------------------------------- + +! use constants_clubb, only: & +! w_tol_sqd + +! use model_flags, only: & +! l_standard_term_ta + +! implicit none + + ! Input Variables +! real, intent(in) :: & +! wp3_zm, & ! w'^3 interpolated to momentum lev. (k) [m^3/s^3] +! wp3_zmm1, & ! w'^3 interpolated to momentum lev. (k-1) [m^3/s^3] +! wp2, & ! w'^2(k) [m^2/s^2] +! wp2m1, & ! w'^2(k-1) [m^2/s^2] +! a1, & ! a_1(k) [-] +! a1_zt, & ! a_1 interpolated to thermo. level (k) [-] +! a1m1, & ! a_1(k-1) [-] +! a3, & ! a_3(k) [-] +! a3_zt, & ! a_3 interpolated to thermo. level (k) [-] +! a3m1, & ! a_3(k-1) [-] +! wp3_on_wp2, & ! (k) [m/s] +! wp3_on_wp2_m1, & ! (k-1) [m/s] +! rho_ds_zm, & ! Dry, static density at moment. lev (k) [kg/m^3] +! rho_ds_zmm1, & ! Dry, static density at moment. lev (k-1) [kg/m^3] +! invrs_rho_ds_zt, & ! Inv dry, static density @ thermo lev (k) [m^3/kg] +! const_three_halves, & ! "3/2" ("0" is sent in for wp3_ta budget) [-] +! invrs_dzt ! Inverse of grid spacing (k) [1/m] + + ! Return Variable +! real :: rhs + + +! if ( l_standard_term_ta ) then + + ! The turbulent advection term is discretized normally, in accordance + ! with the model equations found in the documentation and the description + ! listed above. + +! rhs & +! = + invrs_rho_ds_zt & +! * invrs_dzt & +! * ( rho_ds_zm * a3 * wp2**2 & +! - rho_ds_zmm1 * a3m1 * wp2m1**2 & +! ) & +! + invrs_rho_ds_zt & +! * invrs_dzt & +! * ( rho_ds_zm * a1 & +! * wp3_zm * wp3_on_wp2 & +! - rho_ds_zmm1 * a1m1 & +! * wp3_zmm1 * wp3_on_wp2_m1 & +! ) & +! + const_three_halves & +! * invrs_dzt * ( wp2**2 - wp2m1**2 ) + +! else + + ! Brian tried a new discretization for the turbulent advection term, + ! which contains the term: + ! - (1/rho_ds) * d [ rho_ds * a_1 * (w'^3)^2 / w'^2 ] / dz. In order + ! to help stabilize w'^3, a_1 has been pulled outside of the derivative. + ! This effects the right-hand side of the equation, as well as the + ! left-hand side. + + ! Additionally, the discretization of the turbulent advection term, which + ! contains the term: + ! - (1/rho_ds) * d [ rho_ds * (a_3 + 3) * (w'^2)^2 ] / dz, has been + ! altered to pull (a_3 + 3) outside of the derivative. This was done in + ! order to help stabilize w'^3. This effects the right-hand side of the + ! equation, as well as the left-hand side. + +! rhs & +! = + invrs_rho_ds_zt & +! * a3_zt * invrs_dzt & +! * ( rho_ds_zm * wp2**2 & +! - rho_ds_zmm1 * wp2m1**2 ) & +! + invrs_rho_ds_zt & +! * a1_zt * invrs_dzt & +! * ( rho_ds_zm & +! * ( wp3_zm * wp3_on_wp2 ) & +! - rho_ds_zmm1 & +! * ( wp3_zmm1 * wp3_on_wp2_m1 ) & +! ) & +! + const_three_halves & +! * invrs_dzt * ( wp2**2 - wp2m1**2 ) + + ! End of code that pulls out a3. + ! End of Brian's a1 change. Feb. 14, 2008. + +! endif ! l_standard_term_ta + + +! return +! end function wp3_terms_ta_tp_rhs + + !============================================================================= + pure function wp3_terms_bp1_pr2_rhs( C11_Skw_fnc, thv_ds_zt, wp2thvp ) & + result( rhs ) + + ! Description: + ! Buoyancy production of w'^3 and w'^3 pressure term 2: explicit portion of + ! the code. + ! + ! The d(w'^3)/dt equation contains a buoyancy production term: + ! + ! + 3 (g/thv_ds) w'^2th_v'; + ! + ! and pressure term 2: + ! + ! - C_11 ( -3 w'^3 dw/dz + 3 (g/thv_ds) w'^2th_v' ). + ! + ! The w'^3 buoyancy production term is completely explicit, while w'^3 + ! pressure term 2 has both implicit and explicit components. The buoyancy + ! production term and the explicit portion of pressure term 2 are combined + ! and solved together as: + ! + ! + ( 1 - C_ll ) ( 3 (g/thv_ds) w'^2th_v' ). + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & ! Constant(s) + grav ! Gravitational acceleration [m/s^2] + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C11_Skw_fnc, & ! C_11 parameter with Sk_w applied (k) [-] + thv_ds_zt, & ! Dry, base-state theta_v at thermo. lev. (k) [K] + wp2thvp ! w'^2th_v'(k) [K m^2/s^2] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = + ( 1.0_core_rknd - C11_Skw_fnc ) * 3.0_core_rknd * ( grav / thv_ds_zt ) * wp2thvp + + return + end function wp3_terms_bp1_pr2_rhs + + !============================================================================= + pure function wp3_term_bp2_rhs( C15, Kh_zt, wpthvp, wpthvp_m1, & + dum_dz, dum_dz_m1, dvm_dz, dvm_dz_m1, & + upwp, upwp_m1, vpwp, vpwp_m1, & + thv_ds_zt, invrs_dzt ) & + result( rhs ) + + ! Description: + ! Experimental term from CLUBB TRAC ticket #411. The derivative here is of + ! the form: + ! - C_15 * Kh * ∂{ grav / thv_ds * [w'th_v'(k) - w'th_v'(k-1)] + ! -[ u'w'(k) * ∂u(k)/∂z - u'w'(k-1) * ∂u(k-1)/∂z ] + ! -[ v'w'(k) * ∂v(k)/∂z - v'w'(k-1) * ∂v(k-1)/∂z ] }/∂z. + ! + ! This does not appear in Andre et al. 1976 or Bougeault et al. 1981, but + ! is based on experiments in matching LES data. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & ! Constant(s) + grav ! Gravitational acceleration [m/s^2] + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C15, & ! Model parameter C15 [-] + Kh_zt, & ! Eddy-diffusivity on moment. levels [m^2/s] + wpthvp, & ! w'th_v'(k) [K m/s] + wpthvp_m1, & ! w'th_v'(k-1) [K m/s] + dum_dz, & ! d u wind dz (k) [m/s] + dvm_dz, & ! d v wind dz (k) [m/s] + dum_dz_m1, & ! d u wind dz (k-1) [m/s] + dvm_dz_m1, & ! d v wind dz (k-1) [m/s] + upwp, & ! u'v'(k) [m^2/s^2] + upwp_m1, & ! u'v'(k-1) [m^2/s^2] + vpwp, & ! v'w'(k) [m^2/s^2] + vpwp_m1, & ! v'w'(k-1) [m^2/s^2] + thv_ds_zt, & ! Dry, base-state theta_v at thermo. lev. (k) [K] + invrs_dzt ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + ! ---- Begin Code ---- + +! rhs = - C15 * Kh_zt * invrs_dzt * grav / thv_ds_zt * ( wpthvp - wpthvp_m1 ) + + rhs = - C15 * Kh_zt * invrs_dzt * & + ( grav / thv_ds_zt * ( wpthvp - wpthvp_m1 ) & + - ( upwp * dum_dz - upwp_m1 * dum_dz_m1 ) & + - ( vpwp * dvm_dz - vpwp_m1 * dvm_dz_m1 ) ) + + return + end function wp3_term_bp2_rhs + + + !============================================================================= + pure function wp3_term_pr1_rhs( C8, C8b, tauw3t, Skw_zt, wp3 ) & + result( rhs ) + + ! Description: + ! Pressure term 1 for w'^3: explicit portion of the code. + ! + ! Pressure term 1 is the term: + ! + ! - (C_8/tau_w3t) * ( C_8b * Sk_wt^4 + 1 ) * w'^3; + ! + ! where Sk_wt = w'^3 / (w'^2)^(3/2). + ! + ! This term needs to be linearized, so function L(w'^3) is defined to be + ! equal to this term (pressure term 1), such that: + ! + ! L(w'^3) = - (C_8/tau_w3t) * ( C_8b * (w'^3)^5 / (w'^2)^6 + w'^3 ). + ! + ! A Taylor Series expansion (truncated after the first derivative term) of + ! L(w'^3) around w'^3 = w'^3(t) is used to linearize pressure term 1. + ! Evaluating L(w'^3) at w'^3(t+1): + ! + ! L( w'^3(t+1) ) = L( w'^3(t) ) + ! + ( d L(w'^3) / d w'^3 )|_(w'^3=w'^3(t)) + ! * ( w'^3(t+1) - w'^3(t) ). + ! + ! After evaluating the expression above, the term has become linearized. It + ! is broken down into implicit (LHS) and explicit (RHS) components. + ! The explicit portion is: + ! + ! + (C_8/tau_w3t) * ( 4 * C_8b * Sk_wt^4 + 1 ) * w'^3(t). + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(w'^3)/dt equation. + ! + ! The values of w'^3 are found on the thermodynamic levels, as are the + ! values of tau_w3t and Sk_wt (in Sk_wt, w'^3 is found on thermodynamic + ! levels and w'^2 is interpolated to thermodynamic levels). + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C8, & ! Model parameter C_8 [-] + C8b, & ! Model parameter C_8b [-] + tauw3t, & ! Time-scale tau at thermodynamic levels (k) [s] + Skw_zt, & ! Skewness of w at thermodynamic levels (k) [-] + wp3 ! w'^3(k) [m^3/s^3] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = + ( C8 / tauw3t ) * ( 4.0_core_rknd * C8b * Skw_zt**4 ) * wp3 + + return + end function wp3_term_pr1_rhs + +!=============================================================================== + +end module advance_wp2_wp3_module diff --git a/src/physics/clubb/advance_xm_wpxp_module.F90 b/src/physics/clubb/advance_xm_wpxp_module.F90 new file mode 100644 index 0000000000..a6d7c1bcb4 --- /dev/null +++ b/src/physics/clubb/advance_xm_wpxp_module.F90 @@ -0,0 +1,3563 @@ +!----------------------------------------------------------------------- +! $Id: advance_xm_wpxp_module.F90 7373 2014-11-08 00:44:20Z dschanen@uwm.edu $ +!=============================================================================== +module advance_xm_wpxp_module + + ! Description: + ! Contains the CLUBB advance_xm_wpxp_module scheme. + + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + private ! Default scope + + public :: advance_xm_wpxp + + private :: xm_wpxp_lhs, & + xm_wpxp_rhs, & + xm_wpxp_solve, & + xm_wpxp_clipping_and_stats, & + xm_term_ta_lhs, & + wpxp_term_ta_lhs, & + wpxp_term_tp_lhs, & + wpxp_terms_ac_pr2_lhs, & + wpxp_term_pr1_lhs, & + wpxp_terms_bp_pr3_rhs, & + xm_correction_wpxp_cl, & + damp_coefficient + + ! Parameter Constants + integer, parameter, private :: & + nsub = 2, & ! Number of subdiagonals in the LHS matrix + nsup = 2, & ! Number of superdiagonals in the LHS matrix + xm_wpxp_thlm = 1, & ! Named constant for thlm solving + xm_wpxp_rtm = 2, & ! Named constant for rtm solving + xm_wpxp_scalar = 3 ! Named constant for scalar solving + + contains + + !============================================================================= + subroutine advance_xm_wpxp( dt, sigma_sqd_w, um, vm, wm_zm, wm_zt, wp2, & + Lscale, wp3_on_wp2, wp3_on_wp2_zt, Kh_zt, Kh_zm, & + tau_C6_zm, Skw_zm, rtpthvp, rtm_forcing, & + wprtp_forcing, rtm_ref, thlpthvp, & + thlm_forcing, wpthlp_forcing, thlm_ref, & + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, thv_ds_zm, rtp2, thlp2, & + w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, l_implemented, em, & + sclrpthvp, sclrm_forcing, sclrp2, exner, rcm, & + p_in_Pa, cloud_frac, & + rtm, wprtp, thlm, wpthlp, & + err_code, & + sclrm, wpsclrp ) + + ! Description: + ! Advance the mean and flux terms by one timestep. + + ! References: + ! Eqn. 16 & 17 on p. 3546 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + + ! See Also + ! ``Equations for CLUBB'' Section 5: + ! /Implicit solutions for the means and fluxes/ + !----------------------------------------------------------------------- + + use parameters_tunable, only: & + C6rt, & ! Variable(s) + C6rtb, & + C6rtc, & + C6thl, & + C6thlb, & + C6thlc, & + C7, & + C7b, & + C7c, & + c_K6, & + C6rt_Lscale0, & + C6thl_Lscale0, & + C7_Lscale0, & + wpxp_L_thresh + + use constants_clubb, only: & + fstderr, & ! Constant + rt_tol, & + thl_tol, & + thl_tol_mfl, & + rt_tol_mfl, & + max_mag_correlation, & + one, & + one_half, & + zero, & + zero_threshold + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + sclr_tol + + use grid_class, only: & + gr ! Variable(s) + + use grid_class, only: & + zm2zt, & ! Procedure(s) + zt2zm + + use model_flags, only: & + l_clip_semi_implicit, & ! Variable(s) + l_use_C7_Richardson + + use mono_flux_limiter, only: & + calc_turb_adv_range ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + report_error, & + fatal_error + + use error_code, only: & + clubb_var_out_of_range ! Constant(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_end_update, & + stat_update_var + + use stats_variables, only: & + stats_zt, & + stats_zm, & + irtm_matrix_condt_num, & ! Variables + ithlm_matrix_condt_num, & + irtm_sdmp, ithlm_sdmp, & + l_stats_samp, & + iC7_Skw_fnc, & + iC6rt_Skw_fnc, & + iC6thl_Skw_fnc, & + l_stats_samp + + use sponge_layer_damping, only: & + rtm_sponge_damp_settings, & + thlm_sponge_damp_settings, & + rtm_sponge_damp_profile, & + thlm_sponge_damp_profile, & + sponge_damp_xm ! Procedure(s) + + implicit none + + ! External + intrinsic :: exp, sqrt + + ! Parameter Constants + logical, parameter :: & + l_iter = .true. ! True when the means and fluxes are prognosed + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + sigma_sqd_w, & ! sigma_sqd_w on momentum levels [-] + um, & ! u mean wind component (thermodynamic levels) [m/s] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s] + wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s] + Kh_zt, & ! Eddy diffusivity on thermodynamic levels [m^2/s] + Kh_zm, & ! Eddy diffusivity on momentum levels + tau_C6_zm, & ! Time-scale tau on momentum levels applied to C6 term [s] + Skw_zm, & ! Skewness of w on momentum levels [-] + rtpthvp, & ! r_t'th_v' (momentum levels) [(kg/kg) K] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + wprtp_forcing, & ! forcing (momentum levels) [(kg/kg)/s^2] + rtm_ref, & ! rtm for nudging [kg/kg] + thlpthvp, & ! th_l'th_v' (momentum levels) [K^2] + thlm_forcing, & ! th_l forcing (thermodynamic levels) [K/s] + wpthlp_forcing, & ! forcing (momentum levels) [K/s^2] + thlm_ref, & ! thlm for nudging [K] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on moment. levs. [K] + ! Added for clipping by Vince Larson 29 Sep 2007 + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + ! End of Vince Larson's addition. + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + + ! Additional variables for passive scalars + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrpthvp, sclrm_forcing, & ! [Units vary] + sclrp2 ! For clipping Vince Larson [Units vary] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + exner, & ! Exner function [-] + rcm, & ! cloud water mixing ratio, r_c [kg/kg] + p_in_Pa, & ! Air pressure [Pa] + cloud_frac ! Cloud fraction [-] + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + rtm, & ! r_t (total water mixing ratio) [kg/kg] + wprtp, & ! w'r_t' [(kg/kg) m/s] + thlm, & ! th_l (liquid water potential temperature) [K] + wpthlp ! w'th_l' [K m/s] + + integer, intent(inout) :: err_code ! Error code for the model's status + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & + sclrm, wpsclrp ! [Units vary] + + ! Local variables + real( kind = core_rknd ), dimension(nsup+nsub+1,2*gr%nz) :: & + lhs ! Implicit contributions to wpxp/xm (band diag. matrix) (LAPACK) + + real( kind = core_rknd ), dimension(gr%nz) :: & + C6rt_Skw_fnc, C6thl_Skw_fnc, C7_Skw_fnc + + ! Eddy Diffusion for wpthlp and wprtp. + real( kind = core_rknd ), dimension(gr%nz) :: Kw6 ! wpxp eddy diff. [m^2/s] + + real( kind = core_rknd ), dimension(gr%nz) :: & + a1, & ! a_1 (momentum levels); See eqn. 24 in `Equations for CLUBB' [-] + a1_zt ! a_1 interpolated to thermodynamic levels [-] + + ! Variables used as part of the monotonic turbulent advection scheme. + ! Find the lowermost and uppermost grid levels that can have an effect + ! on the central thermodynamic level during the course of a time step, + ! due to the effects of turbulent advection only. + integer, dimension(gr%nz) :: & + low_lev_effect, & ! Index of the lowest level that has an effect. + high_lev_effect ! Index of the highest level that has an effect. + + ! Variables used for clipping of w'x' due to correlation + ! of w with x, such that: + ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ]; + ! -1 <= corr_(w,x) <= 1. + real( kind = core_rknd ), dimension(gr%nz) :: & + wpxp_upper_lim, & ! Keeps correlations from becoming greater than 1. + wpxp_lower_lim ! Keeps correlations from becoming less than -1. + + real( kind = core_rknd ), dimension(gr%nz) :: dummy_1d ! Unreferenced array + + real( kind = core_rknd ), allocatable, dimension(:,:) :: & + rhs, &! Right-hand sides of band diag. matrix. (LAPACK) + solution ! solution vectors of band diag. matrix. (LAPACK) + + ! Constant parameters as a function of Skw. + + integer :: & + nrhs, & ! Number of RHS vectors + err_code_xm_wpxp ! Error code + + real( kind = core_rknd ) :: rcond + + ! Indices + integer :: i + + !--------------------------------------------------------------------------- + + ! ----- Begin Code ----- + if ( l_clip_semi_implicit ) then + nrhs = 1 + else + nrhs = 2+sclr_dim + endif + + ! Allocate rhs and solution vector + allocate( rhs(2*gr%nz,nrhs) ) + allocate( solution(2*gr%nz,nrhs) ) + + ! This is initialized solely for the purpose of avoiding a compiler + ! warning about uninitialized variables. + dummy_1d = zero + + ! Compute C6 and C7 as a function of Skw + ! The if...then is just here to save compute time + if ( C6rt /= C6rtb ) then + C6rt_Skw_fnc(1:gr%nz) = C6rtb + (C6rt-C6rtb) & + *EXP( -one_half * (Skw_zm(1:gr%nz)/C6rtc)**2 ) + else + C6rt_Skw_fnc(1:gr%nz) = C6rtb + endif + + if ( C6thl /= C6thlb ) then + C6thl_Skw_fnc(1:gr%nz) = C6thlb + (C6thl-C6thlb) & + *EXP( -one_half * (Skw_zm(1:gr%nz)/C6thlc)**2 ) + else + C6thl_Skw_fnc(1:gr%nz) = C6thlb + endif + + ! Compute C7_Skw_fnc + if ( l_use_C7_Richardson ) then + ! New formulation based on Richardson number + C7_Skw_fnc = compute_C7_Skw_fnc_Richardson( thlm, um, vm, em, Lscale, exner, rtm, & + rcm, p_in_Pa, cloud_frac, rho_ds_zm ) + else + if ( C7 /= C7b ) then + C7_Skw_fnc(1:gr%nz) = C7b + (C7-C7b) & + *EXP( -one_half * (Skw_zm(1:gr%nz)/C7c)**2 ) + else + C7_Skw_fnc(1:gr%nz) = C7b + endif + + ! Damp C7 as a function of Lscale in stably stratified regions + C7_Skw_fnc = damp_coefficient( C7, C7_Skw_fnc, & + C7_Lscale0, wpxp_L_thresh, Lscale ) + end if ! l_use_C7_Richardson + + ! Damp C6 as a function of Lscale in stably stratified regions + C6rt_Skw_fnc = damp_coefficient( C6rt, C6rt_Skw_fnc, & + C6rt_Lscale0, wpxp_L_thresh, Lscale ) + C6thl_Skw_fnc = damp_coefficient( C6thl, C6thl_Skw_fnc, & + C6thl_Lscale0, wpxp_L_thresh, Lscale ) + + ! C6rt_Skw_fnc = C6rt + ! C6thl_Skw_fnc = C6thl + ! C7_Skw_fnc = C7 + + if ( l_stats_samp ) then + + call stat_update_var( iC7_Skw_fnc, C7_Skw_fnc, stats_zm ) + call stat_update_var( iC6rt_Skw_fnc, C6rt_Skw_fnc, stats_zm ) + call stat_update_var( iC6thl_Skw_fnc, C6thl_Skw_fnc, stats_zm ) + + end if + + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C7_Skw_fnc + if ( any( C7_Skw_fnc(:) > one ) .or. any( C7_Skw_fnc(:) < zero ) ) then + write(fstderr,*) "The C7_Skw_fnc variable is outside the valid range" + err_code = clubb_var_out_of_range + return + end if + end if + + ! Define the Coefficent of Eddy Diffusivity for the wpthlp and wprtp. + ! Kw6 is used for wpthlp and wprtp, which are located on momentum levels. + ! Kw6 is located on thermodynamic levels. + ! Kw6 = c_K6 * Kh_zt + + Kw6(1:gr%nz) = c_K6 * Kh_zt(1:gr%nz) + + ! Find the number of grid levels, both upwards and downwards, that can + ! have an effect on the central thermodynamic level during the course of + ! one time step due to turbulent advection. This is used as part of the + ! monotonic turbulent advection scheme. + call calc_turb_adv_range( dt, w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! In + mixt_frac_zm, & ! In + low_lev_effect, high_lev_effect ) ! Out + + + ! Define a_1 (located on momentum levels). + ! It is a variable that is a function of sigma_sqd_w (where sigma_sqd_w is + ! located on momentum levels). + a1(1:gr%nz) = one / ( one - sigma_sqd_w(1:gr%nz) ) + + ! Interpolate a_1 from momentum levels to thermodynamic levels. This will + ! be used for the w'x' turbulent advection (ta) term. + a1_zt = max( zm2zt( a1 ), zero_threshold ) ! Positive definite quantity + + ! Setup and decompose matrix for each variable. + + if ( l_clip_semi_implicit ) then + + ! Compute the upper and lower limits of w'r_t' at every level, + ! based on the correlation of w and r_t, such that: + ! corr_(w,r_t) = w'r_t' / [ sqrt(w'^2) * sqrt(r_t'^2) ]; + ! -1 <= corr_(w,r_t) <= 1. + if ( l_clip_semi_implicit ) then + wpxp_upper_lim = max_mag_correlation * sqrt( wp2 * rtp2 ) + wpxp_lower_lim = -wpxp_upper_lim + endif + + ! Compute the implicit portion of the r_t and w'r_t' equations. + ! Build the left-hand side matrix. + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wprtp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) + C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, exner, rtm, rcm, p_in_Pa, cloud_frac, & ! Intent(in) + lhs ) ! Intent(out) + + ! Compute the explicit portion of the r_t and w'r_t' equations. + ! Build the right-hand side vector. + call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) + rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! Intent(in) + rtpthvp, C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) + + ! Solve r_t / w'r_t' + if ( l_stats_samp .and. irtm_matrix_condt_num > 0 ) then + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp, rcond ) ! Intent(out) + else + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp ) ! Intent(out) + endif + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "Mean total water & total water flux LU decomp. failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_rtm, dt, wp2, rtp2, wm_zt, & ! Intent(in) + rtm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + rt_tol**2, rt_tol, rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,1), & ! Intent(in) + rtm, rt_tol_mfl, wprtp, & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "rtm monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + + ! Compute the upper and lower limits of w'th_l' at every level, + ! based on the correlation of w and th_l, such that: + ! corr_(w,th_l) = w'th_l' / [ sqrt(w'^2) * sqrt(th_l'^2) ]; + ! -1 <= corr_(w,th_l) <= 1. + if ( l_clip_semi_implicit ) then + wpxp_upper_lim = max_mag_correlation * sqrt( wp2 * thlp2 ) + wpxp_lower_lim = -wpxp_upper_lim + endif + + ! Compute the implicit portion of the th_l and w'th_l' equations. + ! Build the left-hand side matrix. + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wpthlp, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) + C6thl_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, exner, rtm, rcm, p_in_Pa, cloud_frac, & ! Intent(in) + lhs ) ! Intent(out) + + ! Compute the explicit portion of the th_l and w'th_l' equations. + ! Build the right-hand side vector. + call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) + thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! Intent(in) + thlpthvp, C6thl_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) + + ! Solve for th_l / w'th_l' + if ( l_stats_samp .and. ithlm_matrix_condt_num > 0 ) then + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp, rcond ) ! Intent(out) + else + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp ) ! Intent(out) + endif + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "Liquid pot. temp & thetal flux LU decomp. failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_thlm, dt, wp2, thlp2, wm_zt, & ! Intent(in) + thlm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + thl_tol**2, thl_tol, rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,1), & ! Intent(in) + thlm, thl_tol_mfl, wpthlp, & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "thlm monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + ! Solve sclrm / wpsclrp + ! If sclr_dim is 0, then this loop will execute 0 times. +! ---> h1g, 2010-06-15 +! scalar transport, e.g, droplet and ice number concentration +! are handled in " advance_sclrm_Nd_module.F90 " +#ifdef GFDL + do i = 1, 0, 1 +#else + do i = 1, sclr_dim, 1 +#endif +! <--- h1g, 2010-06-15 + + ! Compute the upper and lower limits of w'sclr' at every level, + ! based on the correlation of w and sclr, such that: + ! corr_(w,sclr) = w'sclr' / [ sqrt(w'^2) * sqrt(sclr'^2) ]; + ! -1 <= corr_(w,sclr) <= 1. + if ( l_clip_semi_implicit ) then + wpxp_upper_lim(:) = max_mag_correlation * sqrt( wp2(:) * sclrp2(:,i) ) + wpxp_lower_lim(:) = -wpxp_upper_lim(:) + endif + + ! Compute the implicit portion of the sclr and w'sclr' equations. + ! Build the left-hand side matrix. + call xm_wpxp_lhs( l_iter, dt, Kh_zm, wpsclrp(:,i), a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) + C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, l_implemented, & ! Intent(in) + em, Lscale, thlm, exner, rtm, rcm, p_in_Pa, cloud_frac, & ! Intent(in) + lhs ) ! Intent(out) + + ! Compute the explicit portion of the sclrm and w'sclr' equations. + ! Build the right-hand side vector. + call xm_wpxp_rhs( xm_wpxp_scalar, l_iter, dt, sclrm(:,i), wpsclrp(:,i), & ! Intent(in) + sclrm_forcing(:,i), dummy_1d, C7_Skw_fnc, & ! Intent(in) + sclrpthvp(:,i), C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) + + ! Solve for sclrm / w'sclr' + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "Passive scalar # ", i, " LU decomp. failed." + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_scalar, dt, wp2, sclrp2(:,i), & ! Intent(in) + wm_zt, sclrm_forcing(:,i), & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + sclr_tol(i)**2, sclr_tol(i), rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,1), & ! Intent(in) + sclrm(:,i), sclr_tol(i), wpsclrp(:,i), & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "sclrm # ", i, "monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + enddo ! passive scalars + + else ! Simple case, where l_clip_semi_implicit is false + + ! Create the lhs once + call xm_wpxp_lhs( l_iter, dt, Kh_zm, dummy_1d, a1, a1_zt, wm_zm, wm_zt, & ! Intent(in) + wp2, wp3_on_wp2, wp3_on_wp2_zt, & ! Intent(in) + Kw6, tau_C6_zm, C7_Skw_fnc, & ! Intent(in) + C6rt_Skw_fnc, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + dummy_1d, dummy_1d, l_implemented, & ! Intent(in) + em, Lscale, thlm, exner, rtm, rcm, p_in_Pa, cloud_frac, & ! Intent(in) + lhs ) ! Intent(out) + + ! Compute the explicit portion of the r_t and w'r_t' equations. + ! Build the right-hand side vector. + call xm_wpxp_rhs( xm_wpxp_rtm, l_iter, dt, rtm, wprtp, & ! Intent(in) + rtm_forcing, wprtp_forcing, C7_Skw_fnc, & ! Intent(in) + rtpthvp, C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,1) ) ! Intent(out) + + ! Compute the explicit portion of the th_l and w'th_l' equations. + ! Build the right-hand side vector. + call xm_wpxp_rhs( xm_wpxp_thlm, l_iter, dt, thlm, wpthlp, & ! Intent(in) + thlm_forcing, wpthlp_forcing, C7_Skw_fnc, & ! Intent(in) + thlpthvp, C6thl_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,2) ) ! Intent(out) + +! ---> h1g, 2010-06-15 +! scalar transport, e.g, droplet and ice number concentration +! are handled in " advance_sclrm_Nd_module.F90 " +#ifdef GFDL + do i = 1, 0, 1 +#else + do i = 1, sclr_dim, 1 +#endif +! <--- h1g, 2010-06-15 + + call xm_wpxp_rhs( xm_wpxp_scalar, l_iter, dt, sclrm(:,i), wpsclrp(:,i), & ! Intent(in) + sclrm_forcing(:,i), dummy_1d, C7_Skw_fnc, & ! Intent(in) + sclrpthvp(:,i), C6rt_Skw_fnc, tau_C6_zm, a1, a1_zt, & ! Intent(in) + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & ! Intent(in) + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & ! Intent(in) + wpxp_upper_lim, wpxp_lower_lim, & ! Intent(in) + rhs(:,2+i) ) ! Intent(out) + + enddo + + ! Solve for all fields + if ( l_stats_samp .and. ithlm_matrix_condt_num + irtm_matrix_condt_num > 0 ) then + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp, rcond ) ! Intent(out) + else + call xm_wpxp_solve( nrhs, & ! Intent(in) + lhs, rhs, & ! Intent(inout) + solution, err_code_xm_wpxp ) ! Intent(out) + endif + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "xm_wpxp matrix LU decomp. failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_rtm, dt, wp2, rtp2, wm_zt, & ! Intent(in) + rtm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + rt_tol**2, rt_tol, rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,1), & ! Intent(in) + rtm, rt_tol_mfl, wprtp, & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "rtm monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_thlm, dt, wp2, thlp2, wm_zt, & ! Intent(in) + thlm_forcing, rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + thl_tol**2, thl_tol, rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,2), & ! Intent(in) + thlm, thl_tol_mfl, wpthlp, & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,'(a)') "thlm monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + +! ---> h1g, 2010-06-15 +! scalar transport, e.g, droplet and ice number concentration +! are handled in " advance_sclrm_Nd_module.F90 " +#ifdef GFDL + do i = 1, 0, 1 +#else + do i = 1, sclr_dim, 1 +#endif +! <--- h1g, 2010-06-15 + + call xm_wpxp_clipping_and_stats & + ( xm_wpxp_scalar, dt, wp2, sclrp2(:,i), & ! Intent(in) + wm_zt, sclrm_forcing(:,i), & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + invrs_rho_ds_zm, invrs_rho_ds_zt, & ! Intent(in) + sclr_tol(i)**2, sclr_tol(i), rcond, & ! Intent(in) + low_lev_effect, high_lev_effect, & ! Intent(in) + l_implemented, solution(:,2+i), & ! Intent(in) + sclrm(:,i), sclr_tol(i), wpsclrp(:,i), & ! Intent(inout) + err_code_xm_wpxp ) ! Intent(out) + + if ( fatal_error( err_code_xm_wpxp ) ) then + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "sclrm # ", i, "monotonic flux limiter: tridag failed" + call report_error( err_code_xm_wpxp ) + end if + + ! Overwrite the current error status with the new fatal error + err_code = err_code_xm_wpxp + + end if + + end do ! 1..sclr_dim + + end if ! l_clip_semi_implicit + + ! De-allocate memory + deallocate( rhs, solution ) + + ! Error Report + ! Joshua Fasching Feb 2008 + if ( fatal_error( err_code ) .and. clubb_at_least_debug_level( 1 ) ) then + + write(fstderr,*) "Error in advance_xm_wpxp" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "dt = ", dt + write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w + write(fstderr,*) "wm_zm = ", wm_zm + write(fstderr,*) "wm_zt = ", wm_zt + write(fstderr,*) "wp2 = ", wp2 + write(fstderr,*) "wp3_on_wp2 = ", wp3_on_wp2 + write(fstderr,*) "wp3_on_wp2_zt = ", wp3_on_wp2_zt + write(fstderr,*) "Kh_zt = ", Kh_zt + write(fstderr,*) "tau_C6_zm = ", tau_C6_zm + write(fstderr,*) "Skw_zm = ", Skw_zm + write(fstderr,*) "rtpthvp = ", rtpthvp + write(fstderr,*) "rtm_forcing = ", rtm_forcing + write(fstderr,*) "wprtp_forcing = ", wprtp_forcing + write(fstderr,*) "rtm_ref = ", rtm_ref + write(fstderr,*) "thlpthvp = ", thlpthvp + write(fstderr,*) "thlm_forcing = ", thlm_forcing + write(fstderr,*) "wpthlp_forcing = ", wpthlp_forcing + write(fstderr,*) "thlm_ref = ", thlm_ref + write(fstderr,*) "rho_ds_zm = ", rho_ds_zm + write(fstderr,*) "rho_ds_zt = ", rho_ds_zt + write(fstderr,*) "invrs_rho_ds_zm = ", invrs_rho_ds_zm + write(fstderr,*) "invrs_rho_ds_zt = ", invrs_rho_ds_zt + write(fstderr,*) "thv_ds_zm = ", thv_ds_zm + write(fstderr,*) "rtp2 = ", rtp2 + write(fstderr,*) "thlp2 = ", thlp2 + write(fstderr,*) "w_1_zm = ", w_1_zm + write(fstderr,*) "w_2_zm = ", w_2_zm + write(fstderr,*) "varnce_w_1_zm = ", varnce_w_1_zm + write(fstderr,*) "varnce_w_2_zm = ", varnce_w_2_zm + write(fstderr,*) "mixt_frac_zm = ", mixt_frac_zm + write(fstderr,*) "l_implemented = ", l_implemented + + if ( sclr_dim > 0 ) then + write(fstderr,*) "sclrp2 = ", sclrp2 + write(fstderr,*) "sclrpthvp = ", sclrpthvp + write(fstderr,*) "sclrm_forcing = ", sclrm_forcing + end if + + write(fstderr,*) "Intent(inout)" + + write(fstderr,*) "rtm = ", rtm + write(fstderr,*) "wprtp = ", wprtp + write(fstderr,*) "thlm = ", thlm + write(fstderr,*) "wpthlp =", wpthlp + + if ( sclr_dim > 0 ) then + write(fstderr,*) "sclrm = ", sclrm + write(fstderr,*) "wpsclrp = ", wpsclrp + end if + + end if ! Fatal error and debug_level >= 1 + + if ( rtm_sponge_damp_settings%l_sponge_damping ) then + if( l_stats_samp ) then + call stat_begin_update( irtm_sdmp, rtm / dt, stats_zt ) + end if + + rtm(1:gr%nz) = sponge_damp_xm( dt, rtm_ref(1:gr%nz), rtm(1:gr%nz), & + rtm_sponge_damp_profile ) + + if( l_stats_samp ) then + call stat_end_update( irtm_sdmp, rtm / dt, stats_zt ) + end if + endif + + if ( thlm_sponge_damp_settings%l_sponge_damping ) then + if( l_stats_samp ) then + call stat_begin_update( ithlm_sdmp, thlm / dt, stats_zt ) + end if + thlm(1:gr%nz) = sponge_damp_xm( dt, thlm_ref(1:gr%nz), thlm(1:gr%nz), & + thlm_sponge_damp_profile ) + if( l_stats_samp ) then + call stat_end_update( ithlm_sdmp, thlm / dt, stats_zt ) + end if + endif + + return + + end subroutine advance_xm_wpxp + + !============================================================================= + subroutine xm_wpxp_lhs( l_iter, dt, Kh_zm, wpxp, a1, a1_zt, wm_zm, wm_zt, & + wp2, wp3_on_wp2, wp3_on_wp2_zt, & + Kw6, tau_C6_zm, C7_Skw_fnc, & + C6x_Skw_fnc, rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, & + wpxp_upper_lim, wpxp_lower_lim, l_implemented, & + em, Lscale, thlm, exner, rtm, rcm, p_in_Pa, cloud_frac, & + lhs ) + + ! Description: + ! Compute LHS band diagonal matrix for xm and w'x'. + ! This subroutine computes the implicit portion of + ! the xm and w'x' equations. + + ! References: + ! None + !------------------------------------------------------------------------ + + use parameters_tunable, only: & + nu6_vert_res_dep ! Variable(s) + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + ddzt + + use constants_clubb, only: & + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero + + use model_flags, only: & + l_clip_semi_implicit, & ! Variable(s) + l_upwind_wpxp_ta, & + l_diffuse_rtm_and_thlm, & + l_stability_correct_Kh_N2_zm + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use diffusion, only: & + diffusion_zt_lhs, &! Procedure(s) + diffusion_zm_lhs + + use mean_adv, only: & + term_ma_zt_lhs, & ! Procedure(s) + term_ma_zm_lhs + + use clip_semi_implicit, only: & + clip_semi_imp_lhs ! Procedure(s) + + use stats_variables, only: & + ztscr01, & ! Variable(s) + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15 + + use stats_variables, only: & + l_stats_samp, & + ithlm_ma, & + ithlm_ta, & + irtm_ma, & + irtm_ta, & + iwpthlp_ma, & + iwpthlp_ta, & + iwpthlp_tp, & + iwpthlp_ac, & + iwpthlp_pr1, & + iwpthlp_pr2, & + iwpthlp_dp1, & + iwpthlp_sicl, & + iwprtp_ma, & + iwprtp_ta, & + iwprtp_tp, & + iwprtp_ac, & + iwprtp_pr1, & + iwprtp_pr2, & + iwprtp_dp1, & + iwprtp_sicl + + use advance_helper_module, only: & + set_boundary_conditions_lhs, & ! Procedure(s) + calc_stability_correction + + implicit none + + ! External + intrinsic :: min, max + + ! Constant parameters + ! Left-hand side matrix diagonal identifiers for + ! momentum-level variable, w'x'. + integer, parameter :: & + m_kp1_mdiag = 1, & ! Momentum superdiagonal index for w'x'. + m_kp1_tdiag = 2, & ! Thermodynamic superdiagonal index for w'x'. + m_k_mdiag = 3, & ! Momentum main diagonal index for w'x'. + m_k_tdiag = 4, & ! Thermodynamic subdiagonal index for w'x'. + m_km1_mdiag = 5 ! Momentum subdiagonal index for w'x'. + + ! Left-hand side matrix diagonal identifiers for + ! thermodynamic-level variable, xm. + integer, parameter :: & + t_kp1_tdiag = 1, & ! Thermodynamic superdiagonal index for xm. + t_k_mdiag = 2, & ! Momentum superdiagonal index for xm. + t_k_tdiag = 3, & ! Thermodynamic main diagonal index for xm. + t_km1_mdiag = 4, & ! Momentum subdiagonal index for xm. + t_km1_tdiag = 5 ! Thermodynamic subdiagonal index for xm. + + ! Input variables + logical, intent(in) :: l_iter + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + wpxp, & ! w'x' (momentum levels) at timestep (t) [{xm units} m/s] + Kh_zm, & ! Eddy diffusivity on momentum levels [m^2/s] + a1, & ! a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + Lscale, & ! Turbulent mixing length [m] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + thlm, & ! th_l (thermo. levels) [K] + exner, & ! Exner function [-] + rtm, & ! total water mixing ratio, r_t [-] + rcm, & ! cloud water mixing ratio, r_c [kg/kg] + p_in_Pa, & ! Air pressure [Pa] + cloud_frac, & ! Cloud fraction [-] + wm_zm, & ! w wind component on momentum levels [m/s] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3_on_wp2, & ! Smoothed wp3 / wp2 on momentum levels [m/s] + wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s] + Kw6, & ! Coefficient of eddy diffusivity for w'x' [m^2/s] + tau_C6_zm, & ! Time-scale tau on momentum levels applied to the C6 term [s] + C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-] + C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + wpxp_upper_lim, & ! Keeps correlations from becoming > 1. [units vary] + wpxp_lower_lim ! Keeps correlations from becoming < -1. [units vary] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + ! Output Variable + real( kind = core_rknd ), intent(out), dimension(nsup+nsub+1,2*gr%nz) :: & + lhs ! Implicit contributions to wpxp/xm (band diag. matrix) (LAPACK) + + ! Local Variables + + ! Indices + integer :: k, kp1, km1 + integer :: k_xm, k_wpxp + integer :: k_wpxp_low, k_wpxp_high + + real( kind = core_rknd ), dimension(3) :: tmp + + logical :: l_upper_thresh, l_lower_thresh ! flags for clip_semi_imp_lhs + + ! These variables are used to change the amount + ! of diffusion applied towards rtm and thlm. They are only used when + ! l_diffuse_rtm_and_thlm = .true. + real (kind = core_rknd), dimension(gr%nz) :: & + zero_nu, & + Kh_N2_zm + + real (kind = core_rknd) :: & + constant_nu ! controls the magnitude of diffusion + + ! Setting up variables used for diffusion + zero_nu = 0.0_core_rknd + constant_nu = 0.1_core_rknd + + if ( l_stability_correct_Kh_N2_zm ) then + Kh_N2_zm = Kh_zm / calc_stability_correction( thlm, Lscale, em, exner, rtm, rcm, & + p_in_Pa, cloud_frac ) + else + Kh_N2_zm = Kh_zm + end if + + ! Initialize the left-hand side matrix to 0. + lhs = zero + + ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at + ! level k = 1, which is below the model surface, is simply set equal to the + ! value of xm at level k = 2 after the solve has been completed. + + do k = 2, gr%nz, 1 + + ! Define indices + + km1 = max( k-1, 1 ) + + k_xm = 2*k - 1 + ! k_wpxp is 2*k + + if ( l_diffuse_rtm_and_thlm ) then + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if + + !!!!!***** xm *****!!!!! + + ! xm: Left-hand side (implicit xm portion of the code). + ! + ! Thermodynamic subdiagonal (lhs index: t_km1_tdiag) + ! [ x xm(k-1,) ] + ! Momentum subdiagonal (lhs index: t_km1_mdiag) + ! [ x wpxp(k-1,) ] + ! Thermodynamic main diagonal (lhs index: t_k_tdiag) + ! [ x xm(k,) ] + ! Momentum superdiagonal (lhs index: t_k_mdiag) + ! [ x wpxp(k,) ] + ! Thermodynamic superdiagonal (lhs index: t_kp1_tdiag) + ! [ x xm(k+1,) ] + + ! LHS mean advection (ma) term. + if ( .not. l_implemented ) then + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + + else + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k_xm) + zero + + endif + + ! LHS turbulent advection (ta) term. + lhs((/t_k_mdiag,t_km1_mdiag/),k_xm) & + = lhs((/t_k_mdiag,t_km1_mdiag/),k_xm) & + + xm_term_ta_lhs( rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), gr%invrs_dzt(k) ) + + ! LHS time tendency. + lhs(t_k_tdiag,k_xm) & + = lhs(t_k_tdiag,k_xm) + one / dt + + if (l_stats_samp) then + + ! Statistics: implicit contributions for rtm or thlm. + + if ( irtm_ma > 0 .or. ithlm_ma > 0 ) then + if ( .not. l_implemented ) then + tmp(1:3) = & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + ztscr01(k) = - tmp(3) + ztscr02(k) = - tmp(2) + ztscr03(k) = - tmp(1) + else + ztscr01(k) = zero + ztscr02(k) = zero + ztscr03(k) = zero + endif + endif + + if ( irtm_ta > 0 .or. ithlm_ta > 0 ) then + tmp(1:2) = & + + xm_term_ta_lhs( rho_ds_zm(k), rho_ds_zm(km1), & + invrs_rho_ds_zt(k), gr%invrs_dzt(k) ) + ztscr04(k) = - tmp(2) + ztscr05(k) = - tmp(1) + endif + + endif + + enddo ! xm loop: 2..gr%nz + + + ! The wpxp loop runs between k = 2 and k = gr%nz-1. The value of wpxp + ! is set to specified values at both the lowest level, k = 1, and the + ! highest level, k = gr%nz. + + do k = 2, gr%nz-1, 1 + + ! Define indices + + kp1 = min( k+1, gr%nz ) + km1 = max( k-1, 1 ) + + ! k_xm is 2*k - 1 + k_wpxp = 2*k + + + !!!!!***** w'x' *****!!!!! + + ! w'x': Left-hand side (implicit w'x' portion of the code). + ! + ! Momentum subdiagonal (lhs index: m_km1_mdiag) + ! [ x wpxp(k-1,) ] + ! Thermodynamic subdiagonal (lhs index: m_k_tdiag) + ! [ x xm(k,) ] + ! Momentum main diagonal (lhs index: m_k_mdiag) + ! [ x wpxp(k,) ] + ! Thermodynamic superdiagonal (lhs index: m_kp1_tdiag) + ! [ x xm(k+1,) ] + ! Momentum superdiagonal (lhs index: m_kp1_mdiag) + ! [ x wpxp(k+1,) ] + + ! LHS mean advection (ma) term. + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + + ! LHS turbulent advection (ta) term. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! The weight of the implicit portion of this term is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (w'x' in this case), y(t) is the linearized portion of + ! the term that gets treated implicitly, and RHS is the portion of + ! the term that is always treated explicitly (in the case of the + ! w'x' turbulent advection term, RHS = 0). A weight of greater + ! than 1 can be applied to make the term more numerically stable. + if ( .not. l_upwind_wpxp_ta ) then + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + + gamma_over_implicit_ts & + * wpxp_term_ta_lhs( a1_zt(kp1), a1_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), & + gr%invrs_dzm(k), k ) + else + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + + gamma_over_implicit_ts & + * wpxp_term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1) ) + end if + + ! LHS turbulent production (tp) term. + lhs((/m_kp1_tdiag,m_k_tdiag/),k_wpxp) & + = lhs((/m_kp1_tdiag,m_k_tdiag/),k_wpxp) & + + wpxp_term_tp_lhs( wp2(k), gr%invrs_dzm(k) ) + + ! LHS accumulation (ac) term and pressure term 2 (pr2). + lhs(m_k_mdiag,k_wpxp) & + = lhs(m_k_mdiag,k_wpxp) & + + wpxp_terms_ac_pr2_lhs( C7_Skw_fnc(k), & + wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + + ! LHS pressure term 1 (pr1). + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs(m_k_mdiag,k_wpxp) & + = lhs(m_k_mdiag,k_wpxp) & + + gamma_over_implicit_ts & + * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) + + ! LHS eddy diffusion term: dissipation term 1 (dp1). + lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + = lhs((/m_kp1_mdiag,m_k_mdiag,m_km1_mdiag/),k_wpxp) & + + diffusion_zm_lhs( Kw6(k), Kw6(kp1), nu6_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + + ! LHS time tendency. + if ( l_iter ) then + lhs(m_k_mdiag,k_wpxp) & + = lhs(m_k_mdiag,k_wpxp) + one / dt + endif + + ! LHS portion of semi-implicit clipping term. + if ( l_clip_semi_implicit ) then + l_upper_thresh = .true. + l_lower_thresh = .true. + + lhs(m_k_mdiag,k_wpxp) & + = lhs(m_k_mdiag,k_wpxp) & + + clip_semi_imp_lhs( dt, wpxp(k), & + l_upper_thresh, wpxp_upper_lim(k), & + l_lower_thresh, wpxp_lower_lim(k) ) + + endif + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for wprtp or wpthlp. + + if ( iwprtp_ma > 0 .or. iwpthlp_ma > 0 ) then + tmp(1:3) = & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + zmscr01(k) = - tmp(3) + zmscr02(k) = - tmp(2) + zmscr03(k) = - tmp(1) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) term). + if ( iwprtp_ta > 0 .or. iwpthlp_ta > 0 ) then + if ( .not. l_upwind_wpxp_ta ) then + tmp(1:3) & + = gamma_over_implicit_ts & + * wpxp_term_ta_lhs( a1_zt(kp1), a1_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), & + gr%invrs_dzm(k), k ) + else + tmp(1:3) & + = gamma_over_implicit_ts & + * wpxp_term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1) ) + end if + + zmscr04(k) = - tmp(3) + zmscr05(k) = - tmp(2) + zmscr06(k) = - tmp(1) + endif + + if ( iwprtp_tp > 0 .or. iwpthlp_tp > 0 ) then + tmp(1:2) = & + + wpxp_term_tp_lhs( wp2(k), gr%invrs_dzm(k) ) + zmscr07(k) = - tmp(2) + zmscr08(k) = - tmp(1) + endif + + ! Note: To find the contribution of w'x' term ac, substitute 0 for the + ! C_7 skewness function input to function wpxp_terms_ac_pr2_lhs. + if ( iwprtp_ac > 0 .or. iwpthlp_ac > 0 ) then + zmscr09(k) = & + - wpxp_terms_ac_pr2_lhs( zero, & + wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) term). + if ( iwprtp_pr1 > 0 .or. iwpthlp_pr1 > 0 ) then + zmscr10(k) & + = - gamma_over_implicit_ts & + * wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) + endif + + ! Note: To find the contribution of w'x' term pr2, add 1 to the + ! C_7 skewness function input to function wpxp_terms_ac_pr2_lhs. + if ( iwprtp_pr2 > 0 .or. iwpthlp_pr2 > 0 ) then + zmscr11(k) = & + - wpxp_terms_ac_pr2_lhs( (one+C7_Skw_fnc(k)), & + wm_zt(kp1), wm_zt(k), gr%invrs_dzm(k) ) + endif + + if ( iwprtp_dp1 > 0 .or. iwpthlp_dp1 > 0 ) then + tmp(1:3) = & + + diffusion_zm_lhs( Kw6(k), Kw6(kp1), nu6_vert_res_dep, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + zmscr12(k) = - tmp(3) + zmscr13(k) = - tmp(2) + zmscr14(k) = - tmp(1) + endif + + if ( l_clip_semi_implicit ) then + if ( iwprtp_sicl > 0 .or. iwpthlp_sicl > 0 ) then + l_upper_thresh = .true. + l_lower_thresh = .true. + zmscr15(k) = & + - clip_semi_imp_lhs( dt, wpxp(k), & + l_upper_thresh, wpxp_upper_lim(k), & + l_lower_thresh, wpxp_lower_lim(k) ) + endif + endif + + endif + + enddo ! wpxp loop: 2..gr%nz-1 + + + ! Boundary conditions + + ! The turbulent flux (wpxp) use fixed-point boundary conditions at both the + ! upper and lower boundaries. Therefore, anything set in the wpxp loop + ! at both the upper and lower boundaries would be overwritten here. + ! However, the wpxp loop does not extend to the boundary levels. An array + ! with a value of 1 at the main diagonal on the left-hand side and with + ! values of 0 at all other diagonals on the left-hand side will preserve the + ! right-hand side value at that level. The value of xm at level k = 1, + ! which is below the model surface, is preserved and then overwritten to + ! match the new value of xm at level k = 2. + ! + ! xm(1) wpxp(1) ... wpxp(nzmax) + ! [ 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 ] + ! [ 1.0 1.0 ... 1.0 ] + ! [ 0.0 0.0 0.0 ] + ! [ 0.0 0.0 0.0 ] + + ! Lower boundary + k = 1 + k_xm = 2*k - 1 + k_wpxp_low = 2*k + + if ( l_diffuse_rtm_and_thlm ) then + ! xm + lhs(:,k_xm) = 0.0_core_rknd + lhs(t_k_tdiag,k_xm) = 1.0_core_rknd + ! w'x' + lhs(:,k_wpxp) = 0.0_core_rknd + lhs(m_k_mdiag,k_wpxp) = 1.0_core_rknd + + km1 = max( k-1, 1 ) + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if + + ! Upper boundary + k = gr%nz + !k_xm is 2*k - 1 + k_wpxp_high = 2*k + + if ( l_diffuse_rtm_and_thlm ) then + ! w'x' + lhs(:,k_wpxp) = 0.0_core_rknd + lhs(m_k_mdiag,k_wpxp) = 1.0_core_rknd + + km1 = max( k-1, 1 ) + + lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + = lhs((/t_kp1_tdiag,t_k_tdiag,t_km1_tdiag/),k) & + + invrs_rho_ds_zt(k) & + * diffusion_zt_lhs( rho_ds_zm(k) * ( Kh_N2_zm(k) + constant_nu ), & + rho_ds_zm(km1) * ( Kh_N2_zm(km1) + constant_nu ), zero_nu, & + gr%invrs_dzm(km1), gr%invrs_dzm(k), gr%invrs_dzt(k), k ) + end if + + call set_boundary_conditions_lhs( m_k_mdiag, k_wpxp_low, k_wpxp_high, lhs, & + t_k_tdiag, k_xm) + + return + + end subroutine xm_wpxp_lhs + + !============================================================================= + subroutine xm_wpxp_rhs( solve_type, l_iter, dt, xm, wpxp, & + xm_forcing, wpxp_forcing, C7_Skw_fnc, & + xpthvp, C6x_Skw_fnc, tau_C6_zm, a1, a1_zt, & + wp3_on_wp2, wp3_on_wp2_zt, rho_ds_zt, & + rho_ds_zm, invrs_rho_ds_zm, thv_ds_zm, & + wpxp_upper_lim, wpxp_lower_lim, & + rhs ) + + ! Description: + ! Compute RHS vector for xm and w'x'. + ! This subroutine computes the explicit portion of + ! the xm and w'x' equations. + + ! References: + !------------------------------------------------------------------------ + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero + + use model_flags, only: & + l_clip_semi_implicit, & ! Variable(s) + l_upwind_wpxp_ta + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use clip_semi_implicit, only: & + clip_semi_imp_rhs ! Procedure(s) + + use stats_type_utilities, only: & + stat_update_var_pt, & + stat_begin_update_pt + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_zm, & + irtm_forcing, & + ithlm_forcing, & + iwprtp_bp, & + iwprtp_pr3, & + iwprtp_sicl, & + iwprtp_ta, & + iwprtp_pr1, & + iwprtp_forcing, & + iwpthlp_bp, & + iwpthlp_pr3, & + iwpthlp_sicl, & + iwpthlp_ta, & + iwpthlp_pr1, & + iwpthlp_forcing, & + l_stats_samp + + use advance_helper_module, only: set_boundary_conditions_rhs + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variables being solved for. + + logical, intent(in) :: l_iter + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm, & ! xm (thermodynamic levels) [{xm units}] + wpxp, & ! (momentum levels) [{xm units} m/s] + xm_forcing, & ! xm forcings (thermodynamic levels) [{xm units}/s] + wpxp_forcing, & ! forcing (momentum levels) [{xm units} m/s^2] + C7_Skw_fnc, & ! C_7 parameter with Sk_w applied [-] + xpthvp, & ! x'th_v' (momentum levels) [{xm units} K] + C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied [-] + tau_C6_zm, & ! Time-scale tau on momentum levels applied to the C6 term [s] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + a1, & ! a_1 [-] + wp3_on_wp2, & ! Smoothed wp3 / wp2 on moment. levels [m/s] + wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels [m/s] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + rho_ds_zm, & ! Dry, static density on moment. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + wpxp_upper_lim, & ! Keeps correlations from becoming > 1. [units vary] + wpxp_lower_lim ! Keeps correlations from becoming < -1. [units vary] + + ! Output Variable + real( kind = core_rknd ), intent(out), dimension(2*gr%nz) :: & + rhs ! Right-hand side of band diag. matrix. (LAPACK) + + ! Local Variables. + + ! For "over-implicit" weighted time step. + ! This vector holds output from the LHS (implicit) portion of a term at a + ! given vertical level. This output is weighted and applied to the RHS. + ! This is used if the implicit portion of the term is "over-implicit", which + ! means that the LHS contribution is given extra weight (>1) in order to + ! increase numerical stability. A weighted factor must then be applied to + ! the RHS in order to balance the weight. + real( kind = core_rknd ), dimension(3) :: lhs_fnc_output + + ! Indices + integer :: k, km1, kp1, k_xm, k_wpxp, k_xm_low, k_wpxp_low, k_wpxp_high + + + integer :: & + ixm_f, & + iwpxp_bp, & + iwpxp_pr3, & + iwpxp_f, & + iwpxp_sicl, & + iwpxp_ta, & + iwpxp_pr1 + + logical :: l_upper_thresh, l_lower_thresh ! flags for clip_semi_imp_lhs + + ! ---- Begin Code ---- + + select case ( solve_type ) + case ( xm_wpxp_rtm ) ! rtm/wprtp budget terms + ixm_f = irtm_forcing + iwpxp_bp = iwprtp_bp + iwpxp_pr3 = iwprtp_pr3 + iwpxp_f = iwprtp_forcing + iwpxp_sicl = iwprtp_sicl + iwpxp_ta = iwprtp_ta + iwpxp_pr1 = iwprtp_pr1 + case ( xm_wpxp_thlm ) ! thlm/wpthlp budget terms + ixm_f = ithlm_forcing + iwpxp_bp = iwpthlp_bp + iwpxp_pr3 = iwpthlp_pr3 + iwpxp_f = iwpthlp_forcing + iwpxp_sicl = iwpthlp_sicl + iwpxp_ta = iwpthlp_ta + iwpxp_pr1 = iwpthlp_pr1 + case default ! this includes the sclrm case + ixm_f = 0 + iwpxp_bp = 0 + iwpxp_pr3 = 0 + iwpxp_f = 0 + iwpxp_sicl = 0 + iwpxp_ta = 0 + iwpxp_pr1 = 0 + end select + + + ! Initialize the right-hand side vector to 0. + rhs = zero + + ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at + ! level k = 1, which is below the model surface, is simply set equal to the + ! value of xm at level k = 2 after the solve has been completed. + + do k = 2, gr%nz, 1 + + ! Define indices + + k_xm = 2*k - 1 + ! k_wpxp is 2*k + + + !!!!!***** xm *****!!!!! + + ! xm: Right-hand side (explicit xm portion of the code). + + ! RHS time tendency. + rhs(k_xm) = rhs(k_xm) + xm(k) / dt + + ! RHS xm forcings. + ! Note: xm forcings include the effects of microphysics, + ! cloud water sedimentation, radiation, and any + ! imposed forcings on xm. + rhs(k_xm) = rhs(k_xm) + xm_forcing(k) + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for xm + ! (including microphysics/radiation). + + ! xm forcings term is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixm_f, k, xm_forcing(k), stats_zt ) + + endif ! l_stats_samp + + enddo ! xm loop: 2..gr%nz + + + ! The wpxp loop runs between k = 2 and k = gr%nz-1. The value of wpxp + ! is set to specified values at both the lowest level, k = 1, and the + ! highest level, k = gr%nz. + + do k = 2, gr%nz-1, 1 + + ! Define indices + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! k_xm is 2*k - 1 + k_wpxp = 2*k + + + !!!!!***** w'x' *****!!!!! + + ! w'x': Right-hand side (explicit w'x' portion of the code). + + ! RHS buoyancy production (bp) term and pressure term 3 (pr3). + rhs(k_wpxp) & + = rhs(k_wpxp) & + + wpxp_terms_bp_pr3_rhs( C7_Skw_fnc(k), thv_ds_zm(k), xpthvp(k) ) + + ! RHS time tendency. + if ( l_iter ) then + rhs(k_wpxp) = rhs(k_wpxp) + wpxp(k) / dt + end if + + ! RHS forcing. + ! Note: forcing includes the effects of microphysics on . + rhs(k_wpxp) = rhs(k_wpxp) + wpxp_forcing(k) + + ! RHS portion of semi-implicit clipping (sicl) term. + if ( l_clip_semi_implicit ) then + l_upper_thresh = .true. + l_lower_thresh = .true. + + rhs(k_wpxp) & + = rhs(k_wpxp) & + + clip_semi_imp_rhs( dt, wpxp(k), & + l_upper_thresh, wpxp_upper_lim(k), & + l_lower_thresh, wpxp_lower_lim(k) ) + + endif + + if( .not. l_upwind_wpxp_ta ) then ! Only do this when not using Upwind Differencing + ! RHS contribution from "over-implicit" weighted time step + ! for LHS turbulent advection (ta) term. + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + ! The weight of the implicit portion of this term is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (w'x' in this case), y(t) is the linearized portion of + ! the term that gets treated implicitly, and RHS is the portion of + ! the term that is always treated explicitly (in the case of the + ! w'x' turbulent advection term, RHS = 0). A weight of greater + ! than 1 can be applied to make the term more numerically stable. + lhs_fnc_output(1:3) & + = wpxp_term_ta_lhs( a1_zt(kp1), a1_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), & + gr%invrs_dzm(k), k ) + else + lhs_fnc_output(1:3) & + = wpxp_term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1) ) + endif + + rhs(k_wpxp) & + = rhs(k_wpxp) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wpxp(kp1) & + - lhs_fnc_output(2) * wpxp(k) & + - lhs_fnc_output(3) * wpxp(km1) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS pressure term 1 (pr1). + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs_fnc_output(1) & + = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) + rhs(k_wpxp) & + = rhs(k_wpxp) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wpxp(k) ) + + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for wpxp. + + ! w'x' term bp is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of w'x' term bp, substitute 0 for the + ! C_7 skewness function input to function wpxp_terms_bp_pr3_rhs. + call stat_update_var_pt( iwpxp_bp, k, & + wpxp_terms_bp_pr3_rhs( zero, thv_ds_zm(k), xpthvp(k) ), stats_zm ) + + ! w'x' term pr3 is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of w'x' term pr3, add 1 to the + ! C_7 skewness function input to function wpxp_terms_bp_pr2_rhs. + call stat_update_var_pt( iwpxp_pr3, k, & + wpxp_terms_bp_pr3_rhs( (one+C7_Skw_fnc(k)), thv_ds_zm(k), & + xpthvp(k) ), & + stats_zm ) + + ! w'x' forcing term is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_f, k, wpxp_forcing(k), stats_zm ) + + ! w'x' term sicl has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on clip_semi_imp_rhs. + if ( l_clip_semi_implicit ) then + l_upper_thresh = .true. + l_lower_thresh = .true. + call stat_begin_update_pt( iwpxp_sicl, k, & + -clip_semi_imp_rhs( dt, wpxp(k), & + l_upper_thresh, wpxp_upper_lim(k), & + l_lower_thresh, wpxp_lower_lim(k) ), stats_zm ) + endif + + if ( l_upwind_wpxp_ta ) then ! Use upwind differencing + lhs_fnc_output(1:3) & + = wpxp_term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1) ) + + else + ! w'x' term ta is normally completely implicit. However, there is a + ! RHS contribution from the "over-implicit" weighted time step. A + ! weighting factor of greater than 1 may be used to make the term more + ! numerically stable (see note above for RHS contribution from + ! "over-implicit" weighted time step for LHS turbulent advection (ta) + ! term). Therefore, w'x' term ta has both implicit and explicit + ! components; call stat_begin_update_pt. Since stat_begin_update_pt + ! automatically subtracts the value sent in, reverse the sign on the + ! input value. + lhs_fnc_output(1:3) & + = wpxp_term_ta_lhs( a1_zt(kp1), a1_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), & + invrs_rho_ds_zm(k), & + gr%invrs_dzm(k), k ) + endif + + call stat_begin_update_pt( iwpxp_ta, k, & + - ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wpxp(kp1) & + - lhs_fnc_output(2) * wpxp(k) & + - lhs_fnc_output(3) * wpxp(km1) ), stats_zm ) + + ! w'x' term pr1 is normally completely implicit. However, there is a + ! RHS contribution from the "over-implicit" weighted time step. A + ! weighting factor of greater than 1 may be used to make the term more + ! numerically stable (see note above for RHS contribution from + ! "over-implicit" weighted time step for LHS turbulent advection (ta) + ! term). Therefore, w'x' term pr1 has both implicit and explicit + ! components; call stat_begin_update_pt. Since stat_begin_update_pt + ! automatically subtracts the value sent in, reverse the sign on the + ! input value. + lhs_fnc_output(1) & + = wpxp_term_pr1_lhs( C6x_Skw_fnc(k), tau_C6_zm(k) ) + call stat_begin_update_pt( iwpxp_pr1, k, & + - ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * wpxp(k) ), stats_zm ) + + + endif ! l_stats_samp + + enddo ! wpxp loop: 2..gr%nz-1 + + + ! Boundary conditions + + ! The turbulent flux (wpxp) use fixed-point boundary conditions at both the + ! upper and lower boundaries. Therefore, anything set in the wpxp loop + ! at both the upper and lower boundaries would be overwritten here. + ! However, the wpxp loop does not extend to the boundary levels. An array + ! with a value of 1 at the main diagonal on the left-hand side and with + ! values of 0 at all other diagonals on the left-hand side will preserve the + ! right-hand side value at that level. The value of xm at level k = 1, + ! which is below the model surface, is preserved and then overwritten to + ! match the new value of xm at level k = 2. + + ! Lower boundary + k = 1 + k_xm_low = 2*k - 1 + k_wpxp_low = 2*k + + ! Upper boundary + k = gr%nz + !k_xm is 2*k - 1 + k_wpxp_high = 2*k + + + ! The value of xm at the lower boundary will remain the same. + ! However, the value of xm at the lower boundary gets overwritten + ! after the matrix is solved for the next timestep, such + ! that xm(1) = xm(2). + + ! The value of w'x' at the lower boundary will remain the same. + ! The surface value of w'x' is set elsewhere + ! (case-specific information). + + ! The value of w'x' at the upper boundary will be 0. + call set_boundary_conditions_rhs( & + wpxp(1), k_wpxp_low, zero, k_wpxp_high, & + rhs, & + xm(1), k_xm_low ) + + + end subroutine xm_wpxp_rhs + + !============================================================================= + subroutine xm_wpxp_solve( nrhs, lhs, rhs, solution, err_code, rcond ) + + ! Description: + ! Solve for xm / w'x' using the band diagonal solver. + + ! References: + ! None + !------------------------------------------------------------------------ + + use grid_class, only: & + gr ! Variable(s) + + use lapack_wrap, only: & + band_solve, & ! Procedure(s) + band_solvex + + use error_code, only: & + clubb_no_error ! Constant + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nrhs ! Number of rhs vectors + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(nsup+nsub+1,2*gr%nz) :: & + lhs ! Implicit contributions to wpxp/xm (band diag. matrix in LAPACK storage) + + real( kind = core_rknd ), intent(inout), dimension(2*gr%nz,nrhs) :: & + rhs ! Right-hand side of band diag. matrix. (LAPACK storage) + + real( kind = core_rknd ), intent(out), dimension(2*gr%nz,nrhs) :: & + solution ! Solution to band diagonal system (LAPACK storage) + + ! Output Variables + integer, intent(out) :: err_code + + real( kind = core_rknd ), optional, intent(out) :: & + rcond ! Est. of the reciprocal of the condition # + + err_code = clubb_no_error ! Initialize to the value for no errors + + if ( present( rcond ) ) then + ! Perform LU decomp and solve system (LAPACK with diagnostics) + call band_solvex( "xm_wpxp", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solution, rcond, err_code ) + + + else + ! Perform LU decomp and solve system (LAPACK) + call band_solve( "xm_wpxp", nsup, nsub, 2*gr%nz, nrhs, & + lhs, rhs, solution, err_code ) + end if + + + return + end subroutine xm_wpxp_solve + +!=============================================================================== + subroutine xm_wpxp_clipping_and_stats & + ( solve_type, dt, wp2, xp2, wm_zt, & + xm_forcing, rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, & + xp2_threshold, xm_threshold, rcond, & + low_lev_effect, high_lev_effect, & + l_implemented, solution, & + xm, xm_tol, wpxp, err_code ) + + ! Description: + ! Clips and computes implicit stats for an artitrary xm and wpxp + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use model_flags, only: & + l_clip_semi_implicit ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use mono_flux_limiter, only: & + monotonic_turbulent_flux_limit ! Procedure(s) + + use pos_definite_module, only: & + pos_definite_adj ! Procedure(s) + + use clip_explicit, only: & + clip_covar, & ! Procedure(s) + clip_wprtp, & ! Variable(s) + clip_wpthlp, & + clip_wpsclrp + + use model_flags, only: & + l_pos_def, & ! Logical for whether to apply the positive definite scheme to rtm + l_hole_fill, & ! Logical for whether to apply the hole filling scheme to thlm/rtm + l_clip_turb_adv ! Logical for whether to clip xm when wpxp is clipped + + use constants_clubb, only: & + fstderr, & ! Constant(s) + one, & + zero + + use fill_holes, only: & + fill_holes_vertical ! Procedure + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + clubb_no_error ! Constant + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_update_var_pt, & + stat_end_update_pt, & + stat_end_update, & + stat_update_var, & + stat_modify + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_zm, & + stats_sfc, & + irtm_ta, & + irtm_ma, & + irtm_matrix_condt_num, & + irtm_pd, & + irtm_cl, & + iwprtp_bt, & + iwprtp_ma, & + iwprtp_ta, & + iwprtp_tp, & + iwprtp_ac, & + iwprtp_pr1, & + iwprtp_pr2, & + iwprtp_dp1, & + iwprtp_pd, & + iwprtp_sicl, & + ithlm_ta + + use stats_variables, only: & + ithlm_ma, & + ithlm_cl, & + ithlm_matrix_condt_num, & + iwpthlp_bt, & + iwpthlp_ma, & + iwpthlp_ta, & + iwpthlp_tp, & + iwpthlp_ac, & + iwpthlp_pr1, & + iwpthlp_pr2, & + iwpthlp_dp1, & + iwpthlp_sicl + + use stats_variables, only: & + l_stats_samp, & + ztscr01, & + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15 + + implicit none + + ! Constant Parameters + logical, parameter :: & + l_mono_flux_lim = .true., & ! Flag for monotonic turbulent flux limiter + l_enable_relaxed_clipping = .true., & ! Flag to relax clipping + l_first_clip_ts = .true., & + l_last_clip_ts = .false. + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variables being solved for. + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + xp2, & ! x'^2 (momentum levels) [{xm units}^2] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + xm_forcing, & ! xm forcings (thermodynamic levels) [units vary] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + real( kind = core_rknd ), intent(in) :: & + xp2_threshold, & ! Minimum allowable value of x'^2 [units vary] + xm_threshold, & ! Minimum allowable value of xm [units vary] + xm_tol, & ! Minimum allowable deviation of xm [units vary] + rcond ! Reciprocal of the estimated condition number (from computing A^-1) + + ! Variables used as part of the monotonic turbulent advection scheme. + ! Find the lowermost and uppermost grid levels that can have an effect + ! on the central thermodynamic level during the course of a time step, + ! due to the effects of turbulent advection only. + integer, dimension(gr%nz), intent(in) :: & + low_lev_effect, & ! Index of the lowest level that has an effect. + high_lev_effect ! Index of the highest level that has an effect. + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + real( kind = core_rknd ), intent(in), dimension(2*gr%nz) :: & + solution ! The value of xm and wpxp [units vary] + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + xm, & ! The mean x field [units vary] + wpxp ! The flux of x [units vary m/s] + + ! Output Variable + integer, intent(out) :: & + err_code ! Returns an error code in the event of a singular matrix + + ! Local Variables + integer :: & + solve_type_cl ! solve_type used for clipping statistics. + + character(len=10) :: & + solve_type_str ! solve_type as a string for debug output purposes + + real( kind = core_rknd ), dimension(gr%nz) :: & + xm_n ! Old value of xm for positive definite scheme [units vary] + + real( kind = core_rknd ), dimension(gr%nz) :: & + wpxp_pd, xm_pd ! Change in xm and wpxp due to the pos. def. scheme + + real( kind = core_rknd ), dimension(gr%nz) :: & + wpxp_chnge, & ! Net change in w'x' due to clipping [units vary] + xp2_relaxed ! Value of x'^2 * clip_factor [units vary] + + ! Indices + integer :: & + k, km1, kp1, & + k_xm, k_wpxp + + integer :: & + ixm_ta, & + ixm_ma, & + ixm_matrix_condt_num, & + ixm_pd, & + ixm_cl, & + iwpxp_bt, & + iwpxp_ma, & + iwpxp_ta, & + iwpxp_tp, & + iwpxp_ac, & + iwpxp_pr1, & + iwpxp_pr2, & + iwpxp_dp1, & + iwpxp_pd, & + iwpxp_sicl + + ! ----- Begin code ------ + err_code = clubb_no_error ! Initialize to the value for no errors + + select case ( solve_type ) + case ( xm_wpxp_rtm ) ! rtm/wprtp budget terms + ixm_ta = irtm_ta + ixm_ma = irtm_ma + ixm_pd = irtm_pd + ixm_cl = irtm_cl + iwpxp_bt = iwprtp_bt + iwpxp_ma = iwprtp_ma + iwpxp_ta = iwprtp_ta + iwpxp_tp = iwprtp_tp + iwpxp_ac = iwprtp_ac + iwpxp_pr1 = iwprtp_pr1 + iwpxp_pr2 = iwprtp_pr2 + iwpxp_dp1 = iwprtp_dp1 + iwpxp_pd = iwprtp_pd + iwpxp_sicl = iwprtp_sicl + + ! This is a diagnostic from inverting the matrix, not a budget + ixm_matrix_condt_num = irtm_matrix_condt_num + case ( xm_wpxp_thlm ) ! thlm/wpthlp budget terms + ixm_ta = ithlm_ta + ixm_ma = ithlm_ma + ixm_pd = 0 + ixm_cl = ithlm_cl + iwpxp_bt = iwpthlp_bt + iwpxp_ma = iwpthlp_ma + iwpxp_ta = iwpthlp_ta + iwpxp_tp = iwpthlp_tp + iwpxp_ac = iwpthlp_ac + iwpxp_pr1 = iwpthlp_pr1 + iwpxp_pr2 = iwpthlp_pr2 + iwpxp_dp1 = iwpthlp_dp1 + iwpxp_pd = 0 + iwpxp_sicl = iwpthlp_sicl + + ! This is a diagnostic from inverting the matrix, not a budget + ixm_matrix_condt_num = ithlm_matrix_condt_num + + case default ! this includes the sclrm case + ixm_ta = 0 + ixm_ma = 0 + ixm_pd = 0 + ixm_cl = 0 + iwpxp_bt = 0 + iwpxp_ma = 0 + iwpxp_ta = 0 + iwpxp_tp = 0 + iwpxp_ac = 0 + iwpxp_pr1 = 0 + iwpxp_pr2 = 0 + iwpxp_dp1 = 0 + iwpxp_pd = 0 + iwpxp_sicl = 0 + + ixm_matrix_condt_num = 0 + end select + + ! Copy result into output arrays + + do k=1, gr%nz, 1 + + k_xm = 2 * k - 1 + k_wpxp = 2 * k + + xm_n(k) = xm(k) + + xm(k) = solution(k_xm) + wpxp(k) = solution(k_wpxp) + + end do ! k=1..gr%nz + + ! Lower boundary condition on xm + xm(1) = xm(2) + + + if ( l_stats_samp ) then + + + if ( ixm_matrix_condt_num > 0 ) then + ! Est. of the condition number of the mean/flux LHS matrix + call stat_update_var_pt( ixm_matrix_condt_num, 1, one / rcond, stats_sfc ) + end if + + + ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at + ! level k = 1, which is below the model surface, is simply set equal to + ! the value of xm at level k = 2 after the solve has been completed. + ! Thus, the statistical code will run from levels 2 through gr%nz. + + do k = 2, gr%nz + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! Finalize implicit contributions for xm + + ! xm term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixm_ma, k, & + ztscr01(k) * xm(km1) & + + ztscr02(k) * xm(k) & + + ztscr03(k) * xm(kp1), stats_zt ) + + ! xm term ta is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixm_ta, k, & + ztscr04(k) * wpxp(km1) & + + ztscr05(k) * wpxp(k), stats_zt ) + + enddo ! xm loop: 2..gr%nz + + + ! The wpxp loop runs between k = 2 and k = gr%nz-1. The value of wpxp + ! is set to specified values at both the lowest level, k = 1, and the + ! highest level, k = gr%nz. Thus, the statistical code will run from + ! levels 2 through gr%nz-1. + + do k = 2, gr%nz-1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! Finalize implicit contributions for wpxp + + ! w'x' term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_ma, k, & + zmscr01(k) * wpxp(km1) & + + zmscr02(k) * wpxp(k) & + + zmscr03(k) * wpxp(kp1), stats_zm ) + +! if( .not. l_upwind_wpxp_ta ) then + ! w'x' term ta is normally completely implicit. However, due to the + ! RHS contribution from the "over-implicit" weighted time step, + ! w'x' term ta has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwpxp_ta, k, & + zmscr04(k) * wpxp(km1) & + + zmscr05(k) * wpxp(k) & + + zmscr06(k) * wpxp(kp1), stats_zm ) +! endif + + ! w'x' term tp is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_tp, k, & + zmscr07(k) * xm(k) & + + zmscr08(k) * xm(kp1), stats_zm ) + + ! w'x' term ac is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_ac, k, & + zmscr09(k) * wpxp(k), stats_zm ) + + ! w'x' term pr1 is normally completely implicit. However, due to the + ! RHS contribution from the "over-implicit" weighted time step, + ! w'x' term pr1 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( iwpxp_pr1, k, & + zmscr10(k) * wpxp(k), stats_zm ) + + ! w'x' term pr2 is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_pr2, k, & + zmscr11(k) * wpxp(k), stats_zm ) + + ! w'x' term dp1 is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( iwpxp_dp1, k, & + zmscr12(k) * wpxp(km1) & + + zmscr13(k) * wpxp(k) & + + zmscr14(k) * wpxp(kp1), stats_zm ) + + ! w'x' term sicl has both implicit and explicit components; + ! call stat_end_update_pt. + if ( l_clip_semi_implicit ) then + call stat_end_update_pt( iwpxp_sicl, k, & + zmscr15(k) * wpxp(k), stats_zm ) + endif + + enddo ! wpxp loop: 2..gr%nz-1 + + + endif ! l_stats_samp + + + ! Apply a monotonic turbulent flux limiter to xm/w'x'. + if ( l_mono_flux_lim ) then + call monotonic_turbulent_flux_limit( solve_type, dt, xm_n, & + xp2, wm_zt, xm_forcing, & + rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, & + xp2_threshold, l_implemented, & + low_lev_effect, high_lev_effect, & + xm, xm_tol, wpxp, err_code ) + end if ! l_mono_flux_lim + + ! Apply a flux limiting positive definite scheme if the solution + ! for the mean field is negative and we're determining total water + if ( solve_type == xm_wpxp_rtm .and. l_pos_def .and. any( xm < zero ) ) then + + call pos_definite_adj( dt, "zt", xm, wpxp, & + xm_n, xm_pd, wpxp_pd ) + + else + ! For stats purposes + xm_pd = zero + wpxp_pd = zero + + end if ! l_pos_def and solve_type == "rtm" and rtm less than 0 + + if ( l_stats_samp ) then + + call stat_update_var( iwpxp_pd, wpxp_pd(1:gr%nz), stats_zm ) + + call stat_update_var( ixm_pd, xm_pd(1:gr%nz), stats_zt ) + + end if + + ! Computed value before clipping + if ( l_stats_samp ) then + call stat_begin_update( ixm_cl, xm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + end if + + if ( any( xm < xm_threshold ) .and. l_hole_fill ) then + + select case ( solve_type ) + case ( xm_wpxp_rtm ) + solve_type_str = "rtm" + case ( xm_wpxp_thlm ) + solve_type_str = "thlm" + case default + solve_type_str = "scalars" + end select + + if ( clubb_at_least_debug_level( 1 ) ) then + do k = 1, gr%nz + if ( xm(k) < zero ) then + write(fstderr,*) solve_type_str//" < ", xm_threshold, & + " in advance_xm_wpxp_module at k= ", k + end if + end do + end if + + call fill_holes_vertical( 2, xm_threshold, "zt", & + rho_ds_zt, rho_ds_zm, & + xm ) + + end if ! any( xm < xm_threshold ) .and. l_hole_fill + + if ( l_stats_samp ) then + call stat_end_update( ixm_cl, xm / dt, & ! Intent(in) + stats_zt ) ! Intent(inout) + end if + + ! Use solve_type to find solve_type_cl, which is used + ! in subroutine clip_covar. + select case ( solve_type ) + case ( xm_wpxp_rtm ) + solve_type_cl = clip_wprtp + case ( xm_wpxp_thlm ) + solve_type_cl = clip_wpthlp + case default + solve_type_cl = clip_wpsclrp + end select + + ! Clipping for w'x' + ! Clipping w'x' at each vertical level, based on the + ! correlation of w and x at each vertical level, such that: + ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ]; + ! -1 <= corr_(w,x) <= 1. + ! Since w'^2, x'^2, and w'x' are updated in different places + ! from each other, clipping for w'x' has to be done three times + ! (three times each for w'r_t', w'th_l', and w'sclr'). This is + ! the second instance of w'x' clipping. + + ! Compute a slightly larger value of rt'^2 for clipping purposes. This was + ! added to prevent a situation in which both the variance and flux are small + ! and the simulation gets "stuck" at the rt_tol^2 value. + ! See ticket #389 on the CLUBB TRAC for further details. + ! -dschanen 10 Jan 2011 + if ( l_enable_relaxed_clipping ) then + if ( solve_type == xm_wpxp_rtm ) then + xp2_relaxed = max( 1e-7_core_rknd , xp2 ) + + else if ( solve_type == xm_wpxp_thlm ) then + xp2_relaxed = max( 0.01_core_rknd, xp2 ) + + else ! This includes the passive scalars + xp2_relaxed = max( 1e-7_core_rknd , xp2 ) + + end if + + else ! Don't relax clipping + xp2_relaxed = xp2 + + end if + + call clip_covar( solve_type_cl, l_first_clip_ts, & ! In + l_last_clip_ts, dt, wp2, xp2_relaxed, & ! In + wpxp, wpxp_chnge ) ! In/Out + + ! Adjusting xm based on clipping for w'x'. + if ( any( wpxp_chnge /= zero ) .and. l_clip_turb_adv ) then + call xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, gr%invrs_dzt, & + xm ) + endif + + if ( l_stats_samp ) then + + ! wpxp time tendency + call stat_modify( iwpxp_bt, wpxp / dt, stats_zm ) + ! Brian Griffin; July 5, 2008. + + endif + + return + end subroutine xm_wpxp_clipping_and_stats + + !============================================================================= + pure function xm_term_ta_lhs( rho_ds_zm, rho_ds_zmm1, & + invrs_rho_ds_zt, invrs_dzt ) & + result( lhs ) + + ! Description: + ! Turbulent advection of xm: implicit portion of the code. + ! + ! The d(xm)/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'x' )/dz. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - (1/rho_ds) * d( rho_ds * w'x'(t+1) )/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'x' being used is from + ! the next timestep, which is being advanced to in solving the d(xm)/dt and + ! d(w'x')/dt equations. + ! + ! This term is discretized as follows: + ! + ! While the values of xm are found on the thermodynamic levels, the values + ! of w'x' are found on the momentum levels. Additionally, the values of + ! rho_ds_zm are found on the momentum levels, and the values of + ! invrs_rho_ds_zt are found on the thermodynamic levels. On the momentum + ! levels, the values of rho_ds_zm are multiplied by the values of w'x'. The + ! derivative of (rho_ds_zm * w'x') is taken over the intermediate (central) + ! thermodynamic level, where it is multiplied by invrs_rho_ds_zt, yielding + ! the desired results. + ! + ! =====rho_ds_zm=====wpxp================================== m(k) + ! + ! ------invrs_rho_ds_zt--------d(rho_ds*wpxp)/dz----------- t(k) + ! + ! =====rho_ds_zmm1===wpxpm1================================ m(k-1) + ! + ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes + ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + k_mdiag = 1, & ! Momentum superdiagonal index. + km1_mdiag = 2 ! Momentum subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rho_ds_zm, & ! Dry, static density at momentum level (k) [kg/m^3] + rho_ds_zmm1, & ! Dry, static density at momentum level (k+1) [kg/m^3] + invrs_rho_ds_zt, & ! Inverse dry, static density @ thermo lev (k) [m^3/kg] + invrs_dzt ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ), dimension(2) :: lhs + + + ! Momentum superdiagonal [ x wpxp(k,) ] + lhs(k_mdiag) & + = + invrs_rho_ds_zt * invrs_dzt * rho_ds_zm + + ! Momentum subdiagonal [ x wpxp(k-1,) ] + lhs(km1_mdiag) & + = - invrs_rho_ds_zt * invrs_dzt * rho_ds_zmm1 + + + return + end function xm_term_ta_lhs + + !============================================================================= + pure function wpxp_term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & + a1_ztp1, a1_zt, & + rho_ds_ztp1, rho_ds_zt, & + invrs_rho_ds_zm, & + invrs_dzm, level ) & + result( lhs ) + + ! Description: + ! Turbulent advection of w'x': implicit portion of the code. + ! + ! The d(w'x')/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'^2x' )/dz. + ! + ! A substitution is made in order to close the turbulent advection term, + ! such that: + ! + ! w'^2x' = a_1 * ( w'^3 / w'^2 ) * w'x', + ! + ! where a_1 is a variable that is a function of sigma_sqd_w. The turbulent + ! advection term becomes: + ! + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( w'^3 / w'^2 ) * w'x' ] / dz. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( w'^3 / w'^2 ) * w'x'(t+1) ] / dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'x' being used is from + ! the next timestep, which is being advanced to in solving the d(w'x')/dt + ! equation. + ! + ! This term is discretized as follows: + ! + ! The values of w'x', w'^2, and a_1 are found on the momentum levels, while + ! the values of w'^3 are found on the thermodynamic levels. Additionally, + ! the values of rho_ds_zt are found on the thermodynamic levels, and the + ! values of invrs_rho_ds_zm are found on the momentum levels. Each of the + ! variables w'x', w'^2, and a_1 are interpolated to the intermediate + ! thermodynamic levels. The values of the mathematical expression (called F + ! here) within the dF/dz term are computed on the thermodynamic levels. + ! Then, the derivative (d/dz) of the expression (F) is taken over the + ! central momentum level, where it is multiplied by invrs_rho_ds_zm, + ! yielding the desired result. In this function, the values of F are as + ! follows: + ! + ! F = rho_ds_zt * a_1(t) * ( w'^3(t) / w'^2(t) ) * w'x'(t+1); + ! + ! where the timestep index (t) stands for the index of the current timestep. + ! + ! + ! =a1p1========wp2p1========wpxpp1=================================== m(k+1) + ! + ! -----a1(interp)---wp2(interp)---wpxp(interp)---wp3p1---rho_ds_ztp1- t(k+1) + ! + ! =a1==========wp2==========wpxp=======invrs_rho_ds_zm=======dF/dz=== m(k) + ! + ! -----a1(interp)---wp2(interp)---wpxp(interp)---wp3-----rho_ds_zt--- t(k) + ! + ! =a1m1========wp2m1========wpxpm1=================================== m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use grid_class, only: & + gr ! Variable; gr%weights_zm2zt + +! use model_flags, only: & +! l_standard_term_ta + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + integer, parameter :: & + m_above = 1, & ! Index for upper momentum level grid weight. + m_below = 2 ! Index for lower momentum level grid weight. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wp3_on_wp2_ztp1, & ! Smoothed wp3 / wp2 on thermo. levels (k+1) [m/s] + wp3_on_wp2_zt, & ! Smoothed wp3 / wp2 on thermo. levels (k) [m/s] +! a1, & ! a_1 interpolated to thermo. level (k+1) [-] + a1_ztp1, & ! a_1 interpolated to thermo. level (k+1) [-] + a1_zt, & ! a_1 interpolated to thermo. level (k) [-] + rho_ds_ztp1, & ! Dry, static density at thermo. level (k+1) [kg/m^3] + rho_ds_zt, & ! Dry, static density at thermo. level (k) [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum lev (k) [m^3/kg] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + integer, intent(in) :: & + level ! Central momentum level (on which calculation occurs). + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + ! Local Variables + integer :: & + tkp1, & ! Thermodynamic level directly above central momentum level. + tk ! Thermodynamic level directly below central momentum level. + + ! Thermodynamic level (k+1) is between momentum level (k+1) + ! and momentum level (k). + tkp1 = level + 1 + + ! Thermodynamic level (k) is between momentum level (k) + ! and momentum level (k-1). + tk = level + + ! Note: The w'x' turbulent advection term, which is + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( w'^3 / w'^2 ) * w'x' ] / dz, + ! still keeps the a_1 term inside the derivative, unlike the w'^3 + ! equation (found in advance_wp2_wp3_module.F90) and the equations for + ! r_t'^2, th_l'^2, r_t'th_l', u'^2, v'^2, sclr'r_t', sclr'th_l', and + ! sclr'^2 (found in advance_xp2_xpyp_module.F90). Brian. + +! if ( l_standard_term_ta ) then + + ! Always use the standard discretization for the w'x' turbulent advection + ! term. Brian. + + ! The turbulent advection term is discretized normally, in accordance + ! with the model equations found in the documentation and the description + ! listed above. + ! The w'x' turbulent advection term is + ! - (1/rho_ds) * d [ rho_ds * a_1 * ( w'^3 / w'^2 ) * w'x' ] / dz + + ! Momentum superdiagonal: [ x wpxp(k+1,) ] + lhs(kp1_mdiag) & + = + invrs_rho_ds_zm & + * invrs_dzm & + * rho_ds_ztp1 * a1_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_above,tkp1) + + ! Momentum main diagonal: [ x wpxp(k,) ] + lhs(k_mdiag) & + = + invrs_rho_ds_zm & + * invrs_dzm & + * ( rho_ds_ztp1 * a1_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_below,tkp1) & + - rho_ds_zt * a1_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_above,tk) & + ) + + ! Momentum subdiagonal: [ x wpxp(k-1,) ] + lhs(km1_mdiag) & + = - invrs_rho_ds_zm & + * invrs_dzm & + * rho_ds_zt * a1_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_below,tk) + +! else + + ! This discretization very similar to what Brian did for the xp2_ta terms + ! and is intended to stabilize the simulation by pulling a1 out of the + ! derivative. It didn't seem to work very well. -dschanen 17 Jan 2010 + + ! Momentum superdiagonal: [ x wpxp(k+1,) ] +! lhs(kp1_mdiag) & +! = + invrs_rho_ds_zm * a1 & +! * invrs_dzm & +! * rho_ds_ztp1 & +! * wp3_on_wp2_ztp1 & +! * gr%weights_zm2zt(m_above,tkp1) + + ! Momentum main diagonal: [ x wpxp(k,) ] +! lhs(k_mdiag) & +! = + invrs_rho_ds_zm * a1 & +! * invrs_dzm & +! * ( rho_ds_ztp1 & +! * wp3_on_wp2_ztp1 & +! * gr%weights_zm2zt(m_below,tkp1) & +! - rho_ds_zt & +! * wp3_on_wp2_zt & +! * gr%weights_zm2zt(m_above,tk) & +! ) + +! ! Momentum subdiagonal: [ x wpxp(k-1,) ] +! lhs(km1_mdiag) & +! = - invrs_rho_ds_zm * a1 & +! * invrs_dzm & +! * rho_ds_zt & +! * wp3_on_wp2_zt & +! * gr%weights_zm2zt(m_below,tk) + +! endif ! l_standard_term_ta + + + return + end function wpxp_term_ta_lhs + + !============================================================================= + pure function wpxp_term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & + wp3_on_wp2_p1, wp3_on_wp2, wp3_on_wp2_m1, & + invrs_dzt, invrs_dztkp1, & + invrs_rho_ds_zm, & + rho_ds_zmp1, rho_ds_zm, rho_ds_zmm1 ) & + result( lhs ) + + ! Description: + ! Upwind Differencing for the wpxp term + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + a1_zm, & ! a_1(k) on momentum levels [-] + a1_zm_p1, & ! a_1(k+1) on momentum levels [-] + a1_zm_m1, & ! a_1(k-1) on momentum levels [-] + wp3_on_wp2_p1, & ! Smoothed wp3 / wp2 on moment. levels (k+1) [m/s] + wp3_on_wp2, & ! Smoothed wp3 / wp2 on moment. levels (k) [m/s] + wp3_on_wp2_m1, & ! Smoothed wp3 / wp2 on moment. levels (k-1) [m/s] + invrs_dzt, & ! Inverse of grid spacing (k) [1/m] + invrs_dztkp1, & ! Inverse of grid spacing (k+1) [1/m] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum lev (k) [m^3/kg] + rho_ds_zm, & ! Density of air (k) [kg/m^3] + rho_ds_zmp1, & ! Density of air (k+1) [kg/m^3] + rho_ds_zmm1 ! Density of air (k-1) [kg/m^3] + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + + if ( wp3_on_wp2 > zero ) then + + ! "Wind" is blowing upwards (a1_zm > 0 and wp2 > 0 always) + lhs(kp1_mdiag) = zero + + lhs(k_mdiag) & + = + invrs_dzt * invrs_rho_ds_zm & + * rho_ds_zm * a1_zm * wp3_on_wp2 + + lhs(km1_mdiag) & + = - invrs_dzt * invrs_rho_ds_zm & + * rho_ds_zmm1 * a1_zm_m1 * wp3_on_wp2_m1 + + else ! "Wind" is blowing downward + + lhs(kp1_mdiag) & + = + invrs_dztkp1 * invrs_rho_ds_zm & + * rho_ds_zmp1 * a1_zm_p1 * wp3_on_wp2_p1 + + lhs(k_mdiag) & + = - invrs_dztkp1 * invrs_rho_ds_zm & + * rho_ds_zm * a1_zm * wp3_on_wp2 + + lhs(km1_mdiag) = zero + + endif + + + return + end function wpxp_term_ta_lhs_upwind + + !============================================================================= + pure function wpxp_term_tp_lhs( wp2, invrs_dzm ) & + result( lhs ) + + ! Description: + ! Turbulent production of w'x': implicit portion of the code. + ! + ! The d(w'x')/dt equation contains a turbulent production term: + ! + ! - w'^2 d(xm)/dz. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - w'^2 * d( xm(t+1) )/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of xm being used is from the + ! next timestep, which is being advanced to in solving the d(w'x')/dt and + ! d(xm)/dt equations. + ! + ! This term is discretized as follows: + ! + ! The values of xm are found on thermodynamic levels, while the values of + ! w'^2 are found on momentum levels. The derivative of xm is taken over the + ! intermediate (central) momentum level, where it is multiplied by w'^2, + ! yielding the desired result. + ! + ! ---------------------------xmp1-------------------------- t(k+1) + ! + ! ==========wp2=====================d(xm)/dz=============== m(k) + ! + ! ---------------------------xm---------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wp2, & ! w'^2(k) [m^2/s^2] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ), dimension(2) :: lhs + + + ! Thermodynamic superdiagonal [ x xm(k+1,) ] + lhs(kp1_tdiag) & + = + wp2 * invrs_dzm + + ! Thermodynamic subdiagonal [ x xm(k,) ] + lhs(k_tdiag) & + = - wp2 * invrs_dzm + + + return + end function wpxp_term_tp_lhs + + !============================================================================= + pure function wpxp_terms_ac_pr2_lhs( C7_Skw_fnc, & + wm_ztp1, wm_zt, invrs_dzm ) & + result( lhs ) + + ! Description: + ! Accumulation of w'x' and w'x' pressure term 2: implicit portion of the + ! code. + ! + ! The d(w'x')/dt equation contains an accumulation term: + ! + ! - w'x' dw/dz; + ! + ! and pressure term 2: + ! + ! + C_7 w'x' dw/dz. + ! + ! Both the w'x' accumulation term and pressure term 2 are completely + ! implicit. The accumulation term and pressure term 2 are combined and + ! solved together as: + ! + ! - ( 1 - C_7 ) * w'x'(t+1) * dw/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'x' being used is from + ! the next timestep, which is being advanced to in solving the d(w'x')/dt + ! equation. + ! + ! The terms are discretized as follows: + ! + ! The values of w'x' are found on momentum levels, while the values of wm_zt + ! (mean vertical velocity on thermodynamic levels) are found on + ! thermodynamic levels. The vertical derivative of wm_zt is taken over the + ! intermediate (central) momentum level. It is then multiplied by w'x' + ! (implicitly calculated at timestep (t+1)) and the coefficients to yield + ! the desired results. + ! + ! -------wm_ztp1------------------------------------------- t(k+1) + ! + ! ===============d(wm_zt)/dz============wpxp=============== m(k) + ! + ! -------wm_zt--------------------------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C7_Skw_fnc, & ! C_7 parameter with Sk_w applied (k) [-] + wm_ztp1, & ! w wind component on thermodynamic level (k+1) [m/s] + wm_zt, & ! w wind component on thermodynamic level (k) [m/s] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + + ! Return Variable + real( kind = core_rknd ) :: lhs + + + ! Momentum main diagonal: [ x wpxp(k,) ] + lhs = ( one - C7_Skw_fnc ) * invrs_dzm * ( wm_ztp1 - wm_zt ) + + + return + end function wpxp_terms_ac_pr2_lhs + + !============================================================================= + pure function wpxp_term_pr1_lhs( C6x_Skw_fnc, tau_C6_zm ) & + result( lhs ) + + ! Description + ! Pressure term 1 for w'x': implicit portion of the code. + ! + ! The d(w'x')/dt equation contains pressure term 1: + ! + ! - ( C_6 / tau_m ) w'x'. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - ( C_6 / tau_m ) w'x'(t+1) + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of w'x' being used is from + ! the next timestep, which is being advanced to in solving the d(w'x')/dt + ! equation. + ! + ! The values of w'x' are found on the momentum levels. The values of the + ! C_6 skewness function and time-scale tau_m are also found on the momentum + ! levels. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C6x_Skw_fnc, & ! C_6x parameter with Sk_w applied (k) [-] + tau_C6_zm ! Time-scale tau at momentum level (k) applied to C6 term [s] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + + ! Momentum main diagonal: [ x wpxp(k,) ] + lhs = C6x_Skw_fnc / tau_C6_zm + + + return + end function wpxp_term_pr1_lhs + + !============================================================================= + pure function wpxp_terms_bp_pr3_rhs( C7_Skw_fnc, thv_ds_zm, xpthvp ) & + result( rhs ) + + ! Description: + ! Buoyancy production of w'x' and w'x' pressure term 3: explicit portion of + ! the code. + ! + ! The d(w'x')/dt equation contains a buoyancy production term: + ! + ! + (g/thv_ds) x'th_v'; + ! + ! and pressure term 3: + ! + ! - C_7 (g/thv_ds) x'th_v'. + ! + ! Both the w'x' buoyancy production term and pressure term 3 are completely + ! explicit. The buoyancy production term and pressure term 3 are combined + ! and solved together as: + ! + ! + ( 1 - C_7 ) * (g/thv_ds) * x'th_v'. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & ! Constants(s) + grav, & ! Gravitational acceleration [m/s^2] + one + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C7_Skw_fnc, & ! C_7 parameter with Sk_w applied (k) [-] + thv_ds_zm, & ! Dry, base-state theta_v on mom. lev. (k) [K] + xpthvp ! x'th_v'(k) [K {xm units}] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + + rhs = ( grav / thv_ds_zm ) * ( one - C7_Skw_fnc ) * xpthvp + + + return + end function wpxp_terms_bp_pr3_rhs + + !============================================================================= + subroutine xm_correction_wpxp_cl( solve_type, dt, wpxp_chnge, invrs_dzt, & + xm ) + + ! Description: + ! Corrects the value of xm if w'x' needed to be clipped, for xm is partially + ! based on the derivative of w'x' with respect to altitude. + ! + ! The time-tendency equation for xm is: + ! + ! d(xm)/dt = -w d(xm)/dz - d(w'x')/dz + d(xm)/dt|_ls; + ! + ! where d(xm)/dt|_ls is the rate of change of xm over time due to radiation, + ! microphysics, and/or any other large-scale forcing(s). + ! + ! The time-tendency equation for xm is solved in conjunction with the + ! time-tendency equation for w'x'. Both equations are solved together in a + ! semi-implicit manner. However, after both equations have been solved (and + ! thus both xm and w'x' have been advanced to the next timestep with + ! timestep index {t+1}), the value of covariance w'x' may be clipped at any + ! level in order to prevent the correlation of w and x from becoming greater + ! than 1 or less than -1. + ! + ! The correlation between w and x is: + ! + ! corr_(w,x) = w'x' / [ sqrt(w'^2) * sqrt(x'^2) ]. + ! + ! The correlation must always have a value between -1 and 1, such that: + ! + ! -1 <= corr_(w,x) <= 1. + ! + ! Therefore, there is an upper limit on w'x', such that: + ! + ! w'x' <= [ sqrt(w'^2) * sqrt(x'^2) ]; + ! + ! and a lower limit on w'x', such that: + ! + ! w'x' >= -[ sqrt(w'^2) * sqrt(x'^2) ]. + ! + ! The aforementioned time-tendency equation for xm is based on the value of + ! w'x' without being clipped (w'x'{t+1}_unclipped), such that: + ! + ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_unclipped)/dz + d(xm{t})/dt|_ls; + ! + ! where the both the mean advection term, -w d(xm{t+1})/dz, and the + ! turbulent advection term, -d(w'x'{t+1}_unclipped)/dz, are solved + ! completely implicitly. The xm forcing term, +d(xm{t})/dt|_ls, is solved + ! completely explicitly. + ! + ! However, if w'x' needs to be clipped after being advanced one timestep, + ! then xm needs to be altered to reflect the fact that w'x' has a different + ! value than the value used while both were being solved together. Ideally, + ! the xm time-tendency equation that should be used is: + ! + ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_clipped)/dz + d(xm{t})/dt|_ls. + ! + ! However, w'x'{t+1}_clipped isn't known until after the w'x' and xm + ! equations have been solved together. However, a proper adjuster can be + ! applied to xm through the use of the following relationship: + ! + ! w'x'{t+1}_clipped = w'x'{t+1}_unclipped + w'x'{t+1}_amount_clipped; + ! + ! at any given vertical level. + ! + ! When the expression above is substituted into the preceeding xm + ! time-tendency equation, the resulting equation for xm time-tendency is: + ! + ! d(xm)/dt = -w d(xm{t+1})/dz - d(w'x'{t+1}_unclipped)/dz + ! - d(w'x'{t+1}_amount_clipped)/dz + d(xm{t})/dt|_ls. + ! + ! Thus, the resulting xm time-tendency equation is the same as the original + ! xm time-tendency equation, but with added adjuster term: + ! + ! -d(w'x'{t+1}_amount_clipped)/dz. + ! + ! Since the adjuster term needs to be applied after xm has already been + ! solved, it needs to be multiplied by the timestep length and added on to + ! xm{t+1}, such that: + ! + ! xm{t+1}_after_adjustment = + ! xm{t+1}_before_adjustment + ( -d(w'x'{t+1}_amount_clipped)/dz ) * dt. + ! + ! The adjuster term is discretized as follows: + ! + ! The values of w'x' are located on the momentum levels. Thus, the values + ! of w'x'_amount_clipped are also located on the momentum levels. The + ! values of xm are located on the thermodynamic levels. The derivatives + ! (d/dz) of w'x'_amount_clipped are taken over the intermediate + ! thermodynamic levels, where they are applied to xm. + ! + ! =======wpxp_amount_clipped=============================== m(k) + ! + ! -----------------------------d(wpxp_amount_clipped)/dz--- t(k) + ! + ! =======wpxpm1_amount_clipped============================= m(k-1) + ! + ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes + ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + + ! Note: The results of this xm adjustment are highly dependent on the + ! numerical stability and the smoothness of the w'^2 and x'^2 fields. + ! An unstable "sawtooth" profile for w'^2 and/or x'^2 causes an + ! unstable "sawtooth" profile for the upper and lower limits on w'x'. + ! In turn, this causes an unstable "sawtooth" profile for + ! w'x'_amount_clipped. Taking the derivative of that such a "noisy" + ! field and applying the results to xm causes the xm field to become + ! more "noisy" and unstable. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s); gr%nz only. + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var ! Procedure(s) + + use stats_variables, only: & + l_stats_samp, & ! Variable(s) + stats_zt, & + ithlm_tacl, & + irtm_tacl + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variable that is being solved for. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wpxp_chnge, & ! Amount of change in w'x' due to clipping [m/s {xm units}] + invrs_dzt ! Inverse of grid spacing [1/m] + + ! Input/Output Variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + xm ! xm (thermodynamic levels) [{xm units}] + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + xm_tndcy_wpxp_cl ! d(xm)/dt due to clipping of w'x' [{xm units}/s] + + integer :: k ! Array index + + integer :: ixm_tacl ! Statistical index + + + select case ( solve_type ) + case ( xm_wpxp_rtm ) + ixm_tacl = irtm_tacl + case ( xm_wpxp_thlm ) + ixm_tacl = ithlm_tacl + case default + ixm_tacl = 0 + end select + + ! Adjusting xm based on clipping for w'x'. + ! Loop over all thermodynamic levels between the second-lowest and the + ! highest. + do k = 2, gr%nz, 1 + xm_tndcy_wpxp_cl(k) = - invrs_dzt(k) * ( wpxp_chnge(k) - wpxp_chnge(k-1) ) + xm(k) = xm(k) + xm_tndcy_wpxp_cl(k) * dt + enddo + + if ( l_stats_samp ) then + ! The adjustment to xm due to turbulent advection term clipping + ! (xm term tacl) is completely explicit; call stat_update_var. + call stat_update_var( ixm_tacl, xm_tndcy_wpxp_cl, stats_zt ) + endif + + + return + + end subroutine xm_correction_wpxp_cl + + + !============================================================================= + pure function damp_coefficient( coefficient, Cx_Skw_fnc, max_coeff_value, & + threshold, Lscale ) & + result( damped_value ) + + ! Description: + ! Damps a given coefficient linearly based on the value of Lscale. + ! For additional information see CLUBB ticket #431. + + use constants_clubb, only: & + one_hundred ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + implicit none + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + coefficient, & ! The coefficient to be damped + max_coeff_value, & ! Maximum value the damped coefficient should have + threshold ! Value of Lscale below which the damping should occur + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + Lscale, & ! Current value of Lscale + Cx_Skw_fnc ! Initial skewness function before damping + + ! Local variables + real( kind = core_rknd ), parameter :: & + ! Added to prevent large damping at low altitudes where Lscale is small + altitude_threshold = one_hundred ! Altitude above which damping should occur + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: damped_value + + damped_value = Cx_Skw_fnc + + where( Lscale < threshold .and. gr%zt > altitude_threshold) + damped_value = max_coeff_value & + + ( ( coefficient - max_coeff_value ) / threshold ) & + * Lscale + end where + + return + + end function damp_coefficient +!=============================================================================== + function compute_C7_Skw_fnc_Richardson( thlm, um, vm, em, Lscale, exner, rtm, & + rcm, p_in_Pa, cloud_frac, rho_ds_zm ) & + result( C7_Skw_fnc ) + + ! Description: + ! Compute C7 as a function of the Richardson number + + ! References: + ! cam:ticket:59 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Konstant + + use grid_class, only: & + gr, & ! Variable + ddzt, & ! Procedure(s) + zt2zm + + use advance_helper_module, only: & + calc_brunt_vaisala_freq_sqd ! Procedure + + use constants_clubb, only: & + one_fourth, & ! Constant(s) + one_third, & + one, & + five + + use interpolation, only: & + linear_interp_factor ! Procedure + + use stats_variables, only: & + iRichardson_num, & ! Variable(s) + ibrunt_vaisala_freq_sqd, & + stats_zm, & + l_stats_samp + + use stats_type_utilities, only: & + stat_update_var ! Procedure + + implicit none + + ! Constant Parameters + real( kind = core_rknd ), parameter :: & + Richardson_num_divisor_threshold = 1.0e-8_core_rknd, & + Richardson_num_min = one_fourth, & + Richardson_num_max = five, & + C7_min = one_third, & + C7_max = one, & + C7_Skw_fnc_below_ground_value = one + + logical, parameter :: & + l_C7_Skw_fnc_vert_avg = .true. ! Vertically average C7_Skw_fnc over a + ! distance of Lscale + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + thlm, & ! th_l (liquid water potential temperature) [K] + um, & ! u mean wind component (thermodynamic levels) [m/s] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + Lscale, & ! Turbulent mixing length [m] + exner, & ! Exner function [-] + rtm, & ! total water mixing ratio, r_t [kg/kg] + rcm, & ! cloud water mixing ratio, r_c [kg/kg] + p_in_Pa, & ! Air pressure [Pa] + cloud_frac, & ! Cloud fraction [-] + rho_ds_zm ! Dry static density on momentum levels [kg/m^3] + + + ! Output Variable + real( kind = core_rknd), dimension(gr%nz) :: & + C7_Skw_fnc + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + brunt_vaisala_freq_sqd, & + Richardson_num, & + dum_dz, dvm_dz, & + shear_sqd, & + turb_freq_sqd, & + Lscale_zm + + !----------------------------------------------------------------------- + !----- Begin Code ----- + brunt_vaisala_freq_sqd = calc_brunt_vaisala_freq_sqd( thlm, exner, rtm, rcm, p_in_Pa, & + cloud_frac ) + + ! Statistics sampling + if ( l_stats_samp ) then + + ! NOTE: This is a kludgy place to sample brunt_vaisala_freq_sqd, because + ! it is used in multiple places, and depending on CLUBB parameters, it + ! could be computed in another place and not here. In the future, we + ! should compute brunt_vaisala_freq_sqd once, and pass it around + ! everywhere. This will save on computational expense as well. + call stat_update_var( ibrunt_vaisala_freq_sqd, brunt_vaisala_freq_sqd, stats_zm ) + + end if ! l_stats_samp + + Lscale_zm = zt2zm( Lscale ) + turb_freq_sqd = em / Lscale_zm**2 + + ! Calculate shear_sqd + dum_dz = ddzt( um ) + dvm_dz = ddzt( vm ) + shear_sqd = dum_dz**2 + dvm_dz**2 + + Richardson_num = brunt_vaisala_freq_sqd / max( shear_sqd, turb_freq_sqd, & + Richardson_num_divisor_threshold ) + + ! C7_Skw_fnc is interpolated based on the value of Richardson_num + where ( Richardson_num <= Richardson_num_min ) + C7_Skw_fnc = C7_min + else where ( Richardson_num >= Richardson_num_max ) + C7_Skw_fnc = C7_max + else where + ! Linear interpolation + C7_Skw_fnc = linear_interp_factor( (Richardson_num-Richardson_num_min) / & + (Richardson_num_max-Richardson_num_min), C7_max, C7_min ) + end where + + if ( l_C7_Skw_fnc_vert_avg ) then + C7_Skw_fnc = Lscale_width_vert_avg( C7_Skw_fnc, Lscale_zm, rho_ds_zm, & + C7_Skw_fnc_below_ground_value ) + end if + + ! Stats sampling + if ( l_stats_samp ) then + call stat_update_var( iRichardson_num, Richardson_num, stats_zm ) + end if + + end function compute_C7_Skw_fnc_Richardson + !---------------------------------------------------------------------- + + !---------------------------------------------------------------------- + function Lscale_width_vert_avg( var_profile, Lscale_zm, rho_ds_zm, var_below_ground_value ) + + ! Description: + ! Averages a profile over vertical levels within Lscale_zm of a given level + + ! References: + ! cam:ticket:59 + + use clubb_precision, only: & + core_rknd ! Precision + + use grid_class, only: & + gr ! Variable + + use fill_holes, only: & + vertical_avg ! Procedure + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + var_profile, & ! Profile on momentum levels + Lscale_zm, & ! Lscale on momentum levels + rho_ds_zm ! Dry static energy on momentum levels! + + real( kind = core_rknd ), intent(in) :: & + var_below_ground_value ! Value to use below ground + + ! Result Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + Lscale_width_vert_avg ! Vertically averaged profile (on momentum levels) + + ! Local Variables + integer :: k, k_avg_lower, k_avg_upper, k_inner_loop + + real( kind = core_rknd ), dimension(:), allocatable :: & + rho_ds_zm_virtual, & + var_profile_virtual, & + invrs_dzm_virtual + + integer :: n_virtual_levels, n_below_ground_levels + + !---------------------------------------------------------------------- + !----- Begin Code ----- + outer_vert_loop: do k=1, gr%nz + + !------------------------------------------------------------ + ! Hunt down all vertical levels with Lscale_zm(k) of gr%zm(k). + !------------------------------------------------------------ + + k_avg_upper = k + inner_vert_loop_upward: do k_inner_loop=k+1, gr%nz + if ( gr%zm(k_inner_loop) - gr%zm(k) <= Lscale_zm(k) ) then + ! Include this height level in the average. + k_avg_upper = k_inner_loop + else + ! Do not include this level in the average. No point in searching further. + exit + end if + end do inner_vert_loop_upward + + k_avg_lower = k + inner_vert_loop_downward: do k_inner_loop=k-1, 1, -1 + if ( gr%zm(k) - gr%zm(k_inner_loop) <= Lscale_zm(k) ) then + ! Include this height level in the average. + k_avg_lower = k_inner_loop + else + ! Do not include this level in the average. No point in searching further. + exit + end if + end do inner_vert_loop_downward + + ! Compute the number of levels below ground to include. + if ( k_avg_lower > 1 ) then + ! k=1, the lowest "real" level, is not included in the average, so no + ! below-ground levels should be included. + n_below_ground_levels = 0 + else + ! The number of below-ground levels included is equal to Lscale_zm(1) + ! divided by the distance between vertical levels below ground; the + ! latter is assumed to be the same as the distance between the first and + ! second vertical levels. + n_below_ground_levels = int( Lscale_zm(1) / (gr%zm(2)-gr%zm(1)) ) + end if + + ! Prepare the virtual levels! + n_virtual_levels = k_avg_upper-k_avg_lower+n_below_ground_levels+1 + allocate( rho_ds_zm_virtual(n_virtual_levels), var_profile_virtual(n_virtual_levels), & + invrs_dzm_virtual(n_virtual_levels) ) + + ! All vertical levels have rho_ds_zm and invrs_dzm_virtual equal to the + ! values at k=1. The value of var_profile at k=1 is given as an argument + ! to this function. + if ( n_below_ground_levels > 0 ) then + rho_ds_zm_virtual(1:n_below_ground_levels) = rho_ds_zm(1) + var_profile_virtual(1:n_below_ground_levels) = var_below_ground_value + invrs_dzm_virtual(1:n_below_ground_levels) = gr%invrs_dzm(1) + end if + + ! Set up the above-ground virtual levels. + rho_ds_zm_virtual(n_below_ground_levels+1:n_virtual_levels) = & + rho_ds_zm(k_avg_lower:k_avg_upper) + var_profile_virtual(n_below_ground_levels+1:n_virtual_levels) = & + var_profile(k_avg_lower:k_avg_upper) + invrs_dzm_virtual(n_below_ground_levels+1:n_virtual_levels) = & + gr%invrs_dzm(k_avg_lower:k_avg_upper) + + ! Finally, compute the average. + Lscale_width_vert_avg(k) = vertical_avg( n_virtual_levels, rho_ds_zm_virtual, & + var_profile_virtual, invrs_dzm_virtual ) + + deallocate( rho_ds_zm_virtual, var_profile_virtual, invrs_dzm_virtual ) + + end do outer_vert_loop + + return + end function Lscale_width_vert_avg + +end module advance_xm_wpxp_module diff --git a/src/physics/clubb/advance_xp2_xpyp_module.F90 b/src/physics/clubb/advance_xp2_xpyp_module.F90 new file mode 100644 index 0000000000..e32312ab6f --- /dev/null +++ b/src/physics/clubb/advance_xp2_xpyp_module.F90 @@ -0,0 +1,3454 @@ +!----------------------------------------------------------------------- +! $Id: advance_xp2_xpyp_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module advance_xp2_xpyp_module + + ! Description: + ! Contains the subroutine advance_xp2_xpyp and ancillary functions. + !----------------------------------------------------------------------- + + implicit none + + public :: advance_xp2_xpyp, & + update_xp2_mc + + private :: xp2_xpyp_lhs, & + xp2_xpyp_solve, & + xp2_xpyp_uv_rhs, & + xp2_xpyp_rhs, & + xp2_xpyp_implicit_stats, & + term_ta_lhs, & + term_ta_lhs_upwind, & + term_ta_rhs, & + term_tp, & + term_dp1_lhs, & + term_dp1_rhs, & + term_pr1, & + term_pr2 + + private ! Set default scope + + ! Private named constants to avoid string comparisons + integer, parameter, private :: & + xp2_xpyp_rtp2 = 1, & ! Named constant for rtp2 solves + xp2_xpyp_thlp2 = 2, & ! Named constant for thlp2 solves + xp2_xpyp_rtpthlp = 3, & ! Named constant for rtpthlp solves + xp2_xpyp_up2_vp2 = 4, & ! Named constant for up2_vp2 solves + xp2_xpyp_up2 = 5, & ! Named constant for up2 solves + xp2_xpyp_vp2 = 6, & ! Named constant for vp2 solves + xp2_xpyp_scalars = 7, & ! Named constant for scalar solves + xp2_xpyp_sclrp2 = 8, & ! Named constant for sclrp2 solves + xp2_xpyp_sclrprtp = 9, & ! Named constant for sclrprtp solves + xp2_xpyp_sclrpthlp = 10 ! Named constant for sclrpthlp solves + + contains + + !============================================================================= + subroutine advance_xp2_xpyp( tau_zm, wm_zm, rtm, wprtp, thlm, & + wpthlp, wpthvp, um, vm, wp2, wp2_zt, & + wp3, upwp, vpwp, sigma_sqd_w, Skw_zm, & + Kh_zt, rtp2_forcing, thlp2_forcing, & + rtpthlp_forcing, rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, thv_ds_zm, & + Lscale, wp3_on_wp2, wp3_on_wp2_zt, & + l_iter, dt, & + sclrm, wpsclrp, & + rtp2, thlp2, rtpthlp, up2, vp2, & + err_code, & + sclrp2, sclrprtp, sclrpthlp ) + + ! Description: + ! Subprogram to diagnose variances by solving steady-state equations + + ! References: + ! Eqn. 13, 14, 15 on p. 3545 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + + ! See also: + ! ``Equations for CLUBB'', Section 4: + ! /Steady-state solution for the variances/ + !----------------------------------------------------------------------- + + use constants_clubb, only: & + w_tol_sqd, & ! Constant(s) + rt_tol, & + thl_tol, & + w_tol_sqd, & + fstderr, & + one, & + two_thirds, & + one_half, & + one_third, & + zero, & + zero_threshold + + use model_flags, only: & + l_hole_fill, & ! logical constants + l_single_C2_Skw + + use parameters_tunable, only: & + C2rt, & ! Variable(s) + C2thl, & + C2rtthl, & + c_K2, & + nu2_vert_res_dep, & + c_K9, & + nu9_vert_res_dep, & + beta, & + C4, & + C14, & + C5, & + C2, & + C2b, & + C2c + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + sclr_tol + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use clip_explicit, only: & + clip_covar, & ! Procedure(s) + clip_variance, & + clip_sclrp2, & + clip_sclrprtp, & + clip_sclrpthlp + + use stats_type_utilities, only: & + stat_modify + + use error_code, only: & + clubb_no_error, & ! Variable(s) + clubb_var_out_of_range, & + clubb_singular_matrix + + use error_code, only: & + fatal_error, & ! Procedure(s) + clubb_at_least_debug_level + + use stats_variables, only: & + stats_zm, & + irtp2_cl, & + l_stats_samp + + use array_index, only: & + iisclr_rt, & + iisclr_thl + + implicit none + + ! Intrinsic functions + intrinsic :: & + exp, sqrt, min + + ! Constant parameters + logical, parameter :: & + l_clip_large_rtp2 = .true. ! Clip rtp2 to be < rtm^2 * coef + + real( kind = core_rknd ), parameter :: & + rtp2_clip_coef = one_half ! Coefficient appled the clipping threshold on rtp2 [-] + + ! Input variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + tau_zm, & ! Time-scale tau on momentum levels [s] + wm_zm, & ! w-wind component on momentum levels [m/s] + rtm, & ! Total water mixing ratio (t-levs) [kg/kg] + wprtp, & ! (momentum levels) [(m/s)(kg/kg)] + thlm, & ! Liquid potential temp. (t-levs) [K] + wpthlp, & ! (momentum levels) [(m K)/s] + wpthvp, & ! (momentum levels) [(m K)/s] + um, & ! u wind (thermodynamic levels) [m/s] + vm, & ! v wind (thermodynamic levels) [m/s] + wp2, & ! (momentum levels) [m^2/s^2] + wp2_zt, & ! interpolated to thermo. levels [m^2/s^2] + wp3, & ! (thermodynamic levels) [m^3/s^3] + upwp, & ! (momentum levels) [m^2/s^2] + vpwp, & ! (momentum levels) [m^2/s^2] + sigma_sqd_w, & ! sigma_sqd_w (momentum levels) [-] + Skw_zm, & ! Skewness of w on momentum levels [-] + Kh_zt, & ! Eddy diffusivity on thermo. levels [m^2/s] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [(kg/kg)K/s] + rho_ds_zm, & ! Dry, static density on momentum levs. [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ mom. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on mom. levs. [K] + Lscale, & ! Mixing length [m] + wp3_on_wp2, & ! Smoothed version of / zm [m/s] + wp3_on_wp2_zt ! Smoothed version of / zt [m/s] + + logical, intent(in) :: l_iter ! Whether variances are prognostic + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + ! Passive scalar input + real( kind = core_rknd ), intent(in), dimension(gr%nz, sclr_dim) :: & + sclrm, wpsclrp + + ! Input/Output variables + ! An attribute of (inout) is also needed to import the value of the variances + ! at the surface. Brian. 12/18/05. + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + rtp2, & ! [(kg/kg)^2] + thlp2, & ! [K^2] + rtpthlp, & ! [(kg K)/kg] + up2, & ! [m^2/s^2] + vp2 ! [m^2/s^2] + + ! Output variable for singular matrices + integer, intent(inout) :: err_code + + ! Passive scalar output + real( kind = core_rknd ), intent(inout), dimension(gr%nz, sclr_dim) :: & + sclrp2, sclrprtp, sclrpthlp + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + C2sclr_1d, C2rt_1d, C2thl_1d, C2rtthl_1d, & + C4_C14_1d ! Parameters C4 and C14 combined for simplicity + + real( kind = core_rknd ), dimension(gr%nz) :: & + a1 ! a_1 (momentum levels); See eqn. 24 in `Equations for CLUBB' [-] + + real( kind = core_rknd ), dimension(gr%nz) :: & + upwp_zt, & ! interpolated to thermodynamic levels [m^2/s^2] + vpwp_zt, & ! interpolated to thermodynamic levels [m^2/s^2] + wpsclrp_zt ! interp. to thermo. levels [m/s {sclrm units}] + + real( kind = core_rknd ) :: & + threshold ! Minimum value for variances [units vary] + + real( kind = core_rknd ), dimension(3,gr%nz) :: & + lhs ! Tridiagonal matrix + + real( kind = core_rknd ), dimension(gr%nz,1) :: & + rhs ! RHS vector of tridiagonal matrix + + real( kind = core_rknd ), dimension(gr%nz,2) :: & + uv_rhs, &! RHS vectors of tridiagonal system for up2/vp2 + uv_solution ! Solution to the tridiagonal system for up2/vp2 + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim*3) :: & + sclr_rhs, & ! RHS vectors of tridiagonal system for the passive scalars + sclr_solution ! Solution to tridiagonal system for the passive scalars + + integer, dimension(5+1) :: & + err_code_array ! Array containing the error codes for each variable + + ! Eddy Diffusion for Variances and Covariances. + real( kind = core_rknd ), dimension(gr%nz) :: & + Kw2, & ! For rtp2, thlp2, rtpthlp, and passive scalars [m^2/s] + Kw9 ! For up2 and vp2 [m^2/s] + + real( kind = core_rknd ), dimension(gr%nz) :: & + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + wprtp_zt, & ! w'r_t' interpolated to thermodynamic levels [(kg/kg) m/s] + wpthlp_zt ! w'th_l' interpolated to thermodyamnic levels [K m/s] + + real( kind = core_rknd ), dimension(gr%nz) :: & + rtpthlp_chnge ! Net change in r_t'th_l' due to clipping [(kg/kg) K] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + sclrprtp_chnge, & ! Net change in sclr'r_t' due to clipping [{units vary}] + sclrpthlp_chnge ! Net change in sclr'th_l' due to clipping [{units vary}] + + real( kind = core_rknd ), dimension(gr%nz) :: & + sclrp2_forcing, & ! forcing (momentum levels) [units vary] + sclrprtp_forcing, & ! forcing (momentum levels) [units vary] + sclrpthlp_forcing ! forcing (momentum levels) [units vary] + + logical :: l_scalar_calc, l_first_clip_ts, l_last_clip_ts + + ! Loop indices + integer :: i, k + + !---------------------------- Begin Code ---------------------------------- + + if ( clubb_at_least_debug_level( 2 ) ) then + ! Assertion check for C5 + if ( C5 > one .or. C5 < zero ) then + write(fstderr,*) "The C5 variable is outside the valid range" + err_code = clubb_var_out_of_range + return + end if + end if + + if ( l_single_C2_Skw ) then + ! Use a single value of C2 for all equations. + C2rt_1d(1:gr%nz) & + = C2b + (C2-C2b) *exp( -one_half * (Skw_zm(1:gr%nz)/C2c)**2 ) + + C2thl_1d = C2rt_1d + C2rtthl_1d = C2rt_1d + + C2sclr_1d = C2rt_1d + else + ! Use 3 different values of C2 for rtp2, thlp2, rtpthlp. + C2rt_1d(1:gr%nz) = C2rt + C2thl_1d(1:gr%nz) = C2thl + C2rtthl_1d(1:gr%nz) = C2rtthl + + C2sclr_1d(1:gr%nz) = C2rt ! Use rt value for now + end if + + ! Combine C4 and C14 for simplicity + C4_C14_1d(1:gr%nz) = ( two_thirds * C4 ) + ( one_third * C14 ) + + ! Are we solving for passive scalars as well? + if ( sclr_dim > 0 ) then + l_scalar_calc = .true. + else + l_scalar_calc = .false. + end if + + + ! Define a_1 (located on momentum levels). + ! It is a variable that is a function of sigma_sqd_w (where sigma_sqd_w is + ! located on the momentum levels). + a1(1:gr%nz) = one / ( one - sigma_sqd_w(1:gr%nz) ) + + + ! Interpolate a_1, w'r_t', w'th_l', u'w', and v'w' from the momentum levels + ! to the thermodynamic levels. These will be used for the turbulent + ! advection (ta) terms in each equation. + a1_zt = max( zm2zt( a1 ), zero_threshold ) ! Positive definite quantity + wprtp_zt = zm2zt( wprtp ) + wpthlp_zt = zm2zt( wpthlp ) + upwp_zt = zm2zt( upwp ) + vpwp_zt = zm2zt( vpwp ) + + ! Initialize tridiagonal solutions to valid + + err_code_array(:) = clubb_no_error + + + ! Define the Coefficent of Eddy Diffusivity for the variances + ! and covariances. + do k = 1, gr%nz, 1 + + ! Kw2 is used for variances and covariances rtp2, thlp2, rtpthlp, and + ! passive scalars. The variances and covariances are located on the + ! momentum levels. Kw2 is located on the thermodynamic levels. + ! Kw2 = c_K2 * Kh_zt + Kw2(k) = c_K2 * Kh_zt(k) + + ! Kw9 is used for variances up2 and vp2. The variances are located on + ! the momentum levels. Kw9 is located on the thermodynamic levels. + ! Kw9 = c_K9 * Kh_zt + Kw9(k) = c_K9 * Kh_zt(k) + + enddo + + !!!!!***** r_t'^2 *****!!!!! + + ! Implicit contributions to term rtp2 + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C2rt_1d, nu2_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) + + + call xp2_xpyp_rhs( xp2_xpyp_rtp2, dt, l_iter, a1, a1_zt, & ! Intent(in) + wp2_zt, wprtp, wprtp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wprtp, wprtp_zt, & ! Intent(in) + rtm, rtm, rtp2, rtp2_forcing, & ! Intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) + C2rt_1d, tau_zm, rt_tol**2, beta, & ! Intent(in) + rhs ) ! Intent(out) + + ! Solve the tridiagonal system + call xp2_xpyp_solve( xp2_xpyp_rtp2, 1, & ! Intent(in) + rhs, lhs, rtp2, & ! Intent(inout) + err_code_array(1) ) ! Intent(out) + + if ( l_stats_samp ) then + call xp2_xpyp_implicit_stats( xp2_xpyp_rtp2, rtp2 ) ! Intent(in) + end if + + !!!!!***** th_l'^2 *****!!!!! + + ! Implicit contributions to term thlp2 + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C2thl_1d, nu2_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) + + ! Explicit contributions to thlp2 + call xp2_xpyp_rhs( xp2_xpyp_thlp2, dt, l_iter, a1, a1_zt, & ! Intent(in) + wp2_zt, wpthlp, wpthlp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! Intent(in) + thlm, thlm, thlp2, thlp2_forcing, & ! Intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) + C2thl_1d, tau_zm, thl_tol**2, beta, & ! Intent(in) + rhs ) ! Intent(out) + + ! Solve the tridiagonal system + call xp2_xpyp_solve( xp2_xpyp_thlp2, 1, & ! Intent(in) + rhs, lhs, thlp2, & ! Intent(inout) + err_code_array(2) ) ! Intent(out) + + if ( l_stats_samp ) then + call xp2_xpyp_implicit_stats( xp2_xpyp_thlp2, thlp2 ) ! Intent(in) + end if + + + !!!!!***** r_t'th_l' *****!!!!! + + ! Implicit contributions to term rtpthlp + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C2rtthl_1d, nu2_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) + + ! Explicit contributions to rtpthlp + call xp2_xpyp_rhs( xp2_xpyp_rtpthlp, dt, l_iter, a1, a1_zt, & ! Intent(in) + wp2_zt, wprtp, wprtp_zt, wp3_on_wp2, & ! Intent(in) + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! Intent(in) + rtm, thlm, rtpthlp, rtpthlp_forcing, & ! Intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) + C2rtthl_1d, tau_zm, zero_threshold, beta, & ! Intent(in) + rhs ) ! Intent(out) + + ! Solve the tridiagonal system + call xp2_xpyp_solve( xp2_xpyp_rtpthlp, 1, & ! Intent(in) + rhs, lhs, rtpthlp, & ! Intent(inout) + err_code_array(3) ) ! Intent(out) + + if ( l_stats_samp ) then + call xp2_xpyp_implicit_stats( xp2_xpyp_rtpthlp, rtpthlp ) ! Intent(in) + end if + + + !!!!!***** u'^2 / v'^2 *****!!!!! + + ! Implicit contributions to term up2/vp2 + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw9, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C4_C14_1d, nu9_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) + + ! Explicit contributions to up2 + call xp2_xpyp_uv_rhs( xp2_xpyp_up2, dt, l_iter, a1, a1_zt, wp2, & ! Intent(in) + wp2_zt, wpthvp, Lscale, wp3_on_wp2_zt, & ! Intent(in) + wp3_on_wp2, C4_C14_1d, tau_zm, & ! Intent(in) + um, vm, upwp, upwp_zt, vpwp, vpwp_zt, & ! Intent(in) + up2, vp2, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) + rho_ds_zm, & ! Intent(in) + thv_ds_zm, C4, C5, C14, beta, & ! Intent(in) + uv_rhs(:,1) ) ! Intent(out) + + ! Explicit contributions to vp2 + call xp2_xpyp_uv_rhs( xp2_xpyp_vp2, dt, l_iter, a1, a1_zt, wp2, & ! Intent(in) + wp2_zt, wpthvp, Lscale, wp3_on_wp2_zt, & ! Intent(in) + wp3_on_wp2, C4_C14_1d, tau_zm, & ! Intent(in) + vm, um, vpwp, vpwp_zt, upwp, upwp_zt, & ! Intent(in) + vp2, up2, rho_ds_zt, invrs_rho_ds_zm, & ! Intent(in) + rho_ds_zm, & ! Intent(in) + thv_ds_zm, C4, C5, C14, beta, & ! Intent(in) + uv_rhs(:,2) ) ! Intent(out) + + ! Solve the tridiagonal system + call xp2_xpyp_solve( xp2_xpyp_up2_vp2, 2, & ! Intent(in) + uv_rhs, lhs, & ! Intent(inout) + uv_solution, err_code_array(4) ) ! Intent(out) + + up2(1:gr%nz) = uv_solution(1:gr%nz,1) + vp2(1:gr%nz) = uv_solution(1:gr%nz,2) + + if ( l_stats_samp ) then + call xp2_xpyp_implicit_stats( xp2_xpyp_up2, up2 ) ! Intent(in) + call xp2_xpyp_implicit_stats( xp2_xpyp_vp2, vp2 ) ! Intent(in) + end if + + + ! Apply the positive definite scheme to variances + if ( l_hole_fill ) then + call pos_definite_variances( xp2_xpyp_rtp2, dt, rt_tol**2, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + rtp2 ) ! Intent(inout) + call pos_definite_variances( xp2_xpyp_thlp2, dt, thl_tol**2, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + thlp2 ) ! Intent(inout) + call pos_definite_variances( xp2_xpyp_up2, dt, w_tol_sqd, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + up2 ) ! Intent(inout) + call pos_definite_variances( xp2_xpyp_vp2, dt, w_tol_sqd, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + vp2 ) ! Intent(inout) + endif + + + ! Clipping for r_t'^2 + + !threshold = zero_threshold + ! + !where ( wp2 >= w_tol_sqd ) & + ! threshold = rt_tol*rt_tol + + threshold = rt_tol**2 + + call clip_variance( xp2_xpyp_rtp2, dt, threshold, & ! Intent(in) + rtp2 ) ! Intent(inout) + + ! Special clipping on the variance of rt to prevent a large variance at + ! higher altitudes. This is done because we don't want the PDF to extend + ! into the negative, and found that for latin hypercube sampling a large + ! variance aloft leads to negative samples of total water. + ! -dschanen 8 Dec 2010 + if ( l_clip_large_rtp2 ) then + + ! This overwrites stats clipping data from clip_variance + if ( l_stats_samp ) then + call stat_modify( irtp2_cl, -rtp2 / dt, stats_zm ) + endif + + do k = 1, gr%nz + threshold = rtp2_clip_coef * rtm(k)**2 + if ( rtp2(k) > threshold ) then + rtp2(k) = threshold + end if + end do ! k = 1..gr%nz + + if ( l_stats_samp ) then + call stat_modify( irtp2_cl, rtp2 / dt, stats_zm ) + endif + + end if ! l_clip_large_rtp2 + + + + ! Clipping for th_l'^2 + + !threshold = zero_threshold + ! + !where ( wp2 >= w_tol_sqd ) & + ! threshold = thl_tol*thl_tol + + threshold = thl_tol**2 + + call clip_variance( xp2_xpyp_thlp2, dt, threshold, & ! Intent(in) + thlp2 ) ! Intent(inout) + + + ! Clipping for u'^2 + + !threshold = zero_threshold + threshold = w_tol_sqd + + call clip_variance( xp2_xpyp_up2, dt, threshold, & ! Intent(in) + up2 ) ! Intent(inout) + + + ! Clipping for v'^2 + + !threshold = zero_threshold + threshold = w_tol_sqd + + call clip_variance( xp2_xpyp_vp2, dt, threshold, & ! Intent(in) + vp2 ) ! Intent(inout) + + + ! Clipping for r_t'th_l' + ! Clipping r_t'th_l' at each vertical level, based on the + ! correlation of r_t and th_l at each vertical level, such that: + ! corr_(r_t,th_l) = r_t'th_l' / [ sqrt(r_t'^2) * sqrt(th_l'^2) ]; + ! -1 <= corr_(r_t,th_l) <= 1. + ! Since r_t'^2, th_l'^2, and r_t'th_l' are all computed in the + ! same place, clipping for r_t'th_l' only has to be done once. + l_first_clip_ts = .true. + l_last_clip_ts = .true. + call clip_covar( xp2_xpyp_rtpthlp, l_first_clip_ts, & ! Intent(in) + l_last_clip_ts, dt, rtp2, thlp2, & ! Intent(in) + rtpthlp, rtpthlp_chnge ) ! Intent(inout) + + if ( l_scalar_calc ) then + + ! Implicit contributions to passive scalars + + !!!!!***** sclr'^2, sclr'r_t', sclr'th_l' *****!!!!! + + call xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & ! Intent(in) + a1, a1_zt, tau_zm, wm_zm, Kw2, & ! Intent(in) + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & ! Intent(in) + C2sclr_1d, nu2_vert_res_dep, beta, & ! Intent(in) + lhs ) ! Intent(out) + + + ! Explicit contributions to passive scalars + + do i = 1, sclr_dim, 1 + + ! Interpolate w'sclr' from momentum levels to thermodynamic + ! levels. These will be used for the turbulent advection (ta) + ! terms in each equation. + wpsclrp_zt = zm2zt( wpsclrp(:,i) ) + + ! Forcing for . + sclrp2_forcing = zero + + !!!!!***** sclr'^2 *****!!!!! + + call xp2_xpyp_rhs( xp2_xpyp_sclrp2, dt, l_iter, a1, a1_zt, & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wpsclrp(:,i), wpsclrp_zt, & ! In + sclrm(:,i), sclrm(:,i), sclrp2(:,i), sclrp2_forcing, & ! In + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In + C2sclr_1d, tau_zm, sclr_tol(i)**2, beta, & ! In + sclr_rhs(:,i) ) ! Out + + + !!!!!***** sclr'r_t' *****!!!!! + if ( i == iisclr_rt ) then + ! In this case we're trying to emulate rt'^2 with sclr'rt', so we + ! handle this as we would a variance, even though generally speaking + ! the scalar is not rt + sclrprtp_forcing = rtp2_forcing + threshold = rt_tol**2 + else + sclrprtp_forcing = zero + threshold = zero_threshold + endif + + call xp2_xpyp_rhs( xp2_xpyp_sclrprtp, dt, l_iter, a1, a1_zt, & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wprtp, wprtp_zt, & ! In + sclrm(:,i), rtm, sclrprtp(:,i), sclrprtp_forcing, & ! In + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In + C2sclr_1d, tau_zm, threshold, beta, & ! In + sclr_rhs(:,i+sclr_dim) ) ! Out + + + !!!!!***** sclr'th_l' *****!!!!! + + if ( i == iisclr_thl ) then + ! In this case we're trying to emulate thl'^2 with sclr'thl', so we + ! handle this as we did with sclr_rt, above. + sclrpthlp_forcing = thlp2_forcing + threshold = thl_tol**2 + else + sclrpthlp_forcing = zero + threshold = zero_threshold + endif + + call xp2_xpyp_rhs( xp2_xpyp_sclrpthlp, dt, l_iter, a1, a1_zt, & ! In + wp2_zt, wpsclrp(:,i), wpsclrp_zt, wp3_on_wp2, & ! In + wp3_on_wp2_zt, wpthlp, wpthlp_zt, & ! In + sclrm(:,i), thlm, sclrpthlp(:,i), sclrpthlp_forcing, & ! In + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! In + C2sclr_1d, tau_zm, threshold, beta, & ! In + sclr_rhs(:,i+2*sclr_dim) ) ! Out + + + enddo ! 1..sclr_dim + + + ! Solve the tridiagonal system + + call xp2_xpyp_solve( xp2_xpyp_scalars, 3*sclr_dim, & ! Intent(in) + sclr_rhs, lhs, sclr_solution, & ! Intent(inout) + err_code_array(6) ) ! Intent(out) + + sclrp2(:,1:sclr_dim) = sclr_solution(:,1:sclr_dim) + + sclrprtp(:,1:sclr_dim) = sclr_solution(:,sclr_dim+1:2*sclr_dim) + + sclrpthlp(:,1:sclr_dim) = sclr_solution(:,2*sclr_dim+1:3*sclr_dim) + + ! Apply hole filling algorithm to the scalar variance terms + if ( l_hole_fill ) then + do i = 1, sclr_dim, 1 + call pos_definite_variances( xp2_xpyp_sclrp2, dt, sclr_tol(i)**2, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + sclrp2(:,i) ) ! Intent(inout) + if ( i == iisclr_rt ) then + ! Here again, we do this kluge here to make sclr'rt' == rt'^2 + call pos_definite_variances( xp2_xpyp_sclrprtp, dt, sclr_tol(i)**2, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + sclrprtp(:,i) ) ! Intent(inout) + end if + if ( i == iisclr_thl ) then + ! As with sclr'rt' above, but for sclr'thl' + call pos_definite_variances( xp2_xpyp_sclrpthlp, dt, sclr_tol(i)**2, & ! Intent(in) + rho_ds_zm, rho_ds_zt, & ! Intent(in) + sclrpthlp(:,i) ) ! Intent(inout) + end if + enddo + endif + + + ! Clipping for sclr'^2 + do i = 1, sclr_dim, 1 + +! threshold = zero_threshold +! +! where ( wp2 >= w_tol_sqd ) & +! threshold = sclr_tol(i)*sclr_tol(i) + + threshold = sclr_tol(i)**2 + + call clip_variance( clip_sclrp2, dt, threshold, & ! Intent(in) + sclrp2(:,i) ) ! Intent(inout) + + enddo + + + ! Clipping for sclr'r_t' + ! Clipping sclr'r_t' at each vertical level, based on the + ! correlation of sclr and r_t at each vertical level, such that: + ! corr_(sclr,r_t) = sclr'r_t' / [ sqrt(sclr'^2) * sqrt(r_t'^2) ]; + ! -1 <= corr_(sclr,r_t) <= 1. + ! Since sclr'^2, r_t'^2, and sclr'r_t' are all computed in the + ! same place, clipping for sclr'r_t' only has to be done once. + do i = 1, sclr_dim, 1 + + if ( i == iisclr_rt ) then + ! Treat this like a variance if we're emulating rt + threshold = sclr_tol(i) * rt_tol + + call clip_variance( clip_sclrprtp, dt, threshold, & ! Intent(in) + sclrprtp(:,i) ) ! Intent(inout) + else + l_first_clip_ts = .true. + l_last_clip_ts = .true. + call clip_covar( clip_sclrprtp, l_first_clip_ts, & ! Intent(in) + l_last_clip_ts, dt, sclrp2(:,i), rtp2(:), & ! Intent(in) + sclrprtp(:,i), sclrprtp_chnge(:,i) ) ! Intent(inout) + end if + enddo + + + ! Clipping for sclr'th_l' + ! Clipping sclr'th_l' at each vertical level, based on the + ! correlation of sclr and th_l at each vertical level, such that: + ! corr_(sclr,th_l) = sclr'th_l' / [ sqrt(sclr'^2) * sqrt(th_l'^2) ]; + ! -1 <= corr_(sclr,th_l) <= 1. + ! Since sclr'^2, th_l'^2, and sclr'th_l' are all computed in the + ! same place, clipping for sclr'th_l' only has to be done once. + do i = 1, sclr_dim, 1 + if ( i == iisclr_thl ) then + ! As above, but for thl + threshold = sclr_tol(i) * thl_tol + call clip_variance( clip_sclrpthlp, dt, threshold, & ! Intent(in) + sclrpthlp(:,i) ) ! Intent(inout) + else + l_first_clip_ts = .true. + l_last_clip_ts = .true. + call clip_covar( clip_sclrpthlp, l_first_clip_ts, & ! Intent(in) + l_last_clip_ts, dt, sclrp2(:,i), thlp2(:), & ! Intent(in) + sclrpthlp(:,i), sclrpthlp_chnge(:,i) ) ! Intent(inout) + end if + enddo + + endif ! l_scalar_calc + + + ! Check for singular matrices and bad LAPACK arguments + if ( any( fatal_error( err_code_array ) ) ) then + err_code = clubb_singular_matrix + end if + + if ( fatal_error( err_code ) .and. & + clubb_at_least_debug_level( 1 ) ) then + + write(fstderr,*) "Error in advance_xp2_xpyp" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "tau_zm = ", tau_zm + write(fstderr,*) "wm_zm = ", wm_zm + write(fstderr,*) "rtm = ", rtm + write(fstderr,*) "wprtp = ", wprtp + write(fstderr,*) "thlm = ", thlm + write(fstderr,*) "wpthlp = ", wpthlp + write(fstderr,*) "wpthvp = ", wpthvp + write(fstderr,*) "um = ", um + write(fstderr,*) "vm = ", vm + write(fstderr,*) "wp2 = ", wp2 + write(fstderr,*) "wp3 = ", wp3 + write(fstderr,*) "upwp = ", upwp + write(fstderr,*) "vpwp = ", vpwp + write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w + write(fstderr,*) "Skw_zm = ", Skw_zm + write(fstderr,*) "Kh_zt = ", Kh_zt + write(fstderr,*) "rtp2_forcing = ", rtp2_forcing + write(fstderr,*) "thlp2_forcing = ", thlp2_forcing + write(fstderr,*) "rtpthlp_forcing = ", rtpthlp_forcing + write(fstderr,*) "rho_ds_zm = ", rho_ds_zm + write(fstderr,*) "rho_ds_zt = ", rho_ds_zt + write(fstderr,*) "invrs_rho_ds_zm = ", invrs_rho_ds_zm + write(fstderr,*) "thv_ds_zm = ", thv_ds_zm + write(fstderr,*) "wp2_zt = ", wp2_zt + + do i = 1, sclr_dim + write(fstderr,*) "sclrm = ", i, sclrm(:,i) + write(fstderr,*) "wpsclrp = ", i, wpsclrp(:,i) + enddo + + write(fstderr,*) "Intent(In/Out)" + + write(fstderr,*) "rtp2 = ", rtp2 + write(fstderr,*) "thlp2 = ", thlp2 + write(fstderr,*) "rtpthlp = ", rtpthlp + write(fstderr,*) "up2 = ", up2 + write(fstderr,*) "vp2 = ", vp2 + + do i = 1, sclr_dim + write(fstderr,*) "sclrp2 = ", i, sclrp2(:,i) + write(fstderr,*) "sclrprtp = ", i, sclrprtp(:,i) + write(fstderr,*) "sclrthlp = ", i, sclrpthlp(:,i) + enddo + + endif + + return + end subroutine advance_xp2_xpyp + + !============================================================================= + subroutine xp2_xpyp_lhs( dt, l_iter, wp3_on_wp2_zt, wp3_on_wp2, & + a1, a1_zt, tau_zm, wm_zm, Kw, & + rho_ds_zt, rho_ds_zm, invrs_rho_ds_zm, & + Cn, nu, beta, lhs ) + + ! Description: + ! Compute LHS tridiagonal matrix for a variance or covariance term + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero + + use model_flags, only: & + l_upwind_xpyp_ta ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use diffusion, only: & + diffusion_zm_lhs ! Procedure(s) + + use mean_adv, only: & + term_ma_zm_lhs ! Procedure(s) + + use stats_variables, only: & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + l_stats_samp, & + irtp2_ma, & + irtp2_ta, & + irtp2_dp1, & + irtp2_dp2, & + ithlp2_ma, & + ithlp2_ta, & + ithlp2_dp1, & + ithlp2_dp2, & + irtpthlp_ma, & + irtpthlp_ta, & + irtpthlp_dp1, & + irtpthlp_dp2, & + iup2_ma, & + iup2_ta, & + iup2_dp2, & + ivp2_ma, & + ivp2_ta, & + ivp2_dp2 + + use advance_helper_module, only: set_boundary_conditions_lhs + + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep length [s] + + logical, intent(in) :: & + l_iter ! Whether the variances are prognostic (T/F) + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp3_on_wp2, & ! Smoothed w'^3 / w'^2 (moment. levels) [m/s] + wp3_on_wp2_zt, & ! Smoothed w'^3 / w'^2 (thermo. levels) [m/s] + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + tau_zm, & ! Time-scale tau on momentum levels [s] + wm_zm, & ! w wind component on momentum levels [m/s] + Kw, & ! Coefficient of eddy diffusivity (all vars.) [m^2/s] + rho_ds_zt, & ! Dry, static density on thermodynamic levels [kg/m^3] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levs. [m^3/kg] + Cn ! Coefficient C_n [-] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + nu ! Background constant coef. of eddy diff. [-] + real( kind = core_rknd ), intent(in) :: & + beta ! Constant model parameter beta [-] + + ! Output Variables + real( kind = core_rknd ), dimension(3,gr%nz), intent(out) :: & + lhs ! Implicit contributions to the term + + ! Local Variables + + ! Array indices + integer :: k, kp1, km1, low_bound, high_bound + + real( kind = core_rknd ), dimension(3) :: & + tmp + + ! Initialize LHS matrix to 0. + lhs = zero + + ! Setup LHS of the tridiagonal system + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! LHS mean advection (ma) term. + lhs(kp1_mdiag:km1_mdiag,k) & + = lhs(kp1_mdiag:km1_mdiag,k) & + + term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + + ! LHS turbulent advection (ta) term. + ! Note: An "over-implicit" weighted time step is applied to this term. + ! The weight of the implicit portion of this term is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (x'^2 or x'y' in this case), y(t) is the linearized + ! portion of the term that gets treated implicitly, and RHS is the + ! portion of the term that is always treated explicitly. A weight + ! of greater than 1 can be applied to make the term more + ! numerically stable. + if ( .not. l_upwind_xpyp_ta ) then + lhs(kp1_mdiag:km1_mdiag,k) & + = lhs(kp1_mdiag:km1_mdiag,k) & + + gamma_over_implicit_ts & + * term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else + lhs(kp1_mdiag:km1_mdiag,k) & + = lhs(kp1_mdiag:km1_mdiag,k) & + + gamma_over_implicit_ts & + * term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + end if + + ! LHS dissipation term 1 (dp1) + ! (combined with pressure term 1 (pr1) for u'^2 and v'^2). + ! Note: An "over-implicit" weighted time step is applied to this term + ! (and to pressure term 1 for u'^2 and v'^2). + lhs(k_mdiag,k) & + = lhs(k_mdiag,k) & + + gamma_over_implicit_ts & + * term_dp1_lhs( Cn(k), tau_zm(k) ) + + ! LHS eddy diffusion term: dissipation term 2 (dp2). + lhs(kp1_mdiag:km1_mdiag,k) & + = lhs(kp1_mdiag:km1_mdiag,k) & + + diffusion_zm_lhs( Kw(k), Kw(kp1), nu, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + + ! LHS time tendency. + if ( l_iter ) then + lhs(k_mdiag,k) = lhs(k_mdiag,k) + ( one / dt ) + endif + + if ( l_stats_samp ) then + + ! Statistics: implicit contributions for rtp2, thlp2, + ! rtpthlp, up2, or vp2. + + if ( irtp2_dp1 + ithlp2_dp1 + irtpthlp_dp1 > 0 ) then + ! Note: The statistical implicit contribution to term dp1 + ! (as well as to term pr1) for up2 and vp2 is recorded + ! in xp2_xpyp_uv_rhs because up2 and vp2 use a special + ! dp1/pr1 combined term. + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note above for + ! LHS turbulent advection (ta) term). + tmp(1) & + = gamma_over_implicit_ts & + * term_dp1_lhs( Cn(k), tau_zm(k) ) + zmscr01(k) = -tmp(1) + endif + + if ( irtp2_dp2 + ithlp2_dp2 + irtpthlp_dp2 + & + iup2_dp2 + ivp2_dp2 > 0 ) then + tmp(1:3) & + = diffusion_zm_lhs( Kw(k), Kw(kp1), nu, & + gr%invrs_dzt(kp1), gr%invrs_dzt(k), & + gr%invrs_dzm(k), k ) + zmscr02(k) = -tmp(3) + zmscr03(k) = -tmp(2) + zmscr04(k) = -tmp(1) + endif + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for LHS turbulent + ! advection (ta) term). + if ( irtp2_ta + ithlp2_ta + irtpthlp_ta + & + iup2_ta + ivp2_ta > 0 ) then + if ( .not. l_upwind_xpyp_ta ) then + tmp(1:3) & + = gamma_over_implicit_ts & + * term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else + tmp(1:3) & + = gamma_over_implicit_ts & + * term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + end if + + zmscr05(k) = -tmp(3) + zmscr06(k) = -tmp(2) + zmscr07(k) = -tmp(1) + endif + + if ( irtp2_ma + ithlp2_ma + irtpthlp_ma + & + iup2_ma + ivp2_ma > 0 ) then + tmp(1:3) & + = term_ma_zm_lhs( wm_zm(k), gr%invrs_dzm(k), k ) + zmscr08(k) = -tmp(3) + zmscr09(k) = -tmp(2) + zmscr10(k) = -tmp(1) + endif + + endif ! l_stats_samp + + enddo ! k=2..gr%nz-1 + + + ! Boundary Conditions + ! These are set so that the surface_varnce value of the variances and + ! covariances can be used at the lowest boundary and the values of those + ! variables can be set to their respective threshold minimum values at the + ! top boundary. Fixed-point boundary conditions are used for both the + ! variances and the covariances. + low_bound = 1 + high_bound = gr%nz + + call set_boundary_conditions_lhs( k_mdiag, low_bound, high_bound, lhs ) + + return + + end subroutine xp2_xpyp_lhs + + !============================================================================= + subroutine xp2_xpyp_solve( solve_type, nrhs, rhs, lhs, xapxbp, err_code ) + + ! Description: + ! Solve a tridiagonal system + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use lapack_wrap, only: & + tridag_solve, & ! Variable(s) + tridag_solvex !, & +! band_solve + + use grid_class, only: & + gr ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only: & + stats_sfc, & ! Derived type + irtp2_matrix_condt_num, & ! Stat index Variables + ithlp2_matrix_condt_num, & + irtpthlp_matrix_condt_num, & + iup2_vp2_matrix_condt_num, & + l_stats_samp ! Logical + + use error_code, only: & + clubb_no_error ! Constant + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: trim + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + ! Input variables + integer, intent(in) :: & + nrhs ! Number of right hand side vectors + + integer, intent(in) :: & + solve_type ! Variable(s) description + + ! Input/Ouput variables + real( kind = core_rknd ), dimension(gr%nz,nrhs), intent(inout) :: & + rhs ! Explicit contributions to x variance/covariance term [units vary] + + real( kind = core_rknd ), dimension(3,gr%nz), intent(inout) :: & + lhs ! Implicit contributions to x variance/covariance term [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz,nrhs), intent(out) :: & + xapxbp ! Computed value of the variable(s) at [units vary] + + integer, intent(out) :: & + err_code ! Returns an error code in the event of a singular matrix + + ! Local variables + real( kind = core_rknd ) :: rcond ! Est. of the reciprocal of the condition # on the matrix + + integer :: ixapxbp_matrix_condt_num ! Stat index + + character(len=10) :: & + solve_type_str ! solve_type in string format for debug output purposes + + ! --- Begin Code --- + err_code = clubb_no_error ! Initialize to the value for no errors + + select case ( solve_type ) + !------------------------------------------------------------------------ + ! Note that these are diagnostics from inverting the matrix, not a budget + !------------------------------------------------------------------------ + case ( xp2_xpyp_rtp2 ) + ixapxbp_matrix_condt_num = irtp2_matrix_condt_num + solve_type_str = "rtp2" + case ( xp2_xpyp_thlp2 ) + ixapxbp_matrix_condt_num = ithlp2_matrix_condt_num + solve_type_str = "thlp2" + case ( xp2_xpyp_rtpthlp ) + ixapxbp_matrix_condt_num = irtpthlp_matrix_condt_num + solve_type_str = "rtpthlp" + case ( xp2_xpyp_up2_vp2 ) + ixapxbp_matrix_condt_num = iup2_vp2_matrix_condt_num + solve_type_str = "up2_vp2" + case default + ! No condition number is setup for the passive scalars + ixapxbp_matrix_condt_num = 0 + solve_type_str = "scalar" + end select + + if ( l_stats_samp .and. ixapxbp_matrix_condt_num > 0 ) then + call tridag_solvex & + ( solve_type_str, gr%nz, nrhs, & ! Intent(in) + lhs(kp1_mdiag,:), lhs(k_mdiag,:), lhs(km1_mdiag,:), rhs(:,1:nrhs), & ! Intent(inout) + xapxbp(:,1:nrhs), rcond, err_code ) ! Intent(out) + + ! Est. of the condition number of the variance LHS matrix + call stat_update_var_pt( ixapxbp_matrix_condt_num, 1, one / rcond, & ! Intent(in) + stats_sfc ) ! Intent(inout) + + else + call tridag_solve & + ( solve_type_str, gr%nz, nrhs, lhs(kp1_mdiag,:), & ! Intent(in) + lhs(k_mdiag,:), lhs(km1_mdiag,:), rhs(:,1:nrhs), & ! Intent(inout) + xapxbp(:,1:nrhs), err_code ) ! Intent(out) + end if + + return + end subroutine xp2_xpyp_solve + + !============================================================================= + subroutine xp2_xpyp_implicit_stats( solve_type, xapxbp ) + + ! Description: + ! Finalize implicit contributions for r_t'^2, th_l'^2, r_t'th_l', + ! u'^2, and v'^2. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Derived type variable + + use stats_type_utilities, only: & + stat_end_update_pt, & ! Procedure(s) + stat_update_var_pt + + use stats_variables, only: & + stats_zm, & ! Variable(s) + irtp2_dp1, & + irtp2_dp2, & + irtp2_ta, & + irtp2_ma, & + ithlp2_dp1, & + ithlp2_dp2, & + ithlp2_ta, & + ithlp2_ma, & + irtpthlp_dp1, & + irtpthlp_dp2, & + irtpthlp_ta, & + irtpthlp_ma, & + iup2_dp1, & + iup2_dp2, & + iup2_ta, & + iup2_ma, & + iup2_pr1, & + ivp2_dp1 + + use stats_variables, only: & + ivp2_dp2, & + ivp2_ta, & + ivp2_ma, & + ivp2_pr1, & + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11 + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: max, min, trim + + ! Input variables + integer, intent(in) :: & + solve_type ! Variable(s) description + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xapxbp ! Computed value of the variable at [units vary] + + ! Local variables + integer :: k, kp1, km1 ! Array indices + + ! Budget indices + integer :: & + ixapxbp_dp1, & + ixapxbp_dp2, & + ixapxbp_ta, & + ixapxbp_ma, & + ixapxbp_pr1 + + ! --- Begin Code --- + + select case ( solve_type ) + case ( xp2_xpyp_rtp2 ) + ixapxbp_dp1 = irtp2_dp1 + ixapxbp_dp2 = irtp2_dp2 + ixapxbp_ta = irtp2_ta + ixapxbp_ma = irtp2_ma + ixapxbp_pr1 = 0 + + case ( xp2_xpyp_thlp2 ) + ixapxbp_dp1 = ithlp2_dp1 + ixapxbp_dp2 = ithlp2_dp2 + ixapxbp_ta = ithlp2_ta + ixapxbp_ma = ithlp2_ma + ixapxbp_pr1 = 0 + + case ( xp2_xpyp_rtpthlp ) + ixapxbp_dp1 = irtpthlp_dp1 + ixapxbp_dp2 = irtpthlp_dp2 + ixapxbp_ta = irtpthlp_ta + ixapxbp_ma = irtpthlp_ma + ixapxbp_pr1 = 0 + + case ( xp2_xpyp_up2 ) + ixapxbp_dp1 = iup2_dp1 + ixapxbp_dp2 = iup2_dp2 + ixapxbp_ta = iup2_ta + ixapxbp_ma = iup2_ma + ixapxbp_pr1 = iup2_pr1 + + case ( xp2_xpyp_vp2 ) + ixapxbp_dp1 = ivp2_dp1 + ixapxbp_dp2 = ivp2_dp2 + ixapxbp_ta = ivp2_ta + ixapxbp_ma = ivp2_ma + ixapxbp_pr1 = ivp2_pr1 + + case default ! No budgets are setup for the passive scalars + ixapxbp_dp1 = 0 + ixapxbp_dp2 = 0 + ixapxbp_ta = 0 + ixapxbp_ma = 0 + ixapxbp_pr1 = 0 + + end select + + do k = 2, gr%nz-1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! x'y' term dp1 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( ixapxbp_dp1, k, & ! Intent(in) + zmscr01(k) * xapxbp(k), & ! Intent(in) + stats_zm ) ! Intent(inout) + + ! x'y' term dp2 is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_dp2, k, & ! Intent(in) + zmscr02(k) * xapxbp(km1) & ! Intent(in) + + zmscr03(k) * xapxbp(k) & + + zmscr04(k) * xapxbp(kp1), & + stats_zm ) ! Intent(inout) + + ! x'y' term ta has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( ixapxbp_ta, k, & ! Intent(in) + zmscr05(k) * xapxbp(km1) & ! Intent(in) + + zmscr06(k) * xapxbp(k) & + + zmscr07(k) * xapxbp(kp1), & + stats_zm ) ! Intent(inout) + + ! x'y' term ma is completely implicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_ma, k, & ! Intent(in) + zmscr08(k) * xapxbp(km1) & ! Intent(in) + + zmscr09(k) * xapxbp(k) & + + zmscr10(k) * xapxbp(kp1), & + stats_zm ) ! Intent(inout) + + ! x'y' term pr1 has both implicit and explicit components; + ! call stat_end_update_pt. + call stat_end_update_pt( ixapxbp_pr1, k, & ! Intent(in) + zmscr11(k) * xapxbp(k), & ! Intent(in) + stats_zm ) ! Intent(inout) + + end do ! k=2..gr%nz-1 + + return + end subroutine xp2_xpyp_implicit_stats + + !============================================================================= + subroutine xp2_xpyp_uv_rhs( solve_type, dt, l_iter, a1, a1_zt, wp2, & + wp2_zt, wpthvp, Lscale, wp3_on_wp2_zt, & + wp3_on_wp2, C4_C14_1d, tau_zm, & + xam, xbm, wpxap, wpxap_zt, wpxbp, wpxbp_zt, & + xap2, xbp2, rho_ds_zt, invrs_rho_ds_zm, & + rho_ds_zm, & + thv_ds_zm, C4, C5, C14, beta, & + rhs ) + + ! Description: + ! Explicit contributions to u'^2 or v'^2 + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + gamma_over_implicit_ts, & ! Constant(s) + w_tol_sqd, & + one, & + two_thirds, & + one_third, & + zero + + use model_flags, only: & + l_upwind_xpyp_ta ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update_pt, & ! Procedure(s) + stat_update_var_pt, & + stat_modify_pt + + use stats_variables, only: & + ivp2_ta, & ! Variable(s) + ivp2_tp, & + ivp2_dp1, & + ivp2_pr1, & + ivp2_pr2, & + iup2_ta, & + iup2_tp, & + iup2_dp1, & + iup2_pr1, & + iup2_pr2, & + stats_zm, & + zmscr01, & + zmscr11, & + l_stats_samp + + implicit none + + ! Input Variables + integer, intent(in) :: solve_type + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + logical, intent(in) :: & + l_iter ! Whether x is prognostic (T/F) + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp2_zt, & ! w'^2 interpolated to thermodynamic levels [m^2/s^2] + wpthvp, & ! w'th_v' (momentum levels) [K m/s] + Lscale, & ! Mixing Length [m] + wp3_on_wp2, & ! Smoothed w'^3 / w'^2 on momentum levels [m/s] + wp3_on_wp2_zt, & ! Smoothed w'^3 / w'^2 on thermo. levels [m/s] + C4_C14_1d, & ! Combination of model params. C_4 and C_14 [-] + tau_zm, & ! Time-scale tau on momentum levels [s] + xam, & ! x_am (thermodynamic levels) [m/s] + xbm, & ! x_bm (thermodynamic levels) [m/s] + wpxap, & ! w'x_a' (momentum levels) [m^2/s^2] + wpxap_zt, & ! w'x_a' interpolated to thermodynamic levels [m^2/s^2] + wpxbp, & ! w'x_b' (momentum levels) [m^2/s^2] + wpxbp_zt, & ! w'x_b' interpolated to thermodynamic levels [m^2/s^2] + xap2, & ! x_a'^2 (momentum levels) [m^2/s^2] + xbp2, & ! x_b'^2 (momentum levels) [m^2/s^2] + rho_ds_zt, & ! Dry, static density on thermodynamic levels [kg/m^3] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levs. [m^3/kg] + thv_ds_zm ! Dry, base-state theta_v on momentum levels [K] + + real( kind = core_rknd ), intent(in) :: & + C4, & ! Model parameter C_4 [-] + C5, & ! Model parameter C_5 [-] + C14, & ! Model parameter C_{14} [-] + beta ! Model parameter beta [-] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz,1), intent(out) :: & + rhs ! Explicit contributions to x variance/covariance terms + + ! Local Variables + + ! Array indices + integer :: k, kp1, km1 + + ! For "over-implicit" weighted time step. + ! This vector holds output from the LHS (implicit) portion of a term at a + ! given vertical level. This output is weighted and applied to the RHS. + ! This is used if the implicit portion of the term is "over-implicit", which + ! means that the LHS contribution is given extra weight (>1) in order to + ! increase numerical stability. A weighted factor must then be applied to + ! the RHS in order to balance the weight. + real( kind = core_rknd ), dimension(3) :: lhs_fnc_output + + real( kind = core_rknd ) :: tmp + + integer :: & + ixapxbp_ta, & + ixapxbp_tp, & + ixapxbp_dp1, & + ixapxbp_pr1, & + ixapxbp_pr2 + + !----------------------------- Begin Code ---------------------------------- + + select case ( solve_type ) + case ( xp2_xpyp_vp2 ) + ixapxbp_ta = ivp2_ta + ixapxbp_tp = ivp2_tp + ixapxbp_dp1 = ivp2_dp1 + ixapxbp_pr1 = ivp2_pr1 + ixapxbp_pr2 = ivp2_pr2 + case ( xp2_xpyp_up2 ) + ixapxbp_ta = iup2_ta + ixapxbp_tp = iup2_tp + ixapxbp_dp1 = iup2_dp1 + ixapxbp_pr1 = iup2_pr1 + ixapxbp_pr2 = iup2_pr2 + case default ! No budgets for passive scalars + ixapxbp_ta = 0 + ixapxbp_tp = 0 + ixapxbp_dp1 = 0 + ixapxbp_pr1 = 0 + ixapxbp_pr2 = 0 + end select + + + ! Initialize RHS vector to 0. + rhs = zero + + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! RHS turbulent advection (ta) term. + rhs(k,1) & + = rhs(k,1) & + + term_ta_rhs( wp2_zt(kp1), wp2_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & + wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS turbulent advection (ta) term. + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + ! The weight of the implicit portion of this term is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (x'^2 or x'y' in this case), y(t) is the linearized + ! portion of the term that gets treated implicitly, and RHS is the + ! portion of the term that is always treated explicitly. A weight + ! of greater than 1 can be applied to make the term more + ! numerically stable. + if ( .not. l_upwind_xpyp_ta ) then + lhs_fnc_output(1:3) & + = term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else + lhs_fnc_output(1:3) & + = term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + end if + + rhs(k,1) & + = rhs(k,1) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * xap2(kp1) & + - lhs_fnc_output(2) * xap2(k) & + - lhs_fnc_output(3) * xap2(km1) ) + + ! RHS turbulent production (tp) term. + rhs(k,1) & + = rhs(k,1) & + + ( one - C5 ) & + * term_tp( xam(kp1), xam(k), xam(kp1), xam(k), & + wpxap(k), wpxap(k), gr%invrs_dzm(k) ) + + ! RHS pressure term 1 (pr1) (and dissipation term 1 (dp1)). + rhs(k,1) & + = rhs(k,1) & + + term_pr1( C4, C14, xbp2(k), wp2(k), tau_zm(k) ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS dissipation term 1 (dp1) and pressure term 1 (pr1). + ! + ! Note: An "over-implicit" weighted time step is applied to these terms. + lhs_fnc_output(1) & + = term_dp1_lhs( C4_C14_1d(k), tau_zm(k) ) + rhs(k,1) & + = rhs(k,1) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * xap2(k) ) + + ! RHS pressure term 2 (pr2). + rhs(k,1) & + = rhs(k,1) & + + term_pr2( C5, thv_ds_zm(k), wpthvp(k), wpxap(k), wpxbp(k), & + xam, xbm, gr%invrs_dzm(k), kp1, k, & + Lscale(kp1), Lscale(k), wp2_zt(kp1), wp2_zt(k) ) + + ! RHS time tendency. + if ( l_iter ) then + rhs(k,1) = rhs(k,1) + one/dt * xap2(k) + endif + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for up2 or vp2. + + ! x'y' term ta has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on term_ta_rhs. + call stat_begin_update_pt( ixapxbp_ta, k, & ! Intent(in) + -term_ta_rhs( wp2_zt(kp1), wp2_zt(k), & ! Intent(in) + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & + wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ), & + stats_zm ) ! Intent(inout) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) term). + if ( .not. l_upwind_xpyp_ta ) then + lhs_fnc_output(1:3) & + = term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else ! turbulent advection is using an upwind discretization + lhs_fnc_output(1:3) & + = term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + end if ! ~l_upwind_xpyp_ta + + call stat_modify_pt( ixapxbp_ta, k, & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) + * ( - lhs_fnc_output(1) * xap2(kp1) & + - lhs_fnc_output(2) * xap2(k) & + - lhs_fnc_output(3) * xap2(km1) ), & + stats_zm ) ! Intent(inout) + + if ( ixapxbp_dp1 > 0 ) then + ! Note: The function term_pr1 is the explicit component of a + ! semi-implicit solution to dp1 and pr1. + ! Record the statistical contribution of the implicit component of + ! term dp1 for up2 or vp2. This will overwrite anything set + ! statistically in xp2_xpyp_lhs for this term. + ! Note: To find the contribution of x'y' term dp1, substitute + ! (2/3)*C_4 for the C_n input to function term_dp1_lhs. + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note above for + ! RHS turbulent advection (ta) term). + tmp & + = gamma_over_implicit_ts & + * term_dp1_lhs( two_thirds*C4, tau_zm(k) ) + zmscr01(k) = -tmp + ! Statistical contribution of the explicit component of term dp1 for + ! up2 or vp2. + ! x'y' term dp1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on term_pr1. + ! Note: To find the contribution of x'y' term dp1, substitute 0 for + ! the C_14 input to function term_pr1. + call stat_begin_update_pt( ixapxbp_dp1, k, & ! Intent(in) + -term_pr1( C4, zero, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note above for + ! RHS turbulent advection (ta) term). + lhs_fnc_output(1) & + = term_dp1_lhs( two_thirds*C4, tau_zm(k) ) + call stat_modify_pt( ixapxbp_dp1, k, & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) + * ( - lhs_fnc_output(1) * xap2(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + endif + + if ( ixapxbp_pr1 > 0 ) then + ! Note: The function term_pr1 is the explicit component of a + ! semi-implicit solution to dp1 and pr1. + ! Statistical contribution of the implicit component of term pr1 for + ! up2 or vp2. + ! Note: To find the contribution of x'y' term pr1, substitute + ! (1/3)*C_14 for the C_n input to function term_dp1_lhs. + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note above for + ! RHS turbulent advection (ta) term). + tmp & + = gamma_over_implicit_ts & + * term_dp1_lhs( one_third*C14, tau_zm(k) ) + zmscr11(k) = -tmp + ! Statistical contribution of the explicit component of term pr1 for + ! up2 or vp2. + ! x'y' term pr1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on term_pr1. + ! Note: To find the contribution of x'y' term pr1, substitute 0 for + ! the C_4 input to function term_pr1. + call stat_begin_update_pt( ixapxbp_pr1, k, & ! Intent(in) + -term_pr1( zero, C14, xbp2(k), wp2(k), tau_zm(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + ! Note: An "over-implicit" weighted time step is applied to this + ! term. A weighting factor of greater than 1 may be used to + ! make the term more numerically stable (see note above for + ! RHS turbulent advection (ta) term). + lhs_fnc_output(1) & + = term_dp1_lhs( one_third*C14, tau_zm(k) ) + call stat_modify_pt( ixapxbp_pr1, k, & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) + * ( - lhs_fnc_output(1) * xap2(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + endif + + ! x'y' term pr2 is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_pr2, k, & ! Intent(in) + term_pr2( C5, thv_ds_zm(k), wpthvp(k), wpxap(k), wpxbp(k), & ! Intent(in) + xam, xbm, gr%invrs_dzm(k), kp1, k, & + Lscale(kp1), Lscale(k), wp2_zt(kp1), wp2_zt(k) ), & + stats_zm ) ! Intent(inout) + + ! x'y' term tp is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_tp, k, & ! Intent(in) + ( one - C5 ) & ! Intent(in) + * term_tp( xam(kp1), xam(k), xam(kp1), xam(k), & + wpxap(k), wpxap(k), gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) + + endif ! l_stats_samp + + enddo ! k=2..gr%nz-1 + + + ! Boundary Conditions + ! These are set so that the surface_varnce value of u'^2 or v'^2 can be + ! used at the lowest boundary and the values of those variables can be + ! set to their respective threshold minimum values at the top boundary. + ! Fixed-point boundary conditions are used for the variances. + + rhs(1,1) = xap2(1) + ! The value of u'^2 or v'^2 at the upper boundary will be set to the + ! threshold minimum value of w_tol_sqd. + rhs(gr%nz,1) = w_tol_sqd + + return + end subroutine xp2_xpyp_uv_rhs + + !============================================================================= + subroutine xp2_xpyp_rhs( solve_type, dt, l_iter, a1, a1_zt, & + wp2_zt, wpxap, wpxap_zt, wp3_on_wp2, & + wp3_on_wp2_zt, wpxbp, wpxbp_zt, & + xam, xbm, xapxbp, xapxbp_forcing, & + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + Cn, tau_zm, threshold, beta, & + rhs ) + + ! Description: + ! Explicit contributions to r_t'^2, th_l'^2, r_t'th_l', sclr'r_t', + ! sclr'th_l', or sclr'^2. + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + gamma_over_implicit_ts, & ! Constant(s) + one, & + zero + + use model_flags, only: & + l_upwind_xpyp_ta ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update_pt, & ! Procedure(s) + stat_update_var_pt, & + stat_modify_pt + + use stats_variables, only: & + irtp2_ta, & ! Variable(s) + irtp2_tp, & + irtp2_dp1, & + irtp2_forcing, & + ithlp2_ta, & + ithlp2_tp, & + ithlp2_dp1, & + ithlp2_forcing, & + irtpthlp_ta, & + irtpthlp_tp1, & + irtpthlp_tp2, & + irtpthlp_dp1, & + irtpthlp_forcing, & + stats_zm, & + l_stats_samp + + use advance_helper_module, only: set_boundary_conditions_rhs + + implicit none + + ! Input Variables + integer, intent(in) :: solve_type + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + logical, intent(in) :: & + l_iter ! Whether x is prognostic (T/F) + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + a1, & ! sigma_sqd_w term a_1 (momentum levels) [-] + a1_zt, & ! a_1 interpolated to thermodynamic levels [-] + wp2_zt, & ! w'^2 interpolated to thermodynamic levels [m^2/s^2] + wpxap, & ! w'x_a' (momentum levels) [m/s {x_am units}] + wpxap_zt, & ! w'x_a' interpolated to thermodynamic levels [m/s {x_am units}] + wp3_on_wp2, & ! w'^3 / w'^2 on momentum levels [m/s] + wp3_on_wp2_zt, & ! w'^3 / w'^2 on thermodynamic levels [m/s] + wpxbp, & ! w'x_b' (momentum levels) [m/s {x_bm units}] + wpxbp_zt, & ! w'x_b' interpolated to thermodynamic levels [m/s {x_bm units}] + xam, & ! x_am (thermodynamic levels) [{x_am units}] + xbm, & ! x_bm (thermodynamic levels) [{x_bm units}] + xapxbp, & ! x_a'x_b' (momentum levels) [{x_am units}*{x_bm units}] + xapxbp_forcing, & ! x_a'x_b' forcing (momentum levels) [{x_am units}*{x_bm units}/s] + rho_ds_zm, & ! Dry, static density on moment. levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density on momentum levs. [m^3/kg] + tau_zm, & ! Time-scale tau on momentum levels [s] + Cn ! Coefficient C_n [-] + + real( kind = core_rknd ), intent(in) :: & + threshold, & ! Smallest allowable mag. value for x_a'x_b' [{x_am units} + ! *{x_bm units}] + beta ! Model parameter beta [-] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz,1), intent(out) :: & + rhs ! Explicit contributions to x variance/covariance terms + + ! Local Variables + + ! Array indices + integer :: k, kp1, km1, k_low, k_high + + ! For "over-implicit" weighted time step. + ! This vector holds output from the LHS (implicit) portion of a term at a + ! given vertical level. This output is weighted and applied to the RHS. + ! This is used if the implicit portion of the term is "over-implicit", which + ! means that the LHS contribution is given extra weight (>1) in order to + ! increase numerical stability. A weighted factor must then be applied to + ! the RHS in order to balance the weight. + real( kind = core_rknd ), dimension(3) :: lhs_fnc_output + + integer :: & + ixapxbp_ta, & + ixapxbp_tp, & + ixapxbp_tp1, & + ixapxbp_tp2, & + ixapxbp_dp1, & + ixapxbp_f + + !------------------------------ Begin Code --------------------------------- + + select case ( solve_type ) + case ( xp2_xpyp_rtp2 ) + ixapxbp_ta = irtp2_ta + ixapxbp_tp = irtp2_tp + ixapxbp_tp1 = 0 + ixapxbp_tp2 = 0 + ixapxbp_dp1 = irtp2_dp1 + ixapxbp_f = irtp2_forcing + case ( xp2_xpyp_thlp2 ) + ixapxbp_ta = ithlp2_ta + ixapxbp_tp = ithlp2_tp + ixapxbp_tp1 = 0 + ixapxbp_tp2 = 0 + ixapxbp_dp1 = ithlp2_dp1 + ixapxbp_f = ithlp2_forcing + case ( xp2_xpyp_rtpthlp ) + ixapxbp_ta = irtpthlp_ta + ixapxbp_tp = 0 + ixapxbp_tp1 = irtpthlp_tp1 + ixapxbp_tp2 = irtpthlp_tp2 + ixapxbp_dp1 = irtpthlp_dp1 + ixapxbp_f = irtpthlp_forcing + case default ! No budgets for passive scalars + ixapxbp_ta = 0 + ixapxbp_tp = 0 + ixapxbp_tp1 = 0 + ixapxbp_tp2 = 0 + ixapxbp_dp1 = 0 + ixapxbp_f = 0 + end select + + + ! Initialize RHS vector to 0. + rhs = zero + + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + kp1 = min( k+1, gr%nz ) + + ! RHS turbulent advection (ta) term. + rhs(k,1) & + = rhs(k,1) & + + term_ta_rhs( wp2_zt(kp1), wp2_zt(k), & + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & + wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS turbulent advection (ta) term. + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + ! The weight of the implicit portion of this term is controlled + ! by the factor gamma_over_implicit_ts (abbreviated "gamma" in the + ! expression below). A factor is added to the right-hand side of + ! the equation in order to balance a weight that is not equal to 1, + ! such that: + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! where X is the variable that is being solved for in a predictive + ! equation (x'^2 or x'y' in this case), y(t) is the linearized + ! portion of the term that gets treated implicitly, and RHS is the + ! portion of the term that is always treated explicitly. A weight + ! of greater than 1 can be applied to make the term more + ! numerically stable. + if ( .not. l_upwind_xpyp_ta ) then + lhs_fnc_output(1:3) & + = term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else + lhs_fnc_output(1:3) & + = term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + endif + + rhs(k,1) & + = rhs(k,1) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * xapxbp(kp1) & + - lhs_fnc_output(2) * xapxbp(k) & + - lhs_fnc_output(3) * xapxbp(km1) ) + + ! RHS turbulent production (tp) term. + rhs(k,1) & + = rhs(k,1) & + + term_tp( xam(kp1), xam(k), xbm(kp1), xbm(k), & + wpxbp(k), wpxap(k), gr%invrs_dzm(k) ) + + ! RHS dissipation term 1 (dp1) + rhs(k,1) & + = rhs(k,1) + term_dp1_rhs( Cn(k), tau_zm(k), threshold ) + + ! RHS contribution from "over-implicit" weighted time step + ! for LHS dissipation term 1 (dp1). + ! + ! Note: An "over-implicit" weighted time step is applied to this term. + lhs_fnc_output(1) & + = term_dp1_lhs( Cn(k), tau_zm(k) ) + rhs(k,1) & + = rhs(k,1) & + + ( one - gamma_over_implicit_ts ) & + * ( - lhs_fnc_output(1) * xapxbp(k) ) + + ! RHS time tendency. + if ( l_iter ) then + rhs(k,1) = rhs(k,1) + one/dt * xapxbp(k) + endif + + ! RHS forcing. + ! Note: forcing includes the effects of microphysics on . + rhs(k,1) = rhs(k,1) + xapxbp_forcing(k) + + + if ( l_stats_samp ) then + + ! Statistics: explicit contributions for rtp2, thlp2, or rtpthlp. + + ! x'y' term ta has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on term_ta_rhs. + call stat_begin_update_pt( ixapxbp_ta, k, & ! Intent(in) + -term_ta_rhs( wp2_zt(kp1), wp2_zt(k), & ! Intent(in) + wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), wpxbp_zt(kp1), wpxbp_zt(k), & + wpxap_zt(kp1), wpxap_zt(k), gr%invrs_dzm(k), beta ), & + stats_zm ) ! Intent(inout) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) term). + if ( .not. l_upwind_xpyp_ta ) then + lhs_fnc_output(1:3) & + = term_ta_lhs( wp3_on_wp2_zt(kp1), wp3_on_wp2_zt(k), & + rho_ds_zt(kp1), rho_ds_zt(k), invrs_rho_ds_zm(k), & + a1_zt(kp1), a1(k), a1_zt(k), gr%invrs_dzm(k), beta, k ) + else + lhs_fnc_output(1:3) & + = term_ta_lhs_upwind( a1(k), a1(kp1), a1(km1), & + wp3_on_wp2(kp1), wp3_on_wp2(k), wp3_on_wp2(km1), & + gr%invrs_dzt(k), gr%invrs_dzt(kp1), & + invrs_rho_ds_zm(k), & + rho_ds_zm(kp1), rho_ds_zm(k), rho_ds_zm(km1), beta ) + end if + call stat_modify_pt( ixapxbp_ta, k, & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) + * ( - lhs_fnc_output(1) * xapxbp(kp1) & + - lhs_fnc_output(2) * xapxbp(k) & + - lhs_fnc_output(3) * xapxbp(km1) ), & + stats_zm ) ! Intent(inout) + + ! x'y' term dp1 has both implicit and explicit components; call + ! stat_begin_update_pt. Since stat_begin_update_pt automatically + ! subtracts the value sent in, reverse the sign on term_dp1_rhs. + call stat_begin_update_pt( ixapxbp_dp1, k, & ! Intent(in) + -term_dp1_rhs( Cn(k), tau_zm(k), threshold ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + ! Note: An "over-implicit" weighted time step is applied to this term. + ! A weighting factor of greater than 1 may be used to make the + ! term more numerically stable (see note above for RHS turbulent + ! advection (ta) term). + lhs_fnc_output(1) & + = term_dp1_lhs( Cn(k), tau_zm(k) ) + call stat_modify_pt( ixapxbp_dp1, k, & ! Intent(in) + + ( one - gamma_over_implicit_ts ) & ! Intent(in) + * ( - lhs_fnc_output(1) * xapxbp(k) ), & ! Intent(in) + stats_zm ) ! Intent(inout) + + ! rtp2/thlp2 case (1 turbulent production term) + ! x'y' term tp is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_tp, k, & ! Intent(in) + term_tp( xam(kp1), xam(k), xbm(kp1), xbm(k), & ! Intent(in) + wpxbp(k), wpxap(k), gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) + + ! rtpthlp case (2 turbulent production terms) + ! x'y' term tp1 is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of x'y' term tp1, substitute 0 for all + ! the xam inputs and the wpxbp input to function term_tp. + call stat_update_var_pt( ixapxbp_tp1, k, & ! Intent(in) + term_tp( zero, zero, xbm(kp1), xbm(k), & ! Intent(in) + zero, wpxap(k), gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) + + ! x'y' term tp2 is completely explicit; call stat_update_var_pt. + ! Note: To find the contribution of x'y' term tp2, substitute 0 for all + ! the xbm inputs and the wpxap input to function term_tp. + call stat_update_var_pt( ixapxbp_tp2, k, & ! Intent(in) + term_tp( xam(kp1), xam(k), zero, zero, & ! Intent(in) + wpxbp(k), zero, gr%invrs_dzm(k) ), & + stats_zm ) ! Intent(inout) + + ! x'y' forcing term is completely explicit; call stat_update_var_pt. + call stat_update_var_pt( ixapxbp_f, k, xapxbp_forcing(k), stats_zm ) + + endif ! l_stats_samp + + enddo ! k=2..gr%nz-1 + + + ! Boundary Conditions + ! These are set so that the surface_varnce value of rtp2, thlp2, or rtpthlp + ! (or sclrp2, sclrprtp, or sclrpthlp) can be used at the lowest boundary and the + ! values of those variables can be set to their respective threshold minimum + ! values (which is 0 in the case of the covariances) at the top boundary. + ! Fixed-point boundary conditions are used for both the variances and the + ! covariances. + + k_low = 1 + k_high = gr%nz + + ! The value of the field at the upper boundary will be set to it's threshold + ! minimum value, as contained in the variable 'threshold'. + call set_boundary_conditions_rhs( & + xapxbp(1), k_low, threshold, k_high, & + rhs(:,1) ) + + return + end subroutine xp2_xpyp_rhs + + !============================================================================= + pure function term_ta_lhs( wp3_on_wp2_ztp1, wp3_on_wp2_zt, & + rho_ds_ztp1, rho_ds_zt, invrs_rho_ds_zm, & + a1_ztp1, a1, a1_zt, invrs_dzm, beta, level ) & + result( lhs ) + + ! Description: + ! Turbulent advection of x_a'x_b': implicit portion of the code. + ! + ! The d(x_a'x_b')/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'x_a'x_b' )/dz. + ! + ! A substitution is made in order to close the turbulent advection term, + ! such that: + ! + ! w'x_a'x_b' = (1/3)*beta * a_1 * ( w'^3 / w'^2 ) * x_a'x_b' + ! + (1-(1/3)*beta) * (a_1)^2 * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b'; + ! + ! where a_1 is a variable that is a function of sigma_sqd_w. The turbulent + ! advection term is rewritten as: + ! + ! - (1/rho_ds) + ! * d [ rho_ds * { (1/3)*beta * a_1 * ( w'^3 / w'^2 ) * x_a'x_b' + ! + (1-(1/3)*beta) * (a_1)^2 * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b' } ] + ! / dz; + ! + ! which produces an implicit and an explicit portion of this term. The + ! implicit portion of this term is: + ! + ! - (1/rho_ds) + ! * d [ rho_ds * (1/3)*beta * a_1 * ( w'^3 / w'^2 ) * x_a'x_b'(t+1) ] + ! / dz. + ! + ! Since (1/3)*beta is a constant, it can be pulled outside of the + ! derivative. The implicit portion of this term becomes: + ! + ! - (1/3)*beta/rho_ds + ! * d [ rho_ds * a_1 * ( w'^3 / w'^2 ) * x_a'x_b'(t+1) ] / dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of x_a'x_b' being used is + ! from the next timestep, which is being advanced to in solving the + ! d(x_a'x_b')/dt equation. + ! + ! The implicit portion of this term is discretized as follows: + ! + ! The values of x_a'x_b' are found on the momentum levels, as are the values + ! of w'^2 and a_1. The values of w'^3 are found on the thermodynamic + ! levels. Additionally, the values of rho_ds_zt are found on the + ! thermodynamic levels, and the values of invrs_rho_ds_zm are found on the + ! momentum levels. The variables x_a'x_b', w'^2, and a_1 are each + ! interpolated to the intermediate thermodynamic levels. The values of the + ! mathematical expression (called F here) within the dF/dz term are computed + ! on the thermodynamic levels. Then the derivative (d/dz) of the + ! expression (F) is taken over the central momentum level, where it is + ! multiplied by (1/3)*beta and by invrs_rho_ds_zm, yielding the desired + ! result. In this function, the values of F are as follows: + ! + ! F = rho_ds_zt * a_1(t) * ( w'^3(t) / w'^2(t) ) * x_a'x_b'(t+1); + ! + ! where the timestep index (t) stands for the index of the current timestep. + ! + ! + ! ==a1p1========wp2p1========xapxbpp1================================ m(k+1) + ! + ! ----a1(interp)--wp2(interp)--xapxbp(interp)--wp3p1---rho_ds_ztp1--- t(k+1) + ! + ! ==a1==========wp2==========xapxbp=======dF/dz====invrs_rho_ds_zm=== m(k) + ! + ! ----a1(interp)--wp2(interp)--xapxbp(interp)--wp3-----rho_ds_zt----- t(k) + ! + ! ==a1m1========wp2m1========xapxbpm1================================ m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & ! gr%weights_zm2zt + gr ! Variable(s) + + use constants_clubb, only: & + one_third ! Constant(s) + + use model_flags, only: & + l_standard_term_ta + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: max + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + integer, parameter :: & + m_above = 1, & ! Index for upper momentum level grid weight. + m_below = 2 ! Index for lower momentum level grid weight. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wp3_on_wp2_ztp1, & ! w'^3 / w'^2 (k+1) [m/s] + wp3_on_wp2_zt, & ! w'^3 / w'^2 (k) [m/s] + rho_ds_ztp1, & ! Dry, static density at thermo. level (k+1) [kg/m^3] + rho_ds_zt, & ! Dry, static density at thermo. level (k) [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum lev (k) [m^3/kg] + a1_ztp1, & ! a_1 interpolated to thermo. level (k+1) [-] + a1, & ! a_1(k) [-] + a1_zt, & ! a_1 interpolated to thermo. level (k) [-] + invrs_dzm, & ! Inverse of grid spacing [1/m] + beta ! Model parameter [-] + + integer, intent(in) :: & + level ! Central momentum level (on which calculation occurs). + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + ! Local Variables + integer :: & + tkp1, & ! Thermodynamic level directly above central momentum level. + tk ! Thermodynamic level directly below central momentum level. + + + ! Thermodynamic level (k+1) is between momentum level (k+1) + ! and momentum level (k). + tkp1 = level + 1 + + ! Thermodynamic level (k) is between momentum level (k) + ! and momentum level (k-1). + tk = level + + if ( l_standard_term_ta ) then + + ! The turbulent advection term is discretized normally, in accordance + ! with the model equations found in the documentation and the description + ! listed above. + + ! Momentum superdiagonal: [ x xapxbp(k+1,) ] + lhs(kp1_mdiag) & + = + one_third * beta & + * invrs_rho_ds_zm & + * invrs_dzm & + * rho_ds_ztp1 * a1_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_above,tkp1) + + ! Momentum main diagonal: [ x xapxbp(k,) ] + lhs(k_mdiag) & + = + one_third * beta & + * invrs_rho_ds_zm & + * invrs_dzm & + * ( rho_ds_ztp1 * a1_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_below,tkp1) & + - rho_ds_zt * a1_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_above,tk) & + ) + + ! Momentum subdiagonal: [ x xapxbp(k-1,) ] + lhs(km1_mdiag) & + = - one_third * beta & + * invrs_rho_ds_zm & + * invrs_dzm & + * rho_ds_zt * a1_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_below,tk) + + else + + ! Brian tried a new discretization for the turbulent advection term, for + ! which the implicit portion of the term is: + ! - (1/rho_ds) + ! * d [ rho_ds * a_1 * (1/3)*beta * ( w'^3 / w'^2 ) * x_a'x_b' ] / dz. + ! In order to help stabilize x_a'x_b', a_1 has been pulled outside the + ! derivative. + + ! Momentum superdiagonal: [ x xapxbp(k+1,) ] + lhs(kp1_mdiag) & + = + one_third * beta & + * invrs_rho_ds_zm * a1 & + * invrs_dzm & + * rho_ds_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_above,tkp1) + + ! Momentum main diagonal: [ x xapxbp(k,) ] + lhs(k_mdiag) & + = + one_third * beta & + * invrs_rho_ds_zm * a1 & + * invrs_dzm & + * ( rho_ds_ztp1 & + * wp3_on_wp2_ztp1 & + * gr%weights_zm2zt(m_below,tkp1) & + - rho_ds_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_above,tk) & + ) + + ! Momentum subdiagonal: [ x xapxbp(k-1,) ] + lhs(km1_mdiag) & + = - one_third * beta & + * invrs_rho_ds_zm * a1 & + * invrs_dzm & + * rho_ds_zt & + * wp3_on_wp2_zt & + * gr%weights_zm2zt(m_below,tk) + + ! End of Brian's a1 change. 14 Feb 2008. + + endif + + + return + end function term_ta_lhs + + !----------------------------------------------------------------------------- + pure function term_ta_lhs_upwind( a1_zm, a1_zm_p1, a1_zm_m1, & + wp3_on_wp2_p1, wp3_on_wp2, wp3_on_wp2_m1, & + invrs_dzt, invrs_dzt_p1, & + invrs_rho_ds_zm, & + rho_ds_zm_p1, rho_ds_zm, rho_ds_zm_m1, beta ) & + result( lhs ) + + ! Description: + ! Turbulent advection of x_a'x_b' using an upwind differencing + ! approximation rather than a centered difference. + ! References: + ! None + !----------------------------------------------------------------------------- + + use constants_clubb, only: & + one_third, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + a1_zm, & ! a_1(k) on momentum levels [-] + a1_zm_p1, & ! a_1(k+1) on momentum levels [-] + a1_zm_m1, & ! a_1(k-1) on momentum levels [-] + wp3_on_wp2_p1, & ! Smoothed wp3 / wp2 on moment. levels (k+1) [m/s] + wp3_on_wp2, & ! Smoothed wp3 / wp2 on moment. levels (k) [m/s] + wp3_on_wp2_m1, & ! Smoothed wp3 / wp2 on moment. levels (k-1) [m/s] + invrs_dzt, & ! Inverse of grid spacing (k) [1/m] + invrs_dzt_p1, & ! Inverse of grid spacing (k+1) [1/m] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum lev (k) [m^3/kg] + rho_ds_zm, & ! Density of air (k) [kg/m^3] + rho_ds_zm_p1, & ! Density of air (k+1) [kg/m^3] + rho_ds_zm_m1, & ! Density of air (k-1) [kg/m^3] + beta ! Model parameter [-] + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + + if ( wp3_on_wp2 > zero ) then + + ! Momentum main diagonal: [ x xapxbp(k+1,) ] + lhs(kp1_mdiag) = zero + + ! Momentum main diagonal: [ x xapxbp(k,) ] + lhs(k_mdiag) & + = + one_third * beta & + * invrs_dzt * invrs_rho_ds_zm & + * rho_ds_zm * a1_zm * wp3_on_wp2 + + ! Momentum subdiagonal: [ x xapxbp(k-1,) ] + lhs(km1_mdiag) & + = - one_third * beta & + * invrs_dzt * invrs_rho_ds_zm & + * rho_ds_zm_m1 * a1_zm_m1 * wp3_on_wp2_m1 + + else ! "Wind" is blowing downward + + ! Momentum main diagonal: [ x xapxbp(k+1,) ] + lhs(kp1_mdiag) & + = + one_third * beta & + * invrs_dzt_p1 * invrs_rho_ds_zm & + * rho_ds_zm_p1 * a1_zm_p1 * wp3_on_wp2_p1 + + ! Momentum main diagonal: [ x xapxbp(k,) ] + lhs(k_mdiag) & + = - one_third * beta & + * invrs_dzt_p1 * invrs_rho_ds_zm & + * rho_ds_zm * a1_zm * wp3_on_wp2 + + ! Momentum subdiagonal: [ x xapxbp(k-1,) ] + lhs(km1_mdiag) = zero + + end if + + return + end function term_ta_lhs_upwind + + !============================================================================= + pure function term_ta_rhs( wp2_ztp1, wp2_zt, & + wp3_on_wp2_ztp1, wp3_on_wp2_zt, & + rho_ds_ztp1, rho_ds_zt, invrs_rho_ds_zm, & + a1_ztp1, a1, a1_zt, wpxbp_ztp1, wpxbp_zt, & + wpxap_ztp1, wpxap_zt, invrs_dzm, beta ) & + result( rhs ) + + ! Description: + ! Turbulent advection of x_a'x_b': explicit portion of the code. + ! + ! The d(x_a'x_b')/dt equation contains a turbulent advection term: + ! + ! - (1/rho_ds) * d( rho_ds * w'x_a'x_b' )/dz. + ! + ! A substitution is made in order to close the turbulent advection term, + ! such that: + ! + ! w'x_a'x_b' = (1/3)*beta * a_1 * ( w'^3 / w'^2 ) * x_a'x_b' + ! + (1-(1/3)*beta) * (a_1)^2 * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b'; + ! + ! where a_1 is a variable that is a function of sigma_sqd_w. The turbulent + ! advection term is rewritten as: + ! + ! - (1/rho_ds) + ! * d [ rho_ds * { (1/3)*beta * a_1 * ( w'^3 / w'^2 ) * x_a'x_b' + ! + (1-(1/3)*beta) * (a_1)^2 * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b' } ] + ! / dz; + ! + ! which produces an implicit and an explicit portion of this term. The + ! explicit portion of this term is: + ! + ! - (1/rho_ds) + ! * d [ rho_ds * (1-(1/3)*beta) * (a_1)^2 * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b' ] / dz. + ! + ! Since (1-(1/3)*beta) is a constant, it can be pulled outside of the + ! derivative. The explicit portion of this term becomes: + ! + ! - (1-(1/3)*beta)/rho_ds + ! * d [ rho_ds * (a_1)^2 * ( w'^3 / (w'^2)^2 ) * w'x_a' * w'x_b' ] / dz. + ! + ! The explicit portion of this term is discretized as follows: + ! + ! The values of w'x_a', w'x_b', w'^2, and a_1 are found on the momentum + ! levels. The values of w'^3 are found on the thermodynamic levels. + ! Additionally, the values of rho_ds_zt are found on the thermodynamic + ! levels, and the values of invrs_rho_ds_zm are found on the momentum + ! levels. The variables w'x_a', w'x_b', w'^2, and a_1 are each interpolated + ! to the intermediate thermodynamic levels. The values of the mathematical + ! expression (called F here) within the dF/dz term are computed on the + ! thermodynamic levels. Then the derivative (d/dz) of the expression (F) is + ! taken over the central momentum level, where it is multiplied by + ! (1-(1/3)*beta), and by invrs_rho_ds_zm, yielding the desired result. In + ! this function, the values of F are as follows: + ! + ! F = rho_ds_zt * ( a_1(t) )^2 * ( w'^3(t) / ( w'^2(t) )^2 ) + ! * w'x_a'(t) * w'x_b'(t); + ! + ! where the timestep index (t) stands for the index of the current timestep. + ! + ! + ! =a1p1=======wp2p1=======wpxapp1=======wpxbpp1========================= m(k+1) + ! + ! -a1(interp)-wp2(interp)-wpxap(interp)-wpxbp(interp)-wp3p1-rho_ds_ztp1- t(k+1) + ! + ! =a1=========wp2=========wpxap=========wpxbp===dF/dz===invrs_rho_ds_zm= m(k) + ! + ! -a1(interp)-wp2(interp)-wpxap(interp)-wpxbp(interp)-wp3---rho_ds_zt--- t(k) + ! + ! =a1m1=======wp2m1=======wpxapm1=======wpxbpm1========================= m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + one_third + + use model_flags, only: & + l_standard_term_ta + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: max + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + wp2_ztp1, & ! w'^2 interpolated to thermo. level (k+1) [m^2/s^2] + wp2_zt, & ! w'^2 interpolated to thermo. level (k) [m^2/s^2] + wp3_on_wp2_ztp1, & ! Smoothed w'^3 / w'^2 on thermo. level (k+1)[m^2/s^2] + wp3_on_wp2_zt, & ! Smoothed w'^3 / w'^2 on thermo. level (k) [m^2/s^2] + rho_ds_ztp1, & ! Dry, static density at thermo. level (k+1) [kg/m^3] + rho_ds_zt, & ! Dry, static density at thermo. level (k) [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ mome. lev (k) [m^3/kg] + a1_ztp1, & ! a_1 interpolated to thermo. level (k+1) [-] + a1, & ! a_1(k) [-] + a1_zt, & ! a_1 interpolated to thermo. level (k) [-] + wpxbp_ztp1, & ! w'x_b' interpolated to thermo. level (k+1) [m/s {x_bm units}] + wpxbp_zt, & ! w'x_b' interpolated to thermo. level (k) [m/s {x_bm units}] + wpxap_ztp1, & ! w'x_a' interpolated to thermo. level (k+1) [m/s {x_am units}] + wpxap_zt, & ! w'x_a' interpolated to thermo. level (k) [m/s {x_am units}] + invrs_dzm, & ! Inverse of grid spacing [1/m] + beta ! Model parameter [-] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + + if ( l_standard_term_ta ) then + + ! The turbulent advection term is discretized normally, in accordance + ! with the model equations found in the documentation and the description + ! listed above. + + rhs & + = - ( one - one_third * beta ) & + * invrs_rho_ds_zm & + * invrs_dzm & + * ( rho_ds_ztp1 * a1_ztp1**2 & + * wp3_on_wp2_ztp1 / wp2_ztp1 & + * wpxap_ztp1 * wpxbp_ztp1 & + - rho_ds_zt * a1_zt**2 & + * wp3_on_wp2_zt / wp2_zt & + * wpxap_zt * wpxbp_zt & + ) + + else + + ! Brian tried a new discretization for the turbulent advection term, for + ! which the explicit portion of the term is: + ! - (1/rho_ds) + ! * d [ rho_ds * (a_1)^2 * (1-(1/3)*beta) * ( w'^3 / (w'^2)^2 ) + ! * w'x_a' * w'x_b' ] / dz. + ! In order to help stabilize x_a'x_b', (a_1)^2 has been pulled outside + ! the derivative. + + rhs & + = - ( one - one_third * beta ) & + * invrs_rho_ds_zm * a1**2 & + * invrs_dzm & + * ( rho_ds_ztp1 & + * wp3_on_wp2_ztp1 / wp2_ztp1 & + * wpxap_ztp1 * wpxbp_ztp1 & + - rho_ds_zt & + * wp3_on_wp2_zt / wp2_zt & + * wpxap_zt * wpxbp_zt & + ) + + ! End of Brian's a1 change. 14 Feb 2008. + + endif + + + return + end function term_ta_rhs + + !============================================================================= + pure function term_tp( xamp1, xam, xbmp1, xbm, & + wpxbp, wpxap, invrs_dzm ) & + result( rhs ) + + ! Description: + ! Turbulent production of x_a'x_b': explicit portion of the code. + ! + ! The d(x_a'x_b')/dt equation contains a turbulent production term: + ! + ! - w'x_b' d(x_am)/dz - w'x_a' d(x_bm)/dz. + ! + ! This term is solved for completely explicitly and is discretized as + ! follows: + ! + ! The values of w'x_a' and w'x_b' are found on the momentum levels, whereas + ! the values of x_am and x_bm are found on the thermodynamic levels. The + ! derivatives of both x_am and x_bm are taken over the intermediate + ! (central) momentum level. All of the remaining mathematical operations + ! take place at the central momentum level, yielding the desired result. + ! + ! ---------xamp1------------xbmp1-------------------------- t(k+1) + ! + ! ===wpxap======d(xam)/dz=========d(xbm)/dz===wpxbp======== m(k) + ! + ! ---------xam--------------xbm---------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + xam, & ! x_am(k) [{x_am units}] + xamp1, & ! x_am(k+1) [{x_am units}] + xbm, & ! x_bm(k) [{x_bm units}] + xbmp1, & ! x_bm(k+1) [{x_bm units}] + wpxbp, & ! w'x_b'(k) [m/s {x_bm units}] + wpxap, & ! w'x_a'(k) [m/s {x_am units}] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = - wpxbp * invrs_dzm * ( xamp1 - xam ) & + - wpxap * invrs_dzm * ( xbmp1 - xbm ) + + return + end function term_tp + + !============================================================================= + pure function term_dp1_lhs( Cn, tau_zm ) & + result( lhs ) + + ! Description: + ! Dissipation term 1 for x_a'x_b': implicit portion of the code. + ! + ! The d(x_a'x_b')/dt equation contains dissipation term 1: + ! + ! - ( C_n / tau_zm ) x_a'x_b'. + ! + ! For cases where x_a'x_b' is a variance (in other words, where x_a and x_b + ! are the same variable), the term is damped to a certain positive + ! threshold, such that: + ! + ! - ( C_n / tau_zm ) * ( x_a'x_b' - threshold ). + ! + ! However, if x_a'x_b' is u'^2 or v'^2, damping to a minimum threshold value + ! is part of pressure term 1 and is handled as part of function 'term_pr1'. + ! Thus, for u'^2 and v'^2, function 'term_dp1_lhs' is called, but function + ! 'term_dp1_rhs' is not called, as function 'term_pr1' is called instead. + ! + ! For cases where x_a'x_b' is a covariance (in other words, where x_a and + ! x_b are different variables), threshold is set to 0, and the expression + ! reverts to the form found in the first equation. + ! + ! This term is broken into implicit and explicit portions. The equations + ! for u'^2, v'^2, and any covariances only include the implicit portion. + ! The implicit portion of this term is: + ! + ! - ( C_n / tau_zm ) x_a'x_b'(t+1). + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "-" in front of the term + ! is changed to a "+". + ! + ! The timestep index (t+1) means that the value of x_a'x_b' being used is + ! from the next timestep, which is being advanced to in solving the + ! d(x_a'x_b')/dt equation. + ! + ! The values of x_a'x_b' are found on momentum levels. The values of + ! time-scale tau_zm are also found on momentum levels. + ! + ! Note: For equations that use pressure term 1 (such as the equations for + ! u'^2 and v'^2), C_n = ( 2*C_4 + C_14 ) / 3; which combines the + ! implicit contributions for dissipation term 1 and pressure term 1 + ! into one expression. Otherwise, C_n = C_2. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Cn, & ! Coefficient C_n [-] + tau_zm ! Time-scale tau at momentum levels (k) [s] + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Momentum main diagonal: [ x xapxbp(k,) ] + lhs & + = + Cn / tau_zm + + return + end function term_dp1_lhs + + !============================================================================= + pure function term_dp1_rhs( Cn, tau_zm, threshold ) & + result( rhs ) + + ! Description: + ! Dissipation term 1 for x_a'x_b': explicit portion of the code. + ! + ! The d(x_a'x_b')/dt equation contains dissipation term 1: + ! + ! - ( C_n / tau_zm ) x_a'x_b'. + ! + ! For cases where x_a'x_b' is a variance (in other words, where x_a and x_b + ! are the same variable), the term is damped to a certain positive + ! threshold, such that: + ! + ! - ( C_n / tau_zm ) * ( x_a'x_b' - threshold ). + ! + ! However, if x_a'x_b' is u'^2 or v'^2, damping to a minimum threshold value + ! is part of pressure term 1 and is handled as part of function 'term_pr1'. + ! Thus, for u'^2 and v'^2, function 'term_dp1_lhs' is called, but function + ! 'term_dp1_rhs' is not called, as function 'term_pr1' is called instead. + ! + ! For cases where x_a'x_b' is a covariance (in other words, where x_a and + ! x_b are different variables), threshold is set to 0, and the expression + ! reverts to the form found in the first equation. + ! + ! This term is broken into implicit and explicit portions. The equations + ! for u'^2, v'^2, and any covariances only include the implicit portion. + ! The explicit portion of this term is: + ! + ! + ( C_n / tau_zm ) * threshold. + ! + ! The values of time-scale tau_zm and the threshold are found on the + ! momentum levels. + ! + ! Note: The equations that use pressure term 1 (such as the equations for + ! u'^2 and v'^2) do not call this function. Thus, within this + ! function, C_n = C_2. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Cn, & ! Coefficient C_n [-] + tau_zm, & ! Time-scale tau at momentum levels (k) [s] + threshold ! Minimum allowable magnitude value of x_a'x_b' [units vary] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs & + = + ( Cn / tau_zm ) * threshold + + return + end function term_dp1_rhs + + !============================================================================= + pure function term_pr1( C4, C14, xbp2, wp2, tau_zm ) & + result( rhs ) + + ! Description: + ! Pressure term 1 for x_a'x_b': explicit portion of the code. + ! + ! Note: Pressure term 1 is only used when x_a'x_b' is either u'^2 or v'^2. + ! For the following description, pressure term 2 for u'^2 is used as + ! the example. Pressure term 2 for v'^2 is the same as pressure + ! term 2 for u'^2, except that the v'^2 and u'^2 variables are + ! switched. + ! + ! The d(u'^2)/dt equation contains dissipation term 1: + ! + ! - ( C_4 / tau_zm ) * ( u'^2 - (2/3)*em ); + ! + ! where em = (1/2) * ( u'^2 + v'^2 + w'^2 ); + ! + ! and with the substitution applied, dissipation term 1 becomes: + ! + ! - ( C_4 / tau_zm ) * ( u'^2 - (1/3) * ( u'^2 + v'^2 + w'^2 ) ). + ! + ! The d(u'^2)/dt equation also contains pressure term 1: + ! + ! - (2/3) * epsilon; + ! + ! where epsilon = C_14 * ( em / tau_zm ). + ! + ! Additionally, since pressure term 1 is a damping term, em is damped only + ! to it's minimum threshold value, em_min, where: + ! + ! em_min = (1/2) * ( u'^2|_min + v'^2|_min + w'^2|_min ) + ! = (1/2) * ( w_tol^2 + w_tol^2 + w_tol^2 ) + ! = (3/2) * w_tol^2. + ! + ! With the damping threshold applied, epsilon becomes: + ! + ! epsilon = C_14 * ( ( em - em_min ) / tau_zm ); + ! + ! and with all substitutions applied, pressure term 1 becomes: + ! + ! - (2/3) * ( C_14 / tau_zm ) + ! * [ (1/2) * ( u'^2 + v'^2 + w'^2 ) - (3/2) * w_tol^2 ]. + ! + ! Dissipation term 1 and pressure term 1 are combined and simplify to: + ! + ! - [ ( 2*C_4 + C_14 ) / ( 3 * tau_zm ) ] * u'^2 + ! + [ ( C_4 - C_14 ) / ( 3 * tau_zm ) ] * ( v'^2 + w'^2 ) + ! + ( C_14 / tau_zm ) * w_tol^2. + ! + ! The combined term has both implicit and explicit components. + ! The implicit component is: + ! + ! - [ ( 2*C_4 + C_14 ) / ( 3 * tau_zm ) ] * u'^2(t+1). + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "-" in front of the term + ! is changed to a "+". + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(x_a'x_b')/dt equation. + ! + ! The implicit component of the combined dp1 and pr1 term is solved in + ! function "term_dp1_lhs" above, where "( 2*C_4 + C_14 ) / 3" is sent in + ! as "C_n". + ! + ! The explicit component of the combined dp1 and pr1 term is: + ! + ! + [ ( C_4 - C_14 ) / ( 3 * tau_zm ) ] * ( v'^2(t) + w'^2(t) ) + ! + ( C_14 / tau_zm ) * w_tol^2; + ! + ! and is discretized as follows: + ! + ! The values for v'^2 and w'^2, as well as for tau_zm, are found on the + ! momentum levels. The mathematical operations all take place on the + ! momentum levels, yielding the desired result. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + w_tol_sqd, & ! Constant(s) + one_third + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C4, & ! Model parameter C_4 [-] + C14, & ! Model parameter C_14 [-] + xbp2, & ! v'^2(k) (if solving for u'^2) or vice versa [m^2/s^2] + wp2, & ! w'^2(k) [m^2/s^2] + tau_zm ! Time-scale tau at momentum levels (k) [s] + + ! Return Variable + real( kind = core_rknd ) :: rhs + + rhs = + one_third * ( C4 - C14 ) * ( xbp2 + wp2 ) / tau_zm & + + ( C14 / tau_zm ) * w_tol_sqd + + return + end function term_pr1 + + !============================================================================= + function term_pr2( C5, thv_ds_zm, wpthvp, upwp, vpwp, & + um, vm, invrs_dzm, kp1, k, & + Lscalep1, Lscale, wp2_ztp1, wp2_zt ) & + result( rhs ) + + ! Description: + ! Pressure term 2 for x_a'x_b': explicit portion of the code. + ! + ! Note: Pressure term 2 is only used when x_a'x_b' is either u'^2 or v'^2. + ! For the following description, pressure term 2 for u'^2 is used as + ! the example. Pressure term 2 for v'^2 is the exact same as + ! pressure term 2 for u'^2. + ! + ! The d(u'^2)/dt equation contains pressure term 2: + ! + ! + (2/3) C_5 [ (g/thv_ds) w'th_v' - u'w' du/dz - v'w' dv/dz ]. + ! + ! This term is solved for completely explicitly and is discretized as + ! follows: + ! + ! The values of w'th_v', u'w', and v'w' are found on the momentum levels, + ! whereas the values of um and vm are found on the thermodynamic levels. + ! Additionally, the values of thv_ds_zm are found on the momentum levels. + ! The derivatives of both um and vm are taken over the intermediate + ! (central) momentum level. All the remaining mathematical operations take + ! place at the central momentum level, yielding the desired result. + ! + ! -----ump1------------vmp1-------------------------------------- t(k+1) + ! + ! =upwp====d(um)/dz========d(vm)/dz==vpwp===thv_ds_zm==wpthvp==== m(k) + ! + ! -----um--------------vm---------------------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & ! Constants + grav, & ! Gravitational acceleration [m/s^2] + one, & + two_thirds, & + zero, & + zero_threshold + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: abs, max + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + C5, & ! Model parameter C_5 [-] + thv_ds_zm, & ! Dry, base-state theta_v at momentum level (k) [K] + wpthvp, & ! w'th_v'(k) [m/K/s] + upwp, & ! u'w'(k) [m^2/s^2] + vpwp, & ! v'w'(k) [m^2/s^2] + invrs_dzm, & ! Inverse of the grid spacing (k) [1/m] + Lscalep1, & ! Mixing length (k+1) [m] + Lscale, & ! Mixing length (k) [m] + wp2_ztp1, & ! w'^2(k+1) (thermo. levels) [m^2/s^2] + wp2_zt ! w'^2(k) (thermo. levels) [m^2/s^2] + + ! Note: Entire arrays of um and vm are now required rather than um and vm + ! only at levels k and k+1. The entire array is necessary when a vertical + ! average calculation of d(um)/dz and d(vm)/dz is used. --ldgrant March 2010 + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + um, & ! mean zonal wind [m/s] + vm ! mean meridional wind [m/s] + + integer, intent(in) :: & + kp1, & ! current level+1 in xp2_xpyp_uv_rhs loop + k ! current level in xp2_xpyp_uv_rhs loop + + ! Return Variable + real( kind = core_rknd ) :: rhs + + ! Local Variable(s) --ldgrant, March 2010 + real( kind = core_rknd ), parameter :: & + ! Constants empirically determined for experimental version of term_pr2 + ! ldgrant March 2010 + constant1 = one, & ! [m/s] + constant2 = 1000.0_core_rknd, & ! [m] + vert_avg_depth = 200.0_core_rknd ! Depth over which to average d(um)/dz and d(vm)/dz [m] + + real( kind = core_rknd ) :: & + zt_high, & ! altitude above current altitude zt(k) [m] + um_high, & ! um at altitude zt_high [m/s] + vm_high, & ! vm at altitude zt_high [m/s] + zt_low, & ! altitude below (or at) current altitude zt(k) [m] + um_low, & ! um at altitude zt_low [m/s] + vm_low ! vm at altitude zt_low [m/s] + + logical, parameter :: & + l_use_experimental_term_pr2 = .false., & ! If true, use experimental version + ! of term_pr2 calculation + l_use_vert_avg_winds = .true. ! If true, use vert_avg_depth average + ! calculation for d(um)/dz and d(vm)/dz + + !------ Begin code ------------ + + if( .not. l_use_experimental_term_pr2 ) then + ! use original version of term_pr2 + + ! As applied to w'2 + rhs = + two_thirds * C5 & + * ( ( grav / thv_ds_zm ) * wpthvp & + - upwp * invrs_dzm * ( um(kp1) - um(k) ) & + - vpwp * invrs_dzm * ( vm(kp1) - vm(k) ) & + ) + + else ! use experimental version of term_pr2 --ldgrant March 2010 + + if( l_use_vert_avg_winds ) then + ! We found that using a 200m running average of d(um)/dz and d(vm)/dz + ! produces larger spikes in up2 and vp2 near the inversion for + ! the stratocumulus cases. + call find_endpts_for_vert_avg_winds & + ( vert_avg_depth, k, um, vm, & ! intent(in) + zt_high, um_high, vm_high, & ! intent(out) + zt_low, um_low, vm_low ) ! intent(out) + + else ! Do not use a vertical average calculation for d(um)/dz and d(vm)/dz + zt_high = gr%zt(kp1) + um_high = um(kp1) + vm_high = vm(kp1) + + zt_low = gr%zt(k) + um_low = um(k) + vm_low = vm(k) + end if ! l_use_vert_avg_winds + + ! *****NOTES on experimental version***** + ! Leah Grant and Vince Larson eliminated the contribution from wpthvp + ! because terms with d(wp2)/dz include buoyancy effects and seem to + ! produce better results. + ! + ! We also eliminated the contribution from the momentum flux terms + ! because they didn't contribute to the results. + ! + ! The constant1 line does not depend on shear. This is important for + ! up2 and vp2 generation in cases that have little shear such as FIRE. + ! We also made the constant1 line proportional to d(Lscale)/dz to account + ! for higher spikes in up2 and vp2 near a stronger inversion. This + ! increases up2 and vp2 near the inversion for the stratocumulus cases, + ! but overpredicts up2 and vp2 near cloud base in cumulus cases such + ! as BOMEX where d(Lscale)/dz is large. Therefore, the d(Lscale)/dz + ! contribution is commented out for now. + ! + ! The constant2 line includes the possibility of shear generation of + ! up2 and vp2, which is important for some cases. The current functional + ! form used is: + ! constant2 * |d(wp2)/dz| * |d(vm)/dz| + ! We use |d(vm)/dz| instead of |d(um)/dz| + |d(vm)/dz| here because + ! this allows for different profiles of up2 and vp2, which occur for + ! many cases. In addition, we found that in buoyant cases, up2 is + ! more related to d(vm)/dz and vp2 is more related to d(um)/dz. This + ! occurs if horizontal rolls are oriented in the direction of the shear + ! vector. However, in stably stratified cases, the opposite relation is + ! true (horizontal rolls caused by shear are perpendicular to the shear + ! vector). This effect is not yet accounted for. + ! + ! For better results, we reduced the value of C5 from 5.2 to 3.0 and + ! changed the eddy diffusivity coefficient Kh so that it is + ! proportional to 1.5*wp2 rather than to em. + rhs = + two_thirds * C5 & + * ( constant1 * abs( wp2_ztp1 - wp2_zt ) * invrs_dzm & + ! * abs( Lscalep1 - Lscale ) * invrs_dzm & + + constant2 * abs( wp2_ztp1 - wp2_zt ) * invrs_dzm & + * abs( vm_high - vm_low ) / ( zt_high - zt_low ) & + + ( Lscalep1 + Lscale ) * zero & + ! This line eliminates an Intel compiler + ) ! warning that Lscalep1/Lscale are not + ! used. -meyern + end if ! .not. l_use_experimental_term_pr2 + + ! Added by dschanen for ticket #36 + ! We have found that when shear generation is zero this term will only be + ! offset by hole-filling (up2_pd/vp2_pd) and reduces turbulence + ! unrealistically at lower altitudes to make up the difference. + rhs = max( rhs, zero_threshold ) + + return + end function term_pr2 + + !============================================================================= + subroutine find_endpts_for_vert_avg_winds & + ( vert_avg_depth, k, um, vm, & ! intent(in) + zt_high, um_high, vm_high, & ! intent(out) + zt_low, um_low, vm_low ) ! intent(out) + ! Description: + ! This subroutine determines values of um and vm which are + ! +/- [vert_avg_depth/2] m above and below the current altitude zt(k). + ! This is for the purpose of using a running vertical average + ! calculation of d(um)/dz and d(vm)/dz in term_pr2 (over a depth + ! vert_avg_depth). E.g. If a running average over 200m is desired, + ! then this subroutine will determine the values of um and vm which + ! are 100m above and below the current level. + ! ldgrant March 2010 + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two ! Constant(s) + + use interpolation, only : & + binary_search, lin_interpolate_two_points ! Function(s) + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + vert_avg_depth ! Depth over which to average d(um)/dz + ! and d(vm)/dz in term_pr2 [m] + + integer, intent(in) :: & + k ! current level in xp2_xpyp_uv_rhs loop + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + um, & ! mean zonal wind [m/s] + vm ! mean meridional wind [m/s] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + zt_high, & ! current altitude zt(k) + depth [m] + um_high, & ! um at altitude zt_high [m/s] + vm_high, & ! vm at altitude zt_high [m/s] + zt_low, & ! current altitude zt(k) - depth [m] + um_low, & ! um at altitude zt_low [m/s] + vm_low ! vm at altitude zt_low [m/s] + + ! Local Variables + real( kind = core_rknd ) :: depth ! vert_avg_depth/2 [m] + + integer :: k_high, k_low + ! Number of levels above (below) the current level where altitude is + ! [depth] greater (less) than the current altitude + ! [unless zt(k) < [depth] from an upper/lower boundary] + + !------ Begin code ------------ + + depth = vert_avg_depth / two + + ! Find the grid level that contains the altitude greater than or + ! equal to the current altitude + depth + k_high = binary_search( gr%nz, gr%zt, gr%zt(k)+depth ) + ! If the current altitude + depth is greater than the highest + ! altitude, binary_search returns a value of -1 + if ( k_high == -1 ) k_high = gr%nz + + if ( k_high == gr%nz ) then + ! Current altitude + depth is higher than or exactly at the top grid level. + ! Since this is a ghost point, use the altitude at grid level nzmax-1 + k_high = gr%nz-1 + zt_high = gr%zt(k_high) + um_high = um(k_high) + vm_high = vm(k_high) + else if ( gr%zt(k_high) == gr%zt(k)+depth ) then + ! Current altitude + depth falls exactly on another grid level. + ! In this case, no interpolation is necessary. + zt_high = gr%zt(k_high) + um_high = um(k_high) + vm_high = vm(k_high) + else ! Do an interpolation to find um & vm at current altitude + depth. + zt_high = gr%zt(k)+depth + um_high = lin_interpolate_two_points( zt_high, gr%zt(k_high), gr%zt(k_high-1), & + um(k_high), um(k_high-1) ) + vm_high = lin_interpolate_two_points( zt_high, gr%zt(k_high), gr%zt(k_high-1), & + vm(k_high), vm(k_high-1) ) + end if ! k_high ... + + + ! Find the grid level that contains the altitude less than or + ! equal to the current altitude - depth + k_low = binary_search( gr%nz, gr%zt, gr%zt(k)-depth ) + ! If the current altitude - depth is less than the lowest + ! altitude, binary_search returns a value of -1 + if ( k_low == -1 ) k_low = 2 + + if ( k_low == 2 ) then + ! Current altitude - depth is less than or exactly at grid level 2. + ! Since grid level 1 is a ghost point, use the altitude at grid level 2 + zt_low = gr%zt(k_low) + um_low = um(k_low) + vm_low = vm(k_low) + else if ( gr%zt(k_low) == gr%zt(k)-depth ) then + ! Current altitude - depth falls exactly on another grid level. + ! In this case, no interpolation is necessary. + zt_low = gr%zt(k_low) + um_low = um(k_low) + vm_low = vm(k_low) + else ! Do an interpolation to find um at current altitude - depth. + zt_low = gr%zt(k)-depth + um_low = lin_interpolate_two_points( zt_low, gr%zt(k_low), gr%zt(k_low-1), & + um(k_low), um(k_low-1) ) + vm_low = lin_interpolate_two_points( zt_low, gr%zt(k_low), gr%zt(k_low-1), & + vm(k_low), vm(k_low-1) ) + end if ! k_low ... + + return + end subroutine find_endpts_for_vert_avg_winds + + !============================================================================= + subroutine pos_definite_variances( solve_type, dt, tolerance, & + rho_ds_zm, rho_ds_zt, & + xp2_np1 ) + + ! Description: + ! Use the hole filling code to make a variance term positive definite + !----------------------------------------------------------------------- + + use fill_holes, only: fill_holes_vertical + use grid_class, only: gr + use clubb_precision, only: core_rknd + + use stats_variables, only: & + stats_zm, l_stats_samp, & + irtp2_pd, ithlp2_pd, iup2_pd, ivp2_pd ! variables + use stats_type_utilities, only: & + stat_begin_update, stat_end_update ! subroutines + + + implicit none + + ! External + intrinsic :: any, real, trim + + ! Input variables + integer, intent(in) :: & + solve_type + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), intent(in) :: & + tolerance ! Threshold for xp2_np1 [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt ! Dry, static density on thermodynamic levels [kg/m^3] + + ! Input/Output variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + xp2_np1 ! Variance for [units vary] + + ! Local variables + integer :: & + ixp2_pd + + select case( solve_type ) + case ( xp2_xpyp_rtp2 ) + ixp2_pd = irtp2_pd + case ( xp2_xpyp_thlp2 ) + ixp2_pd = ithlp2_pd + case ( xp2_xpyp_up2 ) + ixp2_pd = iup2_pd + case ( xp2_xpyp_vp2 ) + ixp2_pd = ivp2_pd + case default + ixp2_pd = 0 ! This includes the passive scalars + end select + + if ( l_stats_samp ) then + ! Store previous value for effect of the positive definite scheme + call stat_begin_update( ixp2_pd, xp2_np1 / dt, & ! Intent(in) + stats_zm ) ! Intent(inout) + endif + + + if ( any( xp2_np1 < tolerance ) ) then + + ! Call the hole-filling scheme. + ! The first pass-through should draw from only two levels on either side + ! of the hole. + call fill_holes_vertical( 2, tolerance, "zm", & ! Intent(in) + rho_ds_zt, rho_ds_zm, & ! Intent(in) + xp2_np1 ) ! Intent(inout) + + endif + + if ( l_stats_samp ) then + ! Store previous value for effect of the positive definite scheme + call stat_end_update( ixp2_pd, xp2_np1 / dt, & ! Intent(in) + stats_zm ) ! Intent(inout) + endif + + + return + end subroutine pos_definite_variances + + !============================================================================ + subroutine update_xp2_mc( nz, dt, cloud_frac, rcm, rvm, thlm, & + wm, exner, rrm_evap, pdf_params, & + rtp2_mc, thlp2_mc, wprtp_mc, wpthlp_mc, & + rtpthlp_mc ) + !Description: + !This subroutine is for use when l_morr_xp2_mc = .true. + !The effects of rain evaporation on rtp2 and thlp2 are included by + !assuming rain falls through the moist (cold) portion of the pdf. + !This is accomplished by defining a precip_fraction and assuming a double + !delta shaped pdf, such that the evaporation makes the moist component + !moister and the colder component colder. Calculations are done using + !variables on the zt grid, and the outputs are on the zm grid --storer + + use pdf_parameter_module, only: pdf_parameter + + use grid_class, only: & + zt2zm ! Procedure(s) + + use constants_clubb, only: & + cloud_frac_min, & !Variables + Cp, & + Lv + + use clubb_precision, only: & + core_rknd ! Variable(s) + + + implicit none + + !input parameters + integer, intent(in) :: nz ! Points in the Vertical [-] + + real( kind = core_rknd ), intent(in) :: dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + cloud_frac, & !Cloud fraction [-] + rcm, & !Cloud water mixing ratio [kg/kg] + rvm, & !Vapor water mixing ratio [kg/kg] + thlm, & !Liquid potential temperature [K] + wm, & !Mean vertical velocity [m/s] + exner, & !Exner function [-] + rrm_evap !Evaporation of rain [kg/kg/s] + !It is expected that this variable is negative, as + !that is the convention in Morrison microphysics + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters + + !input/output variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rtp2_mc, & !Tendency of due to evaporation [(kg/kg)^2/s] + thlp2_mc, & !Tendency of due to evaporation [K^2/s] + wprtp_mc, & !Tendency of due to evaporation [m*(kg/kg)/s^2] + wpthlp_mc, & !Tendency of due to evaporation [m*K/s^2] + rtpthlp_mc !Tendency of due to evaporation [K*(kg/kg)/s] + + !local variables + real( kind = core_rknd ), dimension(nz) :: & + temp_rtp2, & !Used only to calculate rtp2_mc [(kg/kg)^2] + temp_thlp2, & !Used to calculate thlp2_mc [K^2/s] + temp_wp2, & !Used to calculate wpxp_mc [m^2/s^2] + rtp2_mc_zt, & !Calculated on the zt grid [(kg/kg)^2/s] + thlp2_mc_zt, & !Calculated on the zt grid [(kg/kg)^2/s] + wprtp_mc_zt, & !Calculated on the zt grid [m*(kg/kg)/s^2] + wpthlp_mc_zt, & !Calcualted on the zt grid [m*K/s^2] + rtpthlp_mc_zt,& !Calculated on the zt grid [K*(kg/kg)/s] + precip_frac_double_delta, &!Precipitation fraction for a double delta [-] + pf_const ! ( 1 - pf )/( pf ) [-] + + integer :: k + + ! ---- Begin Code ---- + + ! Calculate precip_frac_double_delta + precip_frac_double_delta(nz) = 0.0_core_rknd + do k = nz-1, 1, -1 + if ( cloud_frac(k) > cloud_frac_min ) then + precip_frac_double_delta(k) = cloud_frac(k) + else + precip_frac_double_delta(k) = precip_frac_double_delta(k+1) + end if + end do + + + !pf_const is calculated so that when precip_frac_double_delta = 0, rtp2_mc and + !thlp2_mc will both be zero. This also avoids a divide by zero error + where ( precip_frac_double_delta > cloud_frac_min ) + pf_const = ( 1.0_core_rknd - precip_frac_double_delta ) / precip_frac_double_delta + else where + pf_const = 0.0_core_rknd + end where + + ! Include effects of rain evaporation on rtp2 + temp_rtp2 = pdf_params%mixt_frac & + * ( ( pdf_params%rt_1 - ( rcm + rvm ) )**2 + pdf_params%varnce_rt_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%rt_2 - ( rcm + rvm ) )**2 + pdf_params%varnce_rt_2 ) + + rtp2_mc_zt = rrm_evap**2 * pf_const * dt & + + 2.0_core_rknd * abs(rrm_evap) * sqrt(temp_rtp2 * pf_const) + !use absolute value of evaporation, as evaporation will add + !to rt_1 + rtp2_mc = zt2zm( rtp2_mc_zt ) + + !Include the effects of rain evaporation on thlp2 + temp_thlp2 = pdf_params%mixt_frac & + * ( ( pdf_params%thl_1 - thlm )**2 + pdf_params%varnce_thl_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%thl_2 - thlm )**2 + pdf_params%varnce_thl_2 ) + + thlp2_mc_zt = ( rrm_evap * Lv / ( Cp * exner) )**2 & + * pf_const * dt & + + 2.0_core_rknd * abs(rrm_evap) * Lv / ( Cp * exner ) & + * sqrt(temp_thlp2 * pf_const) + + thlp2_mc = zt2zm( thlp2_mc_zt ) + + ! Include effects of rain evaporation on other moments (wprtp, wpthlp, and + ! rtpthlp - added 07/13 rstorer + + temp_wp2 = pdf_params%mixt_frac & + * ( ( pdf_params%w_1 - wm )**2 + pdf_params%varnce_w_1 ) & + + ( 1.0_core_rknd - pdf_params%mixt_frac ) & + * ( ( pdf_params%w_2 - wm )**2 + pdf_params%varnce_w_2 ) + + wprtp_mc_zt = abs(rrm_evap) * sqrt(pf_const) * sqrt(temp_wp2) + + wpthlp_mc_zt = -1.0_core_rknd * Lv / ( Cp * exner) * abs(rrm_evap) & + * sqrt(pf_const) * sqrt(temp_wp2) + + rtpthlp_mc_zt = -1.0_core_rknd * abs(rrm_evap) * sqrt( pf_const ) & + * ( ( Lv / (cp * exner ) ) * sqrt( temp_rtp2 ) & + + sqrt( temp_thlp2 ) ) & + - ( Lv / (cp * exner ) ) * pf_const & + * ( rrm_evap )**2 * dt + + wprtp_mc = zt2zm( wprtp_mc_zt ) + wpthlp_mc = zt2zm( wpthlp_mc_zt ) + rtpthlp_mc = zt2zm( rtpthlp_mc_zt ) + end subroutine update_xp2_mc + +!=============================================================================== + +end module advance_xp2_xpyp_module diff --git a/src/physics/clubb/anl_erf.F90 b/src/physics/clubb/anl_erf.F90 new file mode 100644 index 0000000000..4931332978 --- /dev/null +++ b/src/physics/clubb/anl_erf.F90 @@ -0,0 +1,344 @@ +!----------------------------------------------------------------------- +! $Id: anl_erf.F90 7269 2014-09-04 21:00:07Z raut@uwm.edu $ +!=============================================================================== +module anl_erf + + implicit none + + public :: dp_erf, & + dp_erfc, & + erf, & + erfc + + private :: cr_erf, & + cr_erfc + + ! The interfaces allow us to avoid a compiler warning about + ! shadowing the intrinsic functions + interface erf + module procedure cr_erf + end interface + + interface erfc + module procedure cr_erfc + end interface + + private ! Default Scope + + contains + + !============================================================================= + pure function cr_erf( x ) result( erfx_core_rknd ) + ! Description: + ! Calls dp_erf after casting x to double precision. + ! This allows CLUBB to run erf even when core_rknd is in single precision. + ! + ! Arguments: + ! Input, real ( kind = dp ) x, the argument of ERF. + ! Output, real ( kind = core_rknd ) erfx_core_rknd, the value of ERF(X). + !----------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Constants + core_rknd + + implicit none + + ! Input Variables(s) + real( kind = core_rknd), intent(in) :: x + + ! Return type + real( kind = core_rknd ) :: erfx_core_rknd + + ! Local Variables + real( kind = dp) :: x_dp, erfx_dp + + ! Cast the input to dp + x_dp = real( x, kind = dp ) + + ! Call the function with the correct argument + erfx_dp = dp_erf( x_dp ) + + ! Get the output in core_rknd + erfx_core_rknd = real( erfx_dp, kind = core_rknd ) + + return + + end function cr_erf + + !============================================================================= + pure function dp_erf( x ) result( erfx ) + + ! Description: + ! DP_ERF evaluates the error function DP_ERF(X). + ! + ! Original Author: + ! William Cody, + ! Mathematics and Computer Science Division, + ! Argonne National Laboratory, + ! Argonne, Illinois, 60439. + ! + ! References: + ! William Cody, + ! "Rational Chebyshev approximations for the error function", + ! Mathematics of Computation, + ! 1969, pages 631-638. + ! + ! Arguments: + ! Input, real ( kind = dp ) X, the argument of ERF. + ! Output, real ( kind = dp ) ERFX, the value of ERF(X). + ! + ! Modifications: + ! kind = 8 was replaced by the more portable sp and dp by UWM. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Constants + core_rknd + + implicit none + + ! Input Variables(s) + real( kind = dp ), intent(in) :: x + + ! External + intrinsic :: epsilon, exp, aint + + ! Local Constants + real( kind = dp ), parameter, dimension( 5 ) :: & + a = (/ 3.16112374387056560E+00_dp, & + 1.13864154151050156E+02_dp, & + 3.77485237685302021E+02_dp, & + 3.20937758913846947E+03_dp, & + 1.85777706184603153E-01_dp /) + real( kind = dp ), parameter, dimension( 4 ) :: & + b = (/ 2.36012909523441209E+01_dp, & + 2.44024637934444173E+02_dp, & + 1.28261652607737228E+03_dp, & + 2.84423683343917062E+03_dp /) + real( kind = dp ), parameter, dimension( 9 ) :: & + c = (/ 5.64188496988670089E-01_dp, & + 8.88314979438837594E+00_dp, & + 6.61191906371416295E+01_dp, & + 2.98635138197400131E+02_dp, & + 8.81952221241769090E+02_dp, & + 1.71204761263407058E+03_dp, & + 2.05107837782607147E+03_dp, & + 1.23033935479799725E+03_dp, & + 2.15311535474403846E-08_dp /) + real( kind = dp ), parameter, dimension( 8 ) :: & + d = (/ 1.57449261107098347E+01_dp, & + 1.17693950891312499E+02_dp, & + 5.37181101862009858E+02_dp, & + 1.62138957456669019E+03_dp, & + 3.29079923573345963E+03_dp, & + 4.36261909014324716E+03_dp, & + 3.43936767414372164E+03_dp, & + 1.23033935480374942E+03_dp /) + real( kind = dp ), parameter, dimension( 6 ) :: & + p = (/ 3.05326634961232344E-01_dp, & + 3.60344899949804439E-01_dp, & + 1.25781726111229246E-01_dp, & + 1.60837851487422766E-02_dp, & + 6.58749161529837803E-04_dp, & + 1.63153871373020978E-02_dp /) + + real( kind = dp ), parameter, dimension( 5 ) :: & + q = (/ 2.56852019228982242E+00_dp, & + 1.87295284992346047E+00_dp, & + 5.27905102951428412E-01_dp, & + 6.05183413124413191E-02_dp, & + 2.33520497626869185E-03_dp /) + + real( kind = dp ), parameter :: & + SQRPI = 0.56418958354775628695E+00_dp, & + THRESH = 0.46875E+00_dp, & + XBIG = 26.543E+00_dp + + ! Return type + real( kind = dp ) :: erfx + + ! Local variables + real( kind = dp ) :: & + del, & + xabs, & + xden, & + xnum, & + xsq + + integer :: i ! Index + + !----------------------------------------------------------------------- + ! Get the abs value of xabs - schemena 20140827 + xabs = abs( x ) + + ! + ! Evaluate ERF(X) for |X| <= 0.46875. + ! + if ( xabs <= THRESH ) then + + if ( epsilon( xabs ) < xabs ) then + xsq = xabs * xabs + else + xsq = 0.0E+00_dp + end if + + xnum = a(5) * xsq + xden = xsq + do i = 1, 3 + xnum = ( xnum + a(i) ) * xsq + xden = ( xden + b(i) ) * xsq + end do + + erfx = x * ( xnum + a(4) ) / ( xden + b(4) ) + ! + ! Evaluate ERFC(X) for 0.46875 <= |X| <= 4.0. + ! + else if ( xabs <= 4.0E+00_dp ) then + + xnum = c(9) * xabs + xden = xabs + do i = 1, 7 + xnum = ( xnum + c(i) ) * xabs + xden = ( xden + d(i) ) * xabs + end do + + erfx = ( xnum + c(8) ) / ( xden + d(8) ) + xsq = aint( xabs * 16.0E+00_dp ) / 16.0E+00_dp + del = ( xabs - xsq ) * ( xabs + xsq ) + ! xsq * xsq in the exponential was changed to xsq**2. + ! This seems to decrease runtime by about a half a percent. + ! ~~EIHoppe//20090622 + erfx = exp( - xsq**2 ) * exp( - del ) * erfx + + erfx = ( 0.5E+00_dp - erfx ) + 0.5E+00_dp + + if ( x < 0.0E+00_dp ) then + erfx = - erfx + end if + ! + ! Evaluate ERFC(X) for 4.0 < |X|. + ! + else + + if ( XBIG <= xabs ) then + + if ( 0.0E+00_dp < real(x, kind=dp) ) then + erfx = 1.0E+00_dp + else + erfx = -1.0E+00_dp + end if + + else + + xsq = 1.0E+00_dp / ( xabs * xabs ) + + xnum = p(6) * xsq + xden = xsq + do i = 1, 4 + xnum = ( xnum + p(i) ) * xsq + xden = ( xden + q(i) ) * xsq + end do + + erfx = xsq * ( xnum + p(5) ) / ( xden + q(5) ) + erfx = ( SQRPI - erfx ) / xabs + xsq = aint( xabs * 16.0E+00_dp ) / 16.0E+00_dp + del = ( xabs - xsq ) * ( xabs + xsq ) + erfx = exp( - xsq * xsq ) * exp( - del ) * erfx + + erfx = ( 0.5E+00_dp - erfx ) + 0.5E+00_dp + if ( x < 0.0E+00_dp ) then + erfx = - erfx + end if + + end if + + end if + + return + + end function dp_erf + + !============================================================================= + pure function cr_erfc( x ) result( erfcx_core_rknd ) + ! Description: + ! Calls dp_erfc after casting x to double precision. + ! This allows CLUBB to run erfc even when core_rknd is in single precision. + ! + ! Arguments: + ! Input, real ( kind = core_rknd ) x, the argument of ERFC. + ! Output, real ( kind = core_rknd ) erfcx_core_rknd, the value of ERFC(X). + !----------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Constants + core_rknd + + implicit none + + ! Input Variables(s) + real( kind = core_rknd), intent(in) :: x + + ! Return type + real( kind = core_rknd ) :: erfcx_core_rknd + + ! Local Variables + real( kind = dp) :: x_dp, erfcx_dp + + ! Cast the input to dp + x_dp = real( x, kind = dp ) + + ! Call the function with the correct argument + erfcx_dp = dp_erfc( x_dp ) + + ! Get the output in core_rknd + erfcx_core_rknd = real( erfcx_dp, kind = core_rknd ) + + return + + end function cr_erfc + + !============================================================================= + pure function dp_erfc( x ) result( erfcx ) + + ! Description: + ! The complimentary error function of x: + ! + ! erfc(x) = 1 - erf(x); + ! + ! where: + ! + ! erf(x) = ( 2 / sqrt(pi) ) INT(0:x) e^-t^2 dt; + ! + ! and + ! + ! erfc(x) = ( 2 / sqrt(pi) ) INT(x:inf) e^-t^2 dt. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! Variable(s) + + implicit none + + ! Input Variable + real( kind = dp ), intent(in) :: x + + ! Return Variable + real( kind = dp ) :: erfcx + + + erfcx = one_dp - dp_erf( x ) + + + return + + end function dp_erfc + +!=============================================================================== + +end module anl_erf diff --git a/src/physics/clubb/array_index.F90 b/src/physics/clubb/array_index.F90 new file mode 100644 index 0000000000..967b8c7524 --- /dev/null +++ b/src/physics/clubb/array_index.F90 @@ -0,0 +1,64 @@ +!--------------------------------------------------------------------------- +! $Id: array_index.F90 7118 2014-07-25 00:12:15Z raut@uwm.edu $ +!=============================================================================== +module array_index + + ! Description: + ! Contains indices to variables in larger arrays. + ! Note that the 'ii' is necessary because 'i' is used in + ! statistics to track locations in the zt/zm/sfc derived types. + + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Variables + ! Microphysics mixing ratios + integer, public :: & + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirgm ! Hydrometeor array index for graupel mixing ratio, rg +!$omp threadprivate(iirrm, iirsm, iirim, iirgm) + + ! Microphysics concentrations + integer, public :: & + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNgm ! Hydrometeor array index for graupel concentration, Ng +!$omp threadprivate(iiNrm, iiNsm, iiNim, iiNgm) + + ! Scalar quantities + integer, public :: & + iisclr_rt, iisclr_thl, iisclr_CO2, & ! [kg/kg]/[K]/[1e6 mol/mol] + iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2 ! " " +!$omp threadprivate(iisclr_rt, iisclr_thl, iisclr_CO2, & +!$omp iiedsclr_rt, iiedsclr_thl, iiedsclr_CO2) + + ! Logical fields + logical, dimension(:), allocatable, public :: & + l_frozen_hm, & ! if true, then the hydrometeor is frozen; otherwise liquid + l_mix_rat_hm ! if true, then the quantity is a hydrometeor mixing ratio +!$omp threadprivate(l_frozen_hm, l_mix_rat_hm) + + character(len=10), dimension(:), allocatable, public :: & + hydromet_list + +!$omp threadprivate( hydromet_list ) + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + hydromet_tol ! Tolerance values for all hydrometeors [units vary] + +!$omp threadprivate( hydromet_tol ) + + private ! Default Scope + +!=============================================================================== + +end module array_index diff --git a/src/physics/clubb/calc_roots.F90 b/src/physics/clubb/calc_roots.F90 new file mode 100644 index 0000000000..2ae200541b --- /dev/null +++ b/src/physics/clubb/calc_roots.F90 @@ -0,0 +1,328 @@ +!--------------------------------------------------------------------------- +! $Id: calc_roots.F90 77826 2016-04-07 23:05:53Z cacraig@ucar.edu $ +!=============================================================================== +module calc_roots + + implicit none + + public :: cubic_solve, & + quadratic_solve, & + cube_root + + private ! Set Default Scope + + contains + + !============================================================================= + pure function cubic_solve( a_coef, b_coef, c_coef, d_coef ) & + result( roots ) + + ! Description: + ! Solve for the roots of x in a cubic equation. + ! + ! The cubic equation has the form: + ! + ! f(x) = a*x^3 + b*x^2 + c*x + d; + ! + ! where a /= 0. When f(x) = 0, the cubic formula is used to solve: + ! + ! a*x^3 + b*x^2 + c*x + d = 0. + ! + ! The cubic formula is also called Cardano's Formula. + ! + ! The three solutions for x are: + ! + ! x(1) = -(1/3)*(b/a) + ( S + T ); + ! x(2) = -(1/3)*(b/a) - (1/2) * ( S + T ) + (1/2)i * sqrt(3) * ( S - T ); + ! x(3) = -(1/3)*(b/a) - (1/2) * ( S + T ) - (1/2)i * sqrt(3) * ( S - T ); + ! + ! where: + ! + ! S = ( R + sqrt( D ) )^(1/3); and + ! T = ( R - sqrt( D ) )^(1/3). + ! + ! The determinant, D, is given by: + ! + ! D = R^2 + Q^3. + ! + ! The values of R and Q relate back to the a, b, c, and d coefficients: + ! + ! Q = ( 3*(c/a) - (b/a)^2 ) / 9; and + ! R = ( 9*(b/a)*(c/a) - 27*(d/a) - 2*(b/a)^3 ) / 54. + ! + ! When D < 0, there are three unique, real-valued roots. When D = 0, there + ! are three real-valued roots, but one root is a double root or a triple + ! root. When D > 0, there is one real-valued root and there are two roots + ! that are complex conjugates. + + ! References: + ! http://mathworld.wolfram.com/CubicFormula.html + !----------------------------------------------------------------------- + + use constants_clubb, only: & + three, & ! Constant(s) + two, & + one_half, & + one_third, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + a_coef, & ! Coefficient a (of x^3) in a*x^3 + b*x^2 + c^x + d = 0 [-] + b_coef, & ! Coefficient b (of x^2) in a*x^3 + b*x^2 + c^x + d = 0 [-] + c_coef, & ! Coefficient c (of x) in a*x^3 + b*x^2 + c^x + d = 0 [-] + d_coef ! Coefficient d in a*x^3 + b*x^2 + c^x + d = 0 [-] + + ! Return Variables + complex( kind = core_rknd ), dimension(3) :: & + roots ! Roots of x that satisfy a*x^3 + b*x^2 + c*x + d = 0 [-] + + ! Local Variables + real( kind = core_rknd ) :: & + cap_Q_coef, & ! Coefficient Q in cubic formula [-] + cap_R_coef, & ! Coefficient R in cubic formula [-] + determinant ! Determinant D in cubic formula [-] + + complex( kind = core_rknd ) :: & + sqrt_det, & ! Square root of determinant D in cubic formula [-] + cap_S_coef, & ! Coefficient S in cubic formula [-] + cap_T_coef ! Coefficient T in cubic formula [-] + + complex( kind = core_rknd ), parameter :: & + i_cmplx = ( 0.0_core_rknd, 1.0_core_rknd ) ! i = sqrt(-1) + + complex( kind = core_rknd ) :: & + sqrt_3, & ! Sqrt 3 (complex data type) + one_half_cmplx, & ! 1/2 (complex data type) + one_third_cmplx ! 1/3 (complex data type) + + + ! Declare some constants as complex data types in order to prevent + ! data-type conversion warning messages. + sqrt_3 = cmplx( sqrt( three ), kind = core_rknd ) + one_half_cmplx = cmplx( one_half, kind = core_rknd ) + one_third_cmplx = cmplx( one_third, kind = core_rknd ) + + ! Find the value of the coefficient Q; where + ! Q = ( 3*(c/a) - (b/a)^2 ) / 9. + cap_Q_coef = ( three * (c_coef/a_coef) - (b_coef/a_coef)**2 ) & + / 9.0_core_rknd + + ! Find the value of the coefficient R; where + ! R = ( 9*(b/a)*(c/a) - 27*(d/a) - 2*(b/a)^3 ) / 54. + cap_R_coef = ( 9.0_core_rknd * (b_coef/a_coef) * (c_coef/a_coef) & + - 27.0_core_rknd * (d_coef/a_coef) & + - two * (b_coef/a_coef)**3 ) / 54.0_core_rknd + + ! Find the value of the determinant D; where + ! D = R^2 + Q^3. + determinant = cap_Q_coef**3 + cap_R_coef**2 + + if ( determinant < zero ) then + + ! Calculate the square root of the determinant. This will be a complex + ! number. + sqrt_det = sqrt( cmplx( determinant, kind = core_rknd ) ) + + ! Find the value of the coefficient S; where + ! S = ( R + sqrt( D ) )^(1/3). + cap_S_coef & + = ( cmplx( cap_R_coef, kind = core_rknd ) + sqrt_det )**one_third_cmplx + + ! Find the value of the coefficient T; where + ! T = ( R - sqrt( D ) )^(1/3). + cap_T_coef & + = ( cmplx( cap_R_coef, kind = core_rknd ) - sqrt_det )**one_third_cmplx + + else ! determinant >= 0 + + ! Find the value of the coefficient S; where + ! S = ( R + sqrt( D ) )^(1/3). + cap_S_coef & + = cmplx( cube_root( cap_R_coef + sqrt( determinant ) ), & + kind = core_rknd ) + + ! Find the value of the coefficient T; where + ! T = ( R - sqrt( D ) )^(1/3). + cap_T_coef & + = cmplx( cube_root( cap_R_coef - sqrt( determinant ) ), & + kind = core_rknd ) + + endif ! determinant < 0 + + ! Find the values of the roots. + ! This root is always real-valued. + ! x(1) = -(1/3)*(b/a) + ( S + T ). + roots(1) = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & + + ( cap_S_coef + cap_T_coef ) + + ! This root is real-valued when D < 0 (even though the square root of the + ! determinant is a complex number), as well as when D = 0 (when it is part + ! of a double or triple root). When D > 0, this root is a complex number. + ! It is the complex conjugate of roots(3). + ! x(2) = -(1/3)*(b/a) - (1/2) * ( S + T ) + (1/2)i * sqrt(3) * ( S - T ). + roots(2) = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & + - one_half_cmplx * ( cap_S_coef + cap_T_coef ) & + + one_half_cmplx * i_cmplx * sqrt_3 * ( cap_S_coef - cap_T_coef ) + + ! This root is real-valued when D < 0 (even though the square root of the + ! determinant is a complex number), as well as when D = 0 (when it is part + ! of a double or triple root). When D > 0, this root is a complex number. + ! It is the complex conjugate of roots(2). + ! x(3) = -(1/3)*(b/a) - (1/2) * ( S + T ) - (1/2)i * sqrt(3) * ( S - T ). + roots(3) = - one_third_cmplx * cmplx( b_coef/a_coef, kind = core_rknd ) & + - one_half_cmplx * ( cap_S_coef + cap_T_coef ) & + - one_half_cmplx * i_cmplx * sqrt_3 * ( cap_S_coef - cap_T_coef ) + + + return + + end function cubic_solve + + !============================================================================= + pure function quadratic_solve( a_coef, b_coef, c_coef ) & + result( roots ) + + ! Description: + ! Solve for the roots of x in a quadratic equation. + ! + ! The equation has the form: + ! + ! f(x) = a*x^2 + b*x + c; + ! + ! where a /= 0. When f(x) = 0, the quadratic formula is used to solve: + ! + ! a*x^2 + b*x + c = 0. + ! + ! The two solutions for x are: + ! + ! x(1) = ( -b + sqrt( b^2 - 4*a*c ) ) / (2*a); and + ! x(2) = ( -b - sqrt( b^2 - 4*a*c ) ) / (2*a). + ! + ! The determinant, D, is given by: + ! + ! D = b^2 - 4*a*c. + ! + ! When D > 0, there are two unique, real-valued roots. When D = 0, there + ! are two real-valued roots, but they are a double root. When D < 0, there + ! there are two roots that are complex conjugates. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + four, & ! Constant(s) + two, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + a_coef, & ! Coefficient a (of x^2) in a*x^2 + b*x + c = 0 [-] + b_coef, & ! Coefficient b (of x) in a*x^2 + b*x + c = 0 [-] + c_coef ! Coefficient c in a*x^2 + b*x + c = 0 [-] + + ! Return Variables + complex( kind = core_rknd ), dimension(2) :: & + roots ! Roots of x that satisfy a*x^2 + b*x + c = 0 [-] + + ! Local Variables + real( kind = core_rknd ) :: & + determinant ! Determinant D in quadratic formula [-] + + complex( kind = core_rknd ) :: & + sqrt_det ! Square root of determinant D in quadratic formula [-] + + + ! Find the value of the determinant D; where + ! D = b^2 - 4*a*c. + determinant = b_coef**2 - four * a_coef * c_coef + + if ( determinant >= zero ) then + + ! Calculate the square root of the determinant. + sqrt_det = cmplx( sqrt( determinant ), kind = core_rknd ) + + else ! determinant < 0 + + ! Calculate the square root of the determinant. This will be a complex + ! number. + sqrt_det = sqrt( cmplx( determinant, kind = core_rknd ) ) + + endif ! determinant >= 0 + + ! Find the values of the roots. + ! This root is real-valued when D > 0, as well as when D = 0 (when it is + ! part of a double root). When D < 0, this root is a complex number. It is + ! the complex conjugate of roots(2). + ! x(1) = ( -b + sqrt( b^2 - 4*a*c ) ) / (2*a); and + roots(1) = ( -cmplx( b_coef, kind = core_rknd ) + sqrt_det ) & + / cmplx( two * a_coef, kind = core_rknd ) + + ! This root is real-valued when D > 0, as well as when D = 0 (when it is + ! part of a double root). When D < 0, this root is a complex number. It is + ! the complex conjugate of roots(1). + ! x(2) = ( -b - sqrt( b^2 - 4*a*c ) ) / (2*a). + roots(2) = ( -cmplx( b_coef, kind = core_rknd ) - sqrt_det ) & + / cmplx( two * a_coef, kind = core_rknd ) + + + return + + end function quadratic_solve + + !============================================================================= + pure function cube_root( x ) + + ! Description: + ! Calculates the cube root of x. + ! + ! When x >= 0, this code simply calculates x^(1/3). When x < 0, this code + ! uses x^(1/3) = -|x|^(1/3). This eliminates numerical errors when the + ! exponent of 1/3 is not treated as exactly 1/3, which would sometimes + ! result in values of NaN. + ! + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_third, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + x ! Variable x + + ! Return Variables + real( kind = core_rknd ) :: & + cube_root ! Cube root of x + + + if ( x >= zero ) then + cube_root = x**one_third + else ! x < 0 + cube_root = -abs(x)**one_third + endif ! x >= 0 + + + return + + end function cube_root + +!=============================================================================== + +end module calc_roots diff --git a/src/physics/clubb/calendar.F90 b/src/physics/clubb/calendar.F90 new file mode 100644 index 0000000000..e8480fa176 --- /dev/null +++ b/src/physics/clubb/calendar.F90 @@ -0,0 +1,252 @@ +!----------------------------------------------------------------------- +!$Id: calendar.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== +module calendar + + implicit none + + public :: gregorian2julian_date, julian2gregorian_date, & + leap_year, compute_current_date, & + gregorian2julian_day + + private ! Default Scope + + ! Constant Parameters + + ! 3 Letter Month Abbreviations + character(len=3), dimension(12), public, parameter :: & + month_names = (/'JAN','FEB','MAR','APR','MAY','JUN', & + 'JUL','AUG','SEP','OCT','NOV','DEC'/) + + ! Number of days per month (Jan..Dec) for a non leap year + integer, public, dimension(12), parameter :: & + days_per_month = (/31, 28, 31, 30, 31, 30, & + 31, 31, 30, 31, 30, 31/) + + contains +!----------------------------------------------------------------------- + integer function gregorian2julian_date( day, month, year ) +! +! Description: +! Computes the Julian Date (gregorian2julian), or the number of days since +! 1 January 4713 BC, given a Gregorian Calender date (day, month, year). +! +! Reference: +! Fliegel, H. F. and van Flandern, T. C., +! Communications of the ACM, Vol. 11, No. 10 (October, 1968) +!---------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + day, & ! Gregorian Calendar Day for given Month [dd] + month, & ! Gregorian Calendar Month for given Year [mm] + year ! Gregorian Calendar Year [yyyy] + + ! Local Variables + integer :: I,J,K + + I = year + J = month + K = day + + gregorian2julian_date = K-32075+1461*(I+4800+(J-14)/12)/4+367* & + (J-2-(J-14)/12*12)/12-3*((I+4900+(J-14)/12)/100)/4 + + return + end function gregorian2julian_date + +!------------------------------------------------------------------ + subroutine julian2gregorian_date & + ( julian_date, day, month, year ) +! +! Description: +! Computes the Gregorina Calendar date (day, month, year) +! given the Julian date (julian_date). +! +! Reference: +! Fliegel, H. F. and van Flandern, T. C., +! Communications of the ACM, Vol. 11, No. 10 (October, 1968) +! http://portal.acm.org/citation.cfm?id=364097 +!------------------------------------------------------------------ + implicit none + + ! Input Variable(s) + integer, intent(in) :: julian_date ! Julian date being converted from + + ! Output Variable(s) + integer, intent(out):: & + day, & ! Gregorian calender day for given Month [dd] + month, & ! Gregorian calender month for given Year [mm] + year ! Gregorian calender year [yyyy] + + ! Local Variables + integer :: i, j, k, n, l + + ! ---- Begin Code ---- + + L = julian_date+68569 ! Known magic number + N = 4*L/146097 ! Known magic number + L = L-(146097*N+3)/4 ! Known magic number + I = 4000*(L+1)/1461001 ! Known magic number + L = L-1461*I/4+31 ! Known magic number + J = 80*L/2447 ! Known magic number + K = L-2447*J/80 ! Known magic number + L = J/11 ! Known magic number + J = J+2-12*L ! Known magic number + I = 100*(N-49)+I+L ! Known magic number + + year = I + month = J + day = K + + return + + end subroutine julian2gregorian_date + +!----------------------------------------------------------------------------- + logical function leap_year( year ) +! +! Description: +! Determines if the given year is a leap year. +! +! References: +! None +!----------------------------------------------------------------------------- + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: year ! Gregorian Calendar Year [yyyy] + + ! ---- Begin Code ---- + + leap_year = ( (mod( year, 4 ) == 0) .and. & + (.not.( mod( year, 100 ) == 0 .and. mod( year, 400 ) /= 0 ) ) ) + + return + end function leap_year + +!---------------------------------------------------------------------------- + subroutine compute_current_date( previous_day, previous_month, & + previous_year, & + seconds_since_previous_date, & + current_day, current_month, & + current_year, & + seconds_since_current_date ) +! +! Description: +! Computes the current Gregorian date from a previous date and +! the seconds that have transpired since that date. +! +! References: +! None +!---------------------------------------------------------------------------- + use clubb_precision, only: & + time_precision ! Variable(s) + + use constants_clubb, only: & + sec_per_day ! Variable(s) + + implicit none + + ! Input Variable(s) + + ! Previous date + integer, intent(in) :: & + previous_day, & ! Day of the month [dd] + previous_month, & ! Month of the year [mm] + previous_year ! Year [yyyy] + + real(kind=time_precision), intent(in) :: & + seconds_since_previous_date ! [s] + + ! Output Variable(s) + + ! Current date + integer, intent(out) :: & + current_day, & ! Day of the month [dd] + current_month, & ! Month of the year [mm] + current_year ! Year [yyyy] + + real(kind=time_precision), intent(out) :: & + seconds_since_current_date + + integer :: & + days_since_1jan4713bc, & + days_since_start + + ! ---- Begin Code ---- + + ! Using Julian dates we are able to add the days that the model + ! has been running + + ! Determine the Julian Date of the starting date, + ! written in Gregorian (day, month, year) form + days_since_1jan4713bc = gregorian2julian_date( previous_day, & + previous_month, previous_year ) + + ! Determine the amount of days that have passed since start date + days_since_start = & + floor( seconds_since_previous_date / real(sec_per_day,kind=time_precision) ) + + ! Set days_since_1jan4713 to the present Julian date + days_since_1jan4713bc = days_since_1jan4713bc + days_since_start + + ! Set Present time to be seconds since the Julian date + seconds_since_current_date = seconds_since_previous_date & + - ( real( days_since_start, kind=time_precision ) * real(sec_per_day,kind=time_precision) ) + + call julian2gregorian_date & + ( days_since_1jan4713bc, & + current_day, current_month, current_year ) + + return + end subroutine compute_current_date + +!------------------------------------------------------------------------------------- + integer function gregorian2julian_day( day, month, year ) +! +! Description: +! This subroutine determines the Julian day (1-366) +! for a given Gregorian calendar date(e.g. July 1, 2008). +! +! References: +! None +!------------------------------------------------------------------------------------- + + implicit none + + ! External + intrinsic :: sum + + ! Input Variable(s) + integer, intent(in) :: & + day, & ! Day of the Month [dd] + month, & ! Month of the Year [mm] + year ! Year [yyyy] + + ! ---- Begin Code ---- + + ! Add the days from the previous months + gregorian2julian_day = day + sum( days_per_month(1:month-1) ) + + ! Kluge for a leap year + ! If the date were 29 Feb 2000 this would not increment julian_day + ! However 01 March 2000 would need the 1 day bump + if ( leap_year( year ) .and. month > 2 ) then + gregorian2julian_day = gregorian2julian_day + 1 + end if + + if ( ( leap_year( year ) .and. gregorian2julian_day > 366 ) .or. & + ( .not. leap_year( year ) .and. gregorian2julian_day > 365 ) ) then + stop "Problem with Julian day conversion in gregorian2julian_day." + end if + + return + end function gregorian2julian_day + +end module calendar diff --git a/src/physics/clubb/clip_explicit.F90 b/src/physics/clubb/clip_explicit.F90 new file mode 100644 index 0000000000..80bd25e0be --- /dev/null +++ b/src/physics/clubb/clip_explicit.F90 @@ -0,0 +1,1026 @@ +!------------------------------------------------------------------------------- +! $Id: clip_explicit.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module clip_explicit + + implicit none + + private + + public :: clip_covars_denom, & + clip_covar, & + clip_covar_level, & + clip_variance, & + clip_skewness, & + clip_skewness_core + + ! Named constants to avoid string comparisons + integer, parameter, public :: & + clip_rtp2 = 1, & ! Named constant for rtp2 clipping + clip_thlp2 = 2, & ! Named constant for thlp2 clipping + clip_rtpthlp = 3, & ! Named constant for rtpthlp clipping + clip_up2 = 5, & ! Named constant for up2 clipping + clip_vp2 = 6, & ! Named constant for vp2 clipping +! clip_scalar = 7, & ! Named constant for scalar clipping + clip_wprtp = 8, & ! Named constant for wprtp clipping + clip_wpthlp = 9, & ! Named constant for wpthlp clipping + clip_upwp = 10, & ! Named constant for upwp clipping + clip_vpwp = 11, & ! Named constant for vpwp clipping + clip_wp2 = 12, & ! Named constant for wp2 clipping + clip_wpsclrp = 13, & ! Named constant for wp scalar clipping + clip_sclrp2 = 14, & ! Named constant for sclrp2 clipping + clip_sclrprtp = 15, & ! Named constant for sclrprtp clipping + clip_sclrpthlp = 16, & ! Named constant for sclrpthlp clipping + clip_wphydrometp = 17 ! Named constant for wphydrometp clipping + + contains + + !============================================================================= + subroutine clip_covars_denom( dt, rtp2, thlp2, up2, vp2, wp2, & + sclrp2, wprtp_cl_num, wpthlp_cl_num, & + wpsclrp_cl_num, upwp_cl_num, vpwp_cl_num, & + wprtp, wpthlp, upwp, vpwp, wpsclrp ) + + ! Description: + ! Some of the covariances found in the CLUBB model code need to be clipped + ! multiple times during each timestep to ensure that the correlation between + ! the two relevant variables stays between -1 and 1 at all times during the + ! model run. The covariances that need to be clipped multiple times are + ! w'r_t', w'th_l', w'sclr', u'w', and v'w'. One of the times that each one + ! of these covariances is clipped is immediately after each one is set. + ! However, each covariance still needs to be clipped two more times during + ! each timestep (once after advance_xp2_xpyp is called and once after + ! advance_wp2_wp3 is called). This subroutine handles the times that the + ! covariances are clipped away from the time that they are set. In other + ! words, this subroutine clips the covariances after the denominator terms + ! in the relevant correlation equation have been altered, ensuring that + ! all correlations will remain between -1 and 1 at all times. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use parameters_model, only: & + sclr_dim ! Variable(s) + + use model_flags, only: & + l_tke_aniso ! Logical + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_modify ! Procedure(s) + + use stats_variables, only: & + iwprtp_bt, & ! Variable(s) + iwpthlp_bt, & + stats_zm, & + l_stats_samp + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rtp2, & ! r_t'^2 [(kg/kg)^2] + thlp2, & ! theta_l'^2 [K^2] + up2, & ! u'^2 [m^2/s^2] + vp2, & ! v'^2 [m^2/s^2] + wp2 ! w'^2 [m^2/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(in) :: & + sclrp2 ! sclr'^2 [{units vary}^2] + + integer, intent(in) :: & + wprtp_cl_num, & + wpthlp_cl_num, & + wpsclrp_cl_num, & + upwp_cl_num, & + vpwp_cl_num + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wprtp, & ! w'r_t' [(kg/kg) m/s] + wpthlp, & ! w'theta_l' [K m/s] + upwp, & ! u'w' [m^2/s^2] + vpwp ! v'w' [m^2/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim), intent(inout) :: & + wpsclrp ! w'sclr' [units m/s] + + ! Local Variables + logical :: & + l_first_clip_ts, & ! First instance of clipping in a timestep. + l_last_clip_ts ! Last instance of clipping in a timestep. + + real( kind = core_rknd ), dimension(gr%nz) :: & + wprtp_chnge, & ! Net change in w'r_t' due to clipping [(kg/kg) m/s] + wpthlp_chnge, & ! Net change in w'th_l' due to clipping [K m/s] + upwp_chnge, & ! Net change in u'w' due to clipping [m^2/s^2] + vpwp_chnge ! Net change in v'w' due to clipping [m^2/s^2] + + real( kind = core_rknd ), dimension(gr%nz,sclr_dim) :: & + wpsclrp_chnge ! Net change in w'sclr' due to clipping [{units vary}] + + integer :: i ! scalar array index. + + ! ---- Begin Code ---- + + !!! Clipping for w'r_t' + ! + ! Clipping w'r_t' at each vertical level, based on the + ! correlation of w and r_t at each vertical level, such that: + ! corr_(w,r_t) = w'r_t' / [ sqrt(w'^2) * sqrt(r_t'^2) ]; + ! -1 <= corr_(w,r_t) <= 1. + ! + ! Since w'^2, r_t'^2, and w'r_t' are each advanced in different + ! subroutines from each other in advance_clubb_core, clipping for w'r_t' + ! is done three times during each timestep (once after each variable has + ! been updated). + ! + ! This subroutine handles the first and third instances of + ! w'r_t' clipping. + ! The first instance of w'r_t' clipping takes place after + ! r_t'^2 is updated in advance_xp2_xpyp. + ! The third instance of w'r_t' clipping takes place after + ! w'^2 is updated in advance_wp2_wp3. + + ! Include effect of clipping in wprtp time tendency budget term. + if ( l_stats_samp ) then + + ! if wprtp_cl_num == 1 do nothing since + ! iwprtp_bt stat_begin_update is called outside of this method + + if ( wprtp_cl_num == 2 ) then + ! wprtp total time tendency (effect of clipping) + call stat_modify( iwprtp_bt, -wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + elseif ( wprtp_cl_num == 3 ) then + ! wprtp total time tendency (effect of clipping) + call stat_modify( iwprtp_bt, -wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + endif + endif + + ! Used within subroutine clip_covar. + if ( wprtp_cl_num == 1 ) then + l_first_clip_ts = .true. + l_last_clip_ts = .false. + elseif ( wprtp_cl_num == 2 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .false. + elseif ( wprtp_cl_num == 3 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .true. + endif + + ! Clip w'r_t' + call clip_covar( clip_wprtp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, rtp2, & ! intent(in) + wprtp, wprtp_chnge ) ! intent(inout) + + if ( l_stats_samp ) then + if ( wprtp_cl_num == 1 ) then + ! wprtp total time tendency (effect of clipping) + call stat_modify( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + elseif ( wprtp_cl_num == 2 ) then + ! wprtp total time tendency (effect of clipping) + call stat_modify( iwprtp_bt, wprtp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + ! if wprtp_cl_num == 3 do nothing since + ! iwprtp_bt stat_end_update is called outside of this method + + endif + endif + + + !!! Clipping for w'th_l' + ! + ! Clipping w'th_l' at each vertical level, based on the + ! correlation of w and th_l at each vertical level, such that: + ! corr_(w,th_l) = w'th_l' / [ sqrt(w'^2) * sqrt(th_l'^2) ]; + ! -1 <= corr_(w,th_l) <= 1. + ! + ! Since w'^2, th_l'^2, and w'th_l' are each advanced in different + ! subroutines from each other in advance_clubb_core, clipping for w'th_l' + ! is done three times during each timestep (once after each variable has + ! been updated). + ! + ! This subroutine handles the first and third instances of + ! w'th_l' clipping. + ! The first instance of w'th_l' clipping takes place after + ! th_l'^2 is updated in advance_xp2_xpyp. + ! The third instance of w'th_l' clipping takes place after + ! w'^2 is updated in advance_wp2_wp3. + + ! Include effect of clipping in wpthlp time tendency budget term. + if ( l_stats_samp ) then + + ! if wpthlp_cl_num == 1 do nothing since + ! iwpthlp_bt stat_begin_update is called outside of this method + + if ( wpthlp_cl_num == 2 ) then + ! wpthlp total time tendency (effect of clipping) + call stat_modify( iwpthlp_bt, -wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + elseif ( wpthlp_cl_num == 3 ) then + ! wpthlp total time tendency (effect of clipping) + call stat_modify( iwpthlp_bt, -wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + endif + endif + + ! Used within subroutine clip_covar. + if ( wpthlp_cl_num == 1 ) then + l_first_clip_ts = .true. + l_last_clip_ts = .false. + elseif ( wpthlp_cl_num == 2 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .false. + elseif ( wpthlp_cl_num == 3 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .true. + endif + + ! Clip w'th_l' + call clip_covar( clip_wpthlp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, thlp2, & ! intent(in) + wpthlp, wpthlp_chnge ) ! intent(inout) + + + if ( l_stats_samp ) then + if ( wpthlp_cl_num == 1 ) then + ! wpthlp total time tendency (effect of clipping) + call stat_modify( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + elseif ( wpthlp_cl_num == 2 ) then + ! wpthlp total time tendency (effect of clipping) + call stat_modify( iwpthlp_bt, wpthlp / dt, & ! intent(in) + stats_zm ) ! intent(inout) + + ! if wpthlp_cl_num == 3 do nothing since + ! iwpthlp_bt stat_end_update is called outside of this method + + endif + endif + + + !!! Clipping for w'sclr' + ! + ! Clipping w'sclr' at each vertical level, based on the + ! correlation of w and sclr at each vertical level, such that: + ! corr_(w,sclr) = w'sclr' / [ sqrt(w'^2) * sqrt(sclr'^2) ]; + ! -1 <= corr_(w,sclr) <= 1. + ! + ! Since w'^2, sclr'^2, and w'sclr' are each advanced in different + ! subroutines from each other in advance_clubb_core, clipping for w'sclr' + ! is done three times during each timestep (once after each variable has + ! been updated). + ! + ! This subroutine handles the first and third instances of + ! w'sclr' clipping. + ! The first instance of w'sclr' clipping takes place after + ! sclr'^2 is updated in advance_xp2_xpyp. + ! The third instance of w'sclr' clipping takes place after + ! w'^2 is updated in advance_wp2_wp3. + + ! Used within subroutine clip_covar. + if ( wpsclrp_cl_num == 1 ) then + l_first_clip_ts = .true. + l_last_clip_ts = .false. + elseif ( wpsclrp_cl_num == 2 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .false. + elseif ( wpsclrp_cl_num == 3 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .true. + endif + + ! Clip w'sclr' + do i = 1, sclr_dim, 1 + call clip_covar( clip_wpsclrp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2(:), sclrp2(:,i), & ! intent(in) + wpsclrp(:,i), wpsclrp_chnge(:,i) ) ! intent(inout) + enddo + + + !!! Clipping for u'w' + ! + ! Clipping u'w' at each vertical level, based on the + ! correlation of u and w at each vertical level, such that: + ! corr_(u,w) = u'w' / [ sqrt(u'^2) * sqrt(w'^2) ]; + ! -1 <= corr_(u,w) <= 1. + ! + ! Since w'^2, u'^2, and u'w' are each advanced in different + ! subroutines from each other in advance_clubb_core, clipping for u'w' + ! is done three times during each timestep (once after each variable has + ! been updated). + ! + ! This subroutine handles the first and second instances of + ! u'w' clipping. + ! The first instance of u'w' clipping takes place after + ! u'^2 is updated in advance_xp2_xpyp. + ! The second instance of u'w' clipping takes place after + ! w'^2 is updated in advance_wp2_wp3. + + ! Used within subroutine clip_covar. + if ( upwp_cl_num == 1 ) then + l_first_clip_ts = .true. + l_last_clip_ts = .false. + elseif ( upwp_cl_num == 2 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .false. + elseif ( upwp_cl_num == 3 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .true. + endif + + ! Clip u'w' + if ( l_tke_aniso ) then + call clip_covar( clip_upwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, up2, & ! intent(in) + upwp, upwp_chnge ) ! intent(inout) + else + ! In this case, up2 = wp2, and the variable `up2' does not interact + call clip_covar( clip_upwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, wp2, & ! intent(in) + upwp, upwp_chnge ) ! intent(inout) + end if + + + + !!! Clipping for v'w' + ! + ! Clipping v'w' at each vertical level, based on the + ! correlation of v and w at each vertical level, such that: + ! corr_(v,w) = v'w' / [ sqrt(v'^2) * sqrt(w'^2) ]; + ! -1 <= corr_(v,w) <= 1. + ! + ! Since w'^2, v'^2, and v'w' are each advanced in different + ! subroutines from each other in advance_clubb_core, clipping for v'w' + ! is done three times during each timestep (once after each variable has + ! been updated). + ! + ! This subroutine handles the first and second instances of + ! v'w' clipping. + ! The first instance of v'w' clipping takes place after + ! v'^2 is updated in advance_xp2_xpyp. + ! The second instance of v'w' clipping takes place after + ! w'^2 is updated in advance_wp2_wp3. + + ! Used within subroutine clip_covar. + if ( vpwp_cl_num == 1 ) then + l_first_clip_ts = .true. + l_last_clip_ts = .false. + elseif ( vpwp_cl_num == 2 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .false. + elseif ( vpwp_cl_num == 3 ) then + l_first_clip_ts = .false. + l_last_clip_ts = .true. + endif + + if ( l_tke_aniso ) then + call clip_covar( clip_vpwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, vp2, & ! intent(in) + vpwp, vpwp_chnge ) ! intent(inout) + else + ! In this case, vp2 = wp2, and the variable `vp2' does not interact + call clip_covar( clip_vpwp, l_first_clip_ts, & ! intent(in) + l_last_clip_ts, dt, wp2, wp2, & ! intent(in) + vpwp, vpwp_chnge ) ! intent(inout) + end if + + + return + end subroutine clip_covars_denom + + !============================================================================= + subroutine clip_covar( solve_type, l_first_clip_ts, & + l_last_clip_ts, dt, xp2, yp2, & + xpyp, xpyp_chnge ) + + ! Description: + ! Clipping the value of covariance x'y' based on the correlation between x + ! and y. + ! + ! The correlation between variables x and y is: + ! + ! corr_(x,y) = x'y' / [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! where x'^2 is the variance of x, y'^2 is the variance of y, and x'y' is + ! the covariance of x and y. + ! + ! The correlation of two variables must always have a value between -1 + ! and 1, such that: + ! + ! -1 <= corr_(x,y) <= 1. + ! + ! Therefore, there is an upper limit on x'y', such that: + ! + ! x'y' <= [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! and a lower limit on x'y', such that: + ! + ! x'y' >= -[ sqrt(x'^2) * sqrt(y'^2) ]. + ! + ! The values of x'y', x'^2, and y'^2 are all found on momentum levels. + ! + ! The value of x'y' may need to be clipped whenever x'y', x'^2, or y'^2 is + ! updated. + ! + ! The following covariances are found in the code: + ! + ! w'r_t', w'th_l', w'sclr', (computed in advance_xm_wpxp); + ! r_t'th_l', sclr'r_t', sclr'th_l', (computed in advance_xp2_xpyp); + ! u'w', v'w', w'edsclr' (computed in advance_windm_edsclrm); + ! and w'hm' (computed in setup_pdf_parameters). + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + max_mag_correlation ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_modify, & + stat_end_update + + use stats_variables, only: & + stats_zm, & ! Variable(s) + iwprtp_cl, & + iwpthlp_cl, & + irtpthlp_cl, & + l_stats_samp + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variable being solved; used for STATS. + + logical, intent(in) :: & + l_first_clip_ts, & ! First instance of clipping in a timestep. + l_last_clip_ts ! Last instance of clipping in a timestep. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep; used here for STATS [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xp2, & ! Variance of x, x'^2 (momentum levels) [{x units}^2] + yp2 ! Variance of y, y'^2 (momentum levels) [{y units}^2] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + xpyp ! Covariance of x and y, x'y' (momentum levels) [{x units}*{y units}] + + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + xpyp_chnge ! Net change in x'y' due to clipping [{x units}*{y units}] + + + ! Local Variable + integer :: k ! Array index + + integer :: & + ixpyp_cl + + ! ---- Begin Code ---- + + select case ( solve_type ) + case ( clip_wprtp ) ! wprtp clipping budget term + ixpyp_cl = iwprtp_cl + case ( clip_wpthlp ) ! wpthlp clipping budget term + ixpyp_cl = iwpthlp_cl + case ( clip_rtpthlp ) ! rtpthlp clipping budget term + ixpyp_cl = irtpthlp_cl + case default ! scalars (or upwp/vpwp) are involved + ixpyp_cl = 0 + end select + + + if ( l_stats_samp ) then + if ( l_first_clip_ts ) then + call stat_begin_update( ixpyp_cl, xpyp / dt, stats_zm ) + else + call stat_modify( ixpyp_cl, -xpyp / dt, stats_zm ) + endif + endif + + ! The value of x'y' at the surface (or lower boundary) is a set value that + ! is either specified or determined elsewhere in a surface subroutine. It + ! is ensured elsewhere that the correlation between x and y at the surface + ! (or lower boundary) is between -1 and 1. Thus, the covariance clipping + ! code does not need to be invoked at the lower boundary. Likewise, the + ! value of x'y' is set at the upper boundary, so the covariance clipping + ! code does not need to be invoked at the upper boundary. + ! Note that if clipping were applied at the lower boundary, momentum will + ! not be conserved, therefore it should never be added. + do k = 2, gr%nz-1, 1 + + ! Clipping for xpyp at an upper limit corresponding with a correlation + ! between x and y of max_mag_correlation. + if ( xpyp(k) > max_mag_correlation * sqrt( xp2(k) * yp2(k) ) ) then + + xpyp_chnge(k) = max_mag_correlation * sqrt( xp2(k) * yp2(k) ) - xpyp(k) + + xpyp(k) = max_mag_correlation * sqrt( xp2(k) * yp2(k) ) + + ! Clipping for xpyp at a lower limit corresponding with a correlation + ! between x and y of -max_mag_correlation. + elseif ( xpyp(k) < -max_mag_correlation * sqrt( xp2(k) * yp2(k) ) ) then + + xpyp_chnge(k) = -max_mag_correlation * sqrt( xp2(k) * yp2(k) ) - xpyp(k) + + xpyp(k) = -max_mag_correlation * sqrt( xp2(k) * yp2(k) ) + + else + + xpyp_chnge(k) = 0.0_core_rknd + + endif + + enddo ! k = 2..gr%nz + + ! Since there is no covariance clipping at the upper or lower boundaries, + ! the change in x'y' due to covariance clipping at those levels is 0. + xpyp_chnge(1) = 0.0_core_rknd + xpyp_chnge(gr%nz) = 0.0_core_rknd + + if ( l_stats_samp ) then + if ( l_last_clip_ts ) then + call stat_end_update( ixpyp_cl, xpyp / dt, stats_zm ) + else + call stat_modify( ixpyp_cl, xpyp / dt, stats_zm ) + endif + endif + + + return + end subroutine clip_covar + + !============================================================================= + subroutine clip_covar_level( solve_type, level, l_first_clip_ts, & + l_last_clip_ts, dt, xp2, yp2, & + xpyp, xpyp_chnge ) + + ! Description: + ! Clipping the value of covariance x'y' based on the correlation between x + ! and y. This is all done at a single vertical level. + ! + ! The correlation between variables x and y is: + ! + ! corr_(x,y) = x'y' / [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! where x'^2 is the variance of x, y'^2 is the variance of y, and x'y' is + ! the covariance of x and y. + ! + ! The correlation of two variables must always have a value between -1 + ! and 1, such that: + ! + ! -1 <= corr_(x,y) <= 1. + ! + ! Therefore, there is an upper limit on x'y', such that: + ! + ! x'y' <= [ sqrt(x'^2) * sqrt(y'^2) ]; + ! + ! and a lower limit on x'y', such that: + ! + ! x'y' >= -[ sqrt(x'^2) * sqrt(y'^2) ]. + ! + ! The values of x'y', x'^2, and y'^2 are all found on momentum levels. + ! + ! The value of x'y' may need to be clipped whenever x'y', x'^2, or y'^2 is + ! updated. + ! + ! The following covariances are found in the code: + ! + ! w'r_t', w'th_l', w'sclr', (computed in advance_xm_wpxp); + ! r_t'th_l', sclr'r_t', sclr'th_l', (computed in advance_xp2_xpyp); + ! u'w', v'w', w'edsclr' (computed in advance_windm_edsclrm); + ! and w'hm' (computed in setup_pdf_parameters). + + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update_pt, & ! Procedure(s) + stat_modify_pt, & + stat_end_update_pt + + use stats_variables, only: & + stats_zm, & ! Variable(s) + iwprtp_cl, & + iwpthlp_cl, & + irtpthlp_cl, & + l_stats_samp + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type, & ! Variable being solved; used for STATS + level ! Vertical level index + + logical, intent(in) :: & + l_first_clip_ts, & ! First instance of clipping in a timestep. + l_last_clip_ts ! Last instance of clipping in a timestep. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep; used here for STATS [s] + + real( kind = core_rknd ), intent(in) :: & + xp2, & ! Variance of x, [{x units}^2] + yp2 ! Variance of y, [{y units}^2] + + ! Output Variable + real( kind = core_rknd ), intent(inout) :: & + xpyp ! Covariance of x and y, [{x units}*{y units}] + + real( kind = core_rknd ), intent(out) :: & + xpyp_chnge ! Net change in due to clipping [{x units}*{y units}] + + + ! Local Variable + integer :: & + ixpyp_cl ! Statistics index + + + select case ( solve_type ) + case ( clip_wprtp ) ! wprtp clipping budget term + ixpyp_cl = iwprtp_cl + case ( clip_wpthlp ) ! wpthlp clipping budget term + ixpyp_cl = iwpthlp_cl + case ( clip_rtpthlp ) ! rtpthlp clipping budget term + ixpyp_cl = irtpthlp_cl + case default ! scalars (or upwp/vpwp) are involved + ixpyp_cl = 0 + end select + + + if ( l_stats_samp ) then + if ( l_first_clip_ts ) then + call stat_begin_update_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + else + call stat_modify_pt( ixpyp_cl, level, & + -xpyp / dt, stats_zm ) + endif + endif + + ! The value of x'y' at the surface (or lower boundary) is a set value that + ! is either specified or determined elsewhere in a surface subroutine. It + ! is ensured elsewhere that the correlation between x and y at the surface + ! (or lower boundary) is between -1 and 1. Thus, the covariance clipping + ! code does not need to be invoked at the lower boundary. Likewise, the + ! value of x'y' is set at the upper boundary, so the covariance clipping + ! code does not need to be invoked at the upper boundary. + ! Note that if clipping were applied at the lower boundary, momentum will + ! not be conserved, therefore it should never be added. + + ! Clipping for xpyp at an upper limit corresponding with a correlation + ! between x and y of max_mag_correlation. + if ( xpyp > max_mag_correlation * sqrt( xp2 * yp2 ) ) then + + xpyp_chnge = max_mag_correlation * sqrt( xp2 * yp2 ) - xpyp + + xpyp = max_mag_correlation * sqrt( xp2 * yp2 ) + + ! Clipping for xpyp at a lower limit corresponding with a correlation + ! between x and y of -max_mag_correlation. + elseif ( xpyp < -max_mag_correlation * sqrt( xp2 * yp2 ) ) then + + xpyp_chnge = -max_mag_correlation * sqrt( xp2 * yp2 ) - xpyp + + xpyp = -max_mag_correlation * sqrt( xp2 * yp2 ) + + else + + xpyp_chnge = zero + + endif + + if ( l_stats_samp ) then + if ( l_last_clip_ts ) then + call stat_end_update_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + else + call stat_modify_pt( ixpyp_cl, level, & + xpyp / dt, stats_zm ) + endif + endif + + + return + end subroutine clip_covar_level + + !============================================================================= + subroutine clip_variance( solve_type, dt, threshold, & + xp2 ) + + ! Description: + ! Clipping the value of variance x'^2 based on a minimum threshold value. + ! The threshold value must be greater than or equal to 0. + ! + ! The values of x'^2 are found on the momentum levels. + ! + ! The following variances are found in the code: + ! + ! r_t'^2, th_l'^2, u'^2, v'^2, sclr'^2, (computed in advance_xp2_xpyp); + ! w'^2 (computed in advance_wp2_wp3). + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_end_update + + use stats_variables, only: & + stats_zm, & ! Variable(s) + iwp2_cl, & + irtp2_cl, & + ithlp2_cl, & + iup2_cl, & + ivp2_cl, & + l_stats_samp + + implicit none + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variable being solved; used for STATS. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep; used here for STATS [s] + + real( kind = core_rknd ), intent(in) :: & + threshold ! Minimum value of x'^2 [{x units}^2] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + xp2 ! Variance of x, x'^2 (momentum levels) [{x units}^2] + + ! Local Variables + integer :: k ! Array index + + + integer :: & + ixp2_cl + + ! ---- Begin Code ---- + + select case ( solve_type ) + case ( clip_wp2 ) ! wp2 clipping budget term + ixp2_cl = iwp2_cl + case ( clip_rtp2 ) ! rtp2 clipping budget term + ixp2_cl = irtp2_cl + case ( clip_thlp2 ) ! thlp2 clipping budget term + ixp2_cl = ithlp2_cl + case ( clip_up2 ) ! up2 clipping budget term + ixp2_cl = iup2_cl + case ( clip_vp2 ) ! vp2 clipping budget term + ixp2_cl = ivp2_cl + case default ! scalars are involved + ixp2_cl = 0 + end select + + + if ( l_stats_samp ) then + call stat_begin_update( ixp2_cl, xp2 / dt, stats_zm ) + endif + + ! Limit the value of x'^2 at threshold. + ! The value of x'^2 at the surface (or lower boundary) is a set value that + ! is determined elsewhere in a surface subroutine. Thus, the variance + ! clipping code does not need to be invoked at the lower boundary. + ! Likewise, the value of x'^2 is set at the upper boundary, so the variance + ! clipping code does not need to be invoked at the upper boundary. + ! + ! charlass on 09/11/2013: I changed the clipping so that also the surface + ! level is clipped. I did this because we discovered that there are slightly + ! negative values in thlp2(1) and rtp2(1) when running quarter_ss case with + ! WRF-CLUBB (see wrf:ticket:51#comment:33) + do k = 1, gr%nz-1, 1 + if ( xp2(k) < threshold ) then + xp2(k) = threshold + endif + enddo + + if ( l_stats_samp ) then + call stat_end_update( ixp2_cl, xp2 / dt, stats_zm ) + endif + + + return + end subroutine clip_variance + + !============================================================================= + subroutine clip_skewness( dt, sfc_elevation, wp2_zt, wp3 ) + + ! Description: + ! Clipping the value of w'^3 based on the skewness of w, Sk_w. + ! + ! Aditionally, to prevent possible crashes due to wp3 growing too large, + ! abs(wp3) will be clipped to 100. + ! + ! The skewness of w is: + ! + ! Sk_w = w'^3 / (w'^2)^(3/2). + ! + ! The value of Sk_w is limited to a range between an upper limit and a lower + ! limit. The values of the limits depend on whether the level altitude is + ! within 100 meters of the surface. + ! + ! For altitudes less than or equal to 100 meters above ground level (AGL): + ! + ! -0.2_core_rknd*sqrt(2) <= Sk_w <= 0.2_core_rknd*sqrt(2); + ! + ! while for all altitudes greater than 100 meters AGL: + ! + ! -4.5_core_rknd <= Sk_w <= 4.5_core_rknd. + ! + ! Therefore, there is an upper limit on w'^3, such that: + ! + ! w'^3 <= threshold_magnitude * (w'^2)^(3/2); + ! + ! and a lower limit on w'^3, such that: + ! + ! w'^3 >= -threshold_magnitude * (w'^2)^(3/2). + ! + ! The values of w'^3 are found on the thermodynamic levels, while the values + ! of w'^2 are found on the momentum levels. Therefore, the values of w'^2 + ! are interpolated to the thermodynamic levels before being used to + ! calculate the upper and lower limits for w'^3. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_end_update + + use stats_variables, only: & + stats_zt, & ! Variable(s) + iwp3_cl, & + l_stats_samp + + implicit none + + ! External + intrinsic :: sign, sqrt, real + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep; used here for STATS [s] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2_zt ! w'^2 interpolated to thermodyamic levels [m^2/s^2] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! ---- Begin Code ---- + + if ( l_stats_samp ) then + call stat_begin_update( iwp3_cl, wp3 / dt, stats_zt ) + endif + + call clip_skewness_core( sfc_elevation, wp2_zt, wp3 ) + + if ( l_stats_samp ) then + call stat_end_update( iwp3_cl, wp3 / dt, stats_zt ) + endif + + return + end subroutine clip_skewness + +!============================================================================= + subroutine clip_skewness_core( sfc_elevation, wp2_zt, wp3 ) +! + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + Skw_max_mag_sqd ! [-] + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: sign, sqrt, real + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wp2_zt ! w'^2 interpolated to thermodyamic levels [m^2/s^2] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + wp2_zt_cubed, & ! Variance of vertical velocity cubed (w^2_{zt}^3) [m^6/s^6] + wp3_lim_sqd ! Keeps absolute value of Sk_w from becoming > limit [m^6/s^6] + + integer :: k ! Vertical array index. + + real( kind = core_rknd ), parameter :: & + wp3_max = 100._core_rknd ! Threshold for wp3 [m^3/s^3] + + ! ---- Begin Code ---- + + ! Compute the upper and lower limits of w'^3 at every level, + ! based on the skewness of w, Sk_w, such that: + ! Sk_w = w'^3 / (w'^2)^(3/2); + ! -4.5 <= Sk_w <= 4.5; + ! or, if the level altitude is within 100 meters of the surface, + ! -0.2*sqrt(2) <= Sk_w <= 0.2*sqrt(2). + + ! The normal magnitude limit of skewness of w in the CLUBB code is 4.5. + ! However, according to Andre et al. (1976b & 1978), wp3 should not exceed + ! [2*(wp2^3)]^(1/2) at any level. However, this term should be multiplied + ! by 0.2 close to the surface to include surface effects. There already is + ! a wp3 clipping term in place for all other altitudes, but this term will + ! be included for the surface layer only. Therefore, the lowest level wp3 + ! should not exceed 0.2 * sqrt(2) * wp2^(3/2). Brian Griffin. 12/18/05. + + ! To lower compute time, we squared both sides of the equation and compute + ! wp2^3 only once. -dschanen 9 Oct 2008 + + wp2_zt_cubed(1:gr%nz) = wp2_zt(1:gr%nz)**3 + + do k = 1, gr%nz, 1 + if ( gr%zt(k) - sfc_elevation <= 100.0_core_rknd ) then ! Clip for 100 m. AGL. + !wp3_upper_lim(k) = 0.2_core_rknd * sqrt_2 * wp2_zt(k)**(3.0_core_rknd/2.0_core_rknd) + !wp3_lower_lim(k) = -0.2_core_rknd * sqrt_2 * wp2_zt(k)**(3.0_core_rknd/2.0_core_rknd) + wp3_lim_sqd(k) = 0.08_core_rknd * wp2_zt_cubed(k) ! Where 0.08_core_rknd + ! == (sqrt(2)*0.2_core_rknd)**2 known magic number + else ! Clip skewness consistently with a. + !wp3_upper_lim(k) = 4.5_core_rknd * wp2_zt(k)**(3.0_core_rknd/2.0_core_rknd) + !wp3_lower_lim(k) = -4.5_core_rknd * wp2_zt(k)**(3.0_core_rknd/2.0_core_rknd) + wp3_lim_sqd(k) = Skw_max_mag_sqd * wp2_zt_cubed(k) ! Skw_max_mag = 4.5_core_rknd^2 + endif + enddo + + ! Clipping for w'^3 at an upper and lower limit corresponding with + ! the appropriate value of Sk_w. + where ( wp3**2 > wp3_lim_sqd ) & + ! Set the magnitude to the wp3 limit and apply the sign of the current wp3 + wp3 = sign( sqrt( wp3_lim_sqd ), wp3 ) + + ! Clipping abs(wp3) to 100. This keeps wp3 from growing too large in some + ! deep convective cases, which helps prevent these cases from blowing up. + where ( abs(wp3) > wp3_max ) & + wp3 = sign( wp3_max , wp3 ) ! Known magic number + + end subroutine clip_skewness_core + +!=============================================================================== + +end module clip_explicit diff --git a/src/physics/clubb/clip_semi_implicit.F90 b/src/physics/clubb/clip_semi_implicit.F90 new file mode 100644 index 0000000000..09caeb90e6 --- /dev/null +++ b/src/physics/clubb/clip_semi_implicit.F90 @@ -0,0 +1,659 @@ +!----------------------------------------------------------------------- +! $Id: clip_semi_implicit.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== +module clip_semi_implicit + + ! Description of the semi-implicit clipping code: + ! The semi-implicit clipping code is based on an upper threshold and/or a + ! lower threshold value for variable f. + ! + ! The semi-implicit clipping code is used when the value of variable f should + ! not exceed the designated threshold(s) when it is advanced to timestep + ! index (t+1). + ! + ! + ! Clipping at an Upper Threshold: + ! + ! When there is an upper threshold to be applied, the equation for the clipped + ! value of the variable f, f_clipped, is: + ! + ! f_clipped(t+1) = MIN( f_unclipped(t+1), upper_threshold ) + ! = ( f_unclipped(t+1) - upper_threshold ) + ! * H(upper_threshold-f_unclipped(t+1)) + ! + upper_threshold; + ! + ! where f_unclipped is the value of the variable f without clipping, and + ! H(upper_threshold-f_unclipped(t+1)) is the Heaviside Step function. The + ! clipping term is turned into a time tendency term, such that: + ! + ! (df/dt)_clipping = (1/dt_clip) + ! * ( f_clipped(t+1) - f_unclipped(t+1) ); + ! + ! where dt_clip is the time scale for the clipping term. The difference + ! between the threshold value and f_unclipped is defined as f_diff: + ! + ! f_diff = upper_threshold - f_unclipped. + ! + ! The clipping time tendency is now simplified as: + ! + ! (df/dt)_clipping = + (1/dt_clip) + ! * { f_diff(t+1) * [ 1 - H(f_diff(t+1)) ] }. + ! + ! Function R(f_diff) is defined as: + ! + ! R(f_diff) = { f_diff * [ 1 - H(f_diff) ] }. + ! + ! The clipping time tendency is now written as: + ! + ! (df/dt)_clipping = + (1/dt_clip) * R(f_diff(t+1)). + ! + ! In order to solve for f_unclipped (and f_diff) at timestep index (t+1), the + ! clipping term must be linearized. A Taylor Series expansion (truncated + ! after the first derivative term) of R(f_diff) around f_diff = f_diff(t) is + ! used to linearize the term. However, the Heaviside Step function, + ! H(f_diff), is not differentiable when f_diff(t) = 0, as the function jumps + ! at that point. Likewise, the function R(f_diff) is not differentiable when + ! f_diff(t) = 0, as the function has a corner at that point. Therefore, a new + ! function, F_R(f_diff) is used as an approximation of R(f_diff). Function + ! F_R(f_diff) is a three-piece function that has the exact same value as + ! R(f_diff) when f_diff <= -sigma or f_diff >= sigma (sigma is an arbitrarily + ! declared value). However, when -sigma < f_diff < sigma, a parabolic + ! function is used to approximate the corner found in R(f_diff). The + ! parabolic function needs to have the same values at f_diff = -sigma and + ! f_diff = sigma as does R(f_diff). Furthermore, the derivative of the + ! parabolic function (with respect to f_diff) needs to have the same values at + ! f_diff = -sigma and f_diff = sigma as does d(R)/d(f_diff). The parabolic + ! function that satisfies these properities is: + ! f_diff - (sigma/4) * [ 1 + (f_diff/sigma) ]^2. + ! Therefore: + ! + ! | f_diff; where f_diff <= -sigma + ! | + ! F_R(f_diff) = | f_diff - (sigma/4) * [ 1 + (f_diff/sigma) ]^2; + ! | where -sigma < f_diff < sigma + ! | + ! | 0; where f_diff >= sigma; and + ! + ! | 1; where f_diff <= -sigma + ! | + ! ( d F_R / d f_diff ) = | 1 - (1/2) * [ 1 + (f_diff/sigma) ]; + ! | where -sigma < f_diff < sigma + ! | + ! | 0; where f_diff >= sigma. + ! + ! Since, R(f_diff(t+1)) approx.= F_R(f_diff(t+1)), the Taylor Series expansion + ! is done for F_R(f_diff) around f_diff = f_diff(t) in order to linearize the + ! term: + ! + ! F_R(f_diff(t+1)) approx.= + ! A_fnc + B_fnc * ( f_diff(t+1) - f_diff(t) ); + ! + ! where A_fnc is defined as F_R(f_diff(t)) and B_fnc is defined as + ! ( d F_R / d f_diff )|_(f_diff=f_diff(t)). + ! + ! The approximation is substituted into the (df/dt)_clipping equation. The + ! rate of change of variable f due to clipping with the upper threshold is: + ! + ! (df/dt)_clipping + ! = + (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) + ! + B_fnc * upper_threshold - B_fnc * f_unclipped(t+1) }. + ! + ! The implicit (LHS) portion of the equation for clipping with the upper + ! threshold is: + ! + ! - (1/dt_clip) * B_fnc * f_unclipped(t+1). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The explicit (RHS) portion of the equation for clipping with the upper + ! threshold is: + ! + ! + (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) + B_fnc * upper_threshold }. + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(f)/dt equation. + ! + ! + ! Clipping at a Lower Threshold: + ! + ! When there is a lower threshold to be applied, the equation for the clipped + ! value of the variable f, f_clipped, is: + ! + ! f_clipped(t+1) = MAX( f_unclipped(t+1), lower_threshold ) + ! = ( f_unclipped(t+1) - lower_threshold ) + ! * H(f_unclipped(t+1)-lower_threshold) + ! + lower_threshold; + ! + ! where f_unclipped is the value of the variable f without clipping, and + ! H(f_unclipped(t+1)-lower_threshold) is the Heaviside Step function. The + ! clipping term is turned into a time tendency term, such that: + ! + ! (df/dt)_clipping = (1/dt_clip) + ! * ( f_clipped(t+1) - f_unclipped(t+1) ); + ! + ! where dt_clip is the time scale for the clipping term. The difference + ! between f_unclipped and the threshold value is defined as f_diff: + ! + ! f_diff = f_unclipped - lower_threshold. + ! + ! The clipping time tendency is now simplified as: + ! + ! (df/dt)_clipping = - (1/dt_clip) + ! * { f_diff(t+1) * [ 1 - H(f_diff(t+1)) ] }. + ! + ! Function R(f_diff) is defined as: + ! + ! R(f_diff) = { f_diff * [ 1 - H(f_diff) ] }. + ! + ! The clipping time tendency is now written as: + ! + ! (df/dt)_clipping = - (1/dt_clip) * R(f_diff(t+1)). + ! + ! The linearization process is the same for the lower threshold as it is for + ! the upper threshold. The formulas for A_fnc and B_fnc are the same, but the + ! values (based on a different f_diff) are different. The rate of change of + ! variable f due to clipping with the lower threshold is: + ! + ! (df/dt)_clipping + ! = - (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) + ! - B_fnc * lower_threshold + B_fnc * f_unclipped(t+1) }. + ! + ! The implicit (LHS) portion of the equation for clipping with the lower + ! threshold is: + ! + ! - (1/dt_clip) * B_fnc * f_unclipped(t+1). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The explicit (RHS) portion of the equation for clipping with the lower + ! threshold is: + ! + ! - (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) - B_fnc * lower_threshold }. + ! + ! All variables in these equations are on the same vertical levels as the + ! variable f. + ! + ! + ! Adjustable parameters: + ! + ! sigma: sigma is the amount on either side of the threshold value to which + ! the parabolic function portion of F_R(f_diff) is applied. The value + ! of sigma must be greater than 0. A proportionally larger value of + ! sigma can be used to effect values of f that are near the threshold, + ! but not to it or over it. The close-to-threshold values will be + ! nudged away from the threshold. + ! + ! dt_clip: dt_clip is the clipping time scale. It can be set equal to the + ! model timestep, dt, but it doesn't have to be. Smaller values of + ! dt_clip produce a greater effect on the clipping term. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private + + public :: clip_semi_imp_lhs, & + clip_semi_imp_rhs + + private :: compute_clip_lhs, & + compute_fncts_A_B + + ! Constant parameters. + + ! sigma coefficient: A coefficient with dimensionless units that must have a + ! value greater than 0. The value should be kept below 1. + ! The larger the value of sigma_coef, the larger the value + ! of sigma, and the larger the range of close-to-threshold + ! values that will be effected (nudged away from the + ! threshold) by the semi-implicit clipping. + real( kind = core_rknd ), parameter :: sigma_coef = 0.15_core_rknd + + ! dt_clip coefficient: A coefficient with dimensionless units that must have + ! a value greater than 0. A value of 1 will set the + ! clipping time scale, dt_clip, equal to the model + ! timestep, dt. The smaller the value of dt_clip_coef, + ! the smaller the value of dt_clip, and the larger the + ! magnitude of (df/dt)_clipping. + real(kind=core_rknd), parameter :: dt_clip_coef = 1.0_core_rknd + + contains + + !============================================================================= + function clip_semi_imp_lhs( dt, f_unclipped, & + l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold ) & + result( lhs ) + + ! Description: + ! The implicit portion of the semi-implicit clipping code. + ! + ! The implicit (LHS) portion of the equation for clipping with the upper + ! threshold is: + ! + ! - (1/dt_clip) * B_fnc * f_unclipped(t+1). + ! + ! The implicit (LHS) portion of the equation for clipping with the lower + ! threshold is: + ! + ! - (1/dt_clip) * B_fnc * f_unclipped(t+1). + ! + ! Note: When either term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of either term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of f being used is from the + ! next timestep, which is being advanced to in solving the d(f)/dt equation. + ! + ! While the formulas are the same for both the upper threshold and the lower + ! threshold, the values of A_fnc, B_fnc, and f_diff will differ between the + ! two thresholds. + ! + ! The overall implicit (LHS) portion for the clipping term is the sum of the + ! implicit portion from the upper threshold and the implicit portion from + ! the lower threshold. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s)implicit none + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep. [s] + + real( kind = core_rknd ), intent(in) :: & + f_unclipped, & ! The unclipped value of variable f at timestep (t). [f units] + upper_threshold, & ! Greatest allowable value of variable f. [f units] + lower_threshold ! Smallest allowable value of variable f. [f units] + + logical, intent(in) :: & + l_upper_thresh, & ! Flag for having an upper threshold value. + l_lower_thresh ! Flag for having a lower threshold value. + + ! Return Variable + real( kind = core_rknd ) :: lhs + + ! Local Variables + real( kind = core_rknd ) :: & + dt_clip ! Time scale for semi-implicit clipping term. [s] + + real( kind = core_rknd ) :: & + f_diff, & ! Difference between the threshold value and f_unclipped. [f units] + A_fnc, & ! Function that approximates { f_diff * [ 1 - H(f_diff) ] }. [f units] + B_fnc, & ! Derivative w/ respect to f_diff of function A_fnc. [] + lhs_upper, & ! Contribution of upper threshold to implicit portion (LHS). [s^-1] + lhs_lower ! Contribution of lower threshold to implicit portion (LHS). [s^-1] + + + ! Compute the clipping time scale, dt_clip. + dt_clip = dt_clip_coef * dt + + + ! Upper Threshold + if ( l_upper_thresh ) then + + ! f_diff is the difference between the threshold value and f_unclipped. + ! In regards to the upper threshold, it is defined as + ! upper_threshold - f_unclipped. + f_diff = upper_threshold - f_unclipped + + ! Compute the values of functions A_fnc and B_fnc evaluated at f_diff(t) + ! for the upper threshold. + call compute_fncts_A_B( l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold, & + f_diff, A_fnc, B_fnc ) + + ! Compute the implicit (LHS) contribution from clipping for the upper + ! threshold. + lhs_upper = compute_clip_lhs( dt_clip, B_fnc ) + + else + + lhs_upper = 0.0_core_rknd + + endif + + + ! Lower Threshold + if ( l_lower_thresh ) then + + ! f_diff is the difference between the threshold value and f_unclipped. + ! In regards to the lower threshold, it is defined as + ! f_unclipped - lower_threshold. + f_diff = f_unclipped - lower_threshold + + ! Compute the values of functions A_fnc and B_fnc evaluated at f_diff(t) + ! for the lower threshold. + call compute_fncts_A_B( l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold, & + f_diff, A_fnc, B_fnc ) + + ! Compute the implicit (LHS) contribution from clipping for the lower + ! threshold. + lhs_lower = compute_clip_lhs( dt_clip, B_fnc ) + + else + + lhs_lower = 0.0_core_rknd + + endif + + + ! Total implicit (LHS) contribution to clipping. + ! Main diagonal: [ x f_unclipped(k,) ] + lhs = lhs_upper + lhs_lower + + + end function clip_semi_imp_lhs + + !============================================================================= + pure function compute_clip_lhs( dt_clip, B_fnc ) & + result( lhs_contribution ) + + ! Description: + ! Calculation of the implicit portion of the semi-implicit clipping term. + ! + ! The implicit portion of the semi-implicit clipping term is: + ! + ! - (1/dt_clip) * B_fnc * f_unclipped(t+1). + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed + ! to a "+". + ! + ! The timestep index (t+1) means that the value of f being used is from the + ! next timestep, which is being advanced to in solving the d(f)/dt equation. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd), intent(in) :: & + dt_clip ! Time scale for semi-implicit clipping term. [s] + + real( kind = core_rknd ), intent(in) :: & + B_fnc ! Derivative w/ respect to f_diff of function A_fnc. [] + + ! Return Variable + real( kind = core_rknd ) :: lhs_contribution + + + ! Main diagonal: [ x f_unclipped(k,) ] + lhs_contribution & + = + (1.0_core_rknd/dt_clip * B_fnc ) + + + end function compute_clip_lhs + + !============================================================================= + function clip_semi_imp_rhs( dt, f_unclipped, & + l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold ) & + result( rhs ) + + ! Description: + ! The explicit portion of the semi-implicit clipping code. + ! + ! The explicit (RHS) portion of the equation for clipping with the upper + ! threshold is: + ! + ! + (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) + B_fnc * upper_threshold }. + ! + ! The explicit (RHS) portion of the equation for clipping with the lower + ! threshold is: + ! + ! - (1/dt_clip) + ! * { A_fnc - B_fnc * f_diff(t) - B_fnc * lower_threshold }. + ! + ! Timestep index (t) stands for the index of the current timestep. + ! + ! The values of A_fnc, B_fnc, and f_diff will differ between the two + ! thresholds. + ! + ! The overall explicit (RHS) portion for the clipping term is the sum of the + ! explicit portion from the upper threshold and the explicit portion from + ! the lower threshold. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep. [s] + + real( kind = core_rknd ), intent(in) :: & + f_unclipped, & ! The unclipped value of variable f at timestep (t). [f units] + upper_threshold, & ! Greatest allowable value of variable f. [f units] + lower_threshold ! Smallest allowable value of variable f. [f units] + + logical, intent(in) :: & + l_upper_thresh, & ! Flag for having an upper threshold value. + l_lower_thresh ! Flag for having a lower threshold value. + + ! Return Variable + real( kind = core_rknd ) :: rhs + + ! Local Variables + real( kind = core_rknd) :: & + dt_clip ! Time scale for semi-implicit clipping term. [s] + + real( kind = core_rknd ) :: & + f_diff, & ! Difference between the threshold value and f_unclipped. [f units] + A_fnc, & ! Function that approximates { f_diff * [ 1 - H(f_diff) ] }. [f units] + B_fnc, & ! Derivative w/ respect to f_diff of function A_fnc. [] + rhs_upper, & ! Contribution of upper threshold to explicit portion (RHS). [s^-1] + rhs_lower ! Contribution of lower threshold to explicit portion (RHS). [s^-1] + + + ! Compute the clipping time scale, dt_clip. + dt_clip = dt_clip_coef * dt + + + ! Upper Threshold + if ( l_upper_thresh ) then + + ! f_diff is the difference between the threshold value and f_unclipped. + ! In regards to the upper threshold, it is defined as + ! upper_threshold - f_unclipped. + f_diff = upper_threshold - f_unclipped + + ! Compute the values of functions A_fnc and B_fnc evaluated at f_diff(t) + ! for the upper threshold. + call compute_fncts_A_B( l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold, & + f_diff, A_fnc, B_fnc ) + + ! Compute the explicit (RHS) contribution from clipping for the upper + ! threshold. + rhs_upper & + = + (1.0_core_rknd/dt_clip & + * ( A_fnc - B_fnc * f_diff + B_fnc * upper_threshold ) ) + + else + + rhs_upper = 0.0_core_rknd + + endif + + + ! Lower Threshold + if ( l_lower_thresh ) then + + ! f_diff is the difference between the threshold value and f_unclipped. + ! In regards to the lower threshold, it is defined as + ! f_unclipped - lower_threshold. + f_diff = f_unclipped - lower_threshold + + ! Compute the values of functions A_fnc and B_fnc evaluated at f_diff(t) + ! for the lower threshold. + call compute_fncts_A_B( l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold, & + f_diff, A_fnc, B_fnc ) + + ! Compute the explicit (RHS) contribution from clipping for the lower + ! threshold. + rhs_lower & + = - (1.0_core_rknd/ dt_clip) & + * ( A_fnc - B_fnc * f_diff - B_fnc * lower_threshold ) + + else + + rhs_lower = 0.0_core_rknd + + endif + + + ! Total explicit (RHS) contribution to clipping. + rhs = rhs_upper + rhs_lower + + + end function clip_semi_imp_rhs + + !============================================================================= + subroutine compute_fncts_A_B( l_upper_thresh, upper_threshold, & + l_lower_thresh, lower_threshold, & + f_diff, A_fnc, B_fnc ) + + ! Description: + ! This subroutine computes the values of two functions used in semi-implicit + ! clipping. Both of the functions are based on the values of f_diff(t) and + ! the parameter sigma. One function is A_fnc, which is F_R(f_diff) + ! evaluated at f_diff = f_diff(t). F_R(f_diff) is a three-piece function + ! that is used to approximate function R(f_diff). The other function is + ! B_fnc, the derivative with respect to f_diff of function A_fnc. In other + ! words, B_fnc is ( d F_R / d f_diff ) evaluated at f_diff = f_diff(t). + ! + ! The equation for A_fnc is: + ! + ! | f_diff(t); where f_diff(t) <= -sigma + ! | + ! A_fnc = | f_diff(t) - (sigma/4) * [ 1 + (f_diff(t)/sigma) ]^2; + ! | where -sigma < f_diff(t) < sigma + ! | + ! | 0; where f_diff(t) >= sigma; + ! + ! while the equation for B_fnc is: + ! + ! | 1; where f_diff(t) <= -sigma + ! | + ! B_fnc = | 1 - (1/2) * [ 1 + (f_diff(t)/sigma) ]; + ! | where -sigma < f_diff(t) < sigma + ! | + ! | 0; where f_diff(t) >= sigma; + ! + ! where timestep index (t) stands for the index of the current timestep. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: eps ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in) :: & + f_diff, & ! Difference between the threshold value and f_unclipped. [f units] + upper_threshold, & ! Greatest allowable value of variable f. [f units] + lower_threshold ! Smallest allowable value of variable f. [f units] + + logical, intent(in) :: & + l_upper_thresh, & ! Flag for having an upper threshold value. + l_lower_thresh ! Flag for having a lower threshold value. + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + A_fnc, & ! Function that approximates { f_diff * [ 1 - H(f_diff) ] }. [f units] + B_fnc ! Derivative w/ respect to f_diff of function A_fnc. [] + + ! Local Variables + real( kind = core_rknd ) :: sigma_val, & ! Value of parameter sigma. [f units] + thresh_avg_mag ! Average magnitude of threshold(s). [f units] + + thresh_avg_mag = 0.0_core_rknd ! Default Initialization + + ! Find the average magnitude of the threshold. + ! In cases where only one threshold applies, the average magnitude of the + ! threshold must be greater than 0. + ! Note: The constant eps is there in case only one threshold applies, and + ! it has a value of 0 (or very close to 0). However, eps is a very + ! small number, and therefore it will not start curbing values until + ! they get extremely close to the threshold. A larger constant value + ! may work better. + if ( l_upper_thresh .and. l_lower_thresh ) then + ! Both thresholds apply. + thresh_avg_mag = 0.5_core_rknd * ( abs(upper_threshold) & + + abs(lower_threshold) ) + elseif ( l_upper_thresh ) then + ! Only the upper threshold applies. + thresh_avg_mag = max( abs(upper_threshold), eps ) + elseif ( l_lower_thresh ) then + ! Only the lower threshold applies. + thresh_avg_mag = max( abs(lower_threshold), eps ) + endif + + ! Compute the value of sigma based on the magnitude of the threshold(s) for + ! variable f and the sigma coefficient. The value of sigma must always be + ! positive. + sigma_val = sigma_coef * thresh_avg_mag + + ! A_fnc is a three-piece function that approximates function + ! R(f_diff(t)) = { f_diff(t) * [ 1 - H(f_diff(t)) ] }. This is needed + ! because the R(f_diff(t)) is not differentiable at point f_diff(t) = 0, as + ! the function has a corner at that point. Function A_fnc is differentiable + ! at all points. It is evaluated for f_diff at timestep index (t). + if ( f_diff <= -sigma_val ) then + A_fnc = f_diff + elseif ( f_diff >= sigma_val ) then + A_fnc = 0.0_core_rknd + else ! -sigma_val < f_diff < sigma_val + A_fnc = f_diff - ( (sigma_val/4.0_core_rknd) & + * ( 1.0_core_rknd + f_diff/sigma_val )**2 ) + endif + + ! B_fnc is the derivative with respect to f_diff of function A_fnc. It is + ! evaluated for f_diff at timestep index (t). + if ( f_diff <= -sigma_val ) then + B_fnc = 1.0_core_rknd + elseif ( f_diff >= sigma_val ) then + B_fnc = 0.0_core_rknd + else ! -sigma_val < f_diff < sigma_val + B_fnc = 1.0_core_rknd - (1.0_core_rknd/2.0_core_rknd)*( 1.0_core_rknd + f_diff/sigma_val ) + endif + + + end subroutine compute_fncts_A_B + +!=============================================================================== + +end module clip_semi_implicit diff --git a/src/physics/clubb/clubb_api_module.F90 b/src/physics/clubb/clubb_api_module.F90 new file mode 100644 index 0000000000..5cf33a93d1 --- /dev/null +++ b/src/physics/clubb/clubb_api_module.F90 @@ -0,0 +1,2160 @@ +!-------------------------------------------------------------------------------------------------- +! $Id: clubb_api_module.F90 7361 2014-11-04 21:51:02Z bmg2@uwm.edu $ +!================================================================================================== +! +! ######## ### ### ### ######### ######### ### ######### ########### +! ### ### ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ######### ######### ########### ######### ### +! ### ### ### ### ### ### ### ### ### ### ### ### +! ### ### ### ### ### ### ### ### ### ### ### ### ### +! ######## ########## ######## ######### ######### ### ### ### ########### +! +! The CLUBB API serves as the doorway through which external models can interact with CLUBB. +! +! PLEASE REMEMBER, IF ANY CODE IS CHANGED IN THIS DOCUMENT, +! THE CHANGES MUST BE PROPOGATED TO ALL HOST MODELS. +! +module clubb_api_module + + use mt95, only : & + assignment( = ), & + genrand_state, & ! Internal representation of the RNG state. + genrand_srepr, & ! Public representation of the RNG state. Should be used to save the RNG state + genrand_intg, & + genrand_init_api => genrand_init + + use array_index, only : & + hydromet_list, & + hydromet_tol, & ! Tolerance values for all hydrometeors [units vary] + iiNgm, & ! Hydrometeor array index for graupel concentration, Ng + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iirgm, & ! Hydrometeor array index for graupel mixing ratio, rg + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iisclr_rt, & + iisclr_thl, & + iisclr_CO2, & + iiedsclr_rt, & + iiedsclr_thl, & + iiedsclr_CO2, & + l_frozen_hm, & ! if true, then the hydrometeor is frozen; otherwise liquid + l_mix_rat_hm ! if true, then the quantity is a hydrometeor mixing ratio + + use clubb_precision, only : & + time_precision, & + core_rknd, & + stat_nknd, & + stat_rknd, & + dp ! Double Precision + + use constants_clubb, only : & + cloud_frac_min, & ! Threshold for cloud fractions + cm3_per_m3, & ! Cubic centimeters per cubic meter + Cp, & ! Dry air specific heat at constant p [J/kg/K] + em_min, & ! Minimum value for em (turbulence kinetic energy) + ep, & ! ep = 0.622 [-] + fstderr, & ! Fortran file unit I/O constant + fstdout, & ! Fortran file unit I/O constant + grav, & ! Gravitational acceleration [m/s^2] + Ls, & ! Latent heat of sublimation [J/kg] + Lv, & ! Latent heat of vaporization [J/kg] + Lf, & ! Latent heat of fusion [J/kg] + pi, & ! The ratio of radii to their circumference + pi_dp, & ! pi in double precision + radians_per_deg_dp, & + Rd, & ! Dry air gas constant [J/kg/K] + Rv, & ! Water vapor gas constant [J/kg/K] + sec_per_day, & ! Seconds in a day. + sec_per_hr, & ! Seconds in an hour. + sec_per_min, & ! Seconds in a minute. + T_freeze_K, & ! Freezing point of water [K] + var_length, & ! Maximum variable name length in CLUBB GrADS or netCDF output + zero, & ! 0.0_core_rknd + zero_threshold, & ! Defining a threshold on a physical quantity to be 0. + ! Tolerances + Nc_tol, & ! Tolerance value for N_c [#/kg] + Ng_tol, & ! Tolerance value for N_s [#/kg] + Ni_tol, & ! Tolerance value for N_i [#/kg] + Nr_tol, & ! Tolerance value for N_r [#/kg] + Ns_tol, & ! Tolerance value for N_s [#/kg] + rg_tol, & ! Tolerance value for r_g [kg/kg] + rho_lw, & + ri_tol, & ! Tolerance value for r_i [kg/kg] + rr_tol, & ! Tolerance value for r_r [kg/kg] + rs_tol, & ! Tolerance value for r_s [kg/kg] + rt_tol, & ! [kg/kg] + thl_tol, & ! [K] + w_tol_sqd ! [m^2/s^2] + + use corr_varnce_module, only : & + corr_array_n_cloud, & ! Variable(s) + corr_array_n_below, & + d_variables, & + iiPDF_chi, & + iiPDF_rr, & + iiPDF_w, & + iiPDF_Nr, & + iiPDF_ri, & + iiPDF_Ni, & + iiPDF_Ncn, & + iiPDF_rs, & + iiPDF_Ns, & + iiPDF_rg, & + iiPDF_Ng, & + hmp2_ip_on_hmm2_ip, & + Ncnp2_on_Ncnm2, & + hmp2_ip_on_hmm2_ip_ratios_type + + use error_code, only : & + clubb_no_error ! Enum representing that no errors have occurred in CLUBB + + use grid_class, only : & + gr + + use hydromet_pdf_parameter_module, only : & + hydromet_pdf_parameter + + use model_flags, only : & + l_use_boussinesq, & ! Use Boussinesq form of predictive equations (default is Anelastic). + l_diagnose_correlations, & ! Diagnose correlations instead of using fixed ones + l_calc_w_corr, & ! Calculate the correlations between w and the hydrometeors + l_use_cloud_cover, & ! helps to increase cloudiness at coarser grid resolutions. + l_use_precip_frac, & ! Flag to use precipitation fraction in KK microphysics. + l_tke_aniso, & ! For anisotropic turbulent kinetic energy + l_fix_chi_eta_correlations, & ! Use a fixed correlation for s and t Mellor(chi/eta) + l_const_Nc_in_cloud, & ! Use a constant cloud droplet conc. within cloud (K&K) + l_diffuse_rtm_and_thlm, & + l_stability_correct_Kh_N2_zm, & + l_stability_correct_tau_zm, & + l_do_expldiff_rtm_thlm, & + l_Lscale_plume_centered, & + l_use_ice_latent + + use parameters_model, only : & + hydromet_dim ! Number of hydrometeor species + + use parameters_tunable, only : & + l_prescribed_avg_deltaz, & ! used in adj_low_res_nu. If .true., avg_deltaz = deltaz + mu + + use parameter_indices, only: & + nparams, & ! Variable(s) + iC1, iC1b, iC1c, iC2, iC2b, iC2c, & + iC2rt, iC2thl, iC2rtthl, iC4, iC5, & + iC6rt, iC6rtb, iC6rtc, iC6thl, iC6thlb, iC6thlc, & + iC7, iC7b, iC7c, iC8, iC8b, iC10, iC11, iC11b, iC11c, & + iC12, iC13, iC14, iC15, iC6rt_Lscale0, iC6thl_Lscale0, & + iC7_Lscale0, iwpxp_L_thresh, ic_K, ic_K1, inu1, ic_K2, inu2, & + ic_K6, inu6, ic_K8, inu8, ic_K9, inu9, inu10, ic_K_hm, ic_K_hmb, iK_hm_min_coef, & + inu_hm, ibeta, igamma_coef, igamma_coefb, igamma_coefc, ilmin_coef, & + iomicron, izeta_vrnce_rat, iupsilon_precip_frac_rat, & + ilambda0_stability_coef, imult_coef, itaumin, itaumax, imu, iLscale_mu_coef, & + iLscale_pert_coef, ialpha_corr, iSkw_denom_coef, ic_K10, ic_K10h, ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh + + use pdf_parameter_module, only : & +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + num_pdf_params, & +#endif + pdf_parameter + + use stat_file_module, only : & + clubb_i, & ! Used to output multiple columns + clubb_j ! The indices must not exceed nlon (for i) or nlat (for j). + + use stats_rad_zm_module, only : & + nvarmax_rad_zm ! Maximum variables allowed + + use stats_rad_zt_module, only : & + nvarmax_rad_zt ! Maximum variables allowed + + use stats_variables, only : & + stats_zt, & ! zt grid + stats_zm, & ! zm grid + stats_rad_zt, & ! rad_zt grid + stats_rad_zm, & ! rad_zm grid + stats_sfc, & + l_stats_last, & ! Last time step of output period + stats_tsamp, & ! Sampling interval [s] + stats_tout, & ! Output interval [s] + l_output_rad_files, & ! Flag to turn off radiation statistics output + l_stats, & ! Main flag to turn statistics on/off + l_stats_samp, & ! Sample flag for current time step + l_grads, & ! Output to GrADS format + fname_rad_zt, & ! Name of the stats file for the stats_zt radiation grid fields + fname_rad_zm, & ! Name of the stats file for the stats_zm radiation grid fields + fname_sfc, & ! Name of the stats file for surface only fields + l_netcdf, & ! Output to NetCDF format + ! These are used in CAM only + ztscr01, ztscr02, ztscr03, & + ztscr04, ztscr05, ztscr06, & + ztscr07, ztscr08, ztscr09, & + ztscr10, ztscr11, ztscr12, & + ztscr13, ztscr14, ztscr15, & + ztscr16, ztscr17, ztscr18, & + ztscr19, ztscr20, ztscr21, & + zmscr01, zmscr02, zmscr03, & + zmscr04, zmscr05, zmscr06, & + zmscr07, zmscr08, zmscr09, & + zmscr10, zmscr11, zmscr12, & + zmscr13, zmscr14, zmscr15, & + zmscr16, zmscr17 + + use stats_zm_module, only : & + nvarmax_zm ! Maximum variables allowed + + use stats_zt_module, only : & + nvarmax_zt ! Maximum variables allowed + + use stats_sfc_module, only : & + nvarmax_sfc + + use variables_diagnostic_module, only : & + Lscale, & ! Mixing lengths + wp2_zt, & ! w'^2 on thermo. grid [m^2/s^2] + wphydrometp ! Covariance of w and hydrometeor (momentum levels) [(m/s)un] + + implicit none + + private + + public & + ! To Implement CLUBB: + read_parameters_api, & + setup_clubb_core_api, & + ! CLUBB can be set more specifically using these flags: + l_use_boussinesq, & + l_diagnose_correlations, & + l_calc_w_corr, & + l_use_cloud_cover, & + l_use_precip_frac, & + l_tke_aniso, & + l_fix_chi_eta_correlations, & + l_const_Nc_in_cloud, & + l_diffuse_rtm_and_thlm, & + l_stability_correct_Kh_N2_zm, & + l_stability_correct_tau_zm, & + l_do_expldiff_rtm_thlm, & + l_Lscale_plume_centered, & + l_use_ice_latent, & + ! The parameters of CLUBB can be retrieved and tuned using these indices: + iC1, iC1b, iC1c, iC2, iC2b, iC2c, & + iC2rt, iC2thl, iC2rtthl, iC4, iC5, & + iC6rt, iC6rtb, iC6rtc, iC6thl, iC6thlb, iC6thlc, & + iC7, iC7b, iC7c, iC8, iC8b, iC10, iC11, iC11b, iC11c, & + iC12, iC13, iC14, iC15, iC6rt_Lscale0, iC6thl_Lscale0, & + iC7_Lscale0, iwpxp_L_thresh, ic_K, ic_K1, inu1, ic_K2, inu2, & + ic_K6, inu6, ic_K8, inu8, ic_K9, inu9, inu10, ic_K_hm, ic_K_hmb, iK_hm_min_coef, & + inu_hm, ibeta, igamma_coef, igamma_coefb, igamma_coefc, ilmin_coef, & + iomicron, izeta_vrnce_rat, iupsilon_precip_frac_rat, & + ilambda0_stability_coef, imult_coef, itaumin, itaumax, imu, iLscale_mu_coef, & + iLscale_pert_coef, ialpha_corr, iSkw_denom_coef, ic_K10, ic_K10h, ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh + + + + public & + advance_clubb_core_api, & + pdf_parameter, & + ! A hydromet array is required, and these variables are required for a hydromet array: + hydromet_list, & + hydromet_tol, & + hydromet_dim, & + iiNgm, & + iiNim, & + iiNrm, & + iiNsm, & + iirgm, & + iirim, & + iirrm, & + iirsm, & + iisclr_rt, & + iisclr_thl, & + iisclr_CO2, & + iiedsclr_rt, & + iiedsclr_thl, & + iiedsclr_CO2, & + l_frozen_hm, & + l_mix_rat_hm, & + cleanup_clubb_core_api + + public & + ! To Implement SILHS: + setup_pdf_indices_api, & + setup_corr_varnce_array_api, & + setup_pdf_parameters_api, & + hydromet_pdf_parameter, & + ! lh_subcolumn_generator - SILHS API + genrand_init_api, & ! if you are doing restarts) + genrand_state, & + genrand_srepr, & + genrand_intg, & + ! To use the results, you will need these variables: + corr_array_n_cloud, & + corr_array_n_below, & + d_variables, & + iiPDF_chi, & + iiPDF_rr, & + iiPDF_w, & + iiPDF_Nr, & + iiPDF_ri, & + iiPDF_Ni, & + iiPDF_Ncn, & + iiPDF_rs, & + iiPDF_Ns, & + iiPDF_rg, & + iiPDF_Ng, & + hmp2_ip_on_hmm2_ip, & + Ncnp2_on_Ncnm2, & + hmp2_ip_on_hmm2_ip_ratios_type + + public & + ! To Interact With CLUBB's Grid: + gr, & + ! For Varying Grids + setup_grid_heights_api ! if heights vary with time + + public & + ! To Obtain More Output from CLUBB for Diagnostics: + stats_begin_timestep_api, & + stats_end_timestep_api, & + stats_finalize_api, & + stats_init_api, & + l_stats, & + l_stats_last, & + l_stats_samp, & + stats_tsamp, & + stats_tout + + public :: & + calculate_thlp2_rad_api, mu, update_xp2_mc_api, sat_mixrat_liq_api + + public :: & + ! To Convert Between Common CLUBB-related quantities: + lin_interpolate_two_points_api, & ! OR + lin_interpolate_on_grid_api, & + T_in_K2thlm_api, & + thlm2T_in_K_api, & + zt2zm_api, & + zm2zt_api + + public & + ! To Check For and Handle CLUBB's Errors: + calculate_spurious_source_api, & + clubb_at_least_debug_level_api, & + clubb_no_error, & + fatal_error_api, & + fill_holes_driver_api, & ! OR + fill_holes_vertical_api, & + report_error_api, & + set_clubb_debug_level_api, & + vertical_integral_api + + public & + ! Constants That May be Helpful: + cloud_frac_min, & + cm3_per_m3, & + core_rknd, & + Cp, & + dp, & + em_min, & + ep, & + fstderr, & + fstdout, & + grav, & + Lf, & + Ls, & + Lv, & + pi_dp, & + pi, & + radians_per_deg_dp, & + Rd, & + Rv, & + sec_per_day, & + sec_per_hr, & + sec_per_min, & + T_freeze_K, & + time_precision, & + var_length, & + zero_threshold, & + zero, & + ! Tolerances + Nc_tol, & + Ng_tol, & + Ni_tol, & + Nr_tol, & + Ns_tol, & + rg_tol, & + rho_lw, & + ri_tol, & + rr_tol, & + rs_tol, & + rt_tol, & + thl_tol, & + w_tol_sqd + + public & + ! Attempt to Not Use the Following: +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + pack_pdf_params_api, & + unpack_pdf_params_api, & + num_pdf_params, & +#endif + adj_low_res_nu_api, & + assignment( = ), & + clubb_i, & + clubb_j, & + compute_current_date_api, & + fname_rad_zm, & + fname_rad_zt, & + fname_sfc, & + gregorian2julian_day_api, & + l_grads, & + l_netcdf, & + l_output_rad_files, & + l_prescribed_avg_deltaz, & + leap_year_api, & + Lscale, & + nvarmax_rad_zm, & + nvarmax_rad_zt, & + nvarmax_sfc, & + nvarmax_zm, & + nvarmax_zt, & + stats_rad_zm, & + stats_rad_zt + public & + nparams, & + setup_parameters_api, & + stats_sfc, & + stat_nknd, & + stat_rknd, & + stats_accumulate_hydromet_api, & + stats_init_rad_zm_api, & + stats_init_rad_zt_api, & + stats_init_sfc_api, & + stats_init_zm_api, & + stats_init_zt_api, & + wp2_zt, & + wphydrometp, & + stats_zm, & + zmscr01, zmscr02, zmscr03, & + zmscr04, zmscr05, zmscr06, & + zmscr07, zmscr08, zmscr09, & + zmscr10, zmscr11, zmscr12, & + zmscr13, zmscr14, zmscr15, & + zmscr16, zmscr17, & + stats_zt, & + ztscr01, ztscr02, ztscr03, & + ztscr04, ztscr05, ztscr06, & + ztscr07, ztscr08, ztscr09, & + ztscr10, ztscr11, ztscr12, & + ztscr13, ztscr14, ztscr15, & + ztscr16, ztscr17, ztscr18, & + ztscr19, ztscr20, ztscr21 + + interface zt2zm_api + module procedure zt2zm_scalar_api, zt2zm_prof_api + end interface + + interface zm2zt_api + module procedure zm2zt_scalar_api, zm2zt_prof_api + end interface + +contains + + !================================================================================================ + ! advance_clubb_core - Advances the model one timestep. + !================================================================================================ + + subroutine advance_clubb_core_api( & + l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf, & ! intent(in) +#ifdef CLUBBND_CAM + varmu, & ! intent(in) +#endif + wphydrometp, wp2hmp, rtphmp, thlphmp, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, rtp3, thlp2, thlp3, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, thlprcp_out, & ! intent(out) +#endif + pdf_params ) ! intent(out) + + use advance_clubb_core_module, only : advance_clubb_core + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim + + implicit none + !!! Input Variables + logical, intent(in) :: & + l_implemented ! Is this part of a larger host model (T/F) ? + + real( kind = core_rknd ), intent(in) :: & + dt ! Current timestep duration [s] + + real( kind = core_rknd ), intent(in) :: & + fcor, & ! Coriolis forcing [s^-1] + sfc_elevation ! Elevation of ground level [m AMSL] + + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeors [#] + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] + vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing, & ! forcing (momentum levels) [K*(kg/kg)/s] + wm_zm, & ! w mean wind component on momentum levels [m/s] + wm_zt, & ! w mean wind component on thermo. levels [m/s] + p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] + rho_zm, & ! Air density on momentum levels [kg/m^3] + rho, & ! Air density on thermodynamic levels [kg/m^3] + exner, & ! Exner function (thermodynamic levels) [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt, & ! Dry, base-state theta_v on thermo. levs. [K] + rfrzm ! Total ice-phase water mixing ratio [kg/kg] + + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! Collection of hydrometeors [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + radf ! Buoyancy production at the CL top due to LW radiative cooling [m^2/s^3] + +#ifdef CLUBBND_CAM + real( kind = core_rknd ), intent(in) :: & + varmu +#endif + + real( kind = core_rknd ), dimension(gr%nz, hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third moment: * [(m/s)^2 ] + rtphmp, & ! Covariance of rt and a hydrometeor [(kg/kg) ] + thlphmp ! Covariance of thl and a hydrometeor [K ] + + real( kind = core_rknd ), intent(in) :: & + wpthlp_sfc, & ! w' theta_l' at surface [(m K)/s] + wprtp_sfc, & ! w' r_t' at surface [(kg m)/( kg s)] + upwp_sfc, & ! u'w' at surface [m^2/s^2] + vpwp_sfc ! v'w' at surface [m^2/s^2] + + ! Passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm_forcing ! Passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Scalar flux at surface [{units vary} m/s] + + ! Eddy passive scalar variables + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm_forcing ! Eddy passive scalar forcing [{units vary}/s] + + real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & + wpedsclrp_sfc ! Eddy-Scalar flux at surface [{units vary} m/s] + + ! Host model horizontal grid spacing, if part of host model. + real( kind = core_rknd ), intent(in) :: & + host_dx, & ! East-West horizontal grid spacing [m] + host_dy ! North-South horizontal grid spacing [m] + + + !!! Input/Output Variables + ! These are prognostic or are planned to be in the future + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + um, & ! u mean wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] + wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] + thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] + wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + rtp3, & ! r_t'^3 (thermodynamic levels) [(kg/kg)^3] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + thlp3, & ! th_l'^3 (thermodynamic levels) [K^3] + rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + ! Passive scalar variables + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! Passive scalar mean (thermo. levels) [units vary] + wpsclrp, & ! w'sclr' (momentum levels) [{units vary} m/s] + sclrp2, & ! sclr'^2 (momentum levels) [{units vary}^2] + sclrprtp, & ! sclr'rt' (momentum levels) [{units vary} (kg/kg)] + sclrpthlp ! sclr'thl' (momentum levels) [{units vary} K] + +#ifdef GFDL + real( kind = core_rknd ), intent(inout), dimension(gr%nz,sclr_dim) :: & ! h1g, 2010-06-16 + sclrm_trsport_only ! Passive scalar concentration due to pure transport [{units vary}/s] +#endif + + real( kind = core_rknd ), intent(inout), dimension(gr%nz,edsclr_dim) :: & + edsclrm ! Eddy passive scalar mean (thermo. levels) [units vary] + + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + rcm, & ! cloud water mixing ratio, r_c (thermo. levels) [kg/kg] + rcm_in_layer, & ! rcm in cloud layer [kg/kg] + cloud_cover ! cloud cover [-] + + type(pdf_parameter), dimension(gr%nz), intent(out) :: & + pdf_params ! PDF parameters [units vary] + + ! Variables that need to be output for use in host models + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + wprcp, & ! w'r_c' (momentum levels) [(kg/kg) m/s] + cloud_frac, & ! cloud fraction (thermodynamic levels) [-] + ice_supersat_frac ! ice cloud fraction (thermodynamic levels) [-] + +#if defined(CLUBB_CAM) || defined(GFDL) + real( kind = core_rknd ), intent(out), dimension(gr%nz) :: & + khzt, & ! eddy diffusivity on thermo levels + khzm ! eddy diffusivity on momentum levels +#endif + +#ifdef CLUBB_CAM + real( kind = core_rknd), intent(out), dimension(gr%nz) :: & + qclvar, & ! cloud water variance + thlprcp_out +#endif + + !!! Output Variable + integer, intent(inout) :: err_code ! Diagnostic, for if some calculation goes amiss. + +#ifdef GFDL + ! hlg, 2010-06-16 + real( kind = core_rknd ), intent(inOUT), dimension(gr%nz, min(1,sclr_dim) , 2) :: & + RH_crit ! critical relative humidity for droplet and ice nucleation + logical, intent(in) :: do_liquid_only_in_clubb +#endif + call advance_clubb_core( & + l_implemented, dt, fcor, sfc_elevation, hydromet_dim, & ! intent(in) + thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & ! intent(in) + sclrm_forcing, edsclrm_forcing, wprtp_forcing, & ! intent(in) + wpthlp_forcing, rtp2_forcing, thlp2_forcing, & ! intent(in) + rtpthlp_forcing, wm_zm, wm_zt, & ! intent(in) + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & ! intent(in) + wpsclrp_sfc, wpedsclrp_sfc, & ! intent(in) + p_in_Pa, rho_zm, rho, exner, & ! intent(in) + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & ! intent(in) + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & ! intent(in) + rfrzm, radf, & ! intent(in) +#ifdef CLUBBND_CAM + varmu, & +#endif + wphydrometp, wp2hmp, rtphmp, thlphmp, & ! intent(in) + host_dx, host_dy, & ! intent(in) + um, vm, upwp, vpwp, up2, vp2, & ! intent(inout) + thlm, rtm, wprtp, wpthlp, & ! intent(inout) + wp2, wp3, rtp2, rtp3, thlp2, thlp3, rtpthlp, & ! intent(inout) + sclrm, & +#ifdef GFDL + sclrm_trsport_only, & ! h1g, 2010-06-16 ! intent(inout) +#endif + sclrp2, sclrprtp, sclrpthlp, & ! intent(inout) + wpsclrp, edsclrm, err_code, & ! intent(inout) +#ifdef GFDL + RH_crit, & !h1g, 2010-06-16 ! intent(inout) + do_liquid_only_in_clubb, & ! intent(in) +#endif + rcm, wprcp, cloud_frac, ice_supersat_frac, & ! intent(out) + rcm_in_layer, cloud_cover, & ! intent(out) +#if defined(CLUBB_CAM) || defined(GFDL) + khzm, khzt, & ! intent(out) +#endif +#ifdef CLUBB_CAM + qclvar, thlprcp_out, & ! intent(out) +#endif + pdf_params ) ! intent(out) + end subroutine advance_clubb_core_api + + !================================================================================================ + ! setup_clubb_core - Sets up the model for execution. + !================================================================================================ + + subroutine setup_clubb_core_api( & + nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + + use advance_clubb_core_module, only : setup_clubb_core + + use parameter_indices, only: & + nparams ! Variable(s) + +! TODO: This should be called from the api, but all the host models appear to call +! it directly or not at all. +! use model_flags, only: & +! setup_model_flags ! Subroutine + +#ifdef MKL + use csr_matrix_class, only: & + initialize_csr_class, & ! Subroutine + intlc_5d_5d_ja_size ! Variable + +#endif + + implicit none + + ! Input Variables + + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + logical, intent(in) :: l_implemented ! (T/F) CLUBB implemented in host model? + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an + ! evenly-spaced grid (grid_type = 1), it needs the vertical + ! grid spacing, momentum-level starting altitude, and maximum + ! altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Change in altitude per level [m] + zm_init, & ! Initial grid altitude (momentum level) [m] + zm_top ! Maximum grid altitude (momentum level) [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Model parameters + real( kind = core_rknd ), intent(in) :: & + T0_in, ts_nudge_in + + integer, intent(in) :: & + hydromet_dim_in, & ! Number of hydrometeor species + sclr_dim_in, & ! Number of passive scalars + edsclr_dim_in ! Number of eddy-diff. passive scalars + + real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & + sclr_tol_in ! Thresholds for passive scalars + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Including C1, nu1, nu2, etc. + + ! Flags + logical, intent(in) :: & + l_uv_nudge, & ! Wind nudging + l_host_applies_sfc_fluxes ! Whether to apply for the surface flux + + character(len=*), intent(in) :: & + saturation_formula ! Approximation for saturation vapor pressure + +#ifdef GFDL + logical, intent(in) :: & ! h1g, 2010-06-16 begin mod + I_sat_sphum + + real( kind = core_rknd ), intent(in) :: & + cloud_frac_min ! h1g, 2010-06-16 end mod +#endif + + ! Output variables + integer, intent(out) :: & + err_code ! Diagnostic for a problem with the setup + + call setup_clubb_core & + ( nzmax, T0_in, ts_nudge_in, & ! intent(in) + hydromet_dim_in, sclr_dim_in, & ! intent(in) + sclr_tol_in, edsclr_dim_in, params, & ! intent(in) + l_host_applies_sfc_fluxes, & ! intent(in) + l_uv_nudge, saturation_formula, & ! intent(in) +#ifdef GFDL + I_sat_sphum, & ! intent(in) h1g, 2010-06-16 +#endif + l_implemented, grid_type, deltaz, zm_init, zm_top, & ! intent(in) + momentum_heights, thermodynamic_heights, & ! intent(in) + sfc_elevation, & ! intent(in) +#ifdef GFDL + cloud_frac_min , & ! intent(in) h1g, 2010-06-16 +#endif + err_code ) ! intent(out) + + end subroutine setup_clubb_core_api + + !================================================================================================ + ! cleanup_clubb_core_api - Frees memory used by the model. + !================================================================================================ + + subroutine cleanup_clubb_core_api( & + l_implemented ) + + use advance_clubb_core_module, only : cleanup_clubb_core + + implicit none + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented ! (T/F) + + call cleanup_clubb_core( & + l_implemented ) + end subroutine cleanup_clubb_core_api + + !================================================================================================ + ! gregorian2julian_day - Computes the number of days since 1 January 4713 BC. + !================================================================================================ + + integer function gregorian2julian_day_api( & + day, month, year ) + + use calendar, only : gregorian2julian_day + + implicit none + + ! Input Variables + integer, intent(in) :: & + day, & ! Gregorian Calendar Day for given Month [dd] + month, & ! Gregorian Calendar Month for given Year [mm] + year ! Gregorian Calendar Year [yyyy] + + gregorian2julian_day_api = gregorian2julian_day( & + day, month, year ) + end function gregorian2julian_day_api + + !================================================================================================ + ! compute_current_date - Computes the current date and the seconds since that date. + !================================================================================================ + + subroutine compute_current_date_api( & + previous_day, previous_month, & + previous_year, & + seconds_since_previous_date, & + current_day, current_month, & + current_year, & + seconds_since_current_date ) + + use calendar, only : compute_current_date + + implicit none + + ! Previous date + integer, intent(in) :: & + previous_day, & ! Day of the month [dd] + previous_month, & ! Month of the year [mm] + previous_year ! Year [yyyy] + + real(kind=time_precision), intent(in) :: & + seconds_since_previous_date ! [s] + + ! Output Variable(s) + + ! Current date + integer, intent(out) :: & + current_day, & ! Day of the month [dd] + current_month, & ! Month of the year [mm] + current_year ! Year [yyyy] + + real(kind=time_precision), intent(out) :: & + seconds_since_current_date + + call compute_current_date( & + previous_day, previous_month, & + previous_year, & + seconds_since_previous_date, & + current_day, current_month, & + current_year, & + seconds_since_current_date ) + end subroutine compute_current_date_api + + !================================================================================================ + ! leap_year - Determines if the given year is a leap year. + !================================================================================================ + + logical function leap_year_api( & + year ) + + use calendar, only : leap_year + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: year ! Gregorian Calendar Year [yyyy] + + leap_year_api = leap_year( & + year ) + end function leap_year_api + + !================================================================================================ + ! setup_corr_varnce_array - Creates a correlation array with x'^2/xm^2 variables on the diagonal + !================================================================================================ + + subroutine setup_corr_varnce_array_api( & + input_file_cloud, input_file_below, iunit ) + + use corr_varnce_module, only : setup_corr_varnce_array + + implicit none + + ! External + intrinsic :: max, epsilon, trim + + ! Input Variables + integer, intent(in) :: & + iunit ! The file unit + + character(len=*), intent(in) :: & + input_file_cloud, & ! Path to the in cloud correlation file + input_file_below ! Path to the out of cloud correlation file + + call setup_corr_varnce_array( & + input_file_cloud, input_file_below, iunit ) + + end subroutine setup_corr_varnce_array_api + + !================================================================================================ + ! setup_pdf_indices - Sets up the iiPDF indices. + !================================================================================================ + + subroutine setup_pdf_indices_api( & + hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + + use corr_varnce_module, only : setup_pdf_indices + + implicit none + + ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeor species. + + integer, intent(in) :: & + iirrm, & ! Index of rain water mixing ratio + iiNrm, & ! Index of rain drop concentration + iirim, & ! Index of ice mixing ratio + iiNim, & ! Index of ice crystal concentration + iirsm, & ! Index of snow mixing ratio + iiNsm, & ! Index of snow flake concentration + iirgm, & ! Index of graupel mixing ratio + iiNgm ! Index of graupel concentration + + call setup_pdf_indices( & + hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + end subroutine setup_pdf_indices_api + + !================================================================================================ + ! report_error - Reports the meaning of an error code to the console. + !================================================================================================ + + subroutine report_error_api( & + err_code) + + use error_code, only: & + report_error ! Procedure + + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + call report_error( & + err_code) + end subroutine report_error_api + + !================================================================================================ + ! fatal_error - Checks to see if an error code is usually one which causes an exit elsewhere. + !================================================================================================ + + elemental function fatal_error_api( & + err_code ) + + use error_code, only : fatal_error + + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + ! Output variable + logical :: fatal_error_api + + fatal_error_api = fatal_error( & + err_code ) + end function fatal_error_api + + !================================================================================================ + ! set_clubb_debug_level - Controls the importance of error messages sent to the console. + !================================================================================================ + + subroutine set_clubb_debug_level_api( & + level ) + + use error_code, only : set_clubb_debug_level + + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + call set_clubb_debug_level( & + level ) + end subroutine set_clubb_debug_level_api + + !================================================================================================ + ! clubb_at_least_debug_level - Checks to see if clubb has been set to a specified debug level. + !================================================================================================ + + logical function clubb_at_least_debug_level_api( & + level ) + + use error_code, only : clubb_at_least_debug_level + + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + clubb_at_least_debug_level_api = clubb_at_least_debug_level( & + level ) + end function clubb_at_least_debug_level_api + + !================================================================================================ + ! fill_holes_driver - Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + !================================================================================================ + + subroutine fill_holes_driver_api( & + nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + + use fill_holes, only : fill_holes_driver + + use constants_clubb, only: & + four_thirds, & + rho_ice + + implicit none + + intrinsic :: trim + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + logical, intent(in) :: l_fill_holes_hm + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt ! Dry, static density on thermo. levels [kg/m^3] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz, hydromet_dim), intent(inout) :: & + hydromet + + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rvm_mc, & ! Microphysics contributions to vapor water [kg/kg/s] + thlm_mc ! Microphysics contributions to liquid potential temp. [K/s] + + call fill_holes_driver( & + nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + end subroutine fill_holes_driver_api + + !================================================================================================ + ! fill_holes_vertical - clips values of 'field' that are below 'threshold' as much as possible. + !================================================================================================ + + subroutine fill_holes_vertical_api( & + num_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) + + use fill_holes, only : fill_holes_vertical + + implicit none + + ! Input variables + integer, intent(in) :: & + num_pts ! The number of points on either side of the hole; + ! Mass is drawn from these points to fill the hole. [] + + real( kind = core_rknd ), intent(in) :: & + threshold ! A threshold (e.g. w_tol*w_tol) below which field must not + ! fall [Units vary; same as field] + + character(len=2), intent(in) :: & + field_grid ! The grid of the field, either stats_zt or stats_zm + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds, & ! Dry, static density on thermodynamic levels [kg/m^3] + rho_ds_zm ! Dry, static density on momentum levels [kg/m^3] + + ! Input/Output variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + field ! The field (e.g. wp2) that contains holes [Units same as threshold] + + call fill_holes_vertical( & + num_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) + end subroutine fill_holes_vertical_api + + !================================================================================================ + ! vertical_integral - Computes the vertical integral. + !================================================================================================ + + function vertical_integral_api( & + total_idx, rho_ds, & + field, invrs_dz ) + + use fill_holes, only : vertical_integral + + implicit none + + ! Input variables + integer, intent(in) :: & + total_idx ! The total numer of indices within the range of averaging + + real( kind = core_rknd ), dimension(total_idx), intent(in) :: & + rho_ds, & ! Dry, static density [kg/m^3] + field, & ! The field to be vertically averaged [Units vary] + invrs_dz ! Level thickness [1/m] + ! Note: The rho_ds and field points need to be arranged from + ! lowest to highest in altitude, with rho_ds(1) and + ! field(1) actually their respective values at level k = begin_idx. + + real( kind = core_rknd ) :: & + vertical_integral_api ! Integral in the numerator (see description) + + vertical_integral_api = vertical_integral( & + total_idx, rho_ds, & + field, invrs_dz ) + end function vertical_integral_api + + !================================================================================================ + ! setup_grid_heights - Sets the heights and interpolation weights of the column. + !================================================================================================ + + subroutine setup_grid_heights_api( & + l_implemented, grid_type, & + deltaz, zm_init, momentum_heights, & + thermodynamic_heights ) + + use grid_class, only : setup_grid_heights + + implicit none + + ! Input Variables + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented + + ! If CLUBB is running on it's own, this option determines if it is using: + ! 1) an evenly-spaced grid; + ! 2) a stretched (unevenly-spaced) grid entered on the thermodynamic grid + ! levels (with momentum levels set halfway between thermodynamic levels); + ! or + ! 3) a stretched (unevenly-spaced) grid entered on the momentum grid levels + ! (with thermodynamic levels set halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an evenly-spaced + ! grid (grid_type = 1), it needs the vertical grid spacing and + ! momentum-level starting altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Vertical grid spacing [m] + zm_init ! Initial grid altitude (momentum level) [m] + + + ! If the CLUBB parameterization is implemented in a host model, it needs to + ! use the host model's momentum level altitudes and thermodynamic level + ! altitudes. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on thermodynamic levels (grid_type = 2), it needs to use the + ! thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on momentum levels (grid_type = 3), it needs to use the momentum + ! level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + call setup_grid_heights( & + l_implemented, grid_type, & + deltaz, zm_init, momentum_heights, & + thermodynamic_heights ) + + end subroutine setup_grid_heights_api + + + !================================================================================================ + ! lin_interpolate_two_points - Computes a linear interpolation of the value of a variable. + !================================================================================================ + + function lin_interpolate_two_points_api( & + height_int, height_high, height_low, & + var_high, var_low ) + + use interpolation, only : lin_interpolate_two_points + + implicit none + + real( kind = core_rknd ), intent(in) :: & + height_int, & ! Height to be interpolated to [m] + height_high, & ! Height above the interpolation [m] + height_low, & ! Height below the interpolation [m] + var_high, & ! Variable above the interpolation [units vary] + var_low ! Variable below the interpolation [units vary] + + ! Output Variables + real( kind = core_rknd ) :: lin_interpolate_two_points_api + + lin_interpolate_two_points_api = lin_interpolate_two_points( & + height_int, height_high, height_low, & + var_high, var_low ) + + end function lin_interpolate_two_points_api + + !================================================================================================ + ! lin_interpolate_on_grid - Linear interpolation for 25 June 1996 altocumulus case. + !================================================================================================ + + subroutine lin_interpolate_on_grid_api( & + nparam, xlist, tlist, xvalue, tvalue ) + + use interpolation, only : lin_interpolate_on_grid + + implicit none + + ! Input Variables + integer, intent(in) :: nparam ! Number of parameters in xlist and tlist + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(nparam) :: & + xlist, & ! List of x-values (independent variable) + tlist ! List of t-values (dependent variable) + + real( kind = core_rknd ), intent(in) :: & + xvalue ! x-value at which to interpolate + + real( kind = core_rknd ), intent(inout) :: & + tvalue ! t-value solved by interpolation + + call lin_interpolate_on_grid( & + nparam, xlist, tlist, xvalue, tvalue ) + + end subroutine lin_interpolate_on_grid_api + + !================================================================================================ + ! read_parameters - Read a namelist containing the model parameters. + !================================================================================================ + + subroutine read_parameters_api( & + iunit, filename, params ) + + use parameters_tunable, only : read_parameters + + use parameter_indices, only: & + nparams ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: iunit + + character(len=*), intent(in) :: filename + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(nparams) :: params + + call read_parameters( & + iunit, filename, params ) + + end subroutine read_parameters_api + + !================================================================================================ + ! setup_parameters - Sets up model parameters. + !================================================================================================ + + subroutine setup_parameters_api( & + deltaz, params, nzmax, & + grid_type, momentum_heights, thermodynamic_heights, & + err_code ) + + use parameters_tunable, only: & + setup_parameters + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_var_out_of_bounds ! Variable(s) + + use parameter_indices, only: & + nparams ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Tuneable model parameters [-] + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on its own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Output Variables + integer, intent(out) :: & + err_code ! Error condition + + call setup_parameters( & + deltaz, params, nzmax, & + grid_type, momentum_heights, thermodynamic_heights, & + err_code ) + + end subroutine setup_parameters_api + + !================================================================================================ + ! adj_low_res_nu - Adjusts values of background eddy diffusivity based on vertical grid spacing. + !================================================================================================ + + subroutine adj_low_res_nu_api( & + nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + + use parameters_tunable, only : adj_low_res_nu + + implicit none + + ! Input Variables + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + call adj_low_res_nu( & + nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + end subroutine adj_low_res_nu_api + +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + !================================================================================================ + ! pack_pdf_params - Returns a two dimensional real array with all values. + !================================================================================================ + + subroutine pack_pdf_params_api( & + pdf_params, nz, r_param_array) + + use pdf_parameter_module, only : pack_pdf_params + + !use statements + + implicit none + + ! Input a pdf_parameter array with nz instances of pdf_parameter + integer, intent(in) :: nz ! Num Vert Model Levs + type (pdf_parameter), dimension(nz), intent(in) :: pdf_params + + ! Output a two dimensional real array with all values + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(out) :: & + r_param_array + + call pack_pdf_params( & + pdf_params, nz, r_param_array) + + end subroutine pack_pdf_params_api + + !================================================================================================ + ! unpack_pdf_params - Returns a pdf_parameter array with nz instances of pdf_parameter. + !================================================================================================ + + subroutine unpack_pdf_params_api( & + r_param_array, nz, pdf_params) + + use pdf_parameter_module, only : unpack_pdf_params + + implicit none + + ! Input a two dimensional real array with pdf values + integer, intent(in) :: nz ! Num Vert Model Levs + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(in) :: & + r_param_array + + ! Output a pdf_parameter array with nz instances of pdf_parameter + type (pdf_parameter), dimension(nz), intent(out) :: pdf_params + + call unpack_pdf_params( & + r_param_array, nz, pdf_params) + end subroutine unpack_pdf_params_api +#endif + + !================================================================================================ + ! setup_pdf_parameters + !================================================================================================ + + subroutine setup_pdf_parameters_api( & + nz, d_variables, dt, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_n_cloud, corr_array_n_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + use setup_clubb_pdf_params, only : setup_pdf_parameters + + use constants_clubb, only: & + one, & ! Constant(s) + Ncn_tol, & + cloud_frac_min + + use advance_windm_edsclrm_module, only: & + xpwp_fnc + + use parameters_tunable, only: & + c_K_hm + + use clip_explicit, only: & + clip_wphydrometp ! Variables(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + Nc_in_cloud, & ! Mean (in-cloud) cloud droplet conc. [num/kg] + rcm, & ! Mean cloud water mixing ratio, < r_c > [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac ! Ice supersaturation fraction [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) (t-levs.) [units] + wphydrometp ! Covariance < w'h_m' > (momentum levels) [(m/s)units] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_n_cloud, & ! Prescribed norm. space corr. array in cloud [-] + corr_array_n_below ! Prescribed norm. space corr. array below cloud [-] + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + logical, intent(in) :: & + l_stats_samp ! Flag to sample statistics + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(inout) :: & + hydrometp2 ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, nz), intent(out) :: & + mu_x_1_n, & ! Mean array (normal space): PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normal space): PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normal space): PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normal space): PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_cholesky_mtx_1, & ! Transposed corr. cholesky matrix, 1st comp. [-] + corr_cholesky_mtx_2 ! Transposed corr. cholesky matrix, 2nd comp. [-] + + type(hydromet_pdf_parameter), dimension(nz), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + call setup_pdf_parameters( & + nz, d_variables, dt, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_n_cloud, corr_array_n_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + end subroutine setup_pdf_parameters_api + + !================================================================================================ + ! stats_init - Initializes the statistics saving functionality of the CLUBB model. + !================================================================================================ + + subroutine stats_init_api( & + iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + + use stats_clubb_utilities, only : stats_init + + implicit none + + ! Input Variables + integer, intent(in) :: iunit ! File unit for fnamelist + + character(len=*), intent(in) :: & + fname_prefix, & ! Start of the stats filenames + fdir ! Directory to output to + + logical, intent(in) :: & + l_stats_in ! Stats on? T/F + + character(len=*), intent(in) :: & + stats_fmt_in ! Format of the stats file output + + real( kind = core_rknd ), intent(in) :: & + stats_tsamp_in, & ! Sampling interval [s] + stats_tout_in ! Output interval [s] + + character(len=*), intent(in) :: & + fnamelist ! Filename holding the &statsnl + + integer, intent(in) :: & + nlon, & ! Number of points in the X direction [-] + nlat, & ! Number of points in the Y direction [-] + nzmax ! Grid points in the vertical [-] + + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + gzt, gzm ! Thermodynamic and momentum levels [m] + + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zt) :: grad_zt ! Radiation levels [m] + + integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zm) :: grad_zm ! Radiation levels [m] + + integer, intent(in) :: day, month, year ! Time of year + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude(s) [Degrees E] + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude(s) [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time_current ! Model time [s] + + real( kind = core_rknd ), intent(in) :: & + delt ! Timestep (dt_main in CLUBB) [s] + + logical, intent(in) :: & + l_silhs_out_in ! Whether to output SILHS files (stats_lh_zt,stats_lh_sfc) [dimensionless] + + call stats_init( & + iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + end subroutine stats_init_api + + !================================================================================================ + ! stats_begin_timestep - Sets flags determining specific timestep info. + !================================================================================================ + + subroutine stats_begin_timestep_api( & + itime, stats_nsamp, stats_nout ) + + + use stats_clubb_utilities, only : stats_begin_timestep + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: & + itime, & ! Elapsed model time [timestep] + stats_nsamp, & ! Stats sampling interval [timestep] + stats_nout ! Stats output interval [timestep] + + call stats_begin_timestep( & + itime, stats_nsamp, stats_nout ) + end subroutine stats_begin_timestep_api + + !================================================================================================ + ! stats_end_timestep - Calls statistics to be written to the output format. + !================================================================================================ + + subroutine stats_end_timestep_api + + use stats_clubb_utilities, only : stats_end_timestep + + implicit none + + call stats_end_timestep + + end subroutine stats_end_timestep_api + + !================================================================================================ + ! stats_accumulate_hydromet - Computes stats related the hydrometeors. + !================================================================================================ + + subroutine stats_accumulate_hydromet_api( & + hydromet, rho_ds_zt ) + + use stats_clubb_utilities, only : stats_accumulate_hydromet + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! All hydrometeors except for rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds_zt ! Dry, static density (thermo. levs.) [kg/m^3] + + call stats_accumulate_hydromet( & + hydromet, rho_ds_zt ) + end subroutine stats_accumulate_hydromet_api + + !================================================================================================ + ! stats_finalize - Close NetCDF files and deallocate scratch space and stats file structures. + !================================================================================================ + + subroutine stats_finalize_api + + use stats_clubb_utilities, only : stats_finalize + + implicit none + + call stats_finalize + + end subroutine stats_finalize_api + + !================================================================================================ + ! stats_init_rad_zm - Initializes array indices for rad_zm variables. + !================================================================================================ + + subroutine stats_init_rad_zm_api( & + vars_rad_zm, l_error ) + + use stats_rad_zm_module, only : stats_init_rad_zm, nvarmax_rad_zm + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm + + ! Input/Output Variable + logical, intent(inout) :: l_error + + call stats_init_rad_zm( & + vars_rad_zm, l_error ) + end subroutine stats_init_rad_zm_api + + !================================================================================================ + ! stats_init_rad_zt - Initializes array indices for zt. + !================================================================================================ + + subroutine stats_init_rad_zt_api( & + vars_rad_zt, l_error ) + + use stats_rad_zt_module, only : stats_init_rad_zt, nvarmax_rad_zt + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt + + ! Input/Output Variable + logical, intent(inout) :: l_error + + call stats_init_rad_zt( & + vars_rad_zt, l_error ) + end subroutine stats_init_rad_zt_api + + !================================================================================================ + ! stats_init_zm - Initializes array indices for zm. + !================================================================================================ + + subroutine stats_init_zm_api( & + vars_zm, l_error ) + + use stats_zm_module, only : stats_init_zm, nvarmax_zm + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm ! zm variable names + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_zm( & + vars_zm, l_error ) + + end subroutine stats_init_zm_api + + !================================================================================================ + ! stats_init_zt - Initializes array indices for zt. + !================================================================================================ + + subroutine stats_init_zt_api( & + vars_zt, l_error ) + + use stats_zt_module, only : stats_init_zt, nvarmax_zt + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_zt( & + vars_zt, l_error ) + + end subroutine stats_init_zt_api + + !================================================================================================ + ! stats_init_sfc - Initializes array indices for sfc. + !================================================================================================ + + subroutine stats_init_sfc_api( & + vars_sfc, l_error ) + + use stats_sfc_module, only : stats_init_sfc, nvarmax_sfc + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + call stats_init_sfc( & + vars_sfc, l_error ) + + end subroutine stats_init_sfc_api + + !================================================================================================ + ! thlm2T_in_K - Calculates absolute temperature from liquid water potential temperature. + !================================================================================================ + + elemental function thlm2T_in_K_api( & + thlm, exner, rcm ) & + result( T_in_K ) + + use T_in_K_module, only : thlm2T_in_K + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + thlm, & ! Liquid potential temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + T_in_K ! Result temperature [K] + + T_in_K = thlm2T_in_K( & + thlm, exner, rcm ) + + end function thlm2T_in_K_api + + !================================================================================================ + ! T_in_K2thlm - Calculates liquid water potential temperature from absolute temperature + !================================================================================================ + + elemental function T_in_K2thlm_api( & + T_in_K, exner, rcm ) & + result( thlm ) + + use T_in_K_module, only : T_in_K2thlm + + implicit none + + ! Input + real( kind = core_rknd ), intent(in) :: & + T_in_K, &! Result temperature [K] + exner, & ! Exner function [-] + rcm ! Liquid water mixing ratio [kg/kg] + + real( kind = core_rknd ) :: & + thlm ! Liquid potential temperature [K] + + thlm = T_in_K2thlm( & + T_in_K, exner, rcm ) + + end function T_in_K2thlm_api + + !================================================================================================ + ! calculate_spurious_source - Checks whether there is conservation within the column. + !================================================================================================ + function calculate_spurious_source_api ( & + integral_after, integral_before, & + flux_top, flux_sfc, & + integral_forcing, dt ) result( spurious_source ) + + use numerical_check, only : calculate_spurious_source + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + integral_after, & ! Vertically-integrated quantity after dt time [units vary] + integral_before, & ! Vertically-integrated quantity before dt time [units vary] + flux_top, & ! Total flux at the top of the domain [units vary] + flux_sfc, & ! Total flux at the bottom of the domain [units vary] + integral_forcing, & ! Vertically-integrated forcing [units vary] + dt ! Timestep size [s] + + ! Return Variable + real( kind = core_rknd ) :: spurious_source ! [units vary] + + spurious_source = calculate_spurious_source( & + integral_after, integral_before, & + flux_top, flux_sfc, & + integral_forcing, dt ) + + end function calculate_spurious_source_api + + !================================================================================================ + ! zm2zt_scalar - Interpolates a variable from zm to zt grid at one height level + !================================================================================================ + function zm2zt_scalar_api( azm, k ) + + use grid_class, only: zm2zt + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + zm2zt_scalar_api ! Variable when interp. to thermo. levels + + zm2zt_scalar_api = zm2zt( azm, k ) + + end function zm2zt_scalar_api + + !================================================================================================ + ! zt2zm_scalar - Interpolates a variable from zt to zm grid at one height level + !================================================================================================ + function zt2zm_scalar_api( azt, k ) + + use grid_class, only: zt2zm + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + zt2zm_scalar_api ! Variable when interp. to momentum levels + + zt2zm_scalar_api = zt2zm( azt, k ) + + end function zt2zm_scalar_api + + !================================================================================================ + ! zt2zm_prof - Interpolates a variable (profile) from zt to zm grid + !================================================================================================ + function zt2zm_prof_api( azt ) + + use grid_class, only: zt2zm + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + zt2zm_prof_api ! Variable when interp. to momentum levels + + zt2zm_prof_api = zt2zm( azt ) + + end function zt2zm_prof_api + + !================================================================================================ + ! zm2zt_prof - Interpolates a variable (profile) from zm to zt grid + !================================================================================================ + function zm2zt_prof_api( azm ) + + use grid_class, only: zm2zt + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + zm2zt_prof_api ! Variable when interp. to thermo. levels + + zm2zt_prof_api = zm2zt( azm ) + + end function zm2zt_prof_api + + !================================================================================================ + ! calculate_thlp2_rad - Computes the contribution of radiative cooling to thlp2 + !================================================================================================ + pure subroutine calculate_thlp2_rad_api & + ( nz, rcm_zm, thlprcp, radht_zm, & ! Intent(in) + thlp2_forcing ) ! Intent(inout) + + use clubb_precision, only: & + core_rknd ! Constant(s) + + use advance_clubb_core_module, only: & + calculate_thlp2_rad + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of vertical levels [-] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rcm_zm, & ! Cloud water mixing ratio on momentum grid [kg/kg] + thlprcp, & ! thl'rc' [K kg/kg] + radht_zm ! SW + LW heating rate (on momentum grid) [K/s] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + thlp2_forcing ! forcing (momentum levels) [K^2/s] + !---------------------------------------------------------------------- + + call calculate_thlp2_rad( nz, rcm_zm, thlprcp, radht_zm, & + thlp2_forcing ) + + return + end subroutine calculate_thlp2_rad_api + + !================================================================================================ + ! update_xp2_mc - Calculates the effects of rain evaporation on rtp2 and thlp2 + !================================================================================================ + subroutine update_xp2_mc_api( nz, dt, cloud_frac, rcm, rvm, thlm, & + wm, exner, rrm_evap, pdf_params, & + rtp2_mc, thlp2_mc, wprtp_mc, wpthlp_mc, & + rtpthlp_mc ) + + use advance_xp2_xpyp_module, only: & + update_xp2_mc + + implicit none + + !input parameters + integer, intent(in) :: nz ! Points in the Vertical [-] + + real( kind = core_rknd ), intent(in) :: dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + cloud_frac, & !Cloud fraction [-] + rcm, & !Cloud water mixing ratio [kg/kg] + rvm, & !Vapor water mixing ratio [kg/kg] + thlm, & !Liquid potential temperature [K] + wm, & !Mean vertical velocity [m/s] + exner, & !Exner function [-] + rrm_evap !Evaporation of rain [kg/kg/s] + !It is expected that this variable is negative, as + !that is the convention in Morrison microphysics + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters + + !input/output variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rtp2_mc, & !Tendency of due to evaporation [(kg/kg)^2/s] + thlp2_mc, & !Tendency of due to evaporation [K^2/s] + wprtp_mc, & !Tendency of due to evaporation [m*(kg/kg)/s^2] + wpthlp_mc, & !Tendency of due to evaporation [m*K/s^2] + rtpthlp_mc !Tendency of due to evaporation [K*(kg/kg)/s] + + call update_xp2_mc( nz, dt, cloud_frac, rcm, rvm, thlm, & + wm, exner, rrm_evap, pdf_params, & + rtp2_mc, thlp2_mc, wprtp_mc, wpthlp_mc, & + rtpthlp_mc ) + return + end subroutine update_xp2_mc_api + + !================================================================================================ + ! sat_mixrat_liq - computes the saturation mixing ratio of liquid water + !================================================================================================ + elemental real( kind = core_rknd ) function sat_mixrat_liq_api( p_in_Pa, T_in_K ) + + use saturation, only: sat_mixrat_liq + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + p_in_Pa, & ! Pressure [Pa] + T_in_K ! Temperature [K] + + sat_mixrat_liq_api = sat_mixrat_liq( p_in_Pa, T_in_K ) + return + end function sat_mixrat_liq_api + + +end module clubb_api_module diff --git a/src/physics/clubb/clubb_precision.F90 b/src/physics/clubb/clubb_precision.F90 new file mode 100644 index 0000000000..1d2554beb2 --- /dev/null +++ b/src/physics/clubb/clubb_precision.F90 @@ -0,0 +1,30 @@ +!------------------------------------------------------------------------------- +! $Id: clubb_precision.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module clubb_precision + + implicit none + + public :: stat_nknd, stat_rknd, time_precision, dp, core_rknd + + private ! Default scope + + ! This definition of double precision must use a real type that is 64 bits + ! wide, because (at least) the LAPACK routines depend on this definition being + ! accurate. Otherwise, LAPACK must be recompiled, or some other trickery must + ! be done. + integer, parameter :: & + dp = selected_real_kind( p=12 ) ! double precision + + ! The precisions below are arbitrary, and could be adjusted as + ! needed for long simulations or time averaging. Note that on + ! most machines 12 digits of precision will use a data type + ! which is 8 bytes long. + integer, parameter :: & + stat_nknd = selected_int_kind( 8 ), & + stat_rknd = selected_real_kind( p=12 ), & + time_precision = selected_real_kind( p=12 ), & + core_rknd = CLUBB_REAL_TYPE ! Value from the preprocessor directive + +end module clubb_precision +!------------------------------------------------------------------------------- diff --git a/src/physics/clubb/code_timer_module.F90 b/src/physics/clubb/code_timer_module.F90 new file mode 100644 index 0000000000..d76bc20159 --- /dev/null +++ b/src/physics/clubb/code_timer_module.F90 @@ -0,0 +1,73 @@ +! $Id: code_timer_module.F90 77826 2016-04-07 23:05:53Z cacraig@ucar.edu $ +module code_timer_module + +! Description: +! This module contains a diagnostic timer utility that can be used +! to time a piece of code. + + implicit none + + private ! Set default scope + + ! A timer!! + type timer_t + real :: time_elapsed ! Time elapsed [sec] + real :: secstart ! Timer starting time + end type timer_t + + public :: timer_t, timer_start, timer_stop + + contains + + !----------------------------------------------------------------------- + subroutine timer_start( timer ) + + ! Description: + ! Starts the timer + + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + ! Input/Output Variables + type(timer_t), intent(inout) :: timer + + !----------------------------------------------------------------------- + !----- Begin Code ----- + call cpu_time( timer%secstart ) + return + end subroutine timer_start + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine timer_stop( timer ) + + ! Description: + ! Stops the timer + + ! References: + ! None + !----------------------------------------------------------------------- + implicit none + + ! Input/Output Variables + type(timer_t), intent(inout) :: timer + + ! Local Variables + real :: secend + + !----------------------------------------------------------------------- + !----- Begin Code ----- + call cpu_time( secend ) + + + timer%time_elapsed = timer%time_elapsed + (secend - timer%secstart) + timer%secstart = 0.0 + + return + end subroutine timer_stop + !----------------------------------------------------------------------- + +end module code_timer_module diff --git a/src/physics/clubb/constants_clubb.F90 b/src/physics/clubb/constants_clubb.F90 new file mode 100644 index 0000000000..a1c415055f --- /dev/null +++ b/src/physics/clubb/constants_clubb.F90 @@ -0,0 +1,427 @@ +!----------------------------------------------------------------------------- +! $Id: constants_clubb.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!============================================================================= +module constants_clubb + + ! Description: + ! Contains frequently occuring model constants + + ! References: + ! None + !--------------------------------------------------------------------------- + + use clubb_precision, only: & + dp, & ! Variable(s) + core_rknd + +#ifdef CLUBB_CAM /* Set constants as they're set in CAM */ + use shr_const_mod, only: shr_const_rdair, shr_const_cpdair, shr_const_latvap, & + shr_const_latice, shr_const_latsub, shr_const_rgas, & + shr_const_mwwv, shr_const_stebol, shr_const_tkfrz, & + shr_const_mwdair, shr_const_g, shr_const_karman, & + shr_const_rhofw +#elif GFDL + ! use GFDL constants, and then rename them to avoid confusion in case + ! that the constants share the same names between GFDL and CLUBB + use constants_mod, only: pi_gfdl => PI, & + radians_per_deg_dp_gfdl => DEG_TO_RAD, & + Cp_gfdl => CP_AIR, & + Lv_gfdl => HLV, & + Ls_gfdl => HLS, & + Lf_gfdl => HLF, & + Rd_gfdl => RDGAS, & + Rv_gfdl => RVGAS, & + stefan_boltzmann_gfdl => STEFAN, & + T_freeze_K_gfdl => TFREEZE, & + grav_gfdl => GRAV, & + vonk_gfdl => VONKARM, & + rho_lw_gfdl => DENS_H2O +#endif + + implicit none + + private ! Default scope + + !----------------------------------------------------------------------------- + ! Numerical/Arbitrary Constants + !----------------------------------------------------------------------------- + + ! Fortran file unit I/O constants + integer, parameter, public :: & + fstderr = 0, fstdin = 5, fstdout = 6 + + ! Maximum variable name length in CLUBB GrADS or netCDF output + integer, parameter, public :: & + var_length = 30 + ! The parameter parab_cyl_max_input is the largest magnitude that the input to + ! the parabolic cylinder function is allowed to have. When the value of the + ! input to the parabolic cylinder function is too large in magnitude + ! (depending on the order of the parabolic cylinder function), overflow + ! occurs, and the output of the parabolic cylinder function is +/-Inf. The + ! parameter parab_cyl_max_input places a limit on the absolute value of the + ! input to the parabolic cylinder function. When the value of the potential + ! input exceeds this parameter (usually due to a very large ratio of ith PDF + ! component mean of x to ith PDF component standard deviation of x), the + ! variable x is considered to be constant and a different version of the + ! equation called. + ! + ! The largest allowable magnitude of the input to the parabolic cylinder + ! function (before overflow occurs) is dependent on the order of parabolic + ! cylinder function. However, after a lot of testing, it was determined that + ! an absolute value of 49 works well for an order of 12 or less. + real( kind = core_rknd ), parameter, public :: & + parab_cyl_max_input = 49.0_core_rknd ! Largest allowable input to parab. cyl. fnct. + + ! "Over-implicit" weighted time step. + ! + ! The weight of the implicit portion of a term is controlled by the factor + ! gamma_over_implicit_ts (abbreviated "gamma" in the expression below). A + ! factor is added to the right-hand side of the equation in order to balance a + ! weight that is not equal to 1, such that: + ! + ! -y(t) * [ gamma * X(t+1) + ( 1 - gamma ) * X(t) ] + RHS; + ! + ! where X is the variable that is being solved for in a predictive equation + ! (such as w'^3, w'th_l', r_t'^2, etc), y(t) is the linearized portion of the + ! term that gets treated implicitly, and RHS is the portion of the term that + ! is always treated explicitly. A weight of greater than 1 can be applied to + ! make the term more numerically stable. + ! + ! gamma_over_implicit_ts Effect on term + ! + ! 0.0 Term becomes completely explicit + ! + ! 1.0 Standard implicit portion of the term; + ! as it was without the weighting factor. + ! + ! 1.5 Strongly weighted implicit portion of the term; + ! increased numerical stability. + ! + ! 2.0 More strongly weighted implicit portion of the + ! term; increased numerical stability. + ! + ! Note: The "over-implicit" weighted time step is only applied to terms that + ! tend to significantly decrease the amount of numerical stability for + ! variable X. + ! The "over-implicit" weighted time step is applied to the turbulent + ! advection term for the following variables: + ! w'^3 (also applied to the turbulent production term), found in + ! module advance_wp2_wp3_module; + ! w'r_t', w'th_l', and w'sclr', found in + ! module advance_xm_wpxp_module; and + ! r_t'^2, th_l'^2, r_t'th_l', u'^2, v'^2, sclr'^2, sclr'r_t', + ! and sclr'th_l', found in module advance_xp2_xpyp_module. + real( kind = core_rknd ), parameter, public :: & + gamma_over_implicit_ts = 1.50_core_rknd + + !----------------------------------------------------------------------------- + ! Mathematical Constants + !----------------------------------------------------------------------------- + real( kind = dp ), parameter, public :: & + pi_dp = 3.14159265358979323846_dp + +#ifdef GFDL + real( kind = core_rknd ), parameter, public :: & + pi = pi_gfdl ! The ratio of radii to their circumference + + real( kind = dp ), parameter, public :: & + radians_per_deg_dp = radians_per_deg_dp_gfdl +#else + + real( kind = core_rknd ), parameter, public :: & + pi = 3.141592654_core_rknd ! The ratio of radii to their circumference + + real( kind = dp ), parameter, public :: & + radians_per_deg_dp = pi_dp / 180._dp +#endif + + real( kind = dp ), parameter, public :: & + sqrt_2pi_dp = 2.5066282746310005024_dp, & ! sqrt(2*pi) + sqrt_2_dp = 1.4142135623730950488_dp ! sqrt(2) + + real( kind = core_rknd ), parameter, public :: & + sqrt_2pi = 2.5066282746310005024_core_rknd, & ! sqrt(2*pi) + sqrt_2 = 1.4142135623730950488_core_rknd ! sqrt(2) + + real( kind = dp ), parameter, public:: & + two_dp = 2.0_dp, & ! 2 + one_dp = 1.0_dp, & ! 1 + one_half_dp = 0.5_dp, & ! 1/2 + one_fourth_dp = 0.25_dp, & ! 1/4 + zero_dp = 0.0_dp ! 0 + + real( kind = core_rknd ), parameter, public :: & + one_hundred = 100.0_core_rknd, & ! 100 + fifty = 50.0_core_rknd, & ! 50 + twenty = 20.0_core_rknd, & ! 20 + ten = 10.0_core_rknd, & ! 10 + five = 5.0_core_rknd, & ! 5 + four = 4.0_core_rknd, & ! 4 + three = 3.0_core_rknd, & ! 3 + two = 2.0_core_rknd, & ! 2 + three_halves = 3.0_core_rknd/2.0_core_rknd, & ! 3/2 + four_thirds = 4.0_core_rknd/3.0_core_rknd, & ! 4/3 + one = 1.0_core_rknd, & ! 1 + three_fourths = 0.75_core_rknd, & ! 3/4 + two_thirds = 2.0_core_rknd/3.0_core_rknd, & ! 2/3 + one_half = 0.5_core_rknd, & ! 1/2 + one_third = 1.0_core_rknd/3.0_core_rknd, & ! 1/3 + one_fourth = 0.25_core_rknd, & ! 1/4 + zero = 0.0_core_rknd ! 0 + + !----------------------------------------------------------------------------- + ! Physical constants + !----------------------------------------------------------------------------- + +#ifdef CLUBB_CAM + + real( kind = core_rknd ), parameter, public :: & + Cp = shr_const_cpdair, & ! Dry air specific heat at constant p [J/kg/K] + Lv = shr_const_latvap, & ! Latent heat of vaporization [J/kg] + Lf = shr_const_latice, & ! Latent heat of fusion [J/kg] + Ls = shr_const_latsub, & ! Latent heat of sublimation [J/kg] + Rd = shr_const_rdair, & ! Dry air gas constant [J/kg/K] + Rv = shr_const_rgas/shr_const_mwwv ! Water vapor gas constant [J/kg/K] + + real( kind = core_rknd ), parameter, public :: & + stefan_boltzmann = shr_const_stebol ! Stefan-Boltzmann constant [W/(m^2 K^4)] + + real( kind = core_rknd ), parameter, public :: & + T_freeze_K = shr_const_tkfrz ! Freezing point of water [K] + + ! Useful combinations of Rd and Rv + real( kind = core_rknd ), parameter, public :: & + ep = shr_const_mwwv/shr_const_mwdair, & ! ep = 0.622 [-] + ep1 = (1.0-ep)/ep,& ! ep1 = 0.61 [-] + ep2 = 1.0/ep ! ep2 = 1.61 [-] + + real( kind = core_rknd ), parameter, public :: & + kappa = (shr_const_rgas/shr_const_mwdair)/shr_const_cpdair ! kappa [-] + + real( kind = core_rknd ), parameter, public :: & + grav = shr_const_g, & ! Gravitational acceleration [m/s^2] + p0 = 1.0e5 ! Reference pressure [Pa] + + ! Von Karman's constant + ! Constant of the logarithmic wind profile in the surface layer + real( kind = core_rknd ), parameter, public :: & + vonk = shr_const_karman, & ! Accepted value is 0.40 (+/-) 0.01 [-] + rho_lw = shr_const_rhofw ! Density of liquid water [kg/m^3] + + +#elif GFDL + real( kind = core_rknd ), parameter, public :: & + Cp = Cp_gfdl, & ! Dry air specific heat at constant p [J/kg/K] + Lv = Lv_gfdl, & ! Latent heat of vaporization [J/kg] + Ls = Ls_gfdl, & ! Latent heat of sublimation [J/kg] + Lf = Lf_gfdl, & ! Latent heat of fusion [J/kg] + Rd = Rd_gfdl, & ! Dry air gas constant [J/kg/K] + Rv = Rv_gfdl ! Water vapor gas constant [J/kg/K] + + + real( kind = core_rknd ), parameter, public :: & + stefan_boltzmann = stefan_boltzmann_gfdl ! Stefan-Boltzmann constant [W/(m^2 K^4)] + + real( kind = core_rknd ), parameter, public :: & + T_freeze_K = T_freeze_K_gfdl ! Freezing point of water [K] + + ! Useful combinations of Rd and Rv + real( kind = core_rknd ), parameter, public :: & + ep = Rd / Rv, & ! ep = 0.622 [-] + ep1 = (1.0-ep)/ep,& ! ep1 = 0.61 [-] + ep2 = 1.0/ep ! ep2 = 1.61 [-] + + real( kind = core_rknd ), parameter, public :: & + kappa = Rd / Cp ! kappa [-] + + ! Changed g to grav to make it easier to find in the code 5/25/05 + ! real, parameter :: grav = 9.80665 ! Gravitational acceleration [m/s^2] + real( kind = core_rknd ), parameter, public :: & + grav = grav_gfdl, & ! Gravitational acceleration [m/s^2] + p0 = 1.0e5 ! Reference pressure [Pa] + + ! Von Karman's constant + ! Constant of the logarithmic wind profile in the surface layer + real( kind = core_rknd ), parameter, public :: & + vonk = vonk_gfdl, & ! Accepted value is 0.40 (+/-) 0.01 [-] + rho_lw = rho_lw_gfdl ! Density of liquid water [kg/m^3] + + +#else + + real( kind = core_rknd ), parameter, public :: & + Cp = 1004.67_core_rknd, & ! Dry air specific heat at constant p [J/kg/K] + Lv = 2.5e6_core_rknd, & ! Latent heat of vaporization [J/kg] + Ls = 2.834e6_core_rknd, & ! Latent heat of sublimation [J/kg] + Lf = 3.33e5_core_rknd, & ! Latent heat of fusion [J/kg] + Rd = 287.04_core_rknd, & ! Dry air gas constant [J/kg/K] + Rv = 461.5_core_rknd ! Water vapor gas constant [J/kg/K] + + + real( kind = core_rknd ), parameter, public :: & + stefan_boltzmann = 5.6704e-8_core_rknd ! Stefan-Boltzmann constant [W/(m^2 K^4)] + + real( kind = core_rknd ), parameter, public :: & + T_freeze_K = 273.15_core_rknd ! Freezing point of water [K] + + ! Useful combinations of Rd and Rv + real( kind = core_rknd ), parameter, public :: & + ep = Rd / Rv, & ! ep = 0.622_core_rknd [-] + ep1 = (1.0_core_rknd-ep)/ep,& ! ep1 = 0.61_core_rknd [-] + ep2 = 1.0_core_rknd/ep ! ep2 = 1.61_core_rknd [-] + + real( kind = core_rknd ), parameter, public :: & + kappa = Rd / Cp ! kappa [-] + + ! Changed g to grav to make it easier to find in the code 5/25/05 + ! real, parameter, public :: grav = 9.80665_core_rknd ! Gravitational acceleration [m/s^2] + real( kind = core_rknd ), parameter, public :: & + grav = 9.81_core_rknd, & ! Gravitational acceleration [m/s^2] + p0 = 1.0e5_core_rknd ! Reference pressure [Pa] + + ! Von Karman's constant + ! Constant of the logarithmic wind profile in the surface layer + real( kind = core_rknd ), parameter, public :: & + vonk = 0.4_core_rknd, & ! Accepted value is 0.40 (+/-) 0.01 [-] + rho_lw = 1000.0_core_rknd ! Density of liquid water [kg/m^3] + +#endif + + real( kind = core_rknd ), parameter, public :: & + rho_ice = 917.0_core_rknd ! Density of ice [kg/m^3] + + ! Tolerances below which we consider moments to be zero + real( kind = core_rknd ), parameter, public :: & + w_tol = 2.e-2_core_rknd, & ! [m/s] + thl_tol = 1.e-2_core_rknd, & ! [K] + rt_tol = 1.e-8_core_rknd, & ! [kg/kg] + chi_tol = 1.e-8_core_rknd, & ! [kg/kg] + eta_tol = chi_tol ! [kg/kg] + + ! Tolerances for use by the monatonic flux limiter. + ! rt_tol_mfl is larger than rt_tol. rt_tol is extremely small + ! (1e-8) to prevent spurious cloud formation aloft in LBA. + ! rt_tol_mfl is larger (1e-4) to prevent the mfl from + ! depositing moisture at the top of the domain. + real( kind = core_rknd ), parameter, public :: & + thl_tol_mfl = 1.e-2_core_rknd, & ! [K] + rt_tol_mfl = 1.e-4_core_rknd ! [kg/kg] + + ! The tolerance for w'^2 is the square of the tolerance for w. + real( kind = core_rknd ), parameter, public :: & + w_tol_sqd = w_tol**2 ! [m^2/s^2] + + real( kind = core_rknd ), parameter, public :: & + Skw_max_mag = 4.5_core_rknd ! Max magnitude of skewness [-] + + real( kind = core_rknd ), parameter, public :: & + Skw_max_mag_sqd = Skw_max_mag**2 ! Max mag. of Skw squared [-] + + ! Set tolerances for Khairoutdinov and Kogan rain microphysics to insure + ! against numerical errors. The tolerance values for Nc, rr, and Nr insure + ! against underflow errors in computing the PDF for l_kk_rain. Basically, + ! they insure that those values squared won't be less then 10^-38, which is + ! the lowest number that can be numerically represented. However, the + ! tolerance value for rc doubles as the lowest mixing ratio there can be to + ! still officially have a cloud at that level. This is figured to be about + ! 1.0_core_rknd x 10^-7 kg/kg. Brian; February 10, 2007. + real( kind = core_rknd ), parameter, public :: & + rc_tol = 1.0E-6_core_rknd, & ! Tolerance value for r_c [kg/kg] + Nc_tol = 1.0E+2_core_rknd, & ! Tolerance value for N_c [#/kg] + Ncn_tol = 1.0E+2_core_rknd ! Tolerance value for N_cn [#/kg] + + real( kind = core_rknd ), parameter, public :: & + mvr_cloud_max = 1.6E-5_core_rknd ! Max. avg. mean vol. rad. cloud [m] + + real( kind = core_rknd ), parameter, public :: & + Nc_in_cloud_min = 2.0e+4_core_rknd + + ! Precipitating hydrometeor tolerances for mixing ratios. + real( kind = core_rknd ), parameter, public :: & + rr_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_r [kg/kg] + ri_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_i [kg/kg] + rs_tol = 1.0E-10_core_rknd, & ! Tolerance value for r_s [kg/kg] + rg_tol = 1.0E-10_core_rknd ! Tolerance value for r_g [kg/kg] + + ! Maximum allowable values for the average mean volume radius of the various + ! hydrometeor species. + real( kind = core_rknd ), parameter, public :: & + mvr_rain_max = 5.0E-3_core_rknd, & ! Max. avg. mean vol. rad. rain [m] + mvr_ice_max = 1.3E-4_core_rknd, & ! Max. avg. mean vol. rad. ice [m] + mvr_snow_max = 1.0E-2_core_rknd, & ! Max. avg. mean vol. rad. snow [m] + mvr_graupel_max = 2.0E-2_core_rknd ! Max. avg. mean vol. rad. graupel [m] + + ! Precipitating hydrometeor tolerances for concentrations. + ! Tolerance value for N_r [#/kg] + real( kind = core_rknd ), parameter, public :: & + Nr_tol = ( one / ( four_thirds * pi * rho_lw * mvr_rain_max**3 ) ) & + * rr_tol + + ! Tolerance value for N_i [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ni_tol = ( one / ( four_thirds * pi * rho_ice * mvr_ice_max**3 ) ) & + * ri_tol + + ! Tolerance value for N_s [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ns_tol = ( one / ( four_thirds * pi * rho_ice * mvr_snow_max**3 ) ) & + * rs_tol + + ! Tolerance value for N_s [#/kg] + real( kind = core_rknd ), parameter, public :: & + Ng_tol = ( one / ( four_thirds * pi * rho_ice * mvr_graupel_max**3 ) ) & + * rg_tol + + ! Minimum value for em (turbulence kinetic energy) + ! If anisotropic TKE is enabled, em = (1/2) * ( up2 + vp2 + wp2 ); + ! otherwise, em = (3/2) * wp2. Since up2, vp2, and wp2 all have + ! the same minimum threshold value of w_tol_sqd, em cannot be less + ! than (3/2) * w_tol_sqd. Thus, em_min = (3/2) * w_tol_sqd. + real( kind = core_rknd ), parameter, public :: & + em_min = 1.5_core_rknd * w_tol_sqd ! [m^2/s^2] + + real( kind = core_rknd ), parameter, public :: & + eps = 1.0e-10_core_rknd ! Small value to prevent a divide by zero + + real( kind = core_rknd ), parameter, public :: & + zero_threshold = 0.0_core_rknd ! Defining a threshold on a physical quantity to be 0. + + ! The maximum absolute value (or magnitude) that a correlation is allowed to + ! have. Statistically, a correlation is not allowed to be less than -1 or + ! greater than 1, so the maximum magnitude would be 1. + real( kind = core_rknd ), parameter, public :: & + max_mag_correlation = 0.99_core_rknd + + real( kind = core_rknd ), parameter, public :: & + cloud_frac_min = 0.005_core_rknd ! Threshold for cloud fractions + + !----------------------------------------------------------------------------- + ! Useful conversion factors. + !----------------------------------------------------------------------------- + real(kind=core_rknd), parameter, public :: & + sec_per_day = 86400.0_core_rknd, & ! Seconds in a day. + sec_per_hr = 3600.0_core_rknd, & ! Seconds in an hour. + sec_per_min = 60.0_core_rknd, & ! Seconds in a minute. + min_per_hr = 60.0_core_rknd ! Minutes in an hour. + + real( kind = core_rknd ), parameter, public :: & + g_per_kg = 1000.0_core_rknd ! Grams in a kilogram. + + real( kind = core_rknd ), parameter, public :: & + pascal_per_mb = 100.0_core_rknd ! Pascals per Millibar + + real( kind = core_rknd ), parameter, public :: & + cm3_per_m3 = 1.e6_core_rknd, & ! Cubic centimeters per cubic meter + micron_per_m = 1.e6_core_rknd, & ! Micrometers per meter + cm_per_m = 100._core_rknd, & ! Centimeters per meter + mm_per_m = 1000._core_rknd ! Millimeters per meter + + !----------------------------------------------------------------------------- + ! Unused variable + !----------------------------------------------------------------------------- + real( kind = core_rknd ), parameter, public :: & + unused_var = -999._core_rknd ! The standard value for unused variables + +!============================================================================= + +end module constants_clubb diff --git a/src/physics/clubb/corr_varnce_module.F90 b/src/physics/clubb/corr_varnce_module.F90 new file mode 100644 index 0000000000..6d3e260beb --- /dev/null +++ b/src/physics/clubb/corr_varnce_module.F90 @@ -0,0 +1,799 @@ +!----------------------------------------------------------------------- +!$Id: corr_varnce_module.F90 7130 2014-07-29 23:29:54Z raut@uwm.edu $ +!------------------------------------------------------------------------------- +module corr_varnce_module + + use clubb_precision, only: & + core_rknd + + implicit none + + type hmp2_ip_on_hmm2_ip_ratios_type + + ! In CLUBB standalone, these parameters can be set based on the value for a + ! given case in the CASE_model.in file. + + ! Prescribed parameters for hydrometeor values of / ^2, + ! where is the in-precip. mean of the hydrometeor and + ! is the in-precip. variance of the hydrometeor. + ! They can be set based on values for a given case in the CASE_model.in file. + real( kind = core_rknd ) :: & + rrp2_ip_on_rrm2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + Nrp2_ip_on_Nrm2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + rip2_ip_on_rim2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + Nip2_ip_on_Nim2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + rsp2_ip_on_rsm2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + Nsp2_ip_on_Nsm2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + rgp2_ip_on_rgm2_ip = 1.0_core_rknd, & ! Ratio / ^2 [-] + Ngp2_ip_on_Ngm2_ip = 1.0_core_rknd ! Ratio / ^2 [-] + + end type hmp2_ip_on_hmm2_ip_ratios_type + + ! Prescribed parameter for / ^2. + ! NOTE: In the case that l_const_Nc_in_cloud is true, Ncn is constant + ! throughout the entire grid box, so the parameter below should be + ! ignored. + real( kind = core_rknd ), public :: & + Ncnp2_on_Ncnm2 = 1.0_core_rknd ! Prescribed ratio / ^2 [-] + +!$omp threadprivate(Ncnp2_on_Ncnm2) + + ! Latin hypercube indices / Correlation array indices + integer, public :: & + iiPDF_chi = -1, & + iiPDF_eta = -1, & + iiPDF_w = -1 +!$omp threadprivate(iiPDF_chi, iiPDF_eta, iiPDF_w) + + integer, public :: & + iiPDF_rr = -1, & + iiPDF_rs = -1, & + iiPDF_ri = -1, & + iiPDF_rg = -1 +!$omp threadprivate(iiPDF_rr, iiPDF_rs, iiPDF_ri, iiPDF_rg) + + integer, public :: & + iiPDF_Nr = -1, & + iiPDF_Ns = -1, & + iiPDF_Ni = -1, & + iiPDF_Ng = -1, & + iiPDF_Ncn = -1 +!$omp threadprivate(iiPDF_Nr, iiPDF_Ns, iiPDF_Ni, iiPDF_Ng, iiPDF_Ncn) + + integer, parameter, public :: & + d_var_total = 12 ! Size of the default correlation arrays + + integer, public :: & + d_variables +!$omp threadprivate(d_variables) + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + hmp2_ip_on_hmm2_ip + +!$omp threadprivate(hmp2_ip_on_hmm2_ip) + + real( kind = core_rknd ), public, dimension(:,:), allocatable :: & + corr_array_n_cloud, & + corr_array_n_below +!$omp threadprivate(corr_array_n_cloud, corr_array_n_below) + + real( kind = core_rknd ), public, dimension(:,:), allocatable :: & + corr_array_n_cloud_def, & + corr_array_n_below_def +!$omp threadprivate( corr_array_n_cloud_def, corr_array_n_below_def ) + + + private + + public :: hmp2_ip_on_hmm2_ip_ratios_type, & + read_correlation_matrix, setup_pdf_indices, & + setup_corr_varnce_array, cleanup_corr_matrix_arrays, & + assert_corr_symmetric, print_corr_matrix + + private :: get_corr_var_index, def_corr_idx + + + contains + + !----------------------------------------------------------------------------- + subroutine init_default_corr_arrays( ) + + ! Description: + ! Initializes the default correlation arrays. + !--------------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + implicit none + + integer:: indx + + ! This "renaming" is used to shorten the matrix declarations below. + integer, parameter :: c = core_rknd + + ! ---- Begin Code ---- + + ! Allocate Arrays. + allocate( corr_array_n_cloud_def(d_var_total,d_var_total) ) + allocate( corr_array_n_below_def(d_var_total,d_var_total) ) + + ! Initialize all values to 0. + corr_array_n_cloud_def = zero + corr_array_n_below_def = zero + + ! Set the correlation of any variable with itself to 1. + do indx = 1, d_var_total, 1 + corr_array_n_cloud_def(indx,indx) = one + corr_array_n_below_def(indx,indx) = one + enddo + + ! Set up default normal space correlation arrays. + ! The default normal space correlation arrays used here are the normal space + ! correlation arrays used for the ARM 97 case. Any changes should be made + ! concurrently here and in + ! ../../input/case_setups/arm_97_corr_array_cloud.in (for "in-cloud") and + ! in ../../input/case_setups/arm_97_corr_array_cloud.in (for "below-cloud"). + corr_array_n_cloud_def = reshape( & + +(/1._c,-.6_c, .09_c , .09_c , .788_c, .675_c, .240_c, .222_c, .240_c, .222_c, .240_c, .222_c, &! chi + 0._c, 1._c, .027_c, .027_c, .114_c, .115_c,-.029_c, .093_c, .022_c, .013_c, 0._c , 0._c , &! eta + 0._c, 0._c, 1._c , .34_c , .315_c, .270_c, .120_c, .167_c, 0._c , 0._c , 0._c , 0._c , &! w + 0._c, 0._c, 0._c , 1._c , 0._c , 0._c , .464_c, .320_c, .168_c, .232_c, 0._c , 0._c , &! Ncn + 0._c, 0._c, 0._c , 0._c , 1._c , .821_c, 0._c , 0._c , .173_c, .164_c, .319_c, .308_c, &! rr + 0._c, 0._c, 0._c , 0._c , 0._c , 1._c , .152_c, .143_c, 0._c , 0._c , .285_c, .273_c, &! Nr + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, .585_c, .571_c, .379_c, .363_c, &! ri + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .571_c, .550_c, .363_c, .345_c, &! Ni + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, .485_c, .470_c, &! rs + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .470_c, .450_c, &! Ns + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, &! rg + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c/), &! Ng + + shape(corr_array_n_cloud_def) ) +! chi eta w Ncn rr Nr ri Ni rs Ns rg Ng + + corr_array_n_cloud_def = transpose( corr_array_n_cloud_def ) + + + corr_array_n_below_def = reshape( & + +(/1._c, .3_c, .09_c , .09_c , .788_c, .675_c, .240_c, .222_c, .240_c, .222_c, .240_c, .222_c, &! chi + 0._c, 1._c, .027_c, .027_c, .114_c, .115_c,-.029_c, .093_c, .022_c, .013_c, 0._c , 0._c , &! eta + 0._c, 0._c, 1._c , .34_c , .315_c, .270_c, .120_c, .167_c, 0._c , 0._c , 0._c , 0._c , &! w + 0._c, 0._c, 0._c , 1._c , 0._c , 0._c , .464_c, .320_c, .168_c, .232_c, 0._c , 0._c , &! Ncn + 0._c, 0._c, 0._c , 0._c , 1._c , .821_c, 0._c , 0._c , .173_c, .164_c, .319_c, .308_c, &! rr + 0._c, 0._c, 0._c , 0._c , 0._c , 1._c , .152_c, .143_c, 0._c , 0._c , .285_c, .273_c, &! Nr + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, .585_c, .571_c, .379_c, .363_c, &! ri + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .571_c, .550_c, .363_c, .345_c, &! Ni + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, .485_c, .470_c, &! rs + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .470_c, .450_c, &! Ns + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c , .758_c, &! rg + 0._c, 0._c, 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 0._c , 1._c/), &! Ng + + shape(corr_array_n_below_def) ) +! chi eta w Ncn rr Nr ri Ni rs Ns rg Ng + + corr_array_n_below_def = transpose( corr_array_n_below_def ) + + + return + + end subroutine init_default_corr_arrays + + !----------------------------------------------------------------------------- + pure function def_corr_idx( iiPDF_x ) result(ii_def_corr) + + ! Description: + ! Map from a iiPDF index to the corresponding index in the default + ! correlation arrays. + !----------------------------------------------------------------------------- + + implicit none + + ! Constant Parameters + + ! Indices that represent the order in the default corr arrays + ! (chi (old s), eta (old t), w, Ncn, rr, Nr, ri, Ni, rs, Ns, rg, Ng) + integer, parameter :: & + ii_chi = 1, & + ii_eta = 2, & + ii_w = 3, & + ii_Ncn = 4, & + ii_rr = 5, & + ii_Nr = 6, & + ii_ri = 7, & + ii_Ni = 8, & + ii_rs = 9, & + ii_Ns = 10, & + ii_rg = 11, & + ii_Ng = 12 + + ! Input Variables + + integer, intent(in) :: iiPDF_x + + ! Return Variable + + integer :: ii_def_corr + + ! ---- Begin Code ---- + + ii_def_corr = -1 + + if (iiPDF_x == iiPDF_chi) then + ii_def_corr = ii_chi + + elseif (iiPDF_x == iiPDF_eta) then + ii_def_corr = ii_eta + + elseif (iiPDF_x == iiPDF_w) then + ii_def_corr = ii_w + + elseif (iiPDF_x == iiPDF_Ncn) then + ii_def_corr = ii_Ncn + + elseif (iiPDF_x == iiPDF_rr) then + ii_def_corr = ii_rr + + elseif (iiPDF_x == iiPDF_Nr) then + ii_def_corr = ii_Nr + + elseif (iiPDF_x == iiPDF_ri) then + ii_def_corr = ii_ri + + elseif (iiPDF_x == iiPDF_Ni) then + ii_def_corr = ii_Ni + + elseif (iiPDF_x == iiPDF_rs) then + ii_def_corr = ii_rs + + elseif (iiPDF_x == iiPDF_Ns) then + ii_def_corr = ii_Ns + + elseif (iiPDF_x == iiPDF_rg) then + ii_def_corr = ii_rg + + elseif (iiPDF_x == iiPDF_Ng) then + ii_def_corr = ii_Ng + + endif + end function def_corr_idx + + !----------------------------------------------------------------------------- + subroutine set_corr_arrays_to_default( ) + + ! Description: + ! If there are no corr_array.in files for the current case, default + ! correlations are used. + !----------------------------------------------------------------------------- + + use constants_clubb, only: & + zero, & + one + + implicit none + + ! Local Variables + integer :: i, j ! Loop iterators + + + ! ---- Begin Code ---- + + corr_array_n_cloud = zero + corr_array_n_below = zero + + do i = 1, d_variables + corr_array_n_cloud(i,i) = one + corr_array_n_below(i,i) = one + enddo + + do i = 1, d_variables-1 + do j = i+1, d_variables + if ( def_corr_idx(i) > def_corr_idx(j) ) then + corr_array_n_cloud(j, i) = corr_array_n_cloud_def(def_corr_idx(j), def_corr_idx(i)) + corr_array_n_below(j, i) = corr_array_n_below_def(def_corr_idx(j), def_corr_idx(i)) + else + corr_array_n_cloud(j, i) = corr_array_n_cloud_def(def_corr_idx(i), def_corr_idx(j)) + corr_array_n_below(j, i) = corr_array_n_below_def(def_corr_idx(i), def_corr_idx(j)) + endif + enddo + enddo + + end subroutine set_corr_arrays_to_default + + + !----------------------------------------------------------------------------- + subroutine read_correlation_matrix( iunit, input_file, d_variables, & + corr_array_n ) + + ! Description: + ! Reads a correlation variance array from a file and stores it in an array. + !----------------------------------------------------------------------------- + + use input_reader, only: & + one_dim_read_var, & ! Variable(s) + read_one_dim_file, deallocate_one_dim_vars, count_columns ! Procedure(s) + + use matrix_operations, only: set_lower_triangular_matrix ! Procedure(s) + + use constants_clubb, only: fstderr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable(s) + integer, intent(in) :: & + iunit, & ! File I/O unit + d_variables ! number of variables in the array + + character(len=*), intent(in) :: input_file ! Path to the file + + ! Input/Output Variable(s) + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(inout) :: & + corr_array_n ! Normal space correlation array + + ! Local Variable(s) + + type(one_dim_read_var), allocatable, dimension(:) :: & + retVars ! stores the variables read in from the corr_varnce.in file + + integer :: & + var_index1, & ! variable index + var_index2, & ! variable index + nCols, & ! the number of columns in the file + i, j ! Loop index + + + !--------------------------- BEGIN CODE ------------------------- + + nCols = count_columns( iunit, input_file ) + + ! Allocate all arrays based on d_variables + allocate( retVars(1:nCols) ) + + ! Initializing to zero means that correlations we don't have are assumed to be 0. + corr_array_n(:,:) = 0.0_core_rknd + + ! Set main diagonal to 1 + do i=1, d_variables + corr_array_n(i,i) = 1.0_core_rknd + end do + + ! Read the values from the specified file + call read_one_dim_file( iunit, nCols, input_file, retVars ) + + if( size( retVars(1)%values ) /= nCols ) then + write(fstderr, *) "Correlation matrix must have an equal number of rows and cols in file ", & + input_file + stop "Bad data in correlation file." + end if + + ! Start at 2 because the first index is always just 1.0 in the first row + ! and the rest of the rows are ignored + do i=2, nCols + var_index1 = get_corr_var_index( retVars(i)%name ) + if( var_index1 > -1 ) then + do j=1, (i-1) + var_index2 = get_corr_var_index( retVars(j)%name ) + if( var_index2 > -1 ) then + call set_lower_triangular_matrix & + ( d_variables, var_index1, var_index2, retVars(i)%values(j), & + corr_array_n ) + end if + end do + end if + end do + + call deallocate_one_dim_vars( nCols, retVars ) + + return + end subroutine read_correlation_matrix + + !-------------------------------------------------------------------------- + function get_corr_var_index( var_name ) result( i ) + + ! Definition: + ! Returns the index for a variable based on its name. + !-------------------------------------------------------------------------- + + implicit none + + character(len=*), intent(in) :: var_name ! The name of the variable + + ! Output variable + integer :: i + + !------------------ BEGIN CODE ----------------------------- + i = -1 + + select case( trim(var_name) ) + + case( "chi" ) + i = iiPDF_chi + + case( "eta" ) + i = iiPDF_eta + + case( "w" ) + i = iiPDF_w + + case( "Ncn" ) + i = iiPDF_Ncn + + case( "rr" ) + i = iiPDF_rr + + case( "Nr" ) + i = iiPDF_Nr + + case( "ri" ) + i = iiPDF_ri + + case( "Ni" ) + i = iiPDF_Ni + + case( "rs" ) + i = iiPDF_rs + + case( "Ns" ) + i = iiPDF_Ns + + case( "rg" ) + i = iiPDF_rg + + case( "Ng" ) + i = iiPDF_Ng + + end select + + return + + end function get_corr_var_index + + !----------------------------------------------------------------------- + subroutine setup_pdf_indices( hydromet_dim, iirrm, iiNrm, & + iirim, iiNim, iirsm, iiNsm, & + iirgm, iiNgm ) + + ! Description: + ! + ! Setup for the iiPDF indices. These indices are used to address chi(s), eta(t), w + ! and the hydrometeors in the mean/stdev/corr arrays + ! + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Total number of hydrometeor species. + + integer, intent(in) :: & + iirrm, & ! Index of rain water mixing ratio + iiNrm, & ! Index of rain drop concentration + iirim, & ! Index of ice mixing ratio + iiNim, & ! Index of ice crystal concentration + iirsm, & ! Index of snow mixing ratio + iiNsm, & ! Index of snow flake concentration + iirgm, & ! Index of graupel mixing ratio + iiNgm ! Index of graupel concentration + + ! Local Variables + integer :: & + pdf_count, & ! Count number of PDF variables + i ! Hydrometeor loop index + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + iiPDF_chi = 1 ! Extended liquid water mixing ratio, chi + iiPDF_eta = 2 ! 'eta' orthogonal to 'chi' + iiPDF_w = 3 ! vertical velocity + iiPDF_Ncn = 4 ! Simplified cloud nuclei concentration or extended Nc. + + pdf_count = iiPDF_Ncn + + ! Loop over hydrometeors. + ! Hydrometeor indices in the PDF arrays should be in the same order as + ! found in the hydrometeor arrays. + if ( hydromet_dim > 0 ) then + + do i = 1, hydromet_dim, 1 + + if ( i == iirrm ) then + pdf_count = pdf_count + 1 + iiPDF_rr = pdf_count + endif + + if ( i == iiNrm ) then + pdf_count = pdf_count + 1 + iiPDF_Nr = pdf_count + endif + + if ( i == iirim ) then + pdf_count = pdf_count + 1 + iiPDF_ri = pdf_count + endif + + if ( i == iiNim ) then + pdf_count = pdf_count + 1 + iiPDF_Ni = pdf_count + endif + + if ( i == iirsm ) then + pdf_count = pdf_count + 1 + iiPDF_rs = pdf_count + endif + + if ( i == iiNsm ) then + pdf_count = pdf_count + 1 + iiPDF_Ns = pdf_count + endif + + if ( i == iirgm ) then + pdf_count = pdf_count + 1 + iiPDF_rg = pdf_count + endif + + if ( i == iiNgm ) then + pdf_count = pdf_count + 1 + iiPDF_Ng = pdf_count + endif + + enddo ! i = 1, hydromet_dim, 1 + + endif ! hydromet_dim > 0 + + d_variables = pdf_count + + + return + + end subroutine setup_pdf_indices + !----------------------------------------------------------------------- + +!=============================================================================== + subroutine setup_corr_varnce_array( input_file_cloud, input_file_below, & + iunit ) + +! Description: +! Setup an array with the x'^2/xm^2 variables on the diagonal and the other +! elements to be correlations between various variables. + +! References: +! None. +!------------------------------------------------------------------------------- + + use model_flags, only: & + l_fix_chi_eta_correlations ! Variable(s) + + use matrix_operations, only: mirror_lower_triangular_matrix ! Procedure + + use constants_clubb, only: & + fstderr, & ! Constant(s) + zero + + use error_code, only: & + clubb_debug, & ! Procedure(s) + clubb_at_least_debug_level + + implicit none + + ! External + intrinsic :: max, epsilon, trim + + character(len=*), intent(in) :: & + input_file_cloud, & ! Path to the in cloud correlation file + input_file_below ! Path to the out of cloud correlation file + + ! Input Variables + integer, intent(in) :: & + iunit ! The file unit + + ! Local variables + logical :: l_warning, l_corr_file_1_exist, l_corr_file_2_exist + integer :: i + + ! ---- Begin Code ---- + + allocate( corr_array_n_cloud(d_variables,d_variables) ) + allocate( corr_array_n_below(d_variables,d_variables) ) + + inquire( file = input_file_cloud, exist = l_corr_file_1_exist ) + inquire( file = input_file_below, exist = l_corr_file_2_exist ) + + if ( l_corr_file_1_exist .and. l_corr_file_2_exist ) then + + call read_correlation_matrix( iunit, trim( input_file_cloud ), d_variables, & ! In + corr_array_n_cloud ) ! Out + + call read_correlation_matrix( iunit, trim( input_file_below ), d_variables, & ! In + corr_array_n_below ) ! Out + + else ! Read in default correlation matrices + + call clubb_debug( 1, "Warning: "//trim( input_file_cloud )//" was not found! " // & + "The default correlation arrays will be used." ) + + call init_default_corr_arrays( ) + + call set_corr_arrays_to_default( ) + + endif + + ! Mirror the correlation matrices + call mirror_lower_triangular_matrix( d_variables, corr_array_n_cloud ) + call mirror_lower_triangular_matrix( d_variables, corr_array_n_below ) + + ! Sanity check to avoid confusing non-convergence results. + if ( clubb_at_least_debug_level( 2 ) ) then + + if ( .not. l_fix_chi_eta_correlations .and. iiPDF_Ncn > 0 ) then + l_warning = .false. + do i = 1, d_variables + if ( ( corr_array_n_cloud(i,iiPDF_Ncn) /= zero .or. & + corr_array_n_below(i,iiPDF_Ncn) /= zero ) .and. & + i /= iiPDF_Ncn ) then + l_warning = .true. + end if + end do ! 1..d_variables + if ( l_warning ) then + write(fstderr,*) "Warning: the specified correlations for chi" & + // " (old s) and Ncn are non-zero." + write(fstderr,*) "The latin hypercube code will not converge to" & + // " the analytic solution using these settings." + end if + end if ! l_fix_chi_eta_correlations .and. iiPDF_Ncn > 0 + + end if ! clubb_at_least_debug_level( 2 ) + + + return + + end subroutine setup_corr_varnce_array + + !----------------------------------------------------------------------------- + subroutine cleanup_corr_matrix_arrays( ) + + ! Description: + ! De-allocate latin hypercube arrays + ! References: + ! None + !--------------------------------------------------------------------------- + implicit none + + ! External + intrinsic :: allocated + + ! ---- Begin Code ---- + + if ( allocated( corr_array_n_cloud ) ) then + deallocate( corr_array_n_cloud ) + end if + + if ( allocated( corr_array_n_below ) ) then + deallocate( corr_array_n_below ) + end if + + if ( allocated( corr_array_n_cloud_def ) ) then + deallocate( corr_array_n_cloud_def ) + end if + + if ( allocated( corr_array_n_below_def ) ) then + deallocate( corr_array_n_below_def ) + end if + + + return + + end subroutine cleanup_corr_matrix_arrays + + !----------------------------------------------------------------------------- + subroutine assert_corr_symmetric( corr_array_n, & ! intent(in) + d_variables ) ! intent(in) + + ! Description: + ! Asserts that corr_matrix(i,j) == corr_matrix(j,i) for all indeces + ! in the correlation array. If this is not the case, stops the program. + ! References: + ! None + !--------------------------------------------------------------------------- + + use constants_clubb, only: fstderr ! Constant(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: corr_array_n ! Normal space correlation array to be checked + + ! Local Variables + + ! tolerance used for real precision testing + real( kind = core_rknd ), parameter :: tol = 1.0e-6_core_rknd + + integer :: n_row, n_col !indeces + + logical :: l_error !error found between the two arrays + + !----- Begin Code ----- + + l_error = .false. + + !Do the check + do n_col = 1, d_variables + do n_row = 1, d_variables + if (abs(corr_array_n(n_col, n_row) - corr_array_n(n_row, n_col)) > tol) then + l_error = .true. + end if + if (n_col == n_row .and. corr_array_n(n_col, n_row) /= 1.0_core_rknd) then + l_error = .true. + end if + end do + end do + + !Report if any errors are found + if (l_error) then + write(fstderr,*) "Error: Correlation array is non symmetric or formatted incorrectly." + write(fstderr,*) corr_array_n + stop + end if + + end subroutine assert_corr_symmetric + + !----------------------------------------------------------------------------- + subroutine print_corr_matrix( d_variables, & ! intent(in) + corr_array_n ) ! intent(in) + + ! Description: + ! Prints the correlation matrix to the console. + ! References: + ! None + !--------------------------------------------------------------------------- + + use clubb_precision, only: core_rknd + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: corr_array_n ! Normal space correlation array to be printed + + ! Local Variables + integer :: n, & ! Loop indeces + m, & + current_character_index ! keeps track of the position in the string + + character(LEN=72) :: current_line ! The current line to be printed + character(LEN=10) :: str_array_value + + !----- Begin Code ----- + + current_character_index = 0 + + do n = 1, d_variables + do m = 1, d_variables + write(str_array_value,'(F5.2)') corr_array_n(m,n) + current_line = current_line(1:current_character_index)//str_array_value + current_character_index = current_character_index + 6 + end do + write(*, *) current_line + current_line = "" + current_character_index = 0 + end do + + end subroutine print_corr_matrix + !----------------------------------------------------------------------------- + +end module corr_varnce_module diff --git a/src/physics/clubb/csr_matrix_module.F90 b/src/physics/clubb/csr_matrix_module.F90 new file mode 100644 index 0000000000..f61b340b9d --- /dev/null +++ b/src/physics/clubb/csr_matrix_module.F90 @@ -0,0 +1,532 @@ +!----------------------------------------------------------------------- +! $Id: csr_matrix_module.F90 7012 2014-07-07 14:18:31Z schemena@uwm.edu $ +!=============================================================================== +module csr_matrix_module + + ! Description: + ! This module contains some of the matrix description arrays required by + ! PARDISO, GMRES, and other sparse matrix solvers. The format is called CSR + ! (compressed sparse row) format, and is currently leveraged through PARDISO + ! and GMRES. + ! These are all 1 dimensional arrays that describe a matrix that + ! will be passed to the solver. The _ja arrays describe which + ! columns in the matrix have nonzero values--for our purposes, all the + ! elements on the appropriate diagonals have values. The _ia arrays describe + ! which _ja array elements correspond to new rows. + ! Further description of this format can be found in the PARDISO manual, or + ! alternately, in Intel MKL's documentation. + ! For our purposes, the _ia and _ja arrays will be fixed for the types + ! of matrices we have, so we calculate these initially using + ! initialize_csr_class and simply use the pointers, similar to how + ! the grid pointers are initialized. This should save a fair amount of time, + ! as we do not have to recalculate the arrays. + ! + ! A description of the CSR matrix format: + ! The CSR matrix format requires three arrays--an a array, + ! a ja array, and an ia array. + ! + ! The a array stores, in sequential order, the actual values in the matrix. + ! Essentially, just copy the matrix into a 1-dimensional array as you move + ! from left to right, top down through the matrix. The a array changes + ! frequently for our purposes in CLUBB, and is not useful to be initialized + ! here. + ! + ! The ja array stores, in sequential order, the columns of each element in + ! the matrix that is nonzero. Essentially, you take the column of each + ! element that is nonzero as you move from left to right, top down through + ! the matrix. + ! + ! An example follows to illustrate the point: + ! [3.0 2.0 0.0 0.0 0.0 0.0 + ! 2.5 1.7 3.6 0.0 0.0 0.0 + ! 0.0 5.2 1.7 3.6 0.0 0.0 + ! 0.0 0.0 4.7 2.9 0.6 0.0 + ! 0.0 0.0 0.0 8.9 4.6 1.2 + ! 0.0 0.0 0.0 0.0 5.8 3.7] + ! + ! Our ja array would look like the following--a pipe denotes a new row: + ! [1 2 | 1 2 3 | 2 3 4 | 3 4 5 | 4 5 6 | 5 6] + ! + ! The ia array stores the indices of the ja array that correspond to new rows + ! in the matrix, with a final entry just beyond the end of the ja matrix + ! that signifies the end of the matrix. + ! In our example, the ia array would look like this: + ! + ! [1 3 6 9 12 15 17] + ! + ! Similar principles can be applied to find the ia and ja matrices for all + ! of the general cases CLUBB uses. In addition, because CLUBB typically + ! uses similar matrices for its calculations, we can simply initialize + ! the ia and ja matrices in this module rather than repeatedly initialize + ! them. This should save on compute time and provide a centralized location + ! to acquire ia and ja arrays. + + implicit none + + public :: csr_tridiag_ia, csr_tridiag_ja, & + csr_banddiag5_135_ia, csr_banddiag5_135_ja, & + csr_banddiag5_12345_ia, csr_banddiag5_12345_ja, & + initialize_csr_matrix, & + ia_size, tridiag_ja_size, band12345_ja_size, band135_ja_size, & + csr_intlc_s3b_f5b_ia, csr_intlc_s3b_f5b_ja, & + csr_intlc_trid_5b_ia, csr_intlc_trid_5b_ja, & + csr_intlc_5b_5b_ia, csr_intlc_5b_5b_ja, & + intlc_ia_size, intlc_s3d_5d_ja_size, intlc_5d_5d_ja_size, & + intlc_td_5d_ja_size + + private ! Default scope + + integer, allocatable, dimension(:) :: & + csr_tridiag_ia, & !_ia array description for a tridiagonal matrix + csr_tridiag_ja, & !_ja array description for a tridiagonal matrix + csr_banddiag5_135_ia, & !_ia array description for a 5-band matrix + ! with the first upper and lower bands as 0. + csr_banddiag5_135_ja, & !_ja array description for a 5-band matrix + ! with the first upper and lower bands as 0. + csr_banddiag5_12345_ia, & !_ia array description for a 5-band matrix + csr_banddiag5_12345_ja, & !_ja array description for a 5-band matrix + csr_intlc_s3b_f5b_ia, & !_ia array description for interlaced 5-band + ! matrix ("spaced 3-band, full 5-band") + csr_intlc_s3b_f5b_ja, & !_ja array description for interlaced 5-band + ! matrix ("spaced 3-band, full 5-band") + csr_intlc_trid_5b_ia, & !_ia array description for interlaced tridiag + ! and 5-band matrix (tridiag, 5-band) + csr_intlc_trid_5b_ja, & !_ja array description for interlaced tridiag + ! and 5-band matrix (tridiag, 5-band) + csr_intlc_5b_5b_ia, & !_ia array description for "interlaced" + ! 5-band and 5-band matrix (double-size 5-band) + csr_intlc_5b_5b_ja !_ja array description for "interlaced" + ! 5-band and 5-band matrix (double-size 5-band) + + integer :: & + ia_size, & ! Size of the _ia arrays. + tridiag_ja_size, & ! Size of the tridiagonal ja array. + band12345_ja_size, & ! Size of the 5-band-with-first-bands-0 ja array. + band135_ja_size, & ! Size of the 5-band ja array. + intlc_ia_size, & ! Size of the interlaced _ia arrays. + intlc_s3d_5d_ja_size, & ! Size of the interlaced spaced + ! 3-diag+5-diag ja arrays. + intlc_5d_5d_ja_size, & ! Size of the interlaced 5-diag+5-diag ja arrays. + intlc_td_5d_ja_size ! Size of the interlaced tridiag+5-diag ja arrays. + +!$omp threadprivate (csr_tridiag_ia, csr_tridiag_ja) +!$omp threadprivate (csr_banddiag5_135_ia, csr_banddiag5_135_ja) +!$omp threadprivate (csr_banddiag5_12345_ia, csr_banddiag5_12345_ja) +!$omp threadprivate (ia_size, tridiag_ja_size, band12345_ja_size, band135_ja_size) +!$omp threadprivate (csr_intlc_s3b_f5b_ia, csr_intlc_s3b_f5b_ja) +!$omp threadprivate (csr_intlc_trid_5b_ia, csr_intlc_trid_5b_ja) +!$omp threadprivate (csr_intlc_5b_5b_ia, csr_intlc_5b_5b_ja) +!$omp threadprivate (intlc_ia_size, intlc_s3d_5d_ja_size, intlc_5d_5d_ja_size) +!$omp threadprivate (intlc_td_5d_ja_size) + + contains + + !============================================================================ + subroutine initialize_csr_matrix + + ! Description: + ! PARDISO matrix array initialization + ! + ! This subroutine creates the _ia and _ja arrays, and calculates their + ! required values for the current gr%nz. + ! + ! References: + ! None + !------------------------------------------------------------------------ + + use constants_clubb, only: & + fstderr ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + implicit none + + ! Local variables + integer :: & + i, j, & ! Loop indices + error, & ! Status for allocation + num_bands, & ! Number of diagonals for allocation + num_diags, & ! Number of non-empty diagonals for allocation + cur_row, & ! Current row--used in initialization + cur_diag, & ! Current diagonal--num_diags/2 + 1 is the main diagonal + ! Note: At the boundaries, less diagonals are in scope. + ! At the lower boundaries, the subdiagonals aren't in scope. + ! At the upper boundaries, the superdiagonals aren't in scope. + counter ! Counter used to initialize the interlaced matrices + + logical :: l_print_ia_ja ! Debug flag to print the ia and ja arrays after + ! initialization is complete. + + ! ---- Begin Code ---- + + ! Define the array sizes + ia_size = gr%nz + 1 + intlc_ia_size = (2 * gr%nz) + 1 + + ! Tridiagonal case and 5-band with 2 empty diagonals have 3 full diagonals + num_diags = 3 + tridiag_ja_size = (gr%nz * num_diags) - 2 + band135_ja_size = (gr%nz * num_diags) - 4 + + ! 5-band with all diagonals has 5 full diagonals + num_diags = 5 + band12345_ja_size = (gr%nz * num_diags) - 6 + + ! Interlaced arrays are tricky--there is an average of 4 diagonals for + ! the 3/5band, but we need to take into account the fact that the + ! tridiagonal and spaced 3-band will have different boundary indices. + num_diags = 4 + intlc_td_5d_ja_size = (gr%nz * 2 * num_diags) - 4 + intlc_s3d_5d_ja_size = (gr%nz * 2 * num_diags) - 5 + + ! The double-sized "interlaced" 5-band is similar to the standard 5-band + num_diags = 5 + intlc_5d_5d_ja_size = (gr%nz * 2 * num_diags) - 6 + + ! Allocate the correct amount of space for the actual _ia and _ja arrays + allocate( csr_tridiag_ia(1:ia_size), & + csr_tridiag_ja(1:tridiag_ja_size), & + csr_banddiag5_12345_ia(1:ia_size), & + csr_banddiag5_12345_ja(1:band12345_ja_size), & + csr_banddiag5_135_ia(1:ia_size), & + csr_banddiag5_135_ja(1:band135_ja_size), & + csr_intlc_s3b_f5b_ia(1:intlc_ia_size), & + csr_intlc_s3b_f5b_ja(1:intlc_s3d_5d_ja_size), & + csr_intlc_trid_5b_ia(1:intlc_ia_size), & + csr_intlc_trid_5b_ja(1:intlc_td_5d_ja_size), & + csr_intlc_5b_5b_ia(1:intlc_ia_size), & + csr_intlc_5b_5b_ja(1:intlc_5d_5d_ja_size), & + stat=error ) + + if ( error /= 0 ) then + write(fstderr,*) "Allocation of CSR matrix arrays failed." + stop "Fatal error--allocation of CSR matrix arrays failed." + end if + + ! Initialize the tridiagonal matrix arrays + num_bands = 3 + do i = 2, (gr%nz - 1), 1 + cur_row = (i - 1) * num_bands + do j = 1, num_bands, 1 + cur_diag = j - 1 + csr_tridiag_ja(cur_row + cur_diag) = i + j - 2 + end do + csr_tridiag_ia(i) = cur_row + end do ! i = 2...gr%nz-1 + + ! Handle boundary conditions for the tridiagonal matrix arrays + ! These conditions have been hand-calculated bearing in mind that the + ! matrix in question is tridiagonal. + + ! Make sure we don't crash if someone sets up gr%nz as 1. + if ( gr%nz > 1 ) then + ! Lower boundaries + csr_tridiag_ja(1) = 1 + csr_tridiag_ja(2) = 2 + csr_tridiag_ia(1) = 1 + + ! Upper boundaries + csr_tridiag_ja(tridiag_ja_size - 1) = gr%nz - 1 + csr_tridiag_ja(tridiag_ja_size) = gr%nz + csr_tridiag_ia(ia_size - 1) = tridiag_ja_size - 1 + + ! This final boundary is to signify the end of the matrix, and is + ! intended to be beyond the bound of the ja array. + csr_tridiag_ia(ia_size) = tridiag_ja_size + 1 + end if ! gr%nz > 1 + + ! Initialize the 5-band matrix arrays + num_bands = 5 + do i = 3, (gr%nz - 2), 1 + + ! Full 5-band matrix has 5 diagonals to initialize + num_diags = 5 + cur_row = num_diags * (i - 1) + do j = 1, num_diags, 1 + cur_diag = j - 3 + csr_banddiag5_12345_ja(cur_row + cur_diag) = i + cur_diag + end do + + csr_banddiag5_12345_ia(i) = cur_row - 2 + + ! 5-band matrix with 2 zero bands has 3 diagonals to initialize + num_diags = 3 + cur_row = num_diags * (i - 1) + do j = 1, num_diags, 1 + cur_diag = j - 2 + ! The first upper and first lower bands are zero, so there needs to be + ! special handling to account for this. The j * 2 takes into account + ! the spaces between diagonals. + csr_banddiag5_135_ja(cur_row + cur_diag) = i + ((j * 2) - 1) - num_diags + end do + + csr_banddiag5_135_ia(i) = cur_row - 1 + + end do ! i = 3...gr%nz-2 + + ! Handle boundary conditions for the 5-band matrix arrays + ! These values have been hand-calculated bearing in mind the two different + ! types of 5-band matrices. + + ! Make sure we don't crash if someone sets up gr%nz as less than 3. + if ( gr%nz > 2 ) then + + ! -------------- (full) 5-band matrix boundaries --------------- + + ! Lower boundaries for the (full) 5-band matrix. + do i = 1, 3, 1 + csr_banddiag5_12345_ja(i) = i + end do + do i = 1, 4, 1 + csr_banddiag5_12345_ja(i + 3) = i + end do + csr_banddiag5_12345_ia(1) = 1 + csr_banddiag5_12345_ia(2) = 4 + + ! Upper boundaries for the (full) 5-band matrix. + ! 7 and 3 are the number of elements from the "end" of the matrix if we + ! travel right to left, bottom up. Because the ja matrices correspond to + ! the column the element is in, we go 3 or 4 elements from the end for the + ! second to last row (both superdiagonals absent on last row), + ! and 3 for the last row (both superdiagonals absent). The indices are + ! similarly calculated, except that in the case of the second to last + ! row, it is necessary to offset for the last row as well (hence, + ! 7 = 4+3). + do i = 1, 4, 1 + csr_banddiag5_12345_ja(band12345_ja_size - 7 + i) = gr%nz + i - 4 + end do + do i = 1, 3, 1 + csr_banddiag5_12345_ja(band12345_ja_size - 3 + i) = gr%nz + i - 3 + end do + csr_banddiag5_12345_ia(ia_size - 2) = band12345_ja_size - 6 + csr_banddiag5_12345_ia(ia_size - 1) = band12345_ja_size - 2 + + ! This final boundary is to signify the end of the matrix, and is + ! intended to be beyond the bound of the ja array. + csr_banddiag5_12345_ia(ia_size) = band12345_ja_size + 1 + + ! ------------ end (full) 5-band matrix boundaries --------------- + + ! --------- 5-band matrix w/ empty first bands boundaries ---------- + + ! Lower boundaries for the 5-band w/ empty first bands matrix + ! The 2 * i is present because of the space between the main diagonal + ! and the superdiagonal that actually have nonzero values. + do i = 1, 2, 1 + csr_banddiag5_135_ja(i) = (2 * i) - 1 + csr_banddiag5_135_ja(i + 2) = (2 * i) + csr_banddiag5_135_ia(i) = (2 * i) - 1 + end do + + ! Upper boundaries for the 5-band w/ empty first bands matrix + ! The values for the boundaries are tricky, as the indices and values + ! are not equal. The indices are 2 and 4 away from the end, as there are + ! only two nonzero values at the two final rows. + ! The values, on the other hand, are different, because of the + ! aforementioned space, this time between the main and subdiagonal. + do i = 1, 2, 1 + csr_banddiag5_135_ja(band135_ja_size - 4 + i) = gr%nz + (i * 2) - 5 + csr_banddiag5_135_ja(band135_ja_size - 2 + i) = gr%nz + (i * 2) - 4 + end do + csr_banddiag5_135_ia(ia_size - 2) = band135_ja_size - 3 + csr_banddiag5_135_ia(ia_size - 1) = band135_ja_size + 1 + + ! This final boundary is to signify the end of the matrix, and is + ! intended to be beyond the bound of the ja array. + csr_banddiag5_135_ia(ia_size) = band135_ja_size + 1 + + ! ------- end 5-band matrix w/ empty first bands boundaries -------- + + end if ! gr%nz > 2 + + ! Initialize the interlaced arrays--all of them are 5-band right now. + num_bands = 5 + + ! Our counter starts at 2--this is used for the 3/5 interlaced matrices. + ! We start at 2 so when we enter the odd row and increment by 5, + ! it becomes 7. + counter = 2 + + do i = 3, ((gr%nz * 2) - 2), 1 + if (mod( i,2 ) == 1) then + ! Odd row, this is the potentially non 5-band row. + ! Increment counter. Last row was an even row, so we'll need to add 5. + counter = counter + 5 + + ! For our tridiag and spaced 3-band arrays, this will be a + ! 3-diagonal row. + num_diags = 3 + cur_row = counter + 1 + do j = 1, num_diags, 1 + cur_diag = j - 2 + csr_intlc_s3b_f5b_ja(cur_row + cur_diag) & + = i + ((j * 2) - 1) - num_diags + csr_intlc_trid_5b_ja(cur_row + cur_diag) = i + cur_diag + end do + csr_intlc_s3b_f5b_ia(i) = counter + csr_intlc_trid_5b_ia(i) = counter + + ! For our 5-band interlaced-size array, this will be a + ! 5-diagonal row (obviously!). + num_diags = 5 + cur_row = num_diags * (i - 1) + do j = 1, num_diags, 1 + cur_diag = j - 3 + csr_intlc_5b_5b_ja(cur_row + cur_diag) = i + cur_diag + end do + + csr_intlc_5b_5b_ia(i) = cur_row - 2 + + else + ! Even row, this is the "guaranteed" 5-band row. + ! Increment counter. Last row was an odd row, so we'll need to add 3. + counter = counter + 3 + + ! For our tridiag and spaced 3-band arrays, this will be a + ! 5-diagonal row. + num_diags = 5 + cur_row = counter + 2 + do j = 1, num_diags, 1 + cur_diag = j - 3 + csr_intlc_s3b_f5b_ja(cur_row + cur_diag) = i + cur_diag + csr_intlc_trid_5b_ja(cur_row + cur_diag) = i + cur_diag + end do + + csr_intlc_s3b_f5b_ia(i) = counter + csr_intlc_trid_5b_ia(i) = counter + + ! For our 5-band "interlaced" array, this will also be a + ! 5-diagonal row. However, we need to change the cur_row to match + ! what we're expecting for the 5-band. + num_diags = 5 + cur_row = num_diags * (i - 1) + do j = 1, num_diags, 1 + cur_diag = j - 3 + csr_intlc_5b_5b_ja(cur_row + cur_diag) = i + cur_diag + end do + + csr_intlc_5b_5b_ia(i) = cur_row - 2 + + end if ! mod(i,2) == 1 + end do ! i = 3...(gr%nz*2)-2 + + ! Handle boundary conditions for the interlaced matrix arrays + ! These conditions have been hand-calculated bearing in mind + ! the structure of the interlaced matrices. + + ! Make sure we don't crash if someone sets up gr%nz as less than 3. + if (gr%nz > 2) then + ! Lower boundaries + + ! First row + do i = 1, 2, 1 + csr_intlc_s3b_f5b_ja(i) = (i * 2) - 1 + csr_intlc_trid_5b_ja(i) = i + end do + do i = 1, 3, 1 + csr_intlc_5b_5b_ja(i) = i + end do + csr_intlc_s3b_f5b_ia(1) = 1 + csr_intlc_trid_5b_ia(1) = 1 + csr_intlc_5b_5b_ia(1) = 1 + + ! Second row + do i = 1, 4, 1 + csr_intlc_s3b_f5b_ja(i + 2) = i + csr_intlc_trid_5b_ja(i + 2) = i + csr_intlc_5b_5b_ja(i + 3) = i + end do + csr_intlc_s3b_f5b_ia(2) = 3 + csr_intlc_trid_5b_ia(2) = 3 + csr_intlc_5b_5b_ia(2) = 4 + + ! Upper boundaries + + ! Last two rows + ! Note that in comparison to the other upper boundaries, we have to use + ! intlc_ia_size - 1 for our upper index limit as the matrix is + ! double-sized. + + ! Second-to-last row + do i = 1, 2, 1 + csr_intlc_s3b_f5b_ja(intlc_s3d_5d_ja_size - 5 + i) & + = intlc_ia_size - 1 + (i * 2) - 5 + end do + do i = 1, 3, 1 + csr_intlc_trid_5b_ja(intlc_td_5d_ja_size - 6 + i) & + = intlc_ia_size - 1 + i - 3 + end do + do i = 1, 4, 1 + csr_intlc_5b_5b_ja(intlc_5d_5d_ja_size - 7 + i) & + = intlc_ia_size-1 + i - 4 + end do + + ! Last row + do i = 1, 3, 1 + csr_intlc_s3b_f5b_ja(intlc_s3d_5d_ja_size - 3 + i) & + = intlc_ia_size-1 + i - 3 + csr_intlc_trid_5b_ja(intlc_td_5d_ja_size - 3 + i) & + = intlc_ia_size-1 + i - 3 + csr_intlc_5b_5b_ja(intlc_5d_5d_ja_size - 3 + i) & + = intlc_ia_size-1 + i - 3 + end do + + ! Lastly, take care of the ia arrays. + csr_intlc_s3b_f5b_ia(intlc_ia_size - 2) = intlc_s3d_5d_ja_size - 4 + csr_intlc_s3b_f5b_ia(intlc_ia_size - 1) = intlc_s3d_5d_ja_size - 2 + csr_intlc_s3b_f5b_ia(intlc_ia_size) = intlc_s3d_5d_ja_size + 1 + + csr_intlc_trid_5b_ia(intlc_ia_size - 2) = intlc_td_5d_ja_size - 5 + csr_intlc_trid_5b_ia(intlc_ia_size - 1) = intlc_td_5d_ja_size - 2 + csr_intlc_trid_5b_ia(intlc_ia_size) = intlc_td_5d_ja_size + 1 + + csr_intlc_5b_5b_ia(intlc_ia_size - 2) = intlc_5d_5d_ja_size - 6 + csr_intlc_5b_5b_ia(intlc_ia_size - 1) = intlc_5d_5d_ja_size - 2 + csr_intlc_5b_5b_ia(intlc_ia_size) = intlc_5d_5d_ja_size + 1 + + + end if ! gr%nz > 2 + + ! Enable printing the ia/ja arrays for debug purposes + l_print_ia_ja = .false. + if (l_print_ia_ja) then + do i = 1, ia_size, 1 + print *, "tridiag ia idx", i, "=", csr_tridiag_ia(i) + print *, "banddiag12345 ia idx", i, "=", csr_banddiag5_12345_ia(i) + print *, "banddiag135 ia idx", i, "=", csr_banddiag5_135_ia(i) + end do + do i = 1, intlc_ia_size, 1 + print *, "interlaced tridiag w/ 5-band ia idx", i, & + "=", csr_intlc_trid_5b_ia(i) + print *, "interlaced spaced-3-band+5-band ia idx", i, & + "=", csr_intlc_s3b_f5b_ia(i) + print *, "interlaced 5-band w/ 5-band ia idx", i, "=", & + csr_intlc_5b_5b_ia(i) + end do + do i = 1, tridiag_ja_size, 1 + print *, "tridiag ja idx", i, "=", csr_tridiag_ja(i) + end do + do i = 1, band12345_ja_size, 1 + print *, "band12345 ja idx", i, "=", csr_banddiag5_12345_ja(i) + end do + do i = 1, band135_ja_size, 1 + print *, "band135 ja idx", i, "=", csr_banddiag5_135_ja(i) + end do + do i = 1, intlc_td_5d_ja_size, 1 + print *, "interlaced tridiag w/ 5-band ja idx", i, & + "=", csr_intlc_trid_5b_ja(i) + end do + do i = 1, intlc_s3d_5d_ja_size, 1 + print *, "interlaced spaced-3-band+5-band ja idx", i, & + "=", csr_intlc_s3b_f5b_ja(i) + end do + do i = 1, intlc_5d_5d_ja_size, 1 + print *, "interlaced 5-band w/ 5-band ja idx", i, "=", & + csr_intlc_5b_5b_ja(i) + end do + end if ! l_print_ia_ja + + end subroutine initialize_csr_matrix + +end module csr_matrix_module diff --git a/src/physics/clubb/diagnose_correlations_module.F90 b/src/physics/clubb/diagnose_correlations_module.F90 new file mode 100644 index 0000000000..52189773ef --- /dev/null +++ b/src/physics/clubb/diagnose_correlations_module.F90 @@ -0,0 +1,1041 @@ +!----------------------------------------------------------------------- +! $Id: diagnose_correlations_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module diagnose_correlations_module + + use clubb_precision, only: & + core_rknd + + implicit none + + public :: calc_mean, calc_varnce, calc_w_corr, & + calc_cholesky_corr_mtx_approx, & + cholesky_to_corr_mtx_approx, setup_corr_cholesky_mtx, & + diagnose_correlations + + + private :: diagnose_corr, rearrange_corr_array, & + corr_array_assertion_checks + + private ! Default scope + contains + +!----------------------------------------------------------------------- + subroutine diagnose_correlations( d_variables, corr_array_pre, & ! Intent(in) + corr_array ) ! Intent(out) + ! Description: + ! This subroutine diagnoses the correlation matrix in order to feed it + ! into SILHS microphysics. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! (see CLUBB Trac ticket#514) + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + +! use corr_varnce_module, only: & +! iiPDF_w ! Variable(s) + + use constants_clubb, only: & + zero + + use model_flags, only: & + l_calc_w_corr ! Flag(s) + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array_pre ! Prescribed correlations + + ! Output variables + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(out) :: & + corr_array + + ! Local Variables + real( kind = core_rknd ), dimension(d_variables, d_variables) :: & + corr_array_pre_swapped, & + corr_array_swapped + + ! We actually don't need this right now + real( kind = core_rknd ), dimension(d_variables) :: & + sigma2_on_mu2_ip_array ! Ratios: sigma_x^2/mu_x^2 (ith PDF comp.) ip [-] + + integer :: i ! Loop iterator + + !-------------------- Begin code -------------------- + + ! Initialize sigma2_on_mu2_ip_array + do i = 1, d_variables + sigma2_on_mu2_ip_array(i) = zero + end do + + ! Swap the w-correlations to the first row for the prescribed correlations + call rearrange_corr_array( d_variables, corr_array_pre, & ! Intent(in) + corr_array_pre_swapped) ! Intent(inout) + + ! diagnose correlations + + if ( .not. l_calc_w_corr ) then + corr_array_swapped = corr_array_pre_swapped + endif + + call diagnose_corr( d_variables, sqrt(sigma2_on_mu2_ip_array), & + corr_array_pre_swapped, & + corr_array_swapped ) + + ! Swap rows back + call rearrange_corr_array( d_variables, corr_array_swapped, & ! Intent(in) + corr_array) ! Intent(out) + + end subroutine diagnose_correlations + + + !----------------------------------------------------------------------- + subroutine diagnose_corr( n_variables, sqrt_sigma2_on_mu2_ip, & ! intent(in) + corr_matrix_prescribed, & !intent(in) + corr_matrix_approx ) ! intent(inout) + + ! Description: + ! This subroutine diagnoses the correlation matrix for each timestep. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! (see CLUBB Trac ticket#514) + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + +! use parameters_tunable, only: & +! alpha_corr ! Constant(s) + + use constants_clubb, only: & + max_mag_correlation + + implicit none + + intrinsic :: & + sqrt, abs, sign + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables), intent(in) :: & + sqrt_sigma2_on_mu2_ip ! sqrt of sigma_x^2/mu_x^2 (ith PDF comp.) ip [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix_prescribed ! correlation matrix [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(inout) :: & + corr_matrix_approx ! correlation matrix [-] + + + ! Local Variables + integer :: i, j ! Loop iterator + + real( kind = core_rknd ) :: & + f_ij +! f_ij_o + + real( kind = core_rknd ), dimension(n_variables) :: & + s_1j ! s_1j = sqrt(1-c_1j^2) + + + !-------------------- Begin code -------------------- + + ! Remove compiler warnings about unused variables. + if ( .false. ) then + print *, "sqrt_sigma2_on_mu2_ip = ", sqrt_sigma2_on_mu2_ip + endif + + ! calculate all square roots + do i = 1, n_variables + + s_1j(i) = sqrt(1._core_rknd-corr_matrix_approx(i,1)**2) + + end do + + + ! Diagnose the missing correlations (upper triangle) + do j = 2, (n_variables-1) + do i = (j+1), n_variables + + ! formula (16) in the ref. paper (Larson et al. (2011)) + !f_ij = alpha_corr * sqrt_sigma2_on_mu2_ip(i) * sqrt_sigma2_on_mu2_ip(j) & + ! * sign(1.0_core_rknd,corr_matrix_approx(1,i)*corr_matrix_approx(1,j)) + + ! If the predicting c1i's are small then cij will be closer to the prescribed value. If + ! the c1i's are bigger, then cij will be closer to formular (15) from the ref. paper. See + ! clubb:ticket:514:comment:61 for details. + !f_ij = (1-abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j)))*corr_matrix_prescribed(i,j) & + ! + abs(corr_matrix_approx(1,i)*corr_matrix_approx(1,j))*f_ij_o + + f_ij = corr_matrix_prescribed(i,j) + + ! make sure -1 < f_ij < 1 + if ( f_ij < -max_mag_correlation ) then + + f_ij = -max_mag_correlation + + else if ( f_ij > max_mag_correlation ) then + + f_ij = max_mag_correlation + + end if + + + ! formula (15) in the ref. paper (Larson et al. (2011)) + corr_matrix_approx(i,j) = corr_matrix_approx(i,1) * corr_matrix_approx(j,1) & + + f_ij * s_1j(i) * s_1j(j) + + end do ! do j + end do ! do i + + end subroutine diagnose_corr + + + !----------------------------------------------------------------------- + subroutine approx_w_corr( nz, d_variables, pdf_params, & ! Intent(in) + rrm, Nrm, Ncnm, & + stdev_w, sigma_rr_1, & + sigma_Nr_1, sigma_Ncn_1, & + corr_array) ! Intent(out) + ! Description: + ! Approximate the correlations of w with the hydrometeors. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use constants_clubb, only: & + one, & ! Constant(s) + rr_tol, & + Nr_tol, & + Ncn_tol, & + w_tol, & ! [m/s] + chi_tol ! [kg/kg] + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of diagnosed correlations + nz ! Number of model vertical grid levels + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg] + Nrm, & ! Mean rain drop concentration, < N_r > [num/kg] + Ncnm, & ! Mean cloud nuclei conc., < N_cn > [num/kg] + stdev_w ! Standard deviation of w [m/s] + + real( kind = core_rknd ), intent(in) :: & + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg] + sigma_Nr_1, & ! Standard deviation of Nr (2nd PDF component) [num/kg] + sigma_rr_1 ! Standard dev. of ln rr (1st PDF comp.) ip [ln(kg/kg)] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables, nz), intent(out) :: & + corr_array + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + corr_chi_w, & ! Correlation between w and chi(s_mellor) (both components) [-] + corr_wrr, & ! Correlation between w and rr (both components) [-] + corr_wNr, & ! Correlation between w and Nr (both components) [-] + corr_wNcn ! Correlation between w and Ncn (both components) [-] + + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zt, & ! Covariance of chi and w on the zt-grid [(m/s)(kg/kg)] + wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)] + wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)] + wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)] + + real( kind = core_rknd ) :: & + chi_m, & ! Mean of chi (s_mellor) [kg/kg] + stdev_chi ! Standard deviation of chi (s_mellor) [kg/kg] + + integer :: k ! vertical loop iterator + + ! ----- Begin Code ----- + + call approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, & ! Intent(in) + wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out) + + do k = 1, nz + + chi_m & + = calc_mean( pdf_params(k)%mixt_frac, pdf_params(k)%chi_1, & + pdf_params(k)%chi_2 ) + + stdev_chi & + = sqrt( pdf_params(k)%mixt_frac & + * ( ( pdf_params(k)%chi_1 - chi_m )**2 & + + pdf_params(k)%stdev_chi_1**2 ) & + + ( one - pdf_params(k)%mixt_frac ) & + * ( ( pdf_params(k)%chi_2 - chi_m )**2 & + + pdf_params(k)%stdev_chi_2**2 ) & + ) + + corr_chi_w(k) & + = calc_w_corr( wpchip_zt(k), stdev_w(k), stdev_chi, & + w_tol, chi_tol ) + + corr_wrr(k) & + = calc_w_corr( wprrp_zt(k), stdev_w(k), sigma_rr_1, w_tol, rr_tol ) + + corr_wNr(k) & + = calc_w_corr( wpNrp_zt(k), stdev_w(k), sigma_Nr_1, w_tol, Nr_tol ) + + corr_wNcn(k) & + = calc_w_corr( wpNcnp_zt(k), stdev_w(k), sigma_Ncn_1, w_tol, Ncn_tol ) + + enddo + + call set_w_corr( nz, d_variables, & ! Intent(in) + corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, & + corr_array ) ! Intent(inout) + + end subroutine approx_w_corr + + + !----------------------------------------------------------------------- + subroutine approx_w_covar( nz, pdf_params, rrm, Nrm, Ncnm, & ! Intent(in) + wpchip_zt, wprrp_zt, wpNrp_zt, wpNcnp_zt ) ! Intent(out) + ! Description: + ! Approximate the covariances of w with the hydrometeors using Eddy + ! diffusivity. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use parameters_tunable, only: & + c_K_hm ! Variable(s) + + use constants_clubb, only: & + one ! Constant(s) + + use advance_windm_edsclrm_module, only: & + xpwp_fnc ! Procedure(s) + + use variables_diagnostic_module, only: & + Kh_zm ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rrm, & ! Mean rain water mixing ratio, < r_r > [kg/kg] + Nrm, & ! Mean rain drop concentration, < N_r > [num/kg] + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + wpchip_zt, & ! Covariance of chi(s) and w on the zt-grid [(m/s)(kg/kg)] + wprrp_zt, & ! Covariance of r_r and w on the zt-grid [(m/s)(kg/kg)] + wpNrp_zt, & ! Covariance of N_r and w on the zt-grid [(m/s)(#/kg)] + wpNcnp_zt ! Covariance of N_cn and w on the zt-grid [(m/s)(#/kg)] + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zm, & ! Covariance of chi(s) and w on the zm-grid [(m/s)(kg/kg)] + wprrp_zm, & ! Covariance of r_r and w on the zm-grid [(m/s)(kg/kg)] + wpNrp_zm, & ! Covariance of N_r and w on the zm-grid [(m/s)(#/kg)] + wpNcnp_zm ! Covariance of N_cn and w on the zm-grid [(m/s)(#/kg)] + + integer :: k ! vertical loop iterator + + ! ----- Begin Code ----- + + ! calculate the covariances of w with the hydrometeors + do k = 1, nz + wpchip_zm(k) = pdf_params(k)%mixt_frac & + * ( one - pdf_params(k)%mixt_frac ) & + * ( pdf_params(k)%chi_1 - pdf_params(k)%chi_2 ) & + * ( pdf_params(k)%w_1 - pdf_params(k)%w_2 ) + enddo + +! same for wpNrp +! wprrp_zm(1:nz-1) & +! = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & +! rrm(1:nz-1) / max( precip_frac(1:nz-1), eps ), & +! rrm(2:nz) / max( precip_frac(2:nz), eps ), & +! gr%invrs_dzm(1:nz-1) ) + + wprrp_zm(1:nz-1) & + = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & + rrm(1:nz-1), rrm(2:nz), & + gr%invrs_dzm(1:nz-1) ) + + wpNrp_zm(1:nz-1) & + = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), & + Nrm(1:nz-1), Nrm(2:nz), & + gr%invrs_dzm(1:nz-1) ) + + wpNcnp_zm(1:nz-1) = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), Ncnm(1:nz-1), & + Ncnm(2:nz), gr%invrs_dzm(1:nz-1) ) + + ! Boundary conditions; We are assuming constant flux at the top. + wprrp_zm(nz) = wprrp_zm(nz-1) + wpNrp_zm(nz) = wpNrp_zm(nz-1) + wpNcnp_zm(nz) = wpNcnp_zm(nz-1) + + ! interpolate back to zt-grid + wpchip_zt = zm2zt(wpchip_zm) + wprrp_zt = zm2zt(wprrp_zm) + wpNrp_zt = zm2zt(wpNrp_zm) + wpNcnp_zt = zm2zt(wpNcnp_zm) + + end subroutine approx_w_covar + + !----------------------------------------------------------------------- + function calc_w_corr( wpxp, stdev_w, stdev_x, w_tol, x_tol ) + ! Description: + ! Compute the correlations of w with the hydrometeors. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + max_mag_correlation + + implicit none + + intrinsic :: max + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + stdev_w, & ! standard deviation of w [m/s] + stdev_x, & ! standard deviation of x [units vary] + wpxp, & ! Covariances of w with the hydrometeors [units vary] + w_tol, & ! tolerance for w [m/s] + x_tol ! tolerance for x [units vary] + + real( kind = core_rknd ) :: & + calc_w_corr + + ! --- Begin Code --- + + calc_w_corr = wpxp / ( max(stdev_x, x_tol) * max(stdev_w, w_tol) ) + + ! Make sure the correlation is in [-1,1] + if ( calc_w_corr < -max_mag_correlation ) then + + calc_w_corr = -max_mag_correlation + + else if ( calc_w_corr > max_mag_correlation ) then + + calc_w_corr = max_mag_correlation + + end if + + end function calc_w_corr + + + !----------------------------------------------------------------------- + function calc_varnce( mixt_frac, x1, x2, xm, x1p2, x2p2 ) + + ! Description: + ! Calculate the variance xp2 from the components x1, x2. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02, + ! page 3535 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mixt_frac, & ! mixing ratio [-] + x1, & ! first component of the double gaussian [units vary] + x2, & ! second component of the double gaussian [units vary] + xm, & ! mean of x [units vary] + x1p2, & ! variance of the first component [units vary] + x2p2 ! variance of the second component [units vary] + + ! Return Variable + real( kind = core_rknd ) :: & + calc_varnce ! variance of x (both components) [units vary] + + ! --- Begin Code --- + + calc_varnce & + = mixt_frac * ( ( x1 - xm )**2 + x1p2 ) & + + ( 1.0_core_rknd - mixt_frac ) * ( ( x2 - xm )**2 + x2p2 ) + + return + end function calc_varnce + + !----------------------------------------------------------------------- + function calc_mean( mixt_frac, x1, x2 ) + + ! Description: + ! Calculate the mean xm from the components x1, x2. + + ! References: + ! Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02, + ! page 3535 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mixt_frac, & ! mixing ratio [-] + x1, & ! first component of the double gaussian [units vary] + x2 ! second component of the double gaussian [units vary] + + ! Return Variable + real( kind = core_rknd ) :: & + calc_mean ! mean of x (both components) [units vary] + + ! --- Begin Code --- + + calc_mean = mixt_frac * x1 + (1.0_core_rknd - mixt_frac) * x2 + + return + end function calc_mean + + + !----------------------------------------------------------------------- + subroutine calc_cholesky_corr_mtx_approx & + ( n_variables, corr_matrix, & ! intent(in) + corr_cholesky_mtx, corr_mtx_approx ) ! intent(out) + + ! Description: + ! This subroutine calculates the transposed correlation cholesky matrix + ! from the correlation matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + zero ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix ! correlation matrix [-] + + ! Output Variables + + ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10 + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_cholesky_mtx, & ! Transposed correlation cholesky matrix [-] + corr_mtx_approx ! Approximated correlation matrix (C = LL') [-] + + ! Local Variables + integer :: i, j ! Loop iterators + + ! Swapped means that the w-correlations are swapped to the first row + real( kind = core_rknd ), dimension(n_variables,n_variables) :: & + corr_cholesky_mtx_swap, & ! Swapped correlation cholesky matrix [-] + corr_mtx_approx_swap, & ! Swapped correlation matrix (approx.) [-] + corr_mtx_swap ! Swapped correlation matrix [-] + + !-------------------- Begin code -------------------- + + call rearrange_corr_array( n_variables, corr_matrix, & ! Intent(in) + corr_mtx_swap ) ! Intent(inout) + + call setup_corr_cholesky_mtx( n_variables, corr_mtx_swap, & ! intent(in) + corr_cholesky_mtx_swap ) ! intent(out) + + call rearrange_corr_array( n_variables, corr_cholesky_mtx_swap, & ! Intent(in) + corr_cholesky_mtx ) ! Intent(inout) + + call cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_swap, & ! intent(in) + corr_mtx_approx_swap ) ! intent(out) + + call rearrange_corr_array( n_variables, corr_mtx_approx_swap, & ! Intent(in) + corr_mtx_approx ) ! Intent(inout) + + call corr_array_assertion_checks( n_variables, corr_mtx_approx ) + + ! Set lower triangle to zero for conformity + do i = 2, n_variables + do j = 1, i-1 + corr_mtx_approx(j,i) = zero + end do + end do + + return + + end subroutine calc_cholesky_corr_mtx_approx + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine setup_corr_cholesky_mtx( n_variables, corr_matrix, & ! intent(in) + corr_cholesky_mtx_t ) ! intent(out) + + ! Description: + ! This subroutine calculates the transposed correlation cholesky matrix + ! from the correlation matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + zero, & ! Variable(s) + one + + implicit none + + intrinsic :: sqrt + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_matrix ! correlation matrix [-] + + ! Output Variables + + ! correlation cholesky matrix transposed L', C = LL'; see reference 1 formula 10 + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-] + + ! Local Variables + integer :: i, j, k ! Loop iterators + + real( kind = core_rknd ), dimension(n_variables, n_variables) :: & + s ! s(i,j) = sqrt(1-c(i,j)^2); see ref 1 + + !-------------------- Begin code -------------------- + + ! calculate all necessary square roots + do i = 1, n_variables-1 + do j = i+1, n_variables + + s(j,i) = sqrt(1._core_rknd - corr_matrix(j,i)**2) + + end do + end do + + !!! calculate transposed correlation cholesky matrix; ref 1 formula 10 + + ! initialize matrix to zero + do i = 1, n_variables + do j = 1, n_variables + + corr_cholesky_mtx_t(j,i) = zero + + end do + end do + + ! initialize upper triangle and diagonal to one + do i = 1, n_variables + do j = i, n_variables + + corr_cholesky_mtx_t(j,i) = one + + end do + end do + + ! set diagonal elements + do j = 2, n_variables + do i = 1, j-1 + + corr_cholesky_mtx_t(j,j) = corr_cholesky_mtx_t(j,j)*s(j,i) + ! print *, "s(", j, ",", i, ") = ", s(j,i) + + end do + end do + + ! set first row + do j = 2, n_variables + + corr_cholesky_mtx_t(j,1) = corr_matrix(j,1) + + end do + + ! set upper triangle + do i = 2, n_variables-1 + do j = i+1, n_variables + do k = 1, i-1 + + corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*s(j,k) + + end do + + corr_cholesky_mtx_t(j,i) = corr_cholesky_mtx_t(j,i)*corr_matrix(j,i) + + end do + end do + + return + + end subroutine setup_corr_cholesky_mtx + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine cholesky_to_corr_mtx_approx( n_variables, corr_cholesky_mtx_t, & ! intent(in) + corr_matrix_approx ) ! intent(out) + + ! Description: + ! This subroutine approximates the correlation matrix from the correlation + ! cholesky matrix + ! + ! References: + ! 1 Larson et al. (2011), J. of Geophysical Research, Vol. 116, D00T02 + ! 2 CLUBB Trac ticket#514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + intrinsic :: matmul, transpose + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_cholesky_mtx_t ! transposed correlation cholesky matrix [-] + + ! Output Variables + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(out) :: & + corr_matrix_approx ! correlation matrix [-] + + !-------------------- Begin code -------------------- + + ! approximate the correlation matrix; see ref 1 formula (8) + corr_matrix_approx = matmul(corr_cholesky_mtx_t, transpose(corr_cholesky_mtx_t)) + + return + + end subroutine cholesky_to_corr_mtx_approx + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine corr_array_assertion_checks( n_variables, corr_array ) + + ! Description: + ! This subroutine does the assertion checks for the corr_array. + + ! References: + ! + ! + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + max_mag_correlation ! Variable(s) + + use constants_clubb, only: & + one ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_variables ! number of variables in the correlation matrix [-] + + real( kind = core_rknd ), dimension(n_variables,n_variables), intent(in) :: & + corr_array ! correlation matrix [-] + + ! Local Variables + integer :: i, j ! Loop iterator + + real( kind = core_rknd ), parameter :: & + tol = 1.e-6_core_rknd ! Maximum acceptable tolerance for the difference of the diagonal + ! elements of corr_array to one + + !-------------------- Begin code -------------------- + + if ( clubb_at_least_debug_level( 1 ) ) then + + do i = 1, n_variables - 1 + do j = i+1, n_variables + + ! Check if upper and lower triangle values are within the correlation boundaries + if ( ( corr_array(i,j) < -max_mag_correlation ) & + .or. ( corr_array(i,j) > max_mag_correlation ) & + .or. ( corr_array(j,i) < -max_mag_correlation ) & + .or. ( corr_array(j,i) > max_mag_correlation ) ) & + then + + stop "Error: A value in the correlation matrix is out of range." + + endif + + enddo + enddo + + endif + + if ( clubb_at_least_debug_level( 2 ) ) then + + do i = 1, n_variables + ! Check if the diagonal elements are one (up to a tolerance) + if ( ( corr_array(i,i) > one + tol ) .or. (corr_array(i,i) < one - tol ) ) then + + stop "Error: Diagonal element(s) of the correlation matrix are unequal to one." + + endif + enddo + + endif + + return + + end subroutine corr_array_assertion_checks + + +!----------------------------------------------------------------------- + subroutine rearrange_corr_array( d_variables, corr_array, & ! Intent(in) + corr_array_swapped) ! Intent(out) + ! Description: + ! This subroutine swaps the w-correlations to the first row if the input + ! matrix is in the same order as the *_corr_array_cloud.in files. It swaps + ! the rows back to the order of the *_corr_array_cloud.in files if the + ! input matrix is already swapped (first row w-correlations). + ! + ! References: + ! + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w ! Variable(s) + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array ! Correlation matrix + + ! Output variables + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(out) :: & + corr_array_swapped ! Swapped correlation matrix + + ! Local Variables + real( kind = core_rknd ), dimension(d_variables) :: & + swap_array + + !-------------------- Begin code -------------------- + + + ! Swap the w-correlations to the first row for the prescribed correlations + corr_array_swapped = corr_array + swap_array = corr_array_swapped (:,1) + corr_array_swapped(1:iiPDF_w, 1) = corr_array_swapped(iiPDF_w, iiPDF_w:1:-1) + corr_array_swapped((iiPDF_w+1):d_variables, 1) = corr_array_swapped( & + (iiPDF_w+1):d_variables, iiPDF_w) + corr_array_swapped(iiPDF_w, 1:iiPDF_w) = swap_array(iiPDF_w:1:-1) + corr_array_swapped((iiPDF_w+1):d_variables, iiPDF_w) = swap_array((iiPDF_w+1):d_variables) + + return + + end subroutine rearrange_corr_array + !----------------------------------------------------------------------- + + + !----------------------------------------------------------------------- + subroutine set_w_corr( nz, d_variables, & ! Intent(in) + corr_chi_w, corr_wrr, corr_wNr, corr_wNcn, & + corr_array ) ! Intent(inout) + + ! Description: + ! Set the first row of corr_array to the according w-correlations. + + ! References: + ! clubb:ticket:514 + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_rr, & + iiPDF_Nr, & + iiPDF_Ncn + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of Variables to be diagnosed + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + corr_chi_w, & ! Correlation between chi (s) & w (both components) [-] + corr_wrr, & ! Correlation between rr & w (both components) [-] + corr_wNr, & ! Correlation between Nr & w (both components) [-] + corr_wNcn ! Correlation between Ncn & w (both components) [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables, nz), & + intent(inout) :: & + corr_array + + ! ----- Begin Code ----- + + corr_array(iiPDF_w, iiPDF_chi, :) = corr_chi_w + corr_array(iiPDF_w, iiPDF_rr, :) = corr_wrr + corr_array(iiPDF_w, iiPDF_Nr, :) = corr_wNr + corr_array(iiPDF_w, iiPDF_Ncn, :) = corr_wNcn + + end subroutine set_w_corr + + !============================================================================= + subroutine unpack_correlations( d_variables, corr_array, & ! Intent(in) + corr_w_chi, corr_wrr, corr_wNr, corr_wNcn, & + corr_chi_eta, corr_chi_rr, corr_chi_Nr, corr_chi_Ncn, & + corr_eta_rr, corr_eta_Nr, corr_eta_Ncn, corr_rrNr ) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_rr, & + iiPDF_Nr, & + iiPDF_Ncn + + implicit none + + intrinsic :: max, sqrt, transpose + + ! Input Variables + integer, intent(in) :: & + d_variables ! number of diagnosed correlations + + real( kind = core_rknd ), dimension(d_variables, d_variables), intent(in) :: & + corr_array ! Prescribed correlations + + ! Output variables + real( kind = core_rknd ), intent(out) :: & + corr_w_chi, & ! Correlation between w and chi(s) (1st PDF component) [-] + corr_wrr, & ! Correlation between w and rr (1st PDF component) ip [-] + corr_wNr, & ! Correlation between w and Nr (1st PDF component) ip [-] + corr_wNcn, & ! Correlation between w and Ncn (1st PDF component) [-] + corr_chi_eta, & ! Correlation between chi(s) and eta(t) (1st PDF component) [-] + corr_chi_rr, & ! Correlation between chi(s) and rr (1st PDF component) ip [-] + corr_chi_Nr, & ! Correlation between chi(s) and Nr (1st PDF component) ip [-] + corr_chi_Ncn, & ! Correlation between chi(s) and Ncn (1st PDF component) [-] + corr_eta_rr, & ! Correlation between eta(t) and rr (1st PDF component) ip [-] + corr_eta_Nr, & ! Correlation between eta(t) and Nr (1st PDF component) ip [-] + corr_eta_Ncn, & ! Correlation between (t) and Ncn (1st PDF component) [-] + corr_rrNr ! Correlation between rr & Nr (1st PDF component) ip [-] + + ! ---- Begin Code ---- + +! corr_w_chi = corr_array(iiPDF_w, iiPDF_chi) +! corr_wrr = corr_array(iiPDF_w, iiPDF_rr) +! corr_wNr = corr_array(iiPDF_w, iiPDF_Nr) +! corr_wNcn = corr_array(iiPDF_w, iiPDF_Ncn) +! corr_chi_eta = corr_array(iiPDF_chi, iiPDF_eta) +! corr_chi_rr = corr_array(iiPDF_chi, iiPDF_rr) +! corr_chi_Nr = corr_array(iiPDF_chi, iiPDF_Nr) +! corr_chi_Ncn = corr_array(iiPDF_chi, iiPDF_Ncn) +! corr_eta_rr = corr_array(iiPDF_eta, iiPDF_rr) +! corr_eta_Nr = corr_array(iiPDF_eta, iiPDF_Nr) +! corr_eta_Ncn = corr_array(iiPDF_eta, iiPDF_Ncn) +! corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr) + + corr_w_chi = corr_array(iiPDF_chi, iiPDF_w) + corr_wrr = corr_array(iiPDF_rr, iiPDF_w) + corr_wNr = corr_array(iiPDF_Nr, iiPDF_w) + corr_wNcn = corr_array(iiPDF_Ncn, iiPDF_w) + corr_chi_eta = corr_array(iiPDF_eta, iiPDF_chi) + corr_chi_rr = corr_array(iiPDF_rr, iiPDF_chi) + corr_chi_Nr = corr_array(iiPDF_Nr, iiPDF_chi) + corr_chi_Ncn = corr_array(iiPDF_Ncn, iiPDF_chi) + corr_eta_rr = corr_array(iiPDF_rr, iiPDF_eta) + corr_eta_Nr = corr_array(iiPDF_Nr, iiPDF_eta) + corr_eta_Ncn = corr_array(iiPDF_Ncn, iiPDF_eta) + corr_rrNr = corr_array(iiPDF_rr, iiPDF_Nr) + + end subroutine unpack_correlations + +!=============================================================================== + +end module diagnose_correlations_module diff --git a/src/physics/clubb/diffusion.F90 b/src/physics/clubb/diffusion.F90 new file mode 100644 index 0000000000..e0caa3c412 --- /dev/null +++ b/src/physics/clubb/diffusion.F90 @@ -0,0 +1,801 @@ +!----------------------------------------------------------------------- +! $Id: diffusion.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module diffusion + + ! Description: + ! Module diffusion computes the eddy diffusion terms for all of the + ! time-tendency (prognostic) equations in the CLUBB parameterization. Most of + ! the eddy diffusion terms are solved for completely implicitly, and therefore + ! become part of the left-hand side of their respective equations. However, + ! wp2 and wp3 have an option to use a Crank-Nicholson eddy diffusion scheme, + ! which has both implicit and explicit components. + ! + ! Function diffusion_zt_lhs handles the eddy diffusion terms for the variables + ! located at thermodynamic grid levels. These variables are: wp3 and all + ! hydrometeor species. The variables um and vm also use the Crank-Nicholson + ! eddy-diffusion scheme for their turbulent advection term. + ! + ! Function diffusion_zm_lhs handles the eddy diffusion terms for the variables + ! located at momentum grid levels. The variables are: wprtp, wpthlp, wp2, + ! rtp2, thlp2, rtpthlp, up2, vp2, wpsclrp, sclrprtp, sclrpthlp, and sclrp2. + + implicit none + + private ! Default Scope + + public :: diffusion_zt_lhs, & + diffusion_cloud_frac_zt_lhs, & + diffusion_zm_lhs + + contains + + !============================================================================= + pure function diffusion_zt_lhs( K_zm, K_zmm1, nu, & + invrs_dzmm1, invrs_dzm, & + invrs_dzt, level ) & + result( lhs ) + + ! Description: + ! Vertical eddy diffusion of var_zt: implicit portion of the code. + ! + ! The variable "var_zt" stands for a variable that is located at + ! thermodynamic grid levels. + ! + ! The d(var_zt)/dt equation contains an eddy diffusion term: + ! + ! + d [ ( K_zm + nu ) * d(var_zt)/dz ] / dz. + ! + ! This term is usually solved for completely implicitly, such that: + ! + ! + d [ ( K_zm + nu ) * d( var_zt(t+1) )/dz ] / dz. + ! + ! However, when a Crank-Nicholson scheme is used, the eddy diffusion term + ! has both implicit and explicit components, such that: + ! + ! + (1/2) * d [ ( K_zm + nu ) * d( var_zt(t+1) )/dz ] / dz + ! + (1/2) * d [ ( K_zm + nu ) * d( var_zt(t) )/dz ] / dz; + ! + ! for which the implicit component is: + ! + ! + (1/2) * d [ ( K_zm + nu ) * d( var_zt(t+1) )/dz ] / dz. + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "+" in front of the term + ! is changed to a "-". + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(var_zt)/dt equation. + ! + ! The implicit portion of this term is discretized as follows: + ! + ! The values of var_zt are found on the thermodynamic levels, while the + ! values of K_zm are found on the momentum levels. The derivatives (d/dz) + ! of var_zt are taken over the intermediate momentum levels. At the + ! intermediate momentum levels, d(var_zt)/dz is multiplied by ( K_zm + nu ). + ! Then, the derivative of the whole mathematical expression is taken over + ! the central thermodynamic level, which yields the desired result. + ! + ! --var_ztp1----------------------------------------------- t(k+1) + ! + ! ==========d(var_zt)/dz==(K_zm+nu)======================== m(k) + ! + ! --var_zt-------------------d[(K_zm+nu)*d(var_zt)/dz]/dz-- t(k) + ! + ! ==========d(var_zt)/dz==(K_zmm1+nu)====================== m(k-1) + ! + ! --var_ztm1----------------------------------------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + ! invrs_dzm(k-1) = 1 / ( zt(k) - zt(k-1) ) + ! + ! Note: This function only computes the general implicit form: + ! + d [ ( K_zm + nu ) * d( var_zt(t+1) )/dz ] / dz. + ! For a Crank-Nicholson scheme, the left-hand side result of this + ! function will have to be multiplied by (1/2). For a + ! Crank-Nicholson scheme, the right-hand side (explicit) component + ! needs to be computed by multiplying the left-hand side results by + ! (1/2), reversing the sign on each left-hand side element, and then + ! multiplying each element by the appropriate var_zt(t) value from + ! the appropriate vertical level. + ! + ! + ! Boundary Conditions: + ! + ! 1) Zero-flux boundary conditions. + ! This function is set up to use zero-flux boundary conditions at both + ! the lower boundary level and the upper boundary level. The flux, F, + ! is the amount of var_zt flowing normal through the boundary per unit + ! time per unit surface area. The derivative of the flux effects the + ! time-tendency of var_zt, such that: + ! + ! d(var_zt)/dt = -dF/dz. + ! + ! For the 2nd-order eddy-diffusion term, +d[(K_zm+nu)*d(var_zt)/dz]/dz, + ! the flux is: + ! + ! F = -(K_zm+nu)*d(var_zt)/dz. + ! + ! In order to have zero-flux boundary conditions, the derivative of + ! var_zt, d(var_zt)/dz, needs to equal 0 at both the lower boundary and + ! the upper boundary. + ! + ! In order to discretize the lower boundary condition, consider a new + ! level outside the model (thermodynamic level 0) just below the lower + ! boundary level (thermodynamic level 1). The value of var_zt at the + ! level just outside the model is defined to be the same as the value of + ! var_zt at the lower boundary level. Therefore, the value of + ! d(var_zt)/dz between the level just outside the model and the lower + ! boundary level is 0, satisfying the zero-flux boundary condition. The + ! other value for d(var_zt)/dz (between thermodynamic level 2 and + ! thermodynamic level 1) is taken over the intermediate momentum level + ! (momentum level 1), where it is multiplied by the factor + ! ( K_zm(1) + nu ). Then, the derivative of the whole expression is + ! taken over the central thermodynamic level. + ! + ! -var_zt(2)-------------------------------------------- t(2) + ! + ! ==========d(var_zt)/dz==(K_zm(1)+nu)================== m(1) + ! + ! -var_zt(1)---------------d[(K_zm+nu)*d(var_zt)/dz]/dz- t(1) Boundary + ! + ! [d(var_zt)/dz = 0] + ! + ! -[var_zt(0) = var_zt(1)]-----(level outside model)---- t(0) + ! + ! The result is dependent only on values of K_zm found at momentum + ! level 1 and values of var_zt found at thermodynamic levels 1 and 2. + ! Thus, it only affects 2 diagonals on the left-hand side matrix. + ! + ! The same method can be used to discretize the upper boundary by + ! considering a new level outside the model just above the upper boundary + ! level. + ! + ! 2) Fixed-point boundary conditions. + ! Many equations in the model use fixed-point boundary conditions rather + ! than zero-flux boundary conditions. This means that the value of + ! var_zt stays the same over the course of the timestep at the lower + ! boundary, as well as at the upper boundary. + ! + ! In order to discretize the boundary conditions for equations requiring + ! fixed-point boundary conditions, either: + ! a) in the parent subroutine or function (that calls this function), + ! loop over all vertical levels from the second-lowest to the + ! second-highest, ignoring the boundary levels. Then set the values + ! at the boundary levels in the parent subroutine; or + ! b) in the parent subroutine or function, loop over all vertical levels + ! and then overwrite the results at the boundary levels. + ! + ! Either way, at the boundary levels, an array with a value of 1 at the + ! main diagonal on the left-hand side and with values of 0 at all other + ! diagonals on the left-hand side will preserve the right-hand side value + ! at that level, thus satisfying the fixed-point boundary conditions. + ! + ! + ! Conservation Properties: + ! + ! When zero-flux boundary conditions are used, this technique of + ! discretizing the eddy diffusion term leads to conservative differencing. + ! When conservative differencing is in place, the column totals for each + ! column in the left-hand side matrix (for the eddy diffusion term) should + ! be equal to 0. This ensures that the total amount of the quantity var_zt + ! over the entire vertical domain is being conserved, meaning that nothing + ! is lost due to diffusional effects. + ! + ! To see that this conservation law is satisfied, compute the eddy diffusion + ! of var_zt and integrate vertically. In discretized matrix notation (where + ! "i" stands for the matrix column and "j" stands for the matrix row): + ! + ! 0 = Sum_j Sum_i ( 1/invrs_dzt )_i + ! ( invrs_dzt * ((K_zm+nu)*invrs_dzm) )_ij (var_zt)_j. + ! + ! The left-hand side matrix, ( invrs_dzt * ((K_zm+nu)*invrs_dzm) )_ij, is + ! partially written below. The sum over i in the above equation removes + ! invrs_dzt everywhere from the matrix below. The sum over j leaves the + ! column totals that are desired. + ! + ! Left-hand side matrix contributions from eddy diffusion term; first four + ! vertical levels: + ! + ! --------------------------------------------------------------------------> + !k=1 | +invrs_dzt(k) -invrs_dzt(k) 0 + ! | *(K_zm(k)+nu) *(K_zm(k)+nu) + ! | *invrs_dzm(k) *invrs_dzm(k) + ! | + !k=2 | -invrs_dzt(k) +invrs_dzt(k) -invrs_dzt(k) + ! | *(K_zm(k-1)+nu) *[ (K_zm(k)+nu) *(K_zm(k)+nu) + ! | *invrs_dzm(k-1) *invrs_dzm(k) *invrs_dzm(k) + ! | +(K_zm(k-1)+nu) + ! | *invrs_dzm(k-1) ] + ! | + !k=3 | 0 -invrs_dzt(k) +invrs_dzt(k) + ! | *(K_zm(k-1)+nu) *[ (K_zm(k)+nu) + ! | *invrs_dzm(k-1) *invrs_dzm(k) + ! | +(K_zm(k-1)+nu) + ! | *invrs_dzm(k-1) ] + ! | + !k=4 | 0 0 -invrs_dzt(k) + ! | *(K_zm(k-1)+nu) + ! | *invrs_dzm(k-1) + ! \ / + ! + ! Note: The superdiagonal term from level 3 and both the main diagonal and + ! superdiagonal terms from level 4 are not shown on this diagram. + ! + ! Note: The matrix shown is a tridiagonal matrix. For a band diagonal + ! matrix (with 5 diagonals), there would be an extra row between each + ! of the rows shown and an extra column between each of the columns + ! shown. However, for the purposes of the var_zt eddy diffusion + ! term, those extra row and column values are all 0, and the + ! conservation properties of the matrix aren't effected. + ! + ! If fixed-point boundary conditions are used, the matrix entries at + ! level 1 (k=1) read: 1 0 0; which means that conservative differencing + ! is not in play. The total amount of var_zt over the entire vertical + ! domain is not being conserved, as amounts of var_zt may be fluxed out + ! through the upper boundary or lower boundary through the effects of + ! diffusion. + ! + ! Brian Griffin. April 26, 2008. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + K_zm, & ! Coef. of eddy diffusivity at momentum level (k) [m^2/s] + K_zmm1, & ! Coef. of eddy diffusivity at momentum level (k-1) [m^2/s + invrs_dzt, & ! Inverse of grid spacing over thermo. level (k) [1/m] + invrs_dzm, & ! Inverse of grid spacing over momentum level (k) [1/m] + invrs_dzmm1 ! Inverse of grid spacing over momentum level (k-1) [1/m] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + nu ! Background constant coef. of eddy diffusivity [m^2/s] + + integer, intent(in) :: & + level ! Thermodynamic level where calculation occurs. [-] + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + if ( level == 1 ) then + + ! k = 1 (bottom level); lower boundary level. + ! Only relevant if zero-flux boundary conditions are used. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) = - invrs_dzt * (K_zm+nu(1)) * invrs_dzm + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) = + invrs_dzt * (K_zm+nu(1)) * invrs_dzm + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) = 0.0_core_rknd + + + elseif ( level > 1 .and. level < gr%nz ) then + + ! Most of the interior model; normal conditions. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) = - invrs_dzt * (K_zm+nu(level)) * invrs_dzm + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) = + invrs_dzt * ( (K_zm+nu(level))*invrs_dzm & + + (K_zmm1+nu(level))*invrs_dzmm1 ) + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) = - invrs_dzt * (K_zmm1+nu(level)) * invrs_dzmm1 + + elseif ( level == gr%nz ) then + + ! k = gr%nz (top level); upper boundary level. + ! Only relevant if zero-flux boundary conditions are used. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) = 0.0_core_rknd + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) = + invrs_dzt * (K_zmm1+nu(gr%nz)) * invrs_dzmm1 + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) = - invrs_dzt * (K_zmm1+nu(gr%nz)) * invrs_dzmm1 + + + endif + + end function diffusion_zt_lhs + + !============================================================================= + pure function diffusion_cloud_frac_zt_lhs & + ( K_zm, K_zmm1, cloud_frac_zt, cloud_frac_ztm1, & + cloud_frac_ztp1, cloud_frac_zm, & + cloud_frac_zmm1, & + nu, invrs_dzmm1, invrs_dzm, invrs_dzt, level ) & + result( lhs ) + + ! Description: + ! This function adds a weight of cloud fraction to the existing diffusion + ! function for number concentration variables (e.g. cloud droplet number + ! concentration). This code should be considered experimental and may + ! contain bugs. + ! References: + ! This algorithm uses equations derived from Guo, et al. 2009. + !----------------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: min + + ! Constant parameters + real( kind = core_rknd ), parameter :: & + cf_ratio = 10._core_rknd ! Maximum cloud-fraction coefficient applied to Kh_zm + + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + K_zm, & ! Coef. of eddy diffusivity at mom. level (k) [m^2/s] + K_zmm1, & ! Coef. of eddy diffusivity at mom. level (k-1) [m^2/s] + cloud_frac_zt, & ! Cloud fraction at the thermo. level (k) [-] + cloud_frac_ztm1, & ! Cloud fraction at the thermo. level (k-1) [-] + cloud_frac_ztp1, & ! Cloud fraction at the thermo. level (k+1) [-] + cloud_frac_zm, & ! Cloud fraction at the momentum level (k) [-] + cloud_frac_zmm1, & ! Cloud fraction at the momentum level (k-1) [-] + invrs_dzt, & ! Inverse of grid spacing over thermo. lev. (k) [1/m] + invrs_dzm, & ! Inverse of grid spacing over mom. level (k) [1/m] + invrs_dzmm1 ! Inverse of grid spacing over mom. level (k-1) [1/m] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + nu ! Background constant coef. of eddy diffusivity [m^2/s] + + integer, intent(in) :: & + level ! Thermodynamic level where calculation occurs. [-] + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + ! ---- Begin Code ---- + + if ( level == 1 ) then + + ! k = 1 (bottom level); lower boundary level. + ! Only relevant if zero-flux boundary conditions are used. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] +! lhs(kp1_tdiag) = - invrs_dzt & +! * (K_zm+nu) & +! * ( cloud_frac_zm / cloud_frac_ztp1 ) * invrs_dzm + lhs(kp1_tdiag) = - invrs_dzt & + * (K_zm & + * min( cloud_frac_zm / cloud_frac_ztp1, cf_ratio ) & + + nu(1)) * invrs_dzm + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] +! lhs(k_tdiag) = + invrs_dzt & +! * (K_zm+nu) & +! * ( cloud_frac_zm / cloud_frac_ztp1 ) * invrs_dzm + lhs(k_tdiag) = + invrs_dzt & + * (K_zm & + * min( cloud_frac_zm / cloud_frac_ztp1, cf_ratio ) & + + nu(1)) * invrs_dzm + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) = 0.0_core_rknd + + + else if ( level > 1 .and. level < gr%nz ) then + + ! Most of the interior model; normal conditions. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] +! lhs(kp1_tdiag) = - invrs_dzt & +! * (K_zm+nu) & +! * ( cloud_frac_zm / cloud_frac_ztp1 ) * invrs_dzm +! lhs(kp1_tdiag) = - invrs_dzt & +! * (K_zm & +! * ( cloud_frac_zm / cloud_frac_ztp1 ) & +! + nu ) * invrs_dzm + lhs(kp1_tdiag) = - invrs_dzt & + * (K_zm & + * min( cloud_frac_zm / cloud_frac_ztp1, cf_ratio ) & + + nu(level) ) * invrs_dzm + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] +! lhs(k_tdiag) = + invrs_dzt & +! * ( ((K_zm+nu)*cloud_frac_zm)*invrs_dzm & +! + ((K_zmm1+nu)*cloud_frac_zmm1)*invrs_dzmm1 ) & +! / cloud_frac_zt +! lhs(k_tdiag) = + invrs_dzt & +! * ( nu*(invrs_dzm+invrs_dzmm1) + & +! ( ((K_zm*cloud_frac_zm)*invrs_dzm + +! (K_zmm1*cloud_frac_zmm1)*invrs_dzmm1)& +! / cloud_frac_zt & +! ) & +! ) + lhs(k_tdiag) = + invrs_dzt & + * ( nu(level)*(invrs_dzm+invrs_dzmm1) + & + ( K_zm*invrs_dzm* & + min( cloud_frac_zm / cloud_frac_zt, & + cf_ratio ) & + + K_zmm1*invrs_dzmm1* & + min( cloud_frac_zmm1 / cloud_frac_zt, & + cf_ratio ) & + ) & + ) + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] +! lhs(km1_tdiag) = - invrs_dzt * (K_zmm1+nu) * & +! ( cloud_frac_zmm1 / cloud_frac_ztm1 ) * invrs_dzmm1 + lhs(km1_tdiag) = - invrs_dzt & + * (K_zmm1 & + * min( cloud_frac_zmm1 / cloud_frac_ztm1, & + cf_ratio ) & + + nu(level) ) * invrs_dzmm1 + + else if ( level == gr%nz ) then + + ! k = gr%nz (top level); upper boundary level. + ! Only relevant if zero-flux boundary conditions are used. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) = 0.0_core_rknd + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] +! lhs(k_tdiag) = + invrs_dzt & +! *(K_zmm1+nu) & +! *( cloud_frac_zmm1 / cloud_frac_ztm1 ) * invrs_dzmm1 + lhs(k_tdiag) = + invrs_dzt & + * (K_zmm1 & + * min( cloud_frac_zmm1 / cloud_frac_ztm1, & + cf_ratio ) & + + nu(gr%nz)) * invrs_dzmm1 + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] +! lhs(km1_tdiag) = - invrs_dzt * (K_zmm1+nu) * & +! ( cloud_frac_zmm1 / cloud_frac_ztm1 ) * invrs_dzmm1 + lhs(km1_tdiag) = - invrs_dzt & + * (K_zmm1 & + * min( cloud_frac_zmm1 / cloud_frac_ztm1, & + cf_ratio ) & + + nu(gr%nz)) * invrs_dzmm1 + + end if + + return + end function diffusion_cloud_frac_zt_lhs + + !============================================================================= + pure function diffusion_zm_lhs( K_zt, K_ztp1, nu, & + invrs_dztp1, invrs_dzt, & + invrs_dzm, level ) & + result( lhs ) + + ! Description: + ! Vertical eddy diffusion of var_zm: implicit portion of the code. + ! + ! The variable "var_zm" stands for a variable that is located at momentum + ! grid levels. + ! + ! The d(var_zm)/dt equation contains an eddy diffusion term: + ! + ! + d [ ( K_zt + nu ) * d(var_zm)/dz ] / dz. + ! + ! This term is usually solved for completely implicitly, such that: + ! + ! + d [ ( K_zt + nu ) * d( var_zm(t+1) )/dz ] / dz. + ! + ! However, when a Crank-Nicholson scheme is used, the eddy diffusion term + ! has both implicit and explicit components, such that: + ! + ! + (1/2) * d [ ( K_zt + nu ) * d( var_zm(t+1) )/dz ] / dz + ! + (1/2) * d [ ( K_zt + nu ) * d( var_zm(t) )/dz ] / dz; + ! + ! for which the implicit component is: + ! + ! + (1/2) * d [ ( K_zt + nu ) * d( var_zm(t+1) )/dz ] / dz. + ! + ! Note: When the implicit term is brought over to the left-hand side, + ! the sign is reversed and the leading "+" in front of the term + ! is changed to a "-". + ! + ! Timestep index (t) stands for the index of the current timestep, while + ! timestep index (t+1) stands for the index of the next timestep, which is + ! being advanced to in solving the d(var_zm)/dt equation. + ! + ! The implicit portion of this term is discretized as follows: + ! + ! The values of var_zm are found on the momentum levels, while the values of + ! K_zt are found on the thermodynamic levels. The derivatives (d/dz) of + ! var_zm are taken over the intermediate thermodynamic levels. At the + ! intermediate thermodynamic levels, d(var_zm)/dz is multiplied by + ! ( K_zt + nu ). Then, the derivative of the whole mathematical expression + ! is taken over the central momentum level, which yields the desired result. + ! + ! ==var_zmp1=============================================== m(k+1) + ! + ! ----------d(var_zm)/dz--(K_ztp1+nu)---------------------- t(k+1) + ! + ! ==var_zm===================d[(K_zt+nu)*d(var_zm)/dz]/dz== m(k) + ! + ! ----------d(var_zm)/dz--(K_zt+nu)------------------------ t(k) + ! + ! ==var_zmm1=============================================== m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + ! invrs_dzt(k+1) = 1 / ( zm(k+1) - zm(k) ) + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + ! + ! Note: This function only computes the general implicit form: + ! + d [ ( K_zt + nu ) * d( var_zm(t+1) )/dz ] / dz. + ! For a Crank-Nicholson scheme, the left-hand side result of this + ! function will have to be multiplied by (1/2). For a + ! Crank-Nicholson scheme, the right-hand side (explicit) component + ! needs to be computed by multiplying the left-hand side results by + ! (1/2), reversing the sign on each left-hand side element, and then + ! multiplying each element by the appropriate var_zm(t) value from + ! the appropriate vertical level. + ! + ! + ! Boundary Conditions: + ! + ! 1) Zero-flux boundary conditions. + ! This function is set up to use zero-flux boundary conditions at both + ! the lower boundary level and the upper boundary level. The flux, F, + ! is the amount of var_zm flowing normal through the boundary per unit + ! time per unit surface area. The derivative of the flux effects the + ! time-tendency of var_zm, such that: + ! + ! d(var_zm)/dt = -dF/dz. + ! + ! For the 2nd-order eddy-diffusion term, +d[(K_zt+nu)*d(var_zm)/dz]/dz, + ! the flux is: + ! + ! F = -(K_zt+nu)*d(var_zm)/dz. + ! + ! In order to have zero-flux boundary conditions, the derivative of + ! var_zm, d(var_zm)/dz, needs to equal 0 at both the lower boundary and + ! the upper boundary. + ! + ! In order to discretize the lower boundary condition, consider a new + ! level outside the model (momentum level 0) just below the lower + ! boundary level (momentum level 1). The value of var_zm at the level + ! just outside the model is defined to be the same as the value of var_zm + ! at the lower boundary level. Therefore, the value of d(var_zm)/dz + ! between the level just outside the model and the lower boundary level + ! is 0, satisfying the zero-flux boundary condition. The other value for + ! d(var_zm)/dz (between momentum level 2 and momentum level 1) is taken + ! over the intermediate thermodynamic level (thermodynamic level 2), + ! where it is multiplied by the factor ( K_zt(2) + nu ). Then, the + ! derivative of the whole expression is taken over the central momentum + ! level. + ! + ! =var_zm(2)============================================ m(2) + ! + ! ----------d(var_zm)/dz==(K_zt(2)+nu)------------------ t(2) + ! + ! =var_zm(1)===============d[(K_zt+nu)*d(var_zm)/dz]/dz= m(1) Boundary + ! + ! ----------[d(var_zm)/dz = 0]-------------------------- t(1) + ! + ! =[var_zm(0) = var_zm(1)]=====(level outside model)==== m(0) + ! + ! The result is dependent only on values of K_zt found at thermodynamic + ! level 2 and values of var_zm found at momentum levels 1 and 2. Thus, + ! it only affects 2 diagonals on the left-hand side matrix. + ! + ! The same method can be used to discretize the upper boundary by + ! considering a new level outside the model just above the upper boundary + ! level. + ! + ! 2) Fixed-point boundary conditions. + ! Many equations in the model use fixed-point boundary conditions rather + ! than zero-flux boundary conditions. This means that the value of + ! var_zm stays the same over the course of the timestep at the lower + ! boundary, as well as at the upper boundary. + ! + ! In order to discretize the boundary conditions for equations requiring + ! fixed-point boundary conditions, either: + ! a) in the parent subroutine or function (that calls this function), + ! loop over all vertical levels from the second-lowest to the + ! second-highest, ignoring the boundary levels. Then set the values + ! at the boundary levels in the parent subroutine; or + ! b) in the parent subroutine or function, loop over all vertical levels + ! and then overwrite the results at the boundary levels. + ! + ! Either way, at the boundary levels, an array with a value of 1 at the + ! main diagonal on the left-hand side and with values of 0 at all other + ! diagonals on the left-hand side will preserve the right-hand side value + ! at that level, thus satisfying the fixed-point boundary conditions. + ! + ! + ! Conservation Properties: + ! + ! When zero-flux boundary conditions are used, this technique of + ! discretizing the eddy diffusion term leads to conservative differencing. + ! When conservative differencing is in place, the column totals for each + ! column in the left-hand side matrix (for the eddy diffusion term) should + ! be equal to 0. This ensures that the total amount of the quantity var_zm + ! over the entire vertical domain is being conserved, meaning that nothing + ! is lost due to diffusional effects. + ! + ! To see that this conservation law is satisfied, compute the eddy diffusion + ! of var_zm and integrate vertically. In discretized matrix notation (where + ! "i" stands for the matrix column and "j" stands for the matrix row): + ! + ! 0 = Sum_j Sum_i ( 1/invrs_dzm )_i + ! ( invrs_dzm * ((K_zt+nu)*invrs_dzt) )_ij (var_zm)_j. + ! + ! The left-hand side matrix, ( invrs_dzm * ((K_zt+nu)*invrs_dzt) )_ij, is + ! partially written below. The sum over i in the above equation removes + ! invrs_dzm everywhere from the matrix below. The sum over j leaves the + ! column totals that are desired. + ! + ! Left-hand side matrix contributions from eddy diffusion term; first four + ! vertical levels: + ! + ! ----------------------------------------------------------------------> + !k=1 | +invrs_dzm(k) -invrs_dzm(k) 0 + ! | *(K_zt(k+1)+nu) *(K_zt(k+1)+nu) + ! | *invrs_dzt(k+1) *invrs_dzt(k+1) + ! | + !k=2 | -invrs_dzm(k) +invrs_dzm(k) -invrs_dzm(k) + ! | *(K_zt(k)+nu) *[ (K_zt(k+1)+nu) *(K_zt(k+1)+nu) + ! | *invrs_dzt(k) *invrs_dzt(k+1) *invrs_dzt(k+1) + ! | +(K_zt(k)+nu) + ! | *invrs_dzt(k) ] + ! | + !k=3 | 0 -invrs_dzm(k) +invrs_dzm(k) + ! | *(K_zt(k)+nu) *[ (K_zt(k+1)+nu) + ! | *invrs_dzt(k) *invrs_dzt(k+1) + ! | +(K_zt(k)+nu) + ! | *invrs_dzt(k) ] + ! | + !k=4 | 0 0 -invrs_dzm(k) + ! | *(K_zt(k)+nu) + ! | *invrs_dzt(k) + ! \ / + ! + ! Note: The superdiagonal term from level 3 and both the main diagonal and + ! superdiagonal terms from level 4 are not shown on this diagram. + ! + ! Note: The matrix shown is a tridiagonal matrix. For a band diagonal + ! matrix (with 5 diagonals), there would be an extra row between each + ! of the rows shown and an extra column between each of the columns + ! shown. However, for the purposes of the var_zm eddy diffusion + ! term, those extra row and column values are all 0, and the + ! conservation properties of the matrix aren't effected. + ! + ! If fixed-point boundary conditions are used, the matrix entries at + ! level 1 (k=1) read: 1 0 0; which means that conservative differencing + ! is not in play. The total amount of var_zm over the entire vertical + ! domain is not being conserved, as amounts of var_zm may be fluxed out + ! through the upper boundary or lower boundary through the effects of + ! diffusion. + ! + ! Brian Griffin. April 26, 2008. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + K_zt, & ! Coef. of eddy diffusivity at thermo. level (k) [m^2/s] + K_ztp1, & ! Coef. of eddy diffusivity at thermo. level (k+1) [m^2/s] + invrs_dzm, & ! Inverse of grid spacing over momentum level (k) [1/m] + invrs_dzt, & ! Inverse of grid spacing over thermo. level (k) [1/m] + invrs_dztp1 ! Inverse of grid spacing over thermo. level (k+1) [1/m] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + nu ! Background constant coef. of eddy diffusivity [m^2/s] + + integer, intent(in) :: & + level ! Momentum level where calculation occurs. [-] + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + if ( level == 1 ) then + + ! k = 1; lower boundary level at surface. + ! Only relevant if zero-flux boundary conditions are used. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) = - invrs_dzm * (K_ztp1+nu(2)) * invrs_dztp1 + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) = + invrs_dzm * (K_ztp1+nu(2)) * invrs_dztp1 + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) = 0.0_core_rknd + + + elseif ( level > 1 .and. level < gr%nz ) then + + ! Most of the interior model; normal conditions. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) = - invrs_dzm * (K_ztp1+nu(level+1)) * invrs_dztp1 + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) = + invrs_dzm * ( (K_ztp1+nu(level+1))*invrs_dztp1 & + + (K_zt+nu(level))*invrs_dzt ) + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) = - invrs_dzm * (K_zt+nu(level)) * invrs_dzt + + + elseif ( level == gr%nz ) then + + ! k = gr%nz (top level); upper boundary level. + ! Only relevant if zero-flux boundary conditions are used. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) = 0.0_core_rknd + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) = + invrs_dzm * (K_zt+nu(gr%nz)) * invrs_dzt + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) = - invrs_dzm * (K_zt+nu(gr%nz)) * invrs_dzt + + + endif + + end function diffusion_zm_lhs + +!=============================================================================== + +end module diffusion diff --git a/src/physics/clubb/endian.F90 b/src/physics/clubb/endian.F90 new file mode 100644 index 0000000000..c14af9cfb7 --- /dev/null +++ b/src/physics/clubb/endian.F90 @@ -0,0 +1,185 @@ +!---------------------------------------------------------------------- +! $Id: endian.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!---------------------------------------------------------------------- +module endian + +! Description: +! big_endian and little_endian are parameters set at compile time +! based on whether the architecture is big or little endian. + +! native_4byte_real is a portable byte re-ordering subroutine +! native_8byte_real is a knock off of the other routine for 8 bytes +! References: +! big_endian, little_endian from: +! +!---------------------------------------------------------------------- + + implicit none + + interface byte_order_swap + module procedure native_4byte_real, native_8byte_real + end interface + + public :: big_endian, little_endian, byte_order_swap + private :: native_4byte_real, native_8byte_real + + private ! Default scope + ! External + intrinsic :: selected_int_kind, ichar, transfer + + ! Parameters + integer, parameter :: & + i4 = 4, & ! 4 byte long integer + ich = ichar( transfer( 1_i4, "a" ) ) + + logical, parameter :: & + big_endian = ich == 0, & + little_endian = .not. big_endian + + contains + +!------------------------------------------------------------------------------- +! SUBPROGRAM: native_4byte_real +! +! AUTHOR: David Stepaniak, NCAR/CGD/CAS +! DATE INITIATED: 29 April 2003 +! LAST MODIFIED: 19 April 2005 +! +! SYNOPSIS: Converts a 32 bit, 4 byte, REAL from big Endian to +! little Endian, or conversely from little Endian to big +! Endian. +! +! DESCRIPTION: This subprogram allows one to convert a 32 bit, 4 byte, +! REAL data element that was generated with, say, a big +! Endian processor (e.g. Sun/sparc, SGI/R10000, etc.) to its +! equivalent little Endian representation for use on little +! Endian processors (e.g. PC/Pentium running Linux). The +! converse, little Endian to big Endian, also holds. +! This conversion is accomplished by writing the 32 bits of +! the REAL data element into a generic 32 bit INTEGER space +! with the TRANSFER intrinsic, reordering the 4 bytes with +! the MVBITS intrinsic, and writing the reordered bytes into +! a new 32 bit REAL data element, again with the TRANSFER +! intrinsic. The following schematic illustrates the +! reordering process +! +! +! -------- -------- -------- -------- +! | D | | C | | B | | A | 4 Bytes +! -------- -------- -------- -------- +! | +! -> 1 bit +! || +! MVBITS +! || +! \/ +! +! -------- -------- -------- -------- +! | A | | B | | C | | D | 4 Bytes +! -------- -------- -------- -------- +! | | | | +! 24 16 8 0 <- bit +! position +! +! INPUT: realIn, a single 32 bit, 4 byte REAL data element. +! OUTPUT: realOut, a single 32 bit, 4 byte REAL data element, with +! reverse byte order to that of realIn. +! RESTRICTION: It is assumed that the default REAL data element is +! 32 bits / 4 bytes. +! +!----------------------------------------------------------------------- + SUBROUTINE native_4byte_real( realInOut ) + + IMPLICIT NONE + + ! Added by Eric Raut, Nov 2015 + integer, parameter :: & + sp = selected_real_kind( 6 ), & ! 32-bit floating point kind + int32 = selected_int_kind( 9 ) ! 32-bit integer kind + + REAL(KIND=sp), INTENT(INOUT):: realInOut ! a single 32 bit, 4 byte + ! REAL data element +! Modified 8/1/05 +! I found transfer does not work on pgf90 when -r8 is used and the mold +! is a literal constant real; Changed the mold "0.0" to "readInOut" +! -dschanen +! +! REAL, INTENT(IN):: realInOut +! REAL, INTENT(OUT) :: realOut +! ! a single 32 bit, 4 byte +! ! REAL data element, with +! ! reverse byte order to +! ! that of realIn +!---------------------------------------------------------------------- +! Local variables (generic 32 bit INTEGER spaces): + + INTEGER(KIND=int32) :: i_element + INTEGER(KIND=int32) :: i_element_br +!---------------------------------------------------------------------- +! Transfer 32 bits of realIn to generic 32 bit INTEGER space: + i_element = TRANSFER( realInOut, i_element ) +!---------------------------------------------------------------------- +! Reverse order of 4 bytes in 32 bit INTEGER space: + CALL MVBITS( i_element, 24, 8, i_element_br, 0 ) + CALL MVBITS( i_element, 16, 8, i_element_br, 8 ) + CALL MVBITS( i_element, 8, 8, i_element_br, 16 ) + CALL MVBITS( i_element, 0, 8, i_element_br, 24 ) +!---------------------------------------------------------------------- +! Transfer reversed order bytes to 32 bit REAL space (realOut): + realInOut = TRANSFER( i_element_br, realInOut ) + + RETURN + END SUBROUTINE native_4byte_real + +!------------------------------------------------------------------------------- + subroutine native_8byte_real( realInOut ) + +! Description: +! This is just a modification of the above routine for 64 bit data +!------------------------------------------------------------------------------- + + ! Added by Eric Raut, Nov 2015 + use clubb_precision, only: & + dp ! Constant (64-bit floating point kind) + + implicit none + + ! Added by Eric Raut, Nov 2015 + integer, parameter :: & + int64 = selected_int_kind( 18 ) ! 64-bit integer kind + + ! External + intrinsic :: mvbits, transfer + + real(kind=dp), intent(inout) :: realInOut ! a single 64 bit, 8 byte + ! REAL data element + ! Local variables (generic 64 bit INTEGER spaces): + + integer(kind=int64) :: i_element + integer(kind=int64) :: i_element_br + +!------------------------------------------------------------------------------- + + ! Transfer 64 bits of realIn to generic 64 bit INTEGER space: + i_element = transfer( realInOut, i_element ) + + ! Reverse order of 8 bytes in 64 bit INTEGER space: + call mvbits( i_element, 56, 8, i_element_br, 0 ) + call mvbits( i_element, 48, 8, i_element_br, 8 ) + call mvbits( i_element, 40, 8, i_element_br, 16 ) + call mvbits( i_element, 32, 8, i_element_br, 24 ) + call mvbits( i_element, 24, 8, i_element_br, 32 ) + call mvbits( i_element, 16, 8, i_element_br, 40 ) + call mvbits( i_element, 8, 8, i_element_br, 48 ) + call mvbits( i_element, 0, 8, i_element_br, 56 ) + + ! Transfer reversed order bytes to 64 bit REAL space (realOut): + realInOut = transfer( i_element_br, realInOut ) + + return + end subroutine native_8byte_real +!------------------------------------------------------------------------------- + +end module endian + +!------------------------------------------------------------------------------- diff --git a/src/physics/clubb/error_code.F90 b/src/physics/clubb/error_code.F90 new file mode 100644 index 0000000000..0e29893387 --- /dev/null +++ b/src/physics/clubb/error_code.F90 @@ -0,0 +1,227 @@ +!------------------------------------------------------------------------------- +! $Id: error_code.F90 7184 2014-08-11 15:23:43Z betlej@uwm.edu $ +!------------------------------------------------------------------------------- + +module error_code + +! Description: +! Since f90/95 lacks enumeration, we're stuck numbering each +! error code by hand like this. + +! We are "enumerating" error codes to be used with CLUBB. Adding +! additional codes is as simple adding an additional integer +! parameter. The error codes are ranked by severity, the higher +! number being more servere. When two errors occur, assign the +! most servere to the output. + +! This code also handles subroutines related to debug_level. See +! the 'set_clubb_debug_level' description for more detail. + +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + private ! Default Scope + + public :: & + report_error, & + fatal_error, & + lapack_error, & + clubb_at_least_debug_level, & + set_clubb_debug_level, & + clubb_debug + + private :: clubb_debug_level + + ! Model-Wide Debug Level + integer, save :: clubb_debug_level = 0 + +!$omp threadprivate(clubb_debug_level) + + ! Error Code Values + integer, parameter, public :: & + clubb_no_error = 0, & + clubb_var_less_than_zero = 1, & + clubb_var_equals_NaN = 2, & + clubb_singular_matrix = 3, & + clubb_bad_lapack_arg = 4, & + clubb_rtm_level_not_found = 5, & + clubb_var_out_of_bounds = 6, & + clubb_var_out_of_range = 7 + + contains + +!------------------------------------------------------------------------------- + subroutine report_error( err_code ) +! +! Description: +! Reports meaning of error code to console. +! +!------------------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Variable(s) + + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + ! ---- Begin Code ---- + + select case ( err_code ) + + case ( clubb_no_error ) + write(fstderr,*) "No errors reported." + + case ( clubb_var_less_than_zero ) + write(fstderr,*) "Variable in CLUBB is less than zero." + + case ( clubb_singular_matrix ) + write(fstderr,*) "Singular Matrix in CLUBB." + + case ( clubb_var_equals_NaN ) + write(fstderr,*) "Variable in CLUBB is NaN." + + case ( clubb_bad_lapack_arg ) + write(fstderr,*) "Argument passed to a LAPACK procedure is invalid." + + case ( clubb_rtm_level_not_found ) + write(fstderr,*) "rtm level not found" + + case ( clubb_var_out_of_bounds ) + write(fstderr,*) "Input variable is out of bounds." + + case ( clubb_var_out_of_range ) + write(fstderr,*) "A CLUBB variable had a value outside the valid range." + + case default + write(fstderr,*) "Unknown error: ", err_code + + end select + + return + end subroutine report_error +!------------------------------------------------------------------------------- + elemental function lapack_error( err_code ) +! +! Description: +! Checks to see if the err_code is equal to one +! caused by an error encountered using LAPACK. +! Reference: +! None +!------------------------------------------------------------------------------- + implicit none + + ! Input variable + integer,intent(in) :: err_code ! Error Code being examined + + ! Output variable + logical :: lapack_error + + ! ---- Begin Code ---- + + lapack_error = (err_code == clubb_singular_matrix .or. & + err_code == clubb_bad_lapack_arg ) + + return + end function lapack_error + +!------------------------------------------------------------------------------- + elemental function fatal_error( err_code ) +! +! Description: Checks to see if the err_code is one that usually +! causes an exit in other parts of CLUBB. +! References: +! None +!------------------------------------------------------------------------------- + implicit none + + ! Input Variable + integer, intent(in) :: err_code ! Error Code being examined + + ! Output variable + logical :: fatal_error + + ! ---- Begin Code ---- + + fatal_error = err_code /= clubb_no_error .and. & + err_code /= clubb_var_less_than_zero + return + end function fatal_error + +!------------------------------------------------------------------ + logical function clubb_at_least_debug_level( level ) +! +! Description: +! Checks to see if clubb has been set to a specified debug level +!------------------------------------------------------------------ + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + ! ---- Begin Code ---- + + clubb_at_least_debug_level = ( level <= clubb_debug_level ) + + return + end function clubb_at_least_debug_level + +!------------------------------------------------------------------------------- + subroutine set_clubb_debug_level( level ) +! +! Description: +! Accessor for clubb_debug_level +! +! 0 => Print no debug messages to the screen +! 1 => Print lightweight debug messages, e.g. print statements +! 2 => Print debug messages that require extra testing, +! e.g. checks for NaNs and spurious negative values. +! References: +! None +!------------------------------------------------------------------------------- + implicit none + + ! Input variable + integer, intent(in) :: level ! The debug level being checked against the current setting + + ! ---- Begin Code ---- + + clubb_debug_level = level + + return + end subroutine set_clubb_debug_level + +!------------------------------------------------------------------------------- + subroutine clubb_debug( level, str ) +! +! Description: +! Prints a message to file unit fstderr if the level is greater +! than or equal to the current debug level. +!------------------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Variable(s) + + implicit none + + ! Input Variable(s) + + character(len=*), intent(in) :: str ! The message being reported + + ! The debug level being checked against the current setting + integer, intent(in) :: level + + ! ---- Begin Code ---- + + if ( level <= clubb_debug_level ) then + write(fstderr,*) str + end if + + return + end subroutine clubb_debug + +end module error_code +!------------------------------------------------------------------------------- diff --git a/src/physics/clubb/file_functions.F90 b/src/physics/clubb/file_functions.F90 new file mode 100644 index 0000000000..f195d26a12 --- /dev/null +++ b/src/physics/clubb/file_functions.F90 @@ -0,0 +1,165 @@ +!----------------------------------------------------------------------- +! $Id: file_functions.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!=============================================================================== +module file_functions + + implicit none + + public :: file_read_1d, file_read_2d + + private ! Default Scope + + contains + +!=============================================================================== + subroutine file_read_1d( file_unit, path_and_filename, & + num_datapts, entries_per_line, variable ) + +! Description: +! This subroutine reads in values from a data file with a number of +! rows and a declared number of columns (entries_per_line) of data. +! It reads in the data in the form of: +! 1 ==> (row 1, column 1); 2 ==> (row 1, column 2); etc. +! +! Example: a diagram of a data file with 18 total data points +! (DP1 to DP18), with 4 data points per row. +! +! i = 1 i = 2 i = 3 i = 4 +! --------------------------------------- +! k = 1 | DP1 DP2 DP3 DP4 +! | +! k = 2 | DP5 DP6 DP7 DP8 +! | +! k = 3 | DP9 DP10 DP11 DP12 +! | +! k = 4 | DP13 DP14 DP15 DP16 +! | +! k = 5 | DP17 DP18 +! +! See Michael Falk's comments below for more information. +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: fstderr ! Constant(s) + + implicit none + + integer, intent(in) :: & + file_unit, & ! Unit number of file being read. + num_datapts, & ! Total number of data points being read in. + entries_per_line ! Number of data points + ! on one line of the file being read. + + character(*), intent(in) :: & + path_and_filename ! Path to file and filename of file being read. + + real( kind = core_rknd ), dimension(num_datapts), intent(out) :: & + variable ! Data values output into variable + + integer :: k ! Data file row number. + integer :: i ! Data file column number. + integer :: ierr + + ! ---- Begin Code ---- +! A ThreadLock is necessary here because FORTRAN can only have each file open on +! one file_unit at a time. For example, suppose we are running CLUBB in parallel +! with OpenMP using two threads. Suppose the first thread opens the file with file_unit = 0 +! (file_unit is assigned a value based on thread number). +! Then suppose, that before thread 1 exits, thread 2 opens the same file with file_unit = 1. +! This would cause FORTRAN to crash. +!$omp critical + + ! Open data file. + open( unit=file_unit, file=path_and_filename, action='read', status='old', & + iostat=ierr ) + if ( ierr /= 0 ) then + write(fstderr,*) "CLUBB encountered an error trying to open "//path_and_filename + stop "Error opening forcings file" + end if + + ! Michael Falk wrote this routine to read data files in a particular format for mpace_a. + ! Each line has a specific number of values, until the last line in the file, which + ! has the last few values and then ends. This reads the correct number of values on + ! each line. 24 September 2007 + + ! Loop over each full line of the input file. + do k = 1, (num_datapts/entries_per_line), 1 + read(file_unit,*) ( variable( ((k-1)*entries_per_line) + i ), & + i=1,entries_per_line ) + enddo + ! Read any partial line remaining. + if ( mod(num_datapts,entries_per_line) /= 0 ) then + k = (num_datapts/entries_per_line) + read(file_unit,*) ( variable( (k*entries_per_line) + i ), & + i=1,(mod(num_datapts,entries_per_line)) ) + endif + + ! Close data file. + close( file_unit ) + +!$omp end critical + + return + + end subroutine file_read_1d + +!=============================================================================== + subroutine file_read_2d( device, file_path, file_dimension1, & + file_dimension2, file_per_line, variable ) + +! Description: +! Michael Falk wrote this routine to read data files in a particular format for mpace_a. +! The 2d mpace_a files list the (file_dimension2) values on a given vertical level, then +! moves to the next level to list its values. +! Each line has a specific number of values, until the last line on a level, which +! is short-- it has the last few values and then a line break. The next line, beginning +! the next level, is full-sized again. 24 September 2007 +! +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + integer, intent(in) :: & + device, & + file_dimension1, & + file_dimension2, & + file_per_line + + character(*), intent(in) :: & + file_path + + real( kind = core_rknd ), dimension(file_dimension1,file_dimension2), intent(out) :: & + variable + + integer i, j, k + + ! ---- Begin Code ---- + + variable = -999._core_rknd ! Initialize to nonsense values + + open(device,file=file_path,action='read') + + do k=1,(file_dimension1) ! For each level in the data file, + do j=0,((file_dimension2/file_per_line)-1) + read(device,*) (variable(k,(j*file_per_line)+i), & ! read file_per_line values in, + i=1,file_per_line) + end do + read (device,*) (variable(k,(j*file_per_line)+i), & ! then read the partial line + i=1,(mod(file_dimension2,file_per_line))) + end do ! and then start over at the next level. + + close(device) + + return + end subroutine file_read_2d + +!=============================================================================== + +end module file_functions diff --git a/src/physics/clubb/fill_holes.F90 b/src/physics/clubb/fill_holes.F90 new file mode 100644 index 0000000000..1e053e19e9 --- /dev/null +++ b/src/physics/clubb/fill_holes.F90 @@ -0,0 +1,1379 @@ +!----------------------------------------------------------------------- +! $Id: fill_holes.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module fill_holes + + implicit none + + public :: fill_holes_driver, & + fill_holes_vertical, & + hole_filling_hm_one_lev, & + fill_holes_hydromet, & + fill_holes_wv, & + vertical_avg, & + vertical_integral, & + setup_stats_indices + + private :: fill_holes_multiplicative + + private ! Set Default Scope + + contains + + !============================================================================= + subroutine fill_holes_vertical( num_draw_pts, threshold, field_grid, & + rho_ds, rho_ds_zm, & + field ) + + ! Description: + ! This subroutine clips values of 'field' that are below 'threshold' as much + ! as possible (i.e. "fills holes"), but conserves the total integrated mass + ! of 'field'. This prevents clipping from acting as a spurious source. + ! + ! Mass is conserved by reducing the clipped field everywhere by a constant + ! multiplicative coefficient. + ! + ! This subroutine does not guarantee that the clipped field will exceed + ! threshold everywhere; blunt clipping is needed for that. + + ! References: + ! ``Numerical Methods for Wave Equations in Geophysical Fluid + ! Dynamics'', Durran (1999), p. 292. + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: & + num_draw_pts ! The number of points on either side of the hole; + ! Mass is drawn from these points to fill the hole. [] + + real( kind = core_rknd ), intent(in) :: & + threshold ! A threshold (e.g. w_tol*w_tol) below which field must not + ! fall [Units vary; same as field] + + character(len=2), intent(in) :: & + field_grid ! The grid of the field, either zt or zm + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds, & ! Dry, static density on thermodynamic levels [kg/m^3] + rho_ds_zm ! Dry, static density on momentum levels [kg/m^3] + + ! Input/Output variable + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + field ! The field (e.g. wp2) that contains holes [Units same as threshold] + + ! Local Variables + integer :: & + k, & ! Loop index for absolute grid level [] + begin_idx, & ! Lower grid level of local hole-filling range [] + end_idx, & ! Upper grid level of local hole-filling range [] + upper_hf_level ! Upper grid level of global hole-filling range [] + + !----------------------------------------------------------------------- + + ! Check whether any holes exist in the entire profile. + ! The lowest level (k=1) should not be included, as the hole-filling scheme + ! should not alter the set value of 'field' at the surface (for momentum + ! level variables), or consider the value of 'field' at a level below the + ! surface (for thermodynamic level variables). For momentum level variables + ! only, the hole-filling scheme should not alter the set value of 'field' at + ! the upper boundary level (k=gr%nz). + + if ( field_grid == "zt" ) then + ! 'field' is on the zt (thermodynamic level) grid + upper_hf_level = gr%nz + elseif ( field_grid == "zm" ) then + ! 'field' is on the zm (momentum level) grid + upper_hf_level = gr%nz-1 + endif + + if ( any( field( 2:upper_hf_level ) < threshold ) ) then + + ! Make one pass up the profile, filling holes as much as we can using + ! nearby mass. + ! The lowest level (k=1) should not be included in the loop, as the + ! hole-filling scheme should not alter the set value of 'field' at the + ! surface (for momentum level variables), or consider the value of + ! 'field' at a level below the surface (for thermodynamic level + ! variables). For momentum level variables only, the hole-filling scheme + ! should not alter the set value of 'field' at the upper boundary + ! level (k=gr%nz). + do k = 2+num_draw_pts, upper_hf_level-num_draw_pts, 1 + + begin_idx = k - num_draw_pts + end_idx = k + num_draw_pts + + if ( any( field( begin_idx:end_idx ) < threshold ) ) then + + ! 'field' is on the zt (thermodynamic level) grid + if ( field_grid == "zt" ) then + call fill_holes_multiplicative & + ( begin_idx, end_idx, threshold, & + rho_ds(begin_idx:end_idx), gr%invrs_dzt(begin_idx:end_idx), & + field(begin_idx:end_idx) ) + + ! 'field' is on the zm (momentum level) grid + elseif ( field_grid == "zm" ) then + call fill_holes_multiplicative & + ( begin_idx, end_idx, threshold, & + rho_ds_zm(begin_idx:end_idx), gr%invrs_dzm(begin_idx:end_idx), & + field(begin_idx:end_idx) ) + endif + + endif + + enddo + + ! Fill holes globally, to maximize the chance that all holes are filled. + ! The lowest level (k=1) should not be included, as the hole-filling + ! scheme should not alter the set value of 'field' at the surface (for + ! momentum level variables), or consider the value of 'field' at a level + ! below the surface (for thermodynamic level variables). For momentum + ! level variables only, the hole-filling scheme should not alter the set + ! value of 'field' at the upper boundary level (k=gr%nz). + if ( any( field( 2:upper_hf_level ) < threshold ) ) then + + ! 'field' is on the zt (thermodynamic level) grid + if ( field_grid == "zt" ) then + call fill_holes_multiplicative & + ( 2, upper_hf_level, threshold, & + rho_ds(2:upper_hf_level), gr%invrs_dzt(2:upper_hf_level), & + field(2:upper_hf_level) ) + + ! 'field' is on the zm (momentum level) grid + elseif ( field_grid == "zm" ) then + call fill_holes_multiplicative & + ( 2, upper_hf_level, threshold, & + rho_ds_zm(2:upper_hf_level), gr%invrs_dzm(2:upper_hf_level), & + field(2:upper_hf_level) ) + endif + + endif + + endif ! End overall check for existence of holes + + return + + end subroutine fill_holes_vertical + + !============================================================================= + subroutine fill_holes_multiplicative & + ( begin_idx, end_idx, threshold, & + rho, invrs_dz, & + field ) + + ! Description: + ! This subroutine clips values of 'field' that are below 'threshold' as much + ! as possible (i.e. "fills holes"), but conserves the total integrated mass + ! of 'field'. This prevents clipping from acting as a spurious source. + ! + ! Mass is conserved by reducing the clipped field everywhere by a constant + ! multiplicative coefficient. + ! + ! This subroutine does not guarantee that the clipped field will exceed + ! threshold everywhere; blunt clipping is needed for that. + + ! References: + ! ``Numerical Methods for Wave Equations in Geophysical Fluid + ! Dynamics", Durran (1999), p. 292. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: & + begin_idx, & ! The beginning index (e.g. k=2) of the range of hole-filling + end_idx ! The end index (e.g. k=gr%nz) of the range of hole-filling + + real( kind = core_rknd ), intent(in) :: & + threshold ! A threshold (e.g. w_tol*w_tol) below which field must not fall + ! [Units vary; same as field] + + real( kind = core_rknd ), dimension(end_idx-begin_idx+1), intent(in) :: & + rho, & ! Dry, static density on either thermodynamic or momentum levels [kg/m^3] + invrs_dz ! Reciprocal of thermodynamic or momentum level thickness depending on whether + ! we're on zt or zm grid. + + ! Input/Output variable + real( kind = core_rknd ), dimension(end_idx-begin_idx+1), intent(inout) :: & + field ! The field (e.g. wp2) that contains holes + ! [Units same as threshold] + + ! Local Variables + real( kind = core_rknd ), dimension(end_idx-begin_idx+1) :: & + field_clipped ! The raw field (e.g. wp2) that contains no holes + ! [Units same as threshold] + + real( kind = core_rknd ) :: & + field_avg, & ! Vertical average of field [Units of field] + field_clipped_avg, & ! Vertical average of clipped field [Units of field] + mass_fraction ! Coefficient that multiplies clipped field + ! in order to conserve mass. [] + + !----------------------------------------------------------------------- + + ! Compute the field's vertical average, which we must conserve. + field_avg = vertical_avg( (end_idx-begin_idx+1), rho, & + field, invrs_dz ) + + ! Clip small or negative values from field. + if ( field_avg >= threshold ) then + ! We know we can fill in holes completely + field_clipped = max( threshold, field ) + else + ! We can only fill in holes partly; + ! to do so, we remove all mass above threshold. + field_clipped = min( threshold, field ) + endif + + ! Compute the clipped field's vertical integral. + ! clipped_total_mass >= original_total_mass + field_clipped_avg = vertical_avg( (end_idx-begin_idx+1), rho, & + field_clipped, invrs_dz ) + + ! If the difference between the field_clipped_avg and the threshold is so + ! small that it falls within numerical round-off, return to the parent + ! subroutine without altering the field in order to avoid divide-by-zero + ! error. + !if ( abs(field_clipped_avg - threshold) & + ! < threshold*epsilon(threshold) ) then + if ( abs(field_clipped_avg - threshold) == 0.0_core_rknd ) then + return + endif + + ! Compute coefficient that makes the clipped field have the same mass as the + ! original field. We should always have mass_fraction > 0. + mass_fraction = ( field_avg - threshold ) / & + ( field_clipped_avg - threshold ) + + ! Output normalized, filled field + field = mass_fraction * ( field_clipped - threshold ) & + + threshold + + + return + + end subroutine fill_holes_multiplicative + + !============================================================================= + function vertical_avg( total_idx, rho_ds, & + field, invrs_dz ) + + ! Description: + ! Computes the density-weighted vertical average of a field. + ! + ! The average value of a function, f, over a set domain, [a,b], is + ! calculated by the equation: + ! + ! f_avg = ( INT(a:b) f*g ) / ( INT(a:b) g ); + ! + ! as long as f is continous and g is nonnegative and integrable. Therefore, + ! the density-weighted (by dry, static, base-static density) vertical + ! average value of any model field, x, is calculated by the equation: + ! + ! x_avg|_z = ( INT(z_bot:z_top) x rho_ds dz ) + ! / ( INT(z_bot:z_top) rho_ds dz ); + ! + ! where z_bot is the bottom of the vertical domain, and z_top is the top of + ! the vertical domain. + ! + ! This calculation is done slightly differently depending on whether x is a + ! thermodynamic-level or a momentum-level variable. + ! + ! Thermodynamic-level computation: + + ! + ! For numerical purposes, INT(z_bot:z_top) x rho_ds dz, which is the + ! numerator integral, is calculated as: + ! + ! SUM(k_bot:k_top) x(k) rho_ds(k) delta_z(k); + ! + ! where k is the index of the given thermodynamic level, x and rho_ds are + ! both thermodynamic-level variables, and delta_z(k) = zm(k) - zm(k-1). The + ! indices k_bot and k_top are the indices of the respective lower and upper + ! thermodynamic levels involved in the integration. + ! + ! Likewise, INT(z_bot:z_top) rho_ds dz, which is the denominator integral, + ! is calculated as: + ! + ! SUM(k_bot:k_top) rho_ds(k) delta_z(k). + ! + ! The first (k=1) thermodynamic level is below ground (or below the + ! official lower boundary at the first momentum level), so it should not + ! count in a vertical average, whether that vertical average is used for + ! the hole-filling scheme or for statistical purposes. Begin no lower + ! than level k=2, which is the first thermodynamic level above ground (or + ! above the model lower boundary). + ! + ! For cases where hole-filling over the entire (global) vertical domain + ! is desired, or where statistics over the entire (global) vertical + ! domain are desired, the lower (thermodynamic-level) index of k = 2 and + ! the upper (thermodynamic-level) index of k = gr%nz, means that the + ! overall vertical domain will be gr%zm(gr%nz) - gr%zm(1). + ! + ! + ! Momentum-level computation: + ! + ! For numerical purposes, INT(z_bot:z_top) x rho_ds dz, which is the + ! numerator integral, is calculated as: + ! + ! SUM(k_bot:k_top) x(k) rho_ds(k) delta_z(k); + ! + ! where k is the index of the given momentum level, x and rho_ds are both + ! momentum-level variables, and delta_z(k) = zt(k+1) - zt(k). The indices + ! k_bot and k_top are the indices of the respective lower and upper momentum + ! levels involved in the integration. + ! + ! Likewise, INT(z_bot:z_top) rho_ds dz, which is the denominator integral, + ! is calculated as: + ! + ! SUM(k_bot:k_top) rho_ds(k) delta_z(k). + ! + ! The first (k=1) momentum level is right at ground level (or right at + ! the official lower boundary). The momentum level variables that call + ! the hole-filling scheme have set values at the surface (or lower + ! boundary), and those set values should not be changed. Therefore, the + ! vertical average (for purposes of hole-filling) should not include the + ! surface level (or lower boundary level). For hole-filling purposes, + ! begin no lower than level k=2, which is the second momentum level above + ! ground (or above the model lower boundary). Likewise, the value at the + ! model upper boundary (k=gr%nz) is also set for momentum level + ! variables. That value should also not be changed. + ! + ! However, this function is also used to keep track (for statistical + ! purposes) of the vertical average of certain variables. In that case, + ! the vertical average needs to be taken over the entire vertical domain + ! (level 1 to level gr%nz). + ! + ! + ! In both the thermodynamic-level computation and the momentum-level + ! computation, the numerator integral is divided by the denominator integral + ! in order to find the average value (over the vertical domain) of x. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: & + total_idx ! The total numer of indices within the range of averaging + + real( kind = core_rknd ), dimension(total_idx), intent(in) :: & + rho_ds, & ! Dry, static density on either thermodynamic or momentum levels [kg/m^3] + field, & ! The field (e.g. wp2) to be vertically averaged [Units vary] + invrs_dz ! Reciprocal of thermodynamic or momentum level thickness [1/m] + ! depending on whether we're on zt or zm grid. + ! Note: The rho_ds and field points need to be arranged from + ! lowest to highest in altitude, with rho_ds(1) and + ! field(1) actually their respective values at level k = 1. + + ! Output variable + real( kind = core_rknd ) :: & + vertical_avg ! Vertical average of field [Units of field] + + ! Local variables + real( kind = core_rknd ) :: & + numer_integral, & ! Integral in the numerator (see description) + denom_integral ! Integral in the denominator (see description) + + real( kind = core_rknd ), dimension(total_idx) :: & + denom_field ! When computing the vertical integral in the denominator + ! there is no field variable, so create a "dummy" variable + ! with value of 1 to pass as an argument + + !----------------------------------------------------------------------- + + ! Fill array with 1's (see variable description) + denom_field = 1.0_core_rknd + + ! Initializing vertical_avg to avoid a compiler warning. + vertical_avg = 0.0_core_rknd + + + ! Compute the numerator integral. + ! Multiply the variable 'field' at level k by rho_ds at level k and by + ! the level thickness at level k. Then, sum over all vertical levels. + ! Note: The level thickness at level k is the distance between either + ! momentum level k and momentum level k-1, or + ! thermodynamic level k+1 and thermodynamic level k, depending + ! on which field grid is being analyzed. Thus, 1.0/invrs_dz(k) + ! is the level thickness for level k. + ! Note: The values of 'field' and rho_ds are passed into this function + ! so that field(1) and rho_ds(1) are actually 'field' and rho_ds + ! at the level k = 1. + + numer_integral = vertical_integral( total_idx, rho_ds(1:total_idx), & + field(1:total_idx), invrs_dz(1:total_idx) ) + + ! Compute the denominator integral. + ! Multiply rho_ds at level k by the level thickness + ! at level k. Then, sum over all vertical levels. + denom_integral = vertical_integral( total_idx, rho_ds(1:total_idx), & + denom_field(1:total_idx), invrs_dz(1:total_idx) ) + + ! Find the vertical average of 'field'. + vertical_avg = numer_integral / denom_integral + + return + end function vertical_avg + + !============================================================================= + pure function vertical_integral( total_idx, rho_ds, & + field, invrs_dz ) + + ! Description: + ! Computes the vertical integral. rho_ds, field, and invrs_dz must all be + ! of size total_idx and should all start at the same index. + ! + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: & + total_idx ! The total numer of indices within the range of averaging + + real( kind = core_rknd ), dimension(total_idx), intent(in) :: & + rho_ds, & ! Dry, static density [kg/m^3] + field, & ! The field to be vertically averaged [Units vary] + invrs_dz ! Level thickness [1/m] + ! Note: The rho_ds and field points need to be arranged from + ! lowest to highest in altitude, with rho_ds(1) and + ! field(1) actually their respective values at level k = begin_idx. + + ! Local variables + real( kind = core_rknd ) :: & + vertical_integral ! Integral in the numerator (see description) + + !----------------------------------------------------------------------- + + ! Assertion checks: that begin_idx <= gr%nz - 1 + ! that end_idx >= 2 + ! that begin_idx <= end_idx + + + ! Initializing vertical_integral to avoid a compiler warning. + vertical_integral = 0.0_core_rknd + + ! Compute the integral. + ! Multiply the field at level k by rho_ds at level k and by + ! the level thickness at level k. Then, sum over all vertical levels. + ! Note: The values of the field and rho_ds are passed into this function + ! so that field(1) and rho_ds(1) are actually the field and rho_ds + ! at level k_start. + vertical_integral = sum( field * rho_ds / invrs_dz ) + + return + end function vertical_integral + +!=============================================================================== + + subroutine hole_filling_hm_one_lev( num_hm_fill, hm_one_lev, & ! Intent(in) + hm_one_lev_filled ) ! Intent(out) + + ! Description: + ! Fills holes between same-phase (i.e. either liquid or frozen) hydrometeors for + ! one height level. + ! + ! Warning: Do not input hydrometeors of different phases, e.g. liquid and frozen. + ! Otherwise heat will not be conserved. + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Variable(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: num_hm_fill ! number of hydrometeors involved + + real(kind = core_rknd), dimension(num_hm_fill), intent(in) :: hm_one_lev + + ! Output Variables + real(kind = core_rknd), dimension(num_hm_fill), intent(out) :: hm_one_lev_filled + + ! Local Variables + integer :: num_neg_hm ! number of holes + + real(kind = core_rknd) :: & + total_hole, & ! Size of the hole ( missing mass, less than 0 ) + total_mass ! Total mass to fill the hole + ! total mass of water substance = total_mass + total_hole + + integer :: i ! loop iterator + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Initialization + hm_one_lev_filled = 0._core_rknd + total_hole = 0._core_rknd + total_mass = 0._core_rknd + num_neg_hm = 0 + + ! Determine the total size of the hole and the number of neg. hydrometeors + ! and the total mass of hole filling material + do i=1, num_hm_fill +! print *, "hm_one_lev(",i,") = ", hm_one_lev(i) + if ( hm_one_lev(i) < zero ) then + total_hole = total_hole + hm_one_lev(i) ! less than zero + num_neg_hm = num_neg_hm + 1 + else + total_mass = total_mass + hm_one_lev(i) + endif + + enddo + +! print *, "total_hole = ", total_hole +! print *, "total_mass = ", total_mass +! print *, "num_neg_hm = ", num_neg_hm + + ! There is no water substance at all to fill the hole + if ( total_mass == zero ) then + + if ( clubb_at_least_debug_level(2) ) then + print *, "Warning: One level hole filling was not successful! total_mass = 0" + endif + + hm_one_lev_filled = hm_one_lev + + return + endif + + ! Fill the holes and adjust the remaining quantities: + ! hm_filled(i) = 0, if hm(i) < 0 + ! or + ! hm_filled(i) = (1 + total_hole/total_mass)*hm(i), if hm(i) > 0 + do i=1, num_hm_fill + + ! if there is not enough material, fill the holes partially with all the material available + if ( abs(total_hole) > total_mass ) then + + if ( clubb_at_least_debug_level(2) ) then + print *, "Warning: One level hole was not able to fill holes completely!" // & + " The holes were filled partially. |total_hole| > total_mass" + endif + + hm_one_lev_filled(i) = min(hm_one_lev(i), zero) * ( one + total_mass / total_hole ) + + else ! fill holes completely + hm_one_lev_filled(i) = max(hm_one_lev(i), zero) * ( one + total_hole / total_mass ) + + endif + + enddo + + ! Assertion checks (water substance conservation, non-negativity) + if ( clubb_at_least_debug_level( 2 ) ) then + + if ( sum( hm_one_lev ) /= sum(hm_one_lev_filled) ) then + print *, "Warning: Hole filling was not conservative!" + endif + + if ( any( hm_one_lev_filled < zero ) ) then + print *, "Warning: Hole filling failed! A hole could not be filled." + endif + + endif + + return + + end subroutine hole_filling_hm_one_lev + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_hydromet( nz, hydromet_dim, hydromet, & ! Intent(in) + hydromet_filled ) ! Intent(out) + + ! Description: + ! Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + ! The hole filling conserves water substance between all same-phase (frozen or liquid) + ! hydrometeors at each height level. + ! + ! Attention: The hole filling for the liquid phase hydrometeors is not yet implemented + ! + ! Attention: l_frozen_hm and l_mix_rat_hm need to be set up before this subroutine is called! + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + use array_index, only: & + l_frozen_hm, & ! Variable(s) + l_mix_rat_hm + + use constants_clubb, only: & + zero + + implicit none + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet + + ! Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(out) :: & + hydromet_filled + + ! Local Variables + integer :: i,j ! Loop iterators + + integer :: num_frozen_hm ! Number of frozen hydrometeor mixing ratios + + real( kind = core_rknd ), dimension(:,:), allocatable :: & + hydromet_frozen, & ! Frozen hydrometeor mixing ratios + hydromet_frozen_filled ! Frozen hydrometeor mixing ratios after hole filling + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Determine the number of frozen hydrometeor mixing ratios + num_frozen_hm = 0 + do i=1,hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + num_frozen_hm = num_frozen_hm + 1 + endif + enddo + + ! Allocation + allocate( hydromet_frozen(nz,num_frozen_hm) ) + allocate( hydromet_frozen_filled(nz,num_frozen_hm) ) + + ! Determine frozen hydrometeor mixing ratios + j = 1 + do i = 1,hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + hydromet_frozen(:,j) = hydromet(:,i) + j = j+1 + endif + enddo + + ! Fill holes for the frozen hydrometeors + do i=1,nz + if ( any( hydromet_frozen(i,:) < zero ) ) then + call hole_filling_hm_one_lev( num_frozen_hm, hydromet_frozen(i,:), & ! Intent(in) + hydromet_frozen_filled(i,:) ) ! Intent(out) + else + hydromet_frozen_filled(i,:) = hydromet_frozen(i,:) + endif + enddo + + ! Setup the filled hydromet array + j = 1 + do i=1, hydromet_dim + if ( l_frozen_hm(i) .and. l_mix_rat_hm(i) ) then + hydromet_filled(:,i) = hydromet_frozen_filled(:,j) + j = j+1 + else + hydromet_filled(:,i) = hydromet(:,i) + endif + enddo + + !!! Here we could do the same hole filling for all the liquid phase hydrometeors + + return + end subroutine fill_holes_hydromet + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_wv( nz, dt, exner, hydromet_name, & ! Intent(in) + rvm_mc, thlm_mc, hydromet )! Intent(inout) + + ! Description: + ! Fills holes using the cloud water mixing ratio from the current height level. + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + use constants_clubb, only: & + zero_threshold, & + Lv, & + Ls, & + Cp + + implicit none + + ! Input Variables + integer, intent(in) :: nz + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + character(len=10), intent(in) :: hydromet_name + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + hydromet, & ! Hydrometeor array [units vary] + rvm_mc, & + thlm_mc + + ! Local Variables + integer :: k ! Loop iterator + + real( kind = core_rknd ) :: rvm_clip_tndcy + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + do k = 2, nz, 1 + + if ( hydromet(k) < zero_threshold ) then + + ! Set rvm_clip_tndcy to the time tendency applied to vapor and removed + ! from the hydrometeor. + rvm_clip_tndcy = hydromet(k) / dt + + ! Adjust the tendency rvm_mc accordingly + rvm_mc(k) = rvm_mc(k) + rvm_clip_tndcy + + ! Adjust the tendency of thlm_mc according to whether the + ! effect is an evaporation or sublimation tendency. + select case ( trim( hydromet_name ) ) + case( "rrm" ) + thlm_mc(k) = thlm_mc(k) - rvm_clip_tndcy * ( Lv / ( Cp*exner(k) ) ) + case( "rim", "rsm", "rgm" ) + thlm_mc(k) = thlm_mc(k) - rvm_clip_tndcy * ( Ls / ( Cp*exner(k) ) ) + case default + stop "Fatal error in microphys_driver" + end select + + ! Set the mixing ratio to 0 + hydromet(k) = zero_threshold + + endif ! hydromet(k,i) < 0 + + enddo ! k = 2..gr%nz + + return + end subroutine fill_holes_wv + !----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + subroutine fill_holes_driver( nz, dt, hydromet_dim, & ! Intent(in) + l_fill_holes_hm, & ! Intent(in) + rho_ds_zm, rho_ds_zt, exner, & ! Intent(in) + thlm_mc, rvm_mc, hydromet ) ! Intent(inout) + + ! Description: + ! Fills holes between same-phase hydrometeors(i.e. for frozen hydrometeors). + ! The hole filling conserves water substance between all same-phase (frozen or liquid) + ! hydrometeors at each height level. + ! + ! Attention: The hole filling for the liquid phase hydrometeors is not yet implemented + ! + ! Attention: l_frozen_hm and l_mix_rat_hm need to be set up before this subroutine is called! + ! + ! References: + ! + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + pi, & + four_thirds, & + one, & + zero, & + zero_threshold, & + Lv, & + Ls, & + Cp, & + rho_lw, & + rho_ice, & + fstderr + + use array_index, only: & + hydromet_list, & ! Names of the hydrometeor species + hydromet_tol + + use array_index, only: & + l_mix_rat_hm, & ! Variable(s) + l_frozen_hm + + use index_mapping, only: & + Nx2rx_hm_idx, & ! Procedure(s) + mvr_hm_max + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Subroutines + stat_end_update + + use stats_variables, only: & + stats_zt, & ! Variables + l_stats_samp + + implicit none + + intrinsic :: trim + + ! Input Variables + integer, intent(in) :: hydromet_dim, nz + + logical, intent(in) :: l_fill_holes_hm + + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt ! Dry, static density on thermo. levels [kg/m^3] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + exner ! Exner function [-] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz, hydromet_dim), intent(inout) :: & + hydromet + + real( kind = core_rknd ), dimension(nz), intent(inout) :: & + rvm_mc, & ! Microphysics contributions to vapor water [kg/kg/s] + thlm_mc ! Microphysics contributions to liquid potential temp. [K/s] + + ! Local Variables + integer :: i, k ! Loop iterators + + real( kind = core_rknd ), dimension(nz, hydromet_dim) :: & + hydromet_filled ! Frozen hydrometeor mixing ratios after hole filling + + character( len = 10 ) :: hydromet_name + + real( kind = core_rknd ) :: & + Nxm_min_coef, & ! Coefficient for min. mean value of a concentration [1/kg] + max_velocity ! Maximum sedimentation velocity [m/s] + + integer :: ixrm_hf, ixrm_wvhf, ixrm_cl, & + ixrm_bt, ixrm_mc + + logical :: l_hole_fill = .true. + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Start stats output for the _hf variables (changes in the hydromet array + ! due to fill_holes_hydromet and fill_holes_vertical) + if ( l_stats_samp ) then + + do i = 1, hydromet_dim + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + call stat_begin_update( ixrm_hf, hydromet(:,i) & + / dt, stats_zt ) + + enddo ! i = 1, hydromet_dim + + endif ! l_stats_samp + + ! If we're dealing with negative hydrometeors, we first try to fill the + ! holes proportionally from other same-phase hydrometeors at each height + ! level. + if ( any( hydromet < zero_threshold ) .and. l_fill_holes_hm ) then + + call fill_holes_hydromet( nz, hydromet_dim, hydromet, & ! Intent(in) + hydromet_filled ) ! Intent(out) + + hydromet = hydromet_filled + + endif ! any( hydromet < zero ) .and. l_fill_holes_hm + + hydromet_filled = zero + + do i = 1, hydromet_dim + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Print warning message if any hydrometeor species has a value < 0. + if ( clubb_at_least_debug_level( 1 ) ) then + if ( any( hydromet(:,i) < zero_threshold ) ) then + + hydromet_name = hydromet_list(i) + + do k = 1, nz + if ( hydromet(k,i) < zero_threshold ) then + write(fstderr,*) trim( hydromet_name ) //" < ", & + zero_threshold, & + " in fill_holes_driver at k= ", k + endif ! hydromet(k,i) < 0 + enddo ! k = 1, nz + endif ! hydromet(:,i) < 0 + endif ! clubb_at_least_debug_level( 1 ) + + + ! Store the previous value of the hydrometeor for the effect of the + ! hole-filling scheme. +! if ( l_stats_samp ) then +! call stat_begin_update( ixrm_hf, hydromet(:,i) & +! / dt, stats_zt ) +! endif + + ! If we're dealing with a mixing ratio and hole filling is enabled, + ! then we apply the hole filling algorithm + if ( any( hydromet(:,i) < zero_threshold ) ) then + + if ( hydromet_name(1:1) == "r" .and. l_hole_fill ) then + + ! Apply the hole filling algorithm + call fill_holes_vertical( 2, zero_threshold, "zt", & + rho_ds_zt, rho_ds_zm, & + hydromet(:,i) ) + + endif ! Variable is a mixing ratio and l_hole_fill is true + + endif ! hydromet(:,i) < 0 + + ! Enter the new value of the hydrometeor for the effect of the + ! hole-filling scheme. + if ( l_stats_samp ) then + call stat_end_update( ixrm_hf, hydromet(:,i) & + / dt, stats_zt ) + endif + + ! Store the previous value of the hydrometeor for the effect of the water + ! vapor hole-filling scheme. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_wvhf, hydromet(:,i) & + / dt, stats_zt ) + endif + + if ( any( hydromet(:,i) < zero_threshold ) ) then + + if ( hydromet_name(1:1) == "r" .and. l_hole_fill ) then + + ! If the hole filling algorithm failed, then we attempt to fill + ! the missing mass with water vapor mixing ratio. + ! We noticed this is needed for ASEX A209, particularly if Latin + ! hypercube sampling is enabled. -dschanen 11 Nov 2010 + call fill_holes_wv( nz, dt, exner, hydromet_name, & ! Intent(in) + rvm_mc, thlm_mc, hydromet(:,i) ) ! Intent(out) + + endif ! Variable is a mixing ratio and l_hole_fill is true + + endif ! hydromet(:,i) < 0 + + ! Enter the new value of the hydrometeor for the effect of the water vapor + ! hole-filling scheme. + if ( l_stats_samp ) then + call stat_end_update( ixrm_wvhf, hydromet(:,i) & + / dt, stats_zt ) + endif + + ! Clipping for hydrometeor mixing ratios. + if ( l_mix_rat_hm(i) ) then + + ! Store the previous value of the hydrometeor for the effect of + ! clipping. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_cl, & + hydromet(:,i) & + / dt, & + stats_zt ) + endif + + if ( any( hydromet(:,i) < zero_threshold ) ) then + + ! Clip any remaining negative values of precipitating hydrometeor + ! mixing ratios to 0. + where ( hydromet(:,i) < zero_threshold ) + hydromet(:,i) = zero_threshold + end where + + endif ! hydromet(:,i) < 0 + + ! Eliminate very small values of mean precipitating hydrometeor mixing + ! ratios by setting them to 0. + do k = 2, gr%nz, 1 + + if ( hydromet(k,i) <= hydromet_tol(i) ) then + + rvm_mc(k) & + = rvm_mc(k) & + + ( hydromet(k,i) / dt ) + + if ( .not. l_frozen_hm(i) ) then + + ! Rain water mixing ratio + + thlm_mc(k) & + = thlm_mc(k) & + - ( Lv / ( Cp * exner(k) ) ) & + * ( hydromet(k,i) / dt ) + + else ! Frozen hydrometeor mixing ratio + + thlm_mc(k) & + = thlm_mc(k) & + - ( Ls / ( Cp * exner(k) ) ) & + * ( hydromet(k,i) / dt ) + + endif ! l_frozen_hm(i) + + hydromet(k,i) = zero + + endif ! hydromet(k,i) <= hydromet_tol(i) + + enddo ! k = 2, gr%nz, 1 + + + ! Enter the new value of the hydrometeor for the effect of clipping. + if ( l_stats_samp ) then + call stat_end_update( ixrm_cl, hydromet(:,i) & + / dt, stats_zt ) + endif + + endif ! l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + ! Clipping for hydrometeor concentrations. + do i = 1, hydromet_dim + + if ( .not. l_mix_rat_hm(i) ) then + + ! Set up the stats indices for hydrometeor at index i + call setup_stats_indices( i, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Store the previous value of the hydrometeor for the effect of + ! clipping. + if ( l_stats_samp ) then + call stat_begin_update( ixrm_cl, & + hydromet(:,i) & + / dt, & + stats_zt ) + endif + + if ( .not. l_frozen_hm(i) ) then + + ! Clipping for mean rain drop concentration, . + ! When mean rain water mixing ratio, , is found at a grid level, + ! mean rain drop concentration must be at least a minimum value so + ! that average rain drop mean volume radius stays within an upper + ! bound. Otherwise, mean rain drop concentration is 0. + + ! The minimum mean rain drop concentration is given by: + ! + ! = / ( (4/3) * pi * rho_lw * mvr_rain_max^3 ). + + Nxm_min_coef & + = one / ( four_thirds * pi * rho_lw * mvr_hm_max(i)**3 ) + + else ! l_frozen_hm(i) + + ! Clipping for mean frozen hydrometeor concentration, . + ! When mean frozen hydrometeor mixing ratio, , is found at a + ! grid level, mean frozen hydrometeor concentration must be at least + ! a minimum value so that average frozen hydrometeor mean volume + ! radius stays within an upper bound. Otherwise, mean frozen + ! hydrometeor concentration is 0. + + ! The minimum mean frozen hydrometeor concentration is given by: + ! + ! = / ( (4/3) * pi * rho_ice * mvr_x_max^3 ). + + Nxm_min_coef & + = one / ( four_thirds * pi * rho_ice * mvr_hm_max(i)**3 ) + + endif ! .not. l_frozen_hm(i) + + ! Loop over vertical levels and increase hydrometeor concentrations + ! when necessary. + do k = 2, gr%nz, 1 + + if ( hydromet(k,Nx2rx_hm_idx(i)) > zero ) then + + ! Hydrometeor mixing ratio, , is found at the grid level. + hydromet(k,i) & + = max( hydromet(k,i), & + Nxm_min_coef * hydromet(k,Nx2rx_hm_idx(i)) ) + + else ! = 0 + + hydromet(k,i) = zero + + endif ! hydromet(k,Nx2rx_hm_idx(i)) > 0 + + enddo ! k = 2, gr%nz, 1 + + ! Enter the new value of the hydrometeor for the effect of clipping. + if ( l_stats_samp ) then + call stat_end_update( ixrm_cl, hydromet(:,i) & + / dt, stats_zt ) + endif + + endif ! .not. l_mix_rat_hm(i) + + enddo ! i = 1, hydromet_dim, 1 + + + return + + end subroutine fill_holes_driver + + !----------------------------------------------------------------------- + subroutine setup_stats_indices( ihm, & ! Intent(in) + ixrm_bt, ixrm_hf, ixrm_wvhf, & ! Intent(inout) + ixrm_cl, ixrm_mc, & ! Intent(inout) + max_velocity ) ! Intent(inout) + + ! Description: + ! + ! Determines the stats output indices depending on the hydrometeor. + + ! Attention: hydromet_list needs to be set up before this routine is called. + ! + ! Bogus example + ! References: + ! + ! None + !----------------------------------------------------------------------- + + + use array_index, only: & + hydromet_list ! Names of the hydrometeor species + + use stats_variables, only: & + irrm_bt, & ! Variable(s) + irrm_mc, & + irrm_hf, & + irrm_wvhf, & + irrm_cl, & + irim_bt, & + irim_mc, & + irim_hf, & + irim_wvhf, & + irim_cl, & + irgm_bt, & + irgm_mc, & + irgm_hf, & + irgm_wvhf, & + irgm_cl, & + irsm_bt, & + irsm_mc, & + irsm_hf, & + irsm_wvhf, & + irsm_cl + + use stats_variables, only: & + iNrm_bt, & ! Variable(s) + iNrm_mc, & + iNrm_cl, & + iNim_bt, & + iNim_cl, & + iNim_mc, & + iNsm_bt, & + iNsm_cl, & + iNsm_mc, & + iNgm_bt, & + iNgm_cl, & + iNgm_mc, & + iNcm_bt, & + iNcm_cl, & + iNcm_mc + + use clubb_precision, only: & + core_rknd + + use constants_clubb, only: & + zero + + implicit none + + ! Input Variables + integer, intent(in) :: ihm + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout) :: & + max_velocity ! Maximum sedimentation velocity [m/s] + + integer, intent(inout) :: ixrm_hf, ixrm_wvhf, ixrm_cl, & + ixrm_bt, ixrm_mc + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Initializing max_velocity in order to avoid a compiler warning. + ! Regardless of the case, it will be reset in the 'select case' + ! statement immediately below. + max_velocity = zero + + select case ( trim( hydromet_list(ihm) ) ) + case ( "rrm" ) + ixrm_bt = irrm_bt + ixrm_hf = irrm_hf + ixrm_wvhf = irrm_wvhf + ixrm_cl = irrm_cl + ixrm_mc = irrm_mc + + max_velocity = -9.1_core_rknd ! m/s + + case ( "rim" ) + ixrm_bt = irim_bt + ixrm_hf = irim_hf + ixrm_wvhf = irim_wvhf + ixrm_cl = irim_cl + ixrm_mc = irim_mc + + max_velocity = -1.2_core_rknd ! m/s + + case ( "rsm" ) + ixrm_bt = irsm_bt + ixrm_hf = irsm_hf + ixrm_wvhf = irsm_wvhf + ixrm_cl = irsm_cl + ixrm_mc = irsm_mc + + ! Morrison limit +! max_velocity = -1.2_core_rknd ! m/s + ! Made up limit. The literature suggests that it is quite possible + ! that snow flake might achieve a terminal velocity of 2 m/s, and this + ! happens in the COAMPS microphysics -dschanen 29 Sept 2009 + max_velocity = -2.0_core_rknd ! m/s + + case ( "rgm" ) + ixrm_bt = irgm_bt + ixrm_hf = irgm_hf + ixrm_wvhf = irgm_wvhf + ixrm_cl = irgm_cl + ixrm_mc = irgm_mc + + max_velocity = -20._core_rknd ! m/s + + case ( "Nrm" ) + ixrm_bt = iNrm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNrm_cl + ixrm_mc = iNrm_mc + + max_velocity = -9.1_core_rknd ! m/s + + case ( "Nim" ) + ixrm_bt = iNim_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNim_cl + ixrm_mc = iNim_mc + + max_velocity = -1.2_core_rknd ! m/s + + case ( "Nsm" ) + ixrm_bt = iNsm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNsm_cl + ixrm_mc = iNsm_mc + + ! Morrison limit +! max_velocity = -1.2_core_rknd ! m/s + ! Made up limit. The literature suggests that it is quite possible + ! that snow flake might achieve a terminal velocity of 2 m/s, and this + ! happens in the COAMPS microphysics -dschanen 29 Sept 2009 + max_velocity = -2.0_core_rknd ! m/s + + case ( "Ngm" ) + ixrm_bt = iNgm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNgm_cl + ixrm_mc = iNgm_mc + + max_velocity = -20._core_rknd ! m/s + + case ( "Ncm" ) + ixrm_bt = iNcm_bt + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = iNcm_cl + ixrm_mc = iNcm_mc + + ! Use the rain water limit, since Morrison has no explicit limit on + ! cloud water. Presumably these numbers are never large. + ! -dschanen 28 Sept 2009 + max_velocity = -9.1_core_rknd ! m/s + + case default + ixrm_bt = 0 + ixrm_hf = 0 + ixrm_wvhf = 0 + ixrm_cl = 0 + ixrm_mc = 0 + + max_velocity = -9.1_core_rknd ! m/s + + end select + + + return + + end subroutine setup_stats_indices + !----------------------------------------------------------------------- + +end module fill_holes diff --git a/src/physics/clubb/gmres_cache.F90 b/src/physics/clubb/gmres_cache.F90 new file mode 100644 index 0000000000..2dad00080f --- /dev/null +++ b/src/physics/clubb/gmres_cache.F90 @@ -0,0 +1,179 @@ +!---------------------------------------------------------------------------- +! $Id: gmres_cache.F90 5623 2012-01-17 17:55:26Z connork@uwm.edu $ +!============================================================================== +module gmres_cache + +#ifdef MKL + + use clubb_precision, only: & + dp ! double precision + + ! Description: + ! This module contains cache data structures for the GMRES wrapper class. + ! + ! This is mostly to allow us to get around some...odd errors when it was + ! integrated into the gmres_wrap module. The cache variables are public, as + ! they will need to be passed in whenever gmres_solve is called. + + implicit none + + public :: gmres_cache_matrix_init, gmres_cache_soln, & + gmres_cache_temp_init + + private ! Default scope + + real( kind = dp ), public, allocatable, dimension(:,:) :: & + gmres_prev_soln, & ! Stores the previous solution vectors from earlier + ! GMRES solve runs. The first dimension is for the + ! actual vector; the second dimension is to determine + ! which cache to access--this is done via the GMRES + ! indices for each of the different matrices. + gmres_prev_precond_a ! Stores the previous preconditioner matrix from + ! earlier GMRES solve runs. The first dimension is + ! for the a-array itself; the second dimension is to + ! determine which cached array to access--this is + ! done via the GMRES indices for each of the + ! different matrices. + +!$omp threadprivate( gmres_prev_soln, gmres_prev_precond_a ) + + real( kind = dp ), public, allocatable, dimension(:) :: & + gmres_temp_intlc, & ! Temporary array that stores GMRES internal values + ! for the interlaced matrices (2 x gr%nz grid + ! levels) + gmres_temp_norm ! Temporary array that stores GMRES internal values + ! for the non-interlaced matrices (gr%nz grid + ! levels) + +!$omp threadprivate( gmres_tmp_intlc, gmres_temp_norm ) + + integer, public :: & + gmres_tempsize_norm, & ! Size of the temporary array for + ! non-interlaced matrices + gmres_tempsize_intlc ! Size of the temporary array for + ! interlaced matrices + +!$omp threadprivate( gmres_tempsize_norm, gmres_tempsize_intlc ) + + integer, public, parameter :: & + maximum_gmres_idx = 1 ! Maximum number of different types of solves the + ! wrapper can keep memory for. If new matrices are + ! added that GMRES is to be used for, increase this + ! number and add a public parameter corresponding to + ! the matrix below: + + integer, public, parameter :: & + gmres_idx_wp2wp3 = 1 ! GMRES wrapper index for the wp2_wp3 matrices + + logical, public, dimension(maximum_gmres_idx) :: & + l_gmres_soln_ok ! Stores if the current solution is "okay"--that is, if an + ! initial solution has been passed in for that particular + ! cache index. This defaults to false and is set to true + ! when a solution is updated. + +!$omp threadprivate(l_gmres_soln_ok) + + contains + + subroutine gmres_cache_temp_init(numeqns) ! Intent(in) + ! Description: + ! Initialization subroutine for the temporary arrays for GMRES + ! + ! This subroutine initializes the temporary arrays that are used to work + ! the GMRES solver. + ! + ! These temporary arrays are used for all GMRES solves. + ! + ! References: + ! None + + implicit none + + ! Input Variables + integer, intent(in) :: & + numeqns ! Number of equations for non-interlaced matrices (gr%nz) + + integer :: & + numeqns_intlc ! Number of equations for interlaced matrices + + numeqns_intlc = numeqns * 2 + + ! Figure out the sizes of the temporary arrays + ! The equations were lifted from the Intel documentation of dfgmres: + ! http://www.intel.com/software/products/mkl/docs/webhelp/ssr/functn_rci_dfgmres.html + ! All of the ipar(15)s have been replaced with "numeqns", as the code + ! examples seemed to use N (numeqns) in place of ipar(15). + gmres_tempsize_norm = ((((2*numeqns + 1)*numeqns) & + + (numeqns*(numeqns+9))/2) + 1) ! Known magic number + + gmres_tempsize_intlc = ((((2*numeqns_intlc + 1)*numeqns_intlc) & + + (numeqns_intlc*(numeqns_intlc+9))/2) + 1) ! Known magic number + + ! Allocate the temporary arrays + allocate( gmres_temp_intlc(1:gmres_tempsize_intlc), & + gmres_temp_norm(1:gmres_tempsize_norm) ) + + end subroutine gmres_cache_temp_init + + subroutine gmres_cache_matrix_init(max_numeqns, max_elements, & ! Intent(in) + max_gmres_idx) ! Intent(in) + ! Description: + ! Initialization subroutine for the caches for GMRES. + ! + ! This initializes the cache that stores the previous solution and + ! previous preconditioner values for all GMRES solves. + ! + ! References: + ! None + + implicit none + + ! Input Variables + integer, intent(in) :: & + max_numeqns, & ! Maximum number of equations for a matrix that will be + ! solved with GMRES + max_elements, & ! Maximum number of non-zero elements for a matrix that + ! will be solved with GMRES + max_gmres_idx ! Maximum number of distinct matrices that will be solved + ! with GMRES + + allocate( gmres_prev_soln(1:max_numeqns,1:max_gmres_idx), & + gmres_prev_precond_a(1:max_elements,1:max_gmres_idx) ) + + l_gmres_soln_ok = .false. + + end subroutine gmres_cache_matrix_init + + subroutine gmres_cache_soln(numeqns, gmres_idx, solution) ! Intent(in) + ! Description: + ! Subroutine that caches a previous solution for a particular GMRES-solved + ! matrix. + ! + ! Stores the current solution in the cache so it can be referenced for + ! the next GMRES solve. This subroutine will also set the solution_ok + ! flag for that particular GMRES index. + ! + ! References: + ! None + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + integer, intent(in) :: & + numeqns, & ! The number of equations in the solution vector + gmres_idx ! The index for the particular matrix solved by GMRES + + real( kind = core_rknd ), dimension(numeqns), intent(in) :: & + solution ! The solution vector to be cached + + gmres_prev_soln(1:numeqns,gmres_idx) = solution + + l_gmres_soln_ok(gmres_idx) = .true. + + end subroutine gmres_cache_soln + +#endif /* MKL */ + +end module gmres_cache diff --git a/src/physics/clubb/gmres_wrap.F90 b/src/physics/clubb/gmres_wrap.F90 new file mode 100644 index 0000000000..4ec015577a --- /dev/null +++ b/src/physics/clubb/gmres_wrap.F90 @@ -0,0 +1,390 @@ +!---------------------------------------------------------------------------- +! $Id: gmres_wrap.F90 7012 2014-07-07 14:18:31Z schemena@uwm.edu $ +!============================================================================== + +module gmres_wrap + +#ifdef MKL + + ! Description: + ! This module wraps the MKL version of GMRES, an iterative solver. Note that + ! this will only work for the MKL-specific version of GMRES--any other GMRES + ! implementations will require retooling of this code! + ! + ! The primary subroutine, gmres_solve utilizes GMRES to solve a given matrix. + ! + ! There is also a gmres_init, which initializes some of the internal data + ! used for the wrapper. + ! + ! This wrapper automatically keeps prior solutions to use the previous data + ! to speed up the solves. For the purposes of allowing this solver to be used + ! with more than one matrix type, the wrapper has a "solve index" variable. + ! Pass in the proper solve index variable to associate your solve with + ! previous solves of the same matrix. + + use gmres_cache, only: & + maximum_gmres_idx ! Variable + + implicit none + + public :: gmres_solve, gmres_init + + private ! Default scope + + contains + + subroutine gmres_init(max_numeqns, max_elements) ! Intent(in) + + ! Description: + ! Initialization subroutine for the GMRES iterative matrix equation solver + ! + ! This subroutine initializes the previous memory handles for the GMRES + ! routines, for the purpose of speeding up calculations. + ! These handles are initialized to a size specified by the number of + ! equations specified in this subroutine. + ! + ! WARNING: Once initialized, only use the specified gmres_idx for that + ! particular matrix! Failure to do so could result in greatly decreased + ! performance, incorrect solutions, or both! + ! + ! Once this is called, the proper prev_soln_ and prev_lu_ + ! handles in the gmres_cache module can be used, and will need to be passed + ! in to gmres_solve for that matrix. + ! + ! References: + ! None + + use gmres_cache, only: & + gmres_cache_matrix_init ! Subroutines + + implicit none + + ! Input Variables + integer, intent(in) :: & + max_numeqns, & ! Maximum number of equations for a matrix that will be + ! solved with GMRES + max_elements ! Maximum number of non-zero elements for a matrix that + ! will be solved with GMRES + + call gmres_cache_matrix_init( max_numeqns, max_elements, maximum_gmres_idx ) + + end subroutine gmres_init + + subroutine gmres_solve(elements, numeqns, & !Intent(in) + csr_a, csr_ia, csr_ja, tempsize, & !Intent(in) + prev_soln, prev_lu, rhs, temp, & !Intent(in/out) + solution, err_code) !Intent(out) + + ! Description: + ! Solves a matrix equation using GMRES. On the first timestep and every + ! fifth timestep afterward, a preconditioner is computed for the matrix + ! and stored. In addition, on the first timestep the matrix is solved using + ! LAPACK, which is used as the estimate for GMRES for the first timestep. + ! After this, the previous solution found is used as the estimate. + ! + ! To use the proper cached preconditioner and solution, make sure you pass + ! the proper gmres_idx corresponding to the matrix you're solving--using a + ! value different than what has been used in the past will cause, at best, + ! a slower solve, and at worst, an incorrect one. + ! + ! References: + ! None + + use clubb_precision, only: & + dp, & ! double precision + core_rknd + + implicit none + + include "mkl_rci.fi" + + ! Input variables + integer, intent(in) :: & + elements, & ! Number of elements in the csr_a/csr_ja arrays + numeqns ! Number of equations in the matrix + + real( kind = core_rknd ), dimension(elements), intent(in) :: & + csr_a ! A-array description of the matrix in CSR format. This + ! will be converted to double precision for the purposes + ! of running GMRES. + + integer, dimension(numeqns + 1), intent(in) :: & + csr_ia ! IA-array portion of the matrix description in CSR format. + ! This describes the indices of the JA-array that start + ! new rows. For more details, check the documentation in + ! the csr_matrix_module. + + integer, dimension(elements), intent(in) :: & + csr_ja ! JA-array portion of the matrix description in CSR format. + ! This describes which columns of a are nonzero. For more + ! details, check the documentation in the csr_matrix_module. + + integer, intent(in) :: & + tempsize ! Denotes the size of the temporary array used for GMRES + ! calculations. + + ! Input/Output variables + real( kind = core_rknd ), dimension(numeqns), intent(inout) :: & + rhs ! Right-hand-side vectors to solve the equation for. + + real( kind = dp ), dimension(numeqns), intent(inout) :: & + prev_soln ! Previous solution cache vector for the matrix to be solved + ! for--pass the proper handle from the gmres_cache module + + real( kind = dp ), dimension(elements), intent(inout) :: & + prev_lu ! Previous LU-decomposition a-array for the matrix to be + ! solved for--pass the proper handle from the gmres_cache + ! module + + real( kind = dp ), dimension(tempsize), intent(inout) :: & + temp ! Temporary array that stores working values while the GMRES + ! solver iterates + + ! Output variables + real( kind = core_rknd ), dimension(numeqns), intent(out) :: & + solution ! Solution vector, output of solver routine + + integer, intent(out) :: & + err_code ! Error code, nonzero if errors occurred. + + ! Local variables + logical :: l_gmres_run ! Variable denoting if we need to loop and run + ! a GMRES iteration again. + + integer :: & + rci_req, & ! RCI_Request for GMRES--allows us to take action based + ! on what the iterative solver requests to be done. + iters ! Total number of iterations GMRES has run. + + integer, dimension(128) :: & + ipar ! Parameter array for the GMRES iterative solver + + real( kind = dp ), dimension(128) :: & + dpar ! Parameter array for the GMRES iterative solver + + ! The following local variables are double-precision so we can use GMRES + ! as there is only double-precision support for GMRES. + ! We will need to convert our single-precision numbers to double precision + ! for the duration of the calculations. + real( kind = dp ), dimension(elements) :: & + csr_dbl_a ! Double-precision version of the CSR-format A array + + real( kind = dp ), dimension(numeqns) :: & + dbl_rhs, & ! Double-precision version of the rhs vector + dbl_soln, & ! Double-precision version of the solution vector + tempvec ! Temporary vector for applying inverse LU-decomp matrix + !tmp_rhs + + ! Variables used to solve the preconditioner the first time with PARDISO. + !integer, parameter :: & + !pardiso_size_arrays = 64, & + !real_nonsymm = 11 + + !integer(kind=8), dimension(pardiso_size_arrays) :: & + ! pt ! PARDISO internal pointer array + + !integer(kind=4), dimension(pardiso_size_arrays) :: & + ! iparm + + !integer(kind=4), dimension(numeqns) :: & + ! perm + + ! integer :: i, j + + ! We want to be running, initially. + l_gmres_run = .true. + + ! Set the default error code to 0 (no errors) + ! This is to make the default explicit; Fortran initializes + ! values to 0. + err_code = 0 + + ! Convert our A array and rhs vector to double precision... + csr_dbl_a = real(csr_a, kind=dp) + dbl_rhs = real(rhs, kind=dp) + + ! DEBUG: Set our a_array so it represents the identity matrix, and + ! set the RHS so we can get a meaningful answer. +! csr_dbl_a = 1_dp +! csr_dbl_a(1) = 1D1 +! csr_dbl_a(5) = 1D1 +! csr_dbl_a(elements) = 1D1 +! csr_dbl_a(elements - 4) = 1D1 +! do i=10,elements - 9,5 +! csr_dbl_a(i) = 1D1 +! end do +! do i=1,numeqns,1 +! dbl_rhs(i) = i * 1_dp +! end do +! dbl_rhs = 9D3 +! dbl_rhs = 1D1 + + ! DEBUG: Make sure our a_array isn't wrong +! do i=1,elements,1 +! print *, "csr_dbl_a idx",i,"=",csr_dbl_a(i) +! end do + + ! Figure out the default value for ipar(15) and put it in our ipar_15 int. + !ip_15 = min(150, numeqns) + + ! Figure out the size of the temp array. + !tempsize = ((((2*numeqns + 1)*numeqns)+(numeqns*(numeqns+9))/2) + 1) + ! This ugly equation was lifted from the Intel documentation of dfgmres: + ! http://www.intel.com/software/products/mkl/docs/webhelp/ssr/functn_rci_dfgmres.html + ! All of the ipar(15)s have been replaced with "numeqns", as the code + ! examples seemed to use N (numeqns) in place of ipar(15). + + ! Allocate the temp array. + !allocate(temp(1:tempsize)) + + ! Generate our preconditioner matrix with the ILU0 subroutine. + call dcsrilu0( numeqns, csr_dbl_a, csr_ia, csr_ja, & + prev_lu, ipar, dpar, err_code ) + + ! On the first timestep we need to solve our preconditioner to give us + ! our first solution estimate. After this, the previous solution will + ! suffice as an estimate. +! if (iteration_num(gmres_idx) == 0) then + !solve with precond_a, csr_ia, csr_ja. + !One thing to test, too: try just setting the solution vector to 1 + ! for the first timestep and see if it's not too unreasonably slow? +! call pardisoinit( pt, real_nonsymm, iparm ) +#ifdef _OPENMP +! iparm(3) = omp_get_max_threads() +#else +! iparm(3) = 1 +#endif + +! call pardiso( pt, 1, 1, real_nonsymm, 13, numeqns, & !Intent(in) +! prev_lu, csr_ia, csr_ja, perm, 1, iparm, 0, & !Intent(in) +! dbl_rhs, & !Intent(inout) +! prev_soln, err_code ) !Intent(out) +! end if !iteration_num == 1 + + !DEBUG: Set apporximate solution vector to 0.9 (?) for now + !prev_soln(:) = 0.9_dp + + !do i=1,numeqns,1 + ! print *, "Current approximate solution idx",i,"=",prev_soln(i) + !end do + + ! Initialize our solution vector to the previous solution passed in + dbl_soln = prev_soln + + ! Set up the GMRES solver. + call dfgmres_init( numeqns, dbl_soln, dbl_rhs, & + rci_req, ipar, dpar, temp ) + + ! Set the parameters that tell GMRES to handle stopping tests + ipar(9) = 1 + ipar(10) = 0 + ipar(12) = 1 + + ! Set the parameter that tells GMRES to use a preconditioner + ipar(11) = 1 + + ! Check our GMRES settings. + call dfgmres_check( numeqns, dbl_soln, dbl_rhs, & + rci_req, ipar, dpar, temp ) + + ! Start the GMRES solver. We set up a while loop which will be broken when + ! the GMRES solver indicates that a solution has been found. + do while(l_gmres_run) + !print *, "********************************************************" + !print *, "BEGINNING ANOTHER ITERATION..." + !print *, "========================================================" + ! Run a GMRES iteration. + call dfgmres( numeqns, dbl_soln, dbl_rhs, & + rci_req, ipar, dpar, temp ) + + select case(rci_req) + case (0) + l_gmres_run = .false. + case (1) + ! Multiply our left-hand side by the vector placed in the temp array, + ! at ipar(22), and place the result in the temp array at ipar(23). + ! Display temp(ipar(22)) + ! print *, "------------------------------------------------" + ! print *, "RCI_REQ=1: MULTIPLY VECTOR BY A MATRIX" + ! do i=1,numeqns,1 + ! print *, "Tempvec before, idx",i,"=",temp(ipar(22)+i-1) + ! end do + call mkl_dcsrgemv( 'N', numeqns, csr_dbl_a, csr_ia, csr_ja, & + temp(ipar(22)), temp(ipar(23)) ) ! Known magic number + ! do i=1,numeqns,1 + ! print *, "Tempvec after, idx",i,"=",temp(ipar(23)+i-1) + ! end do + ! print *, "------------------------------------------------" + case (2) + ! Ignore this for now, see if GMRES ever escapes. + case (3) + ! Apply the inverse of the preconditioner to the vector placed in the + ! temp array at ipar(22), and place the result in the temp array at + ! ipar(23). + !print *, "------------------------------------------------" + !print *, "RCI_REQ=3: APPLY PRECONDITION TO VECTOR" + !do i=1,numeqns,1 + ! print *, "Tempvec before, idx",i,"=",temp(ipar(22)+i-1) + !end do + call mkl_dcsrtrsv( 'L', 'N', 'U', numeqns, & + prev_lu, csr_ia, csr_ja, & + temp(ipar(22)), tempvec ) ! Known magic number + call mkl_dcsrtrsv( 'U', 'N', 'N', numeqns, & + prev_lu, csr_ia, csr_ja, & + tempvec, temp(ipar(23)) ) ! Known magic number + !do i=1,numeqns,1 + ! print *, "Tempvec after, idx",i,"=",temp(ipar(23)+i-1) + !end do + !print *, "------------------------------------------------" + + case (4) +! if (dpar(7) < GMRES_TOL) then +! l_gmres_run = .false. +! else +! ! Keep running, we aren't there yet. +! l_gmres_run = .true. +! end if + case default + ! We got a response we weren't expecting. This is probably bad. + ! (Then again, maybe it's just not something we accounted for?) + ! Regardless, let's set an error code and break out of here. + print *, "Unknown rci_request returned from GMRES:", rci_req + l_gmres_run = .false. + err_code = -1 + end select + ! Report current iteration +! call dfgmres_get( numeqns, dbl_soln, dbl_rhs, rci_req, & +! ipar, dpar, temp, iters ) +! print *, "========================================================" +! print *, "END OF LOOP: REPORTING INFORMATION" +! print *, "Current number of GMRES iterations: ", iters +! do i=1,numeqns,1 +! print *, "double value of soln so far, idx",i,"=",dbl_soln(i) +! end do +! print *, "========================================================" +! print *, "********************************************************" + end do + !if (err_code == 0) then + + ! Get the answer, convert it to single-precision + call dfgmres_get( numeqns, dbl_soln, dbl_rhs, rci_req, & + ipar, dpar, temp, iters ) + + !print *, "Total iterations for GMRES:",iters + + !do i=1,numeqns,1 + ! print *, "double value of soln, idx",i,"=",dbl_soln(i) + !end do + + ! Store our solution as the previous solution for use in the next + ! simulation timestep. + prev_soln = dbl_soln + + solution = real(dbl_soln) + !end if + + end subroutine gmres_solve + +#endif /* MKL */ + +end module gmres_wrap diff --git a/src/physics/clubb/grid_class.F90 b/src/physics/clubb/grid_class.F90 new file mode 100644 index 0000000000..c06c7ed736 --- /dev/null +++ b/src/physics/clubb/grid_class.F90 @@ -0,0 +1,2298 @@ +!------------------------------------------------------------------------ +! $Id: grid_class.F90 7200 2014-08-13 15:15:12Z betlej@uwm.edu $ +!=============================================================================== +module grid_class + + ! Description: + ! + ! Definition of a grid class and associated functions + ! + ! The grid specification is as follows: + ! + ! + ================== zm(nz) =========GP========= + ! | + ! | + ! 1/dzt(nz) + ------------------ zt(nz) ---------GP--------- + ! | | + ! | | + ! + 1/dzm(nz-1) ================== zm(nz-1) ================== + ! | + ! | + ! + ------------------ zt(nz-1) ------------------ + ! + ! . + ! . + ! . + ! . + ! + ! ================== zm(k+1) =================== + ! + ! + ! + ------------------ zt(k+1) ------------------- + ! | + ! | + ! + 1/dzm(k) ================== zm(k) ===================== + ! | | + ! | | + ! 1/dzt(k) + ------------------ zt(k) --------------------- + ! | + ! | + ! + ================== zm(k-1) =================== + ! + ! + ! ------------------ zt(k-1) ------------------- + ! + ! . + ! . + ! . + ! . + ! + ! + ================== zm(2) ===================== + ! | + ! | + ! 1/dzt(2) + ------------------ zt(2) --------------------- + ! | | + ! | | + ! + 1/dzm(1) ================== zm(1) ============GP======= zm_init + ! | ////////////////////////////////////////////// surface + ! | + ! + ------------------ zt(1) ------------GP------- + ! + ! + ! The variable zm(k) stands for the momentum level altitude at momentum + ! level k; the variable zt(k) stands for the thermodynamic level altitude at + ! thermodynamic level k; the variable invrs_dzt(k) is the inverse distance + ! between momentum levels (over a central thermodynamic level k); and the + ! variable invrs_dzm(k) is the inverse distance between thermodynamic levels + ! (over a central momentum level k). Please note that in the above diagram, + ! "invrs_dzt" is denoted "dzt", and "invrs_dzm" is denoted "dzm", such that + ! 1/dzt is the distance between successive momentum levels k-1 and k (over a + ! central thermodynamic level k), and 1/dzm is the distance between successive + ! thermodynamic levels k and k+1 (over a central momentum level k). + ! + ! The grid setup is compatible with a stretched (unevely-spaced) grid. Thus, + ! the distance between successive grid levels may not always be constant. + ! + ! The following diagram is an example of a stretched grid that is defined on + ! momentum levels. The thermodynamic levels are placed exactly halfway + ! between the momentum levels. However, the momentum levels do not fall + ! halfway between the thermodynamic levels. + ! + ! =============== zm(k+1) =============== + ! + ! + ! + ! --------------- zt(k+1) --------------- + ! + ! + ! + ! =============== zm(k) =============== + ! + ! --------------- zt(k) --------------- + ! + ! =============== zm(k-1) =============== + ! + ! The following diagram is an example of a stretched grid that is defined on + ! thermodynamic levels. The momentum levels are placed exactly halfway + ! between the thermodynamic levels. However, the thermodynamic levels do not + ! fall halfway between the momentum levels. + ! + ! --------------- zt(k+1) --------------- + ! + ! + ! + ! =============== zm(k) =============== + ! + ! + ! + ! --------------- zt(k) --------------- + ! + ! =============== zm(k-1) =============== + ! + ! --------------- zt(k-1) --------------- + ! + ! NOTE: Any future code written for use in the CLUBB parameterization should + ! use interpolation formulas consistent with a stretched grid. The + ! simplest way to do so is to call the appropriate interpolation + ! function from this module. Interpolations should *not* be handled in + ! the form of: ( var_zm(k) + var_zm(k-1) ) / 2; *nor* in the form of: + ! 0.5_core_rknd*( var_zt(k+1) + var_zt(k) ). Rather, all explicit interpolations + ! should call zt2zm or zm2zt; while interpolations for a variable being + ! solved for implicitly in the code should use gr%weights_zt2zm (which + ! refers to interp_weights_zt2zm_imp), or gr%weights_zm2zt (which + ! refers to interp_weights_zm2zt_imp). + ! + ! Momentum level 1 is placed at altitude zm_init, which is usually at the + ! surface. However, in general, zm_init can be at any altitude defined by the + ! user. + ! + ! GP indicates ghost points. Variables located at those levels are not + ! prognosed, but only used for boundary conditions. + ! + ! Chris Golaz, 7/17/99 + ! modified 9/10/99 + ! schemena, modified 6/11/2014 - Restructered code to add cubic/linear flag + + ! References: + + ! Section 3c, p. 3548 /Numerical discretization/ of: + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + public :: gr, grid, zt2zm, interp_weights_zt2zm_imp, zm2zt, & + interp_weights_zm2zt_imp, ddzm, ddzt, & + setup_grid, cleanup_grid, setup_grid_heights, & + read_grid_heights, flip + + private :: linear_interpolated_azm, linear_interpolated_azmk, & + interpolated_azmk_imp, linear_interpolated_azt, & + linear_interpolated_aztk, interpolated_aztk_imp, & + gradzm, gradzt, t_above, t_below, m_above, m_below, & + cubic_interpolated_azmk, cubic_interpolated_aztk, & + cubic_interpolated_azm, cubic_interpolated_azt + + private ! Default Scoping + + ! Constant parameters + integer, parameter :: & + t_above = 1, & ! Upper thermodynamic level index (gr%weights_zt2zm). + t_below = 2, & ! Lower thermodynamic level index (gr%weights_zt2zm). + m_above = 1, & ! Upper momentum level index (gr%weights_zm2zt). + m_below = 2 ! Lower momentum level index (gr%weights_zm2zt). + + type grid + + integer :: nz ! Number of points in the grid + ! Note: Fortran 90/95 prevents an allocatable array from appearing + ! within a derived type. However, Fortran 2003 does not!!!!!!!! + real( kind = core_rknd ), allocatable, dimension(:) :: & + zm, & ! Momentum grid + zt ! Thermo grid + real( kind = core_rknd ), allocatable, dimension(:) :: & + invrs_dzm, & ! The inverse spacing between thermodynamic grid + ! levels; centered over momentum grid levels. + invrs_dzt ! The inverse spacing between momentum grid levels; + ! centered over thermodynamic grid levels. + + real( kind = core_rknd ), allocatable, dimension(:) :: & + dzm, & ! Spacing between thermodynamic grid levels; centered over + ! momentum grid levels + dzt ! Spcaing between momentum grid levels; centered over + ! thermodynamic grid levels + + ! These weights are normally used in situations + ! where a momentum level variable is being + ! solved for implicitly in an equation and + ! needs to be interpolated to the thermodynamic grid levels. + real( kind = core_rknd ), allocatable, dimension(:,:) :: weights_zm2zt, & + ! These weights are normally used in situations where a + ! thermodynamic level variable is being solved for implicitly in an equation + ! and needs to be interpolated to the momentum grid levels. + weights_zt2zm + + end type grid + + ! The grid is defined here so that it is common throughout the module. + ! The implication is that only one grid can be defined ! + + type (grid), target :: gr + +! Modification for using CLUBB in a host model (i.e. one grid per column) +!$omp threadprivate(gr) + + ! Interfaces provided for function overloading + + interface zt2zm + ! For l_cubic_interp = .true. + ! This version uses cublic spline interpolation of Stefen (1990). + ! + ! For l_cubic_interp = .false. + ! This performs a linear extension at the highest grid level and therefore + ! does not guarantee, for positive definite quantities (e.g. wp2), that the + ! extended point is indeed positive definite. Positive definiteness can be + ! ensured with a max statement. + ! In the future, we could add a flag (lposdef) and, when needed, apply the + ! max statement directly within interpolated_azm and interpolated_azmk. + module procedure redirect_interpolated_azmk, redirect_interpolated_azm + end interface + + interface zm2zt + ! For l_cubic_interp = .true. + ! This version uses cublic spline interpolation of Stefen (1990). + ! + ! For l_cubic_interp = .false. + ! This performs a linear extension at the lowest grid level and therefore + ! does not guarantee, for positive definite quantities (e.g. wp2), that the + ! extended point is indeed positive definite. Positive definiteness can be + ! ensured with a max statement. + ! In the future, we could add a flag (lposdef) and, when needed, apply the + ! max statement directly within interpolated_azt and interpolated_aztk. + module procedure redirect_interpolated_aztk, redirect_interpolated_azt + end interface + + interface interp_weights_zt2zm_imp + module procedure interpolated_azmk_imp + end interface + + + interface interp_weights_zm2zt_imp + module procedure interpolated_aztk_imp + end interface + + ! Vertical derivative functions + interface ddzm + module procedure gradzm + end interface + + interface ddzt + module procedure gradzt + end interface + + contains + + !============================================================================= + subroutine setup_grid( nzmax, sfc_elevation, l_implemented, & + grid_type, deltaz, zm_init, zm_top, & + momentum_heights, thermodynamic_heights, & + begin_height, end_height ) + + ! Description: + ! Grid Constructor + ! + ! This subroutine sets up the CLUBB vertical grid. + ! + ! References: + ! ``Equations for CLUBB'', Sec. 8, Grid Configuration. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + NWARNING = 250 ! Issue a warning if nzmax exceeds this number. + + ! Input Variables + integer, intent(in) :: & + nzmax ! Number of vertical levels in grid [#] + + real( kind = core_rknd ), intent(in) :: & + sfc_elevation ! Elevation of ground level [m AMSL] + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented + + ! If CLUBB is running on it's own, this option determines if it is using: + ! 1) an evenly-spaced grid; + ! 2) a stretched (unevenly-spaced) grid entered on the thermodynamic grid + ! levels (with momentum levels set halfway between thermodynamic levels); + ! or + ! 3) a stretched (unevenly-spaced) grid entered on the momentum grid levels + ! (with thermodynamic levels set halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an evenly-spaced + ! grid (grid_type = 1), it needs the vertical grid spacing and + ! momentum-level starting altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Vertical grid spacing [m] + zm_init, & ! Initial grid altitude (momentum level) [m] + zm_top ! Maximum grid altitude (momentum level) [m] + + ! If the CLUBB parameterization is implemented in a host model, it needs to + ! use the host model's momentum level altitudes and thermodynamic level + ! altitudes. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on thermodynamic levels (grid_type = 2), it needs to use the + ! thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on momentum levels (grid_type = 3), it needs to use the momentum + ! level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + integer, intent(out) :: & + begin_height, & ! Lower bound for *_heights arrays [-] + end_height ! Upper bound for *_heights arrays [-] + + ! Local Variables + integer :: ierr, & ! Allocation stat + i ! Loop index + + + ! ---- Begin Code ---- + + ! Define the grid size + + if ( nzmax > NWARNING .and. clubb_at_least_debug_level( 1 ) ) then + write(fstderr,*) "Warning: running with vertical grid "// & + "which is larger than", NWARNING, "levels." + write(fstderr,*) "This may take a lot of CPU time and memory." + end if + + gr%nz = nzmax + + ! Default bounds + begin_height = 1 + + end_height = gr%nz + + !--------------------------------------------------- + if ( .not. l_implemented ) then + + if ( grid_type == 1 ) then + + ! Determine the number of grid points given the spacing + ! to fit within the bounds without going over. + gr%nz = floor( ( zm_top - zm_init + deltaz ) / deltaz ) + + else if( grid_type == 2 ) then! Thermo + + ! Find begin_height (lower bound) + + i = gr%nz + + do while( thermodynamic_heights(i) >= zm_init .and. i > 1 ) + + i = i - 1 + + end do + + if( thermodynamic_heights(i) >= zm_init ) then + + stop "Stretched zt grid cannot fulfill zm_init requirement" + + else + + begin_height = i + + end if + + ! Find end_height (upper bound) + + i = gr%nz + + do while( thermodynamic_heights(i) > zm_top .and. i > 1 ) + + i = i - 1 + + end do + + if( zm_top < thermodynamic_heights(i) ) then + + stop "Stretched zt grid cannot fulfill zm_top requirement" + + else + + end_height = i + + gr%nz = size( thermodynamic_heights(begin_height:end_height) ) + + end if + + else if( grid_type == 3 ) then ! Momentum + + ! Find begin_height (lower bound) + + i = 1 + + do while( momentum_heights(i) < zm_init .and. i < gr%nz ) + + i = i + 1 + + end do + + if( momentum_heights(i) < zm_init ) then + + stop "Stretched zm grid cannot fulfill zm_init requirement" + + else + + begin_height = i + + end if + + ! Find end_height (lower bound) + + i = gr%nz + + do while( momentum_heights(i) > zm_top .and. i > 1 ) + + i = i - 1 + + end do + + if( momentum_heights(i) > zm_top ) then + + stop "Stretched zm grid cannot fulfill zm_top requirement" + + else + + end_height = i + + gr%nz = size( momentum_heights(begin_height:end_height) ) + + end if + + endif ! grid_type + + endif ! .not. l_implemented + + !--------------------------------------------------- + + ! Allocate memory for the grid levels + allocate( gr%zm(gr%nz), gr%zt(gr%nz), & + gr%dzm(gr%nz), gr%dzt(gr%nz), & + gr%invrs_dzm(gr%nz), gr%invrs_dzt(gr%nz), & + gr%weights_zm2zt(m_above:m_below,gr%nz), & + gr%weights_zt2zm(t_above:t_below,gr%nz), & + stat=ierr ) + + if ( ierr /= 0 ) then + write(fstderr,*) "In setup_grid: allocation of grid variables failed." + stop "Fatal error." + end if + + ! Set the values for the derived types used for heights, derivatives, and + ! interpolation from the momentum/thermodynamic grid + call setup_grid_heights & + ( l_implemented, grid_type, & + deltaz, zm_init, & + momentum_heights(begin_height:end_height), & + thermodynamic_heights(begin_height:end_height) ) + + if ( sfc_elevation > gr%zm(1) ) then + write(fstderr,*) "The altitude of the lowest momentum level, " & + // "gr%zm(1), must be at or above the altitude of " & + // "the surface, sfc_elevation. The lowest model " & + // "momentum level cannot be below the surface." + write(fstderr,*) "Altitude of lowest momentum level =", gr%zm(1) + write(fstderr,*) "Altitude of the surface =", sfc_elevation + stop "Fatal error." + endif + + return + + end subroutine setup_grid + + !============================================================================= + subroutine cleanup_grid + + ! Description: + ! De-allocates the memory for the grid + ! + ! References: + ! None + !------------------------------------------------------------------------------ + use constants_clubb, only: & + fstderr ! Constant(s) + + implicit none + + ! Local Variable(s) + integer :: ierr + + ! ----- Begin Code ----- + + ! Allocate memory for grid levels + deallocate( gr%zm, gr%zt, & + gr%dzm, gr%dzt, & + gr%invrs_dzm, gr%invrs_dzt, & + gr%weights_zm2zt, gr%weights_zt2zm, & + stat=ierr ) + + if ( ierr /= 0 ) then + write(fstderr,*) "Grid deallocation failed." + end if + + + return + + end subroutine cleanup_grid + + !============================================================================= + subroutine setup_grid_heights & + ( l_implemented, grid_type, & + deltaz, zm_init, momentum_heights, & + thermodynamic_heights ) + + ! Description: + ! Sets the heights and interpolation weights of the column. + ! This is seperated from setup_grid for those host models that have heights + ! that vary with time. + ! References: + ! None + !------------------------------------------------------------------------------ + + use constants_clubb, only: & + fstderr ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + + ! Flag to see if CLUBB is running on it's own, + ! or if it's implemented as part of a host model. + logical, intent(in) :: l_implemented + + ! If CLUBB is running on it's own, this option determines if it is using: + ! 1) an evenly-spaced grid; + ! 2) a stretched (unevenly-spaced) grid entered on the thermodynamic grid + ! levels (with momentum levels set halfway between thermodynamic levels); + ! or + ! 3) a stretched (unevenly-spaced) grid entered on the momentum grid levels + ! (with thermodynamic levels set halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB model is running by itself, and is using an evenly-spaced + ! grid (grid_type = 1), it needs the vertical grid spacing and + ! momentum-level starting altitude as input. + real( kind = core_rknd ), intent(in) :: & + deltaz, & ! Vertical grid spacing [m] + zm_init ! Initial grid altitude (momentum level) [m] + + + ! If the CLUBB parameterization is implemented in a host model, it needs to + ! use the host model's momentum level altitudes and thermodynamic level + ! altitudes. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on thermodynamic levels (grid_type = 2), it needs to use the + ! thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on momentum levels (grid_type = 3), it needs to use the momentum + ! level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + integer :: k + + ! ---- Begin Code ---- + + if ( .not. l_implemented ) then + + + if ( grid_type == 1 ) then + + ! Evenly-spaced grid. + ! Momentum level altitudes are defined based on the grid starting + ! altitude, zm_init, the constant grid-spacing, deltaz, and the number + ! of grid levels, gr%nz. + + ! Define momentum level altitudes. The first momentum level is at + ! altitude zm_init. + do k = 1, gr%nz, 1 + gr%zm(k) = zm_init + real( k-1, kind = core_rknd ) * deltaz + enddo + + ! Define thermodynamic level altitudes. Thermodynamic level altitudes + ! are located at the central altitude levels, exactly halfway between + ! momentum level altitudes. The lowermost thermodynamic level is + ! found by taking 1/2 the altitude difference between the bottom two + ! momentum levels and subtracting that value from the bottom momentum + ! level. The first thermodynamic level is below zm_init. + gr%zt(1) = zm_init - ( 0.5_core_rknd * deltaz ) + do k = 2, gr%nz, 1 + gr%zt(k) = 0.5_core_rknd * ( gr%zm(k) + gr%zm(k-1) ) + enddo + + + elseif ( grid_type == 2 ) then + + ! Stretched (unevenly-spaced) grid: stretched thermodynamic levels. + ! Thermodynamic levels are defined according to a stretched grid that + ! is entered through the use of an input file. This is similar to a + ! SAM-style stretched grid. + + ! Define thermodynamic level altitudes. + do k = 1, gr%nz, 1 + gr%zt(k) = thermodynamic_heights(k) + enddo + + ! Define momentum level altitudes. Momentum level altitudes are + ! located at the central altitude levels, exactly halfway between + ! thermodynamic level altitudes. The uppermost momentum level + ! altitude is found by taking 1/2 the altitude difference between the + ! top two thermodynamic levels and adding that value to the top + ! thermodynamic level. + do k = 1, gr%nz-1, 1 + gr%zm(k) = 0.5_core_rknd * ( gr%zt(k+1) + gr%zt(k) ) + enddo + gr%zm(gr%nz) = gr%zt(gr%nz) + & + 0.5_core_rknd * ( gr%zt(gr%nz) - gr%zt(gr%nz-1) ) + + elseif ( grid_type == 3 ) then + + ! Stretched (unevenly-spaced) grid: stretched momentum levels. + ! Momentum levels are defined according to a stretched grid that is + ! entered through the use of an input file. This is similar to a + ! WRF-style stretched grid. + + ! Define momentum level altitudes. + do k = 1, gr%nz, 1 + gr%zm(k) = momentum_heights(k) + enddo + + ! Define thermodynamic level altitudes. Thermodynamic level altitudes + ! are located at the central altitude levels, exactly halfway between + ! momentum level altitudes. The lowermost thermodynamic level + ! altitude is found by taking 1/2 the altitude difference between the + ! bottom two momentum levels and subtracting that value from the + ! bottom momentum level. + gr%zt(1) = gr%zm(1) - 0.5_core_rknd * ( gr%zm(2) - gr%zm(1) ) + do k = 2, gr%nz, 1 + gr%zt(k) = 0.5_core_rknd * ( gr%zm(k) + gr%zm(k-1) ) + enddo + + + else + + ! Invalid grid type. + write(fstderr,*) "Invalid grid type: ", grid_type, & + ". Valid options are 1, 2, or 3." + stop "Fatal error." + + + endif + + + else + + ! The CLUBB parameterization is implemented in a host model. + ! Use the host model's momentum level altitudes and thermodynamic level + ! altitudes to set up the CLUBB grid. + + ! Momentum level altitudes from host model. + do k = 1, gr%nz, 1 + gr%zm(k) = momentum_heights(k) + enddo + + ! Thermodynamic level altitudes from host model after possible grid-index + ! adjustment for CLUBB interface. + do k = 1, gr%nz, 1 + gr%zt(k) = thermodynamic_heights(k) + enddo + + + endif ! not l_implemented + + + ! Define dzm, the spacing between thermodynamic grid levels; centered over + ! momentum grid levels + do k=1,gr%nz-1 + gr%dzm(k) = gr%zt(k+1) - gr%zt(k) + enddo + gr%dzm(gr%nz) = gr%dzm(gr%nz-1) + + ! Define dzt, the spacing between momentum grid levels; centered over + ! thermodynamic grid levels + do k=2,gr%nz + gr%dzt(k) = gr%zm(k) - gr%zm(k-1) + enddo + gr%dzt(1) = gr%dzt(2) + + ! Define invrs_dzm, which is the inverse spacing between thermodynamic grid + ! levels; centered over momentum grid levels. + do k=1,gr%nz-1 + gr%invrs_dzm(k) = 1._core_rknd / ( gr%zt(k+1) - gr%zt(k) ) + enddo + gr%invrs_dzm(gr%nz) = gr%invrs_dzm(gr%nz-1) + + + ! Define invrs_dzt, which is the inverse spacing between momentum grid + ! levels; centered over thermodynamic grid levels. + do k=2,gr%nz + gr%invrs_dzt(k) = 1._core_rknd / ( gr%zm(k) - gr%zm(k-1) ) + enddo + gr%invrs_dzt(1) = gr%invrs_dzt(2) + + + ! Interpolation Weights: zm grid to zt grid. + ! The grid index (k) is the index of the level on the thermodynamic (zt) + ! grid. The result is the weights of the upper and lower momentum levels + ! (that sandwich the thermodynamic level) applied to that thermodynamic + ! level. These weights are normally used in situations where a momentum + ! level variable is being solved for implicitly in an equation, and the + ! aforementioned variable needs to be interpolated from three successive + ! momentum levels (the central momentum level, as well as one momentum level + ! above and below the central momentum level) to the intermediate + ! thermodynamic grid levels that sandwich the central momentum level. + ! For more information, see the comments in function interpolated_aztk_imp. + do k = 1, gr%nz, 1 + gr%weights_zm2zt(m_above:m_below,k) & + = interp_weights_zm2zt_imp( k ) + enddo + + + ! Interpolation Weights: zt grid to zm grid. + ! The grid index (k) is the index of the level on the momentum (zm) grid. + ! The result is the weights of the upper and lower thermodynamic levels + ! (that sandwich the momentum level) applied to that momentum level. These + ! weights are normally used in situations where a thermodynamic level + ! variable is being solved for implicitly in an equation, and the + ! aforementioned variable needs to be interpolated from three successive + ! thermodynamic levels (the central thermodynamic level, as well as one + ! thermodynamic level above and below the central thermodynamic level) to + ! the intermediate momentum grid levels that sandwich the central + ! thermodynamic level. + ! For more information, see the comments in function interpolated_azmk_imp. + + do k = 1, gr%nz, 1 + gr%weights_zt2zm(t_above:t_below,k) & + = interp_weights_zt2zm_imp( k ) + enddo + + return + end subroutine setup_grid_heights + + !============================================================================= + subroutine read_grid_heights( nzmax, grid_type, & + zm_grid_fname, zt_grid_fname, & + file_unit, & + momentum_heights, & + thermodynamic_heights ) + + ! Description: + ! This subroutine is used foremost in cases where the grid_type corresponds + ! with the stretched (unevenly-spaced) grid options (either grid_type = 2 or + ! grid_type = 3). This subroutine reads in the values of the stretched grid + ! altitude levels for either the thermodynamic level grid or the momentum + ! level grid. This subroutine also handles basic error checking for all + ! three grid types. + !------------------------------------------------------------------------ + + use constants_clubb, only: & + fstderr ! Variable(s) + + use file_functions, only: & + file_read_1d ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables. + + ! Declared number of vertical levels. + integer, intent(in) :: & + nzmax + + ! If CLUBB is running on it's own, this option determines if it is using: + ! 1) an evenly-spaced grid; + ! 2) a stretched (unevenly-spaced) grid entered on the thermodynamic grid + ! levels (with momentum levels set halfway between thermodynamic levels); + ! or + ! 3) a stretched (unevenly-spaced) grid entered on the momentum grid levels + ! (with thermodynamic levels set halfway between momentum levels). + integer, intent(in) :: & + grid_type + + character(len=*), intent(in) :: & + zm_grid_fname, & ! Path and filename of file for momentum level altitudes + zt_grid_fname ! Path and filename of file for thermodynamic level altitudes + + integer, intent(in) :: & + file_unit ! Unit number for zt_grid_fname & zm_grid_fname (based on the OpenMP thread) + + ! Output Variables. + + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on thermodynamic levels (grid_type = 2), it needs to use the + ! thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a stretched grid + ! entered on momentum levels (grid_type = 3), it needs to use the momentum + ! level altitudes as input. + real( kind = core_rknd ), dimension(nzmax), intent(out) :: & + momentum_heights, & ! Momentum level altitudes (file input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (file input) [m] + + ! Local Variables. + + integer :: & + zt_level_count, & ! Number of altitudes found in zt_grid_fname + zm_level_count ! Number of altitudes found in zm_grid_fname + + integer :: input_status ! Status of file being read: + ! > 0 ==> error reading file. + ! = 0 ==> no error and more file to be read. + ! < 0 ==> end of file indicator. + + ! Generic variable for storing file data while counting the number + ! of file entries. + real( kind = core_rknd ) :: generic_input_item + + integer :: k ! Loop index + + ! ---- Begin Code ---- + + ! Declare the momentum level altitude array and the thermodynamic level + ! altitude array to be 0 until overwritten. + momentum_heights(1:nzmax) = 0.0_core_rknd + thermodynamic_heights(1:nzmax) = 0.0_core_rknd + + ! Avoid uninitialized memory + generic_input_item = 0.0_core_rknd + + + if ( grid_type == 1 ) then + + ! Evenly-spaced grid. + ! Grid level altitudes are based on a constant distance between them and + ! a starting point for the bottom of the grid. + + ! As a way of error checking, make sure that there isn't any file entry + ! for either momentum level altitudes or thermodynamic level altitudes. + if ( zm_grid_fname /= '' ) then + write(fstderr,*) & + "An evenly-spaced grid has been selected. " & + // " Please reset zm_grid_fname to ''." + stop + endif + if ( zt_grid_fname /= '' ) then + write(fstderr,*) & + "An evenly-spaced grid has been selected. " & + // " Please reset zt_grid_fname to ''." + stop + endif + + + elseif ( grid_type == 2 ) then + + ! Stretched (unevenly-spaced) grid: stretched thermodynamic levels. + ! Thermodynamic levels are defined according to a stretched grid that is + ! entered through the use of an input file. Momentum levels are set + ! halfway between thermodynamic levels. This is similar to a SAM-style + ! stretched grid. + + ! As a way of error checking, make sure that there isn't any file entry + ! for momentum level altitudes. + if ( zm_grid_fname /= '' ) then + write(fstderr,*) & + "Thermodynamic level altitudes have been selected " & + // "for use in a stretched (unevenly-spaced) grid. " & + // " Please reset zm_grid_fname to ''." + stop + endif + +!$omp critical + ! Open the file zt_grid_fname. + open( unit=file_unit, file=zt_grid_fname, & + status='old', action='read' ) + + ! Find the number of thermodynamic level altitudes listed + ! in file zt_grid_fname. + zt_level_count = 0 + do + read( unit=file_unit, fmt=*, iostat=input_status ) & + generic_input_item + if ( input_status < 0 ) exit ! end of file indicator + if ( input_status > 0 ) stop & ! error reading input + "Error reading thermodynamic level input file." + zt_level_count = zt_level_count + 1 + enddo + + ! Close the file zt_grid_fname. + close( unit=file_unit ) +!$omp end critical + + ! Check that the number of thermodynamic grid altitudes in the input file + ! matches the declared number of CLUBB grid levels (nzmax). + if ( zt_level_count /= nzmax ) then + write(fstderr,*) & + "The number of thermodynamic grid altitudes " & + // "listed in file " // trim(zt_grid_fname) & + // " does not match the number of CLUBB grid " & + // "levels specified in the model.in file." + write(fstderr,*) & + "Number of thermodynamic grid altitudes listed: ", & + zt_level_count + write(fstderr,*) & + "Number of CLUBB grid levels specified: ", nzmax + stop + endif + + ! Read the thermodynamic level altitudes from zt_grid_fname. + call file_read_1d( file_unit, zt_grid_fname, nzmax, 1, & + thermodynamic_heights ) + + ! Check that each thermodynamic level altitude increases + ! in height as the thermodynamic level grid index increases. + do k = 2, nzmax, 1 + if ( thermodynamic_heights(k) & + <= thermodynamic_heights(k-1) ) then + write(fstderr,*) & + "The declared thermodynamic level grid " & + // "altitudes are not increasing in height " & + // "as grid level index increases." + write(fstderr,*) & + "Grid index: ", k-1, ";", & + " Thermodynamic level altitude: ", & + thermodynamic_heights(k-1) + write(fstderr,*) & + "Grid index: ", k, ";", & + " Thermodynamic level altitude: ", & + thermodynamic_heights(k) + stop + endif + enddo + + + elseif ( grid_type == 3 ) then + + ! Stretched (unevenly-spaced) grid: stretched momentum levels. + ! Momentum levels are defined according to a stretched grid that is + ! entered through the use of an input file. Thermodynamic levels are set + ! halfway between momentum levels. This is similar to a WRF-style + ! stretched grid. + + ! As a way of error checking, make sure that there isn't any file entry + ! for thermodynamic level altitudes. + if ( zt_grid_fname /= '' ) then + write(fstderr,*) & + "Momentum level altitudes have been selected " & + // "for use in a stretched (unevenly-spaced) grid. " & + // " Please reset zt_grid_fname to ''." + stop + endif + + ! Open the file zm_grid_fname. + open( unit=file_unit, file=zm_grid_fname, & + status='old', action='read' ) + + ! Find the number of momentum level altitudes + ! listed in file zm_grid_fname. + zm_level_count = 0 + do + read( unit=file_unit, fmt=*, iostat=input_status ) & + generic_input_item + if ( input_status < 0 ) exit ! end of file indicator + if ( input_status > 0 ) stop & ! error reading input + "Error reading momentum level input file." + zm_level_count = zm_level_count + 1 + enddo + + ! Close the file zm_grid_fname. + close( unit=file_unit ) + + ! Check that the number of momentum grid altitudes in the input file + ! matches the declared number of CLUBB grid levels (nzmax). + if ( zm_level_count /= nzmax ) then + write(fstderr,*) & + "The number of momentum grid altitudes " & + // "listed in file " // trim(zm_grid_fname) & + // " does not match the number of CLUBB grid " & + // "levels specified in the model.in file." + write(fstderr,*) & + "Number of momentum grid altitudes listed: ", & + zm_level_count + write(fstderr,*) & + "Number of CLUBB grid levels specified: ", nzmax + stop + endif + + ! Read the momentum level altitudes from zm_grid_fname. + call file_read_1d( file_unit, zm_grid_fname, nzmax, 1, & + momentum_heights ) + + ! Check that each momentum level altitude increases in height as the + ! momentum level grid index increases. + do k = 2, nzmax, 1 + if ( momentum_heights(k) & + <= momentum_heights(k-1) ) then + write(fstderr,*) & + "The declared momentum level grid " & + // "altitudes are not increasing in height " & + // "as grid level index increases." + write(fstderr,*) & + "Grid index: ", k-1, ";", & + " Momentum level altitude: ", & + momentum_heights(k-1) + write(fstderr,*) & + "Grid index: ", k, ";", & + " Momentum level altitude: ", & + momentum_heights(k) + stop + endif + enddo + + + endif + + + ! The purpose of this if statement is to avoid a compiler warning. + if ( generic_input_item > 0.0_core_rknd ) then + ! Do nothing + endif + ! Joshua Fasching June 2008 + + return + + end subroutine read_grid_heights + + !============================================================================= + function redirect_interpolated_azmk( azt, k ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + redirect_interpolated_azmk ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azmk = cubic_interpolated_azmk( azt, k ) + else + redirect_interpolated_azmk = linear_interpolated_azmk( azt, k ) + end if + + return + end function redirect_interpolated_azmk + + !============================================================================= + function redirect_interpolated_azm( azt ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + redirect_interpolated_azm ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azm = cubic_interpolated_azm( azt ) + else + redirect_interpolated_azm = linear_interpolated_azm( azt ) + end if + + return + end function redirect_interpolated_azm + + !============================================================================= + function redirect_interpolated_aztk( azt, k ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + redirect_interpolated_aztk ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_aztk = cubic_interpolated_aztk( azt, k ) + else + redirect_interpolated_aztk = linear_interpolated_aztk( azt, k ) + end if + + return + end function redirect_interpolated_aztk + + !============================================================================= + function redirect_interpolated_azt( azt ) + + ! Description: + ! Calls the appropriate corresponding function based on l_cubic_temp + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_cubic_interp, & ! Variable(s) + l_quintic_poly_interp + + use constants_clubb, only: & + fstdout ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + redirect_interpolated_azt ! Variable when interp. to momentum levels + + ! ---- Begin Code ---- + + ! Sanity Check + if (l_quintic_poly_interp) then + if (.not. l_cubic_interp) then + write (fstdout, *) "Error: Model flag l_quintic_poly_interp should not be true if "& + //"l_cubic_interp is false." + stop + end if + end if + + ! Redirect + if (l_cubic_interp) then + redirect_interpolated_azt = cubic_interpolated_azt( azt ) + else + redirect_interpolated_azt = linear_interpolated_azt( azt ) + end if + + return + end function redirect_interpolated_azt + + !============================================================================= + + + pure function linear_interpolated_azm( azt ) + + ! Description: + ! Function to interpolate a variable located on the thermodynamic grid + ! levels (azt) to the momentum grid levels (azm). This function inputs the + ! entire azt array and outputs the results as an azm array. The + ! formulation used is compatible with a stretched (unevenly-spaced) grid. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use interpolation, only: & + linear_interp_factor ! Procedure(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + linear_interpolated_azm ! Variable when interp. to momentum levels + + ! Local Variable + integer :: k ! Grid level loop index + + + ! Set the value of the thermodynamic-level variable, azt, at the uppermost + ! level of the model, which is a momentum level. The name of the variable + ! when interpolated/extended to momentum levels is azm. + k = gr%nz +! ! Set the value of azm at level gr%nz (the uppermost level in the model) +! ! to the value of azt at level gr%nz. +! linear_interpolated_azm(k) = azt(k) + ! Use a linear extension based on the values of azt at levels gr%nz and + ! gr%nz-1 to find the value of azm at level gr%nz (the uppermost level + ! in the model). + linear_interpolated_azm(k) & + = ( ( azt(k) - azt(k-1) ) / ( gr%zt(k) - gr%zt(k-1) ) ) & + * ( gr%zm(k) - gr%zt(k) ) + azt(k) + + ! Interpolate the value of a thermodynamic-level variable to the central + ! momentum level, k, between two successive thermodynamic levels using + ! linear interpolation. + forall( k = 1 : gr%nz-1 : 1 ) + linear_interpolated_azm(k) & + = linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) + end forall ! k = 1 : gr%nz-1 : 1 + + + return + + end function linear_interpolated_azm + + !============================================================================= + pure function linear_interpolated_azmk( azt, k ) + + ! Description: + ! Function to interpolate a variable located on the thermodynamic grid + ! levels (azt) to the momentum grid levels (azm). This function outputs the + ! value of azm at a single grid level (k) after interpolating using values + ! of azt at two grid levels. The formulation used is compatible with a + ! stretched (unevenly-spaced) grid. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use interpolation, only: & + linear_interp_factor ! Procedure(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variable + real( kind = core_rknd ) :: & + linear_interpolated_azmk ! Variable when interp. to momentum levels + + + ! Interpolate the value of a thermodynamic-level variable to the central + ! momentum level, k, between two successive thermodynamic levels using + ! linear interpolation. + if ( k /= gr%nz ) then + + linear_interpolated_azmk & + = linear_interp_factor( gr%weights_zt2zm(1, k), azt(k+1), azt(k) ) + + else + +! ! Set the value of azm at level gr%nz (the uppermost level in the +! ! model) to the value of azt at level gr%nz. +! linear_interpolated_azmk = azt(gr%nz) + ! Use a linear extension based on the values of azt at levels gr%nz and + ! gr%nz-1 to find the value of azm at level gr%nz (the uppermost + ! level in the model). + linear_interpolated_azmk & + = ( ( azt(gr%nz) - azt(gr%nz-1) ) / ( gr%zt(gr%nz) - gr%zt(gr%nz-1) ) ) & + * ( gr%zm(gr%nz) - gr%zt(gr%nz) ) + azt(gr%nz) + + endif + + + return + + end function linear_interpolated_azmk + + !============================================================================= + function cubic_interpolated_azm( azt ) + + ! Description: + ! Function to interpolate a variable located on the thermodynamic grid + ! levels (azt) to the momentum grid levels (azm). This function outputs the + ! value of azt at a all grid levels using Steffen's monotonic cubic + ! interpolation implemented by Tak Yamaguchi. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + cubic_interpolated_azm + + ! Local Variable(s) + real( kind = core_rknd ), dimension(gr%nz) :: & + tmp ! This is needed for variables that self-reference + integer :: & + k + + ! ---- Begin Code ---- + + do k = 1, gr%nz + tmp(k) = cubic_interpolated_azmk( azt, k ) + end do + + cubic_interpolated_azm = tmp + + return + + end function cubic_interpolated_azm + + !============================================================================= + function cubic_interpolated_azmk( azt, k ) + + ! Description: + ! Function to interpolate a variable located on the thermodynamic grid + ! levels (azt) to the momentum grid levels (azm). This function outputs the + ! value of azm at a single grid level (k) using Steffen's monotonic cubic + ! interpolation implemented by Tak Yamaguchi. + !----------------------------------------------------------------------- + + use interpolation, only: & + mono_cubic_interp ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Constant(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azt + + integer, intent(in) :: k + + ! Return Variable + real( kind = core_rknd ) :: cubic_interpolated_azmk + + ! Local Variable(s) + integer :: km1, k00, kp1, kp2 + + ! ---- Begin Code ---- + + ! Special case for a very small domain + if ( gr%nz < 3 ) then + cubic_interpolated_azmk = linear_interpolated_azmk( azt, k ) + return + end if + + ! k levels are based on Tak's find_indices subroutine -dschanen 24 Oct 2011 + if ( k == gr%nz-1 ) then + km1 = gr%nz-2 + kp1 = gr%nz + kp2 = gr%nz + k00 = gr%nz-1 + else if ( k == gr%nz ) then ! Extrapolation + km1 = gr%nz + kp1 = gr%nz + kp2 = gr%nz + k00 = gr%nz-1 + else if ( k == 1 ) then + km1 = 1 + kp1 = 2 + kp2 = 3 + k00 = 1 + else + km1 = k-1 + kp1 = k+1 + kp2 = k+2 + k00 = k + end if + + ! Do the actual interpolation. + ! Use a cubic monotonic spline interpolation. + cubic_interpolated_azmk = & + mono_cubic_interp( gr%zm(k), km1, k00, kp1, kp2, & + gr%zt(km1), gr%zt(k00), gr%zt(kp1), gr%zt(kp2), & + azt(km1), azt(k00), azt(kp1), azt(kp2) ) + + return + + end function cubic_interpolated_azmk + + !============================================================================= + pure function interpolated_azmk_imp( m_lev ) & + result( azt_weight ) + + ! Description: + ! Function used to help in an interpolation of a variable (var_zt) located + ! on the thermodynamic grid levels (azt) to the momentum grid levels (azm). + ! This function computes a weighting factor for both the upper thermodynamic + ! level (k+1) and the lower thermodynamic level (k) applied to the central + ! momentum level (k). For the uppermost momentum grid level (k=gr%nz), a + ! weighting factor for both the thermodynamic level at gr%nz and the + ! thermodynamic level at gr%nz-1 are calculated based on the use of a + ! linear extension. This function outputs the weighting factors at a single + ! momentum grid level (k). The formulation used is compatible with a + ! stretched (unevenly-spaced) grid. The weights are defined as follows: + ! + ! ---var_zt(k+1)------------------------------------------- t(k+1) + ! azt_weight(t_above) = factor + ! ===========var_zt(interp)================================ m(k) + ! azt_weight(t_below) = 1 - factor + ! ---var_zt(k)--------------------------------------------- t(k) + ! + ! The vertical indices t(k+1), m(k), and t(k) correspond with altitudes + ! zt(k+1), zm(k), and zt(k), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! For all levels k < gr%nz: + ! + ! The formula for a linear interpolation is given by: + ! + ! var_zt( interp to zm(k) ) + ! = [ ( var_zt(k+1) - var_zt(k) ) / ( zt(k+1) - zt(k) ) ] + ! * ( zm(k) - zt(k) ) + var_zt(k); + ! + ! which can be rewritten as: + ! + ! var_zt( interp to zm(k) ) + ! = [ ( zm(k) - zt(k) ) / ( zt(k+1) - zt(k) ) ] + ! * ( var_zt(k+1) - var_zt(k) ) + var_zt(k). + ! + ! Furthermore, the formula can be rewritten as: + ! + ! var_zt( interp to zm(k) ) + ! = factor * var_zt(k+1) + ( 1 - factor ) * var_zt(k); + ! + ! where: + ! + ! factor = ( zm(k) - zt(k) ) / ( zt(k+1) - zt(k) ). + ! + ! One of the important uses of this function is in situations where the + ! variable to be interpolated is being treated IMPLICITLY in an equation. + ! Usually, the variable to be interpolated is involved in a derivative (such + ! as d(var_zt)/dz in the diagram below). For the term of the equation + ! containing the derivative, grid weights are needed for two interpolations, + ! rather than just one interpolation. Thus, four grid weights (labeled + ! A(k), B(k), C(k), and D(k) in the diagram below) are needed. + ! + ! ---var_zt(k+1)------------------------------------------- t(k+1) + ! A(k) + ! ===========var_zt(interp)================================ m(k) + ! B(k) = 1 - A(k) + ! ---var_zt(k)-----------d(var_zt)/dz---------------------- t(k) + ! C(k) + ! ===========var_zt(interp)================================ m(k-1) + ! D(k) = 1 - C(k) + ! ---var_zt(k-1)------------------------------------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! The grid weights, indexed around the central thermodynamic level (k), are + ! defined as follows: + ! + ! A(k) = ( zm(k) - zt(k) ) / ( zt(k+1) - zt(k) ); + ! + ! which is the same as "factor" for the interpolation to momentum + ! level (k). In the code, this interpolation is referenced as + ! gr%weights_zt2zm(t_above,mk), which can be read as "grid weight in a zt2zm + ! interpolation of the thermodynamic level above momentum level (k) (applied + ! to momentum level (k))". + ! + ! B(k) = 1 - [ ( zm(k) - zt(k) ) / ( zt(k+1) - zt(k) ) ] + ! = 1 - A(k); + ! + ! which is the same as "1 - factor" for the interpolation to momentum + ! level (k). In the code, this interpolation is referenced as + ! gr%weights_zt2zm(t_below,mk), which can be read as "grid weight in a zt2zm + ! interpolation of the thermodynamic level below momentum level (k) (applied + ! to momentum level (k))". + ! + ! C(k) = ( zm(k-1) - zt(k-1) ) / ( zt(k) - zt(k-1) ); + ! + ! which is the same as "factor" for the interpolation to momentum + ! level (k-1). In the code, this interpolation is referenced as + ! gr%weights_zt2zm(t_above,mkm1), which can be read as "grid weight in a + ! zt2zm interpolation of the thermodynamic level above momentum level (k-1) + ! (applied to momentum level (k-1))". + ! + ! D(k) = 1 - [ ( zm(k-1) - zt(k-1) ) / ( zt(k) - zt(k-1) ) ] + ! = 1 - C(k); + ! + ! which is the same as "1 - factor" for the interpolation to momentum + ! level (k-1). In the code, this interpolation is referenced as + ! gr%weights_zt2zm(t_below,mkm1), which can be read as "grid weight in a + ! zt2zm interpolation of the thermodynamic level below momentum level (k-1) + ! (applied to momentum level (k-1))". + ! + ! Additionally, as long as the central thermodynamic level (k) in the above + ! scenario is not the uppermost thermodynamic level or the lowermost + ! thermodynamic level (k /= gr%nz and k /= 1), the four weighting factors + ! have the following relationships: A(k) = C(k+1) and B(k) = D(k+1). + ! + ! + ! Special condition for uppermost grid level, k = gr%nz: + ! + ! The uppermost momentum grid level is above the uppermost thermodynamic + ! grid level. Thus, a linear extension is used at this level. + ! + ! For level k = gr%nz: + ! + ! The formula for a linear extension is given by: + ! + ! var_zt( extend to zm(k) ) + ! = [ ( var_zt(k) - var_zt(k-1) ) / ( zt(k) - zt(k-1) ) ] + ! * ( zm(k) - zt(k-1) ) + var_zt(k-1); + ! + ! which can be rewritten as: + ! + ! var_zt( extend to zm(k) ) + ! = [ ( zm(k) - zt(k-1) ) / ( zt(k) - zt(k-1) ) ] + ! * ( var_zt(k) - var_zt(k-1) ) + var_zt(k-1). + ! + ! Furthermore, the formula can be rewritten as: + ! + ! var_zt( extend to zm(k) ) + ! = factor * var_zt(k) + ( 1 - factor ) * var_zt(k-1); + ! + ! where: + ! + ! factor = ( zm(k) - zt(k-1) ) / ( zt(k) - zt(k-1) ). + ! + ! Due to the fact that a linear extension is being used, the value of factor + ! will be greater than 1. The weight of thermodynamic level k = gr%nz on + ! momentum level k = gr%nz equals the value of factor. The weight of + ! thermodynamic level k = gr%nz-1 on momentum level k = gr%nz equals + ! 1 - factor, which is less than 0. However, the sum of the two weights + ! equals 1. + ! + ! + ! Brian Griffin; September 12, 2008. + ! + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + t_above = 1, & ! Upper thermodynamic level. + t_below = 2 ! Lower thermodynamic level. + + ! Input Variable + integer, intent(in) :: m_lev ! Momentum level index + + ! Output Variable + real( kind = core_rknd ), dimension(2) :: & + azt_weight ! Weights of the thermodynamic levels. + + ! Local Variables + real( kind = core_rknd ) :: factor + + integer :: k + + + ! Compute the weighting factors at momentum level k. + k = m_lev + + if ( k /= gr%nz ) then + ! At most levels, the momentum level is found in-between two + ! thermodynamic levels. Linear interpolation is used. + factor = ( gr%zm(k) - gr%zt(k) ) / ( gr%zt(k+1) - gr%zt(k) ) + else + ! The top model level (gr%nz) is formulated differently because the top + ! momentum level is above the top thermodynamic level. A linear + ! extension is required, rather than linear interpolation. + ! Note: Variable "factor" will be greater than 1 in this situation. + factor & + = ( gr%zm(gr%nz) - gr%zt(gr%nz-1) ) / ( gr%zt(gr%nz) - gr%zt(gr%nz-1) ) + endif + + ! Weight of upper thermodynamic level on momentum level. + azt_weight(t_above) = factor + ! Weight of lower thermodynamic level on momentum level. + azt_weight(t_below) = one - factor + + + return + + end function interpolated_azmk_imp + + !============================================================================= + pure function linear_interpolated_azt( azm ) + + ! Description: + ! Function to interpolate a variable located on the momentum grid levels + ! (azm) to the thermodynamic grid levels (azt). This function inputs the + ! entire azm array and outputs the results as an azt array. The formulation + ! used is compatible with a stretched (unevenly-spaced) grid. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use interpolation, only: & + linear_interp_factor ! Procedure(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + linear_interpolated_azt ! Variable when interp. to thermodynamic levels + + ! Local Variable + integer :: k ! Grid level loop index + + + ! Set the value of the momentum-level variable, azm, at the lowermost level + ! of the model (below the model lower boundary), which is a thermodynamic + ! level. The name of the variable when interpolated/extended to + ! thermodynamic levels is azt. + k = 1 +! ! Set the value of azt at level 1 (the lowermost level in the model) to the +! ! value of azm at level 1. +! linear_interpolated_azt(k) = azm(k) + ! Use a linear extension based on the values of azm at levels 1 and 2 to + ! find the value of azt at level 1 (the lowermost level in the model). + linear_interpolated_azt(k) & + = ( ( azm(k+1) - azm(k) ) / ( gr%zm(k+1) - gr%zm(k) ) ) & + * ( gr%zt(k) - gr%zm(k) ) + azm(k) + + ! Interpolate the value of a momentum-level variable to the central + ! thermodynamic level, k, between two successive momentum levels using + ! linear interpolation. + forall( k = gr%nz : 2 : -1 ) + linear_interpolated_azt(k) & + = linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) + end forall ! k = gr%nz : 2 : -1 + + + return + + end function linear_interpolated_azt + + !============================================================================= + pure function linear_interpolated_aztk( azm, k ) + + ! Description: + ! Function to interpolate a variable located on the momentum grid levels + ! (azm) to the thermodynamic grid levels (azt). This function outputs the + ! value of azt at a single grid level (k) after interpolating using values + ! of azm at two grid levels. The formulation used is compatible with a + ! stretched (unevenly-spaced) grid. + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use interpolation, only: & + linear_interp_factor ! Procedure(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] + + integer, intent(in) :: & + k ! Vertical level index + + ! Return Variables + real( kind = core_rknd ) :: & + linear_interpolated_aztk ! Variable when interp. to thermodynamic levs. + + + ! Interpolate the value of a momentum-level variable to the central + ! thermodynamic level, k, between two successive momentum levels using + ! linear interpolation. + if ( k /= 1 ) then + + linear_interpolated_aztk & + = linear_interp_factor( gr%weights_zm2zt(1, k), azm(k), azm(k-1) ) + + else + +! ! Set the value of azt at level 1 (the lowermost level in the model) to +! ! the value of azm at level 1. +! linear_interpolated_aztk = azm(1) + ! Use a linear extension based on the values of azm at levels 1 and 2 to + ! find the value of azt at level 1 (the lowermost level in the model). + linear_interpolated_aztk & + = ( ( azm(2) - azm(1) ) / ( gr%zm(2) - gr%zm(1) ) ) & + * ( gr%zt(1) - gr%zm(1) ) + azm(1) + + endif + + + return + + end function linear_interpolated_aztk + + !============================================================================= + function cubic_interpolated_azt( azm ) + + ! Description: + ! Function to interpolate a variable located on the momentum grid + ! levels (azm) to the thermodynamic grid levels (azt). This function outputs the + ! value of azt at a all grid levels using Steffen's monotonic cubic + ! interpolation implemented by Tak Yamaguchi. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + cubic_interpolated_azt + + ! Local Variable(s) + real( kind = core_rknd ), dimension(gr%nz) :: & + tmp ! This is needed for variables that self-reference + integer :: & + k + + ! ---- Begin Code ---- + + do k = 1, gr%nz + tmp(k) = cubic_interpolated_aztk( azm, k ) + end do + + cubic_interpolated_azt = tmp + + return + + end function cubic_interpolated_azt + + + !============================================================================= + function cubic_interpolated_aztk( azm, k ) + + ! Description: + ! Function to interpolate a variable located on the momentum grid + ! levels (azm) to the thermodynamic grid levels (azt). This function outputs the + ! value of azt at a single grid level (k) using Steffen's monotonic cubic + ! interpolation implemented by Tak Yamaguchi. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use interpolation, only: & + mono_cubic_interp ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: azm + + integer, intent(in) :: k + + ! Return Variable + real( kind = core_rknd ) :: cubic_interpolated_aztk + + ! Local Variable(s) + integer :: km1, k00, kp1, kp2 + + ! ---- Begin Code ---- + + ! Special case for a very small domain + if ( gr%nz < 3 ) then + cubic_interpolated_aztk = linear_interpolated_aztk( azm, k ) + return + end if + + ! k levels are based on Tak's find_indices subroutine -dschanen 24 Oct 2011 + if ( k == gr%nz ) then + km1 = gr%nz-2 + kp1 = gr%nz + kp2 = gr%nz + k00 = gr%nz-1 + else if ( k == 2 ) then + km1 = 1 + kp1 = 2 + kp2 = 3 + k00 = 1 + else if ( k == 1 ) then ! Extrapolation for the ghost point + km1 = gr%nz + k00 = 1 + kp1 = 2 + kp2 = 3 + else + km1 = k-2 + kp1 = k + kp2 = k+1 + k00 = k-1 + end if + ! Do the actual interpolation. + ! Use a cubic monotonic spline interpolation. + cubic_interpolated_aztk = & + mono_cubic_interp( gr%zt(k), km1, k00, kp1, kp2, & + gr%zm(km1), gr%zm(k00), gr%zm(kp1), gr%zm(kp2), & + azm(km1), azm(k00), azm(kp1), azm(kp2) ) + + return + + end function cubic_interpolated_aztk + + !============================================================================= + pure function interpolated_aztk_imp( t_lev ) & + result( azm_weight ) + + ! Description: + ! Function used to help in an interpolation of a variable (var_zm) located + ! on the momentum grid levels (azm) to the thermodynamic grid levels (azt). + ! This function computes a weighting factor for both the upper momentum + ! level (k) and the lower momentum level (k-1) applied to the central + ! thermodynamic level (k). For the lowermost thermodynamic grid + ! level (k=1), a weighting factor for both the momentum level at 1 and the + ! momentum level at 2 are calculated based on the use of a linear extension. + ! This function outputs the weighting factors at a single thermodynamic grid + ! level (k). The formulation used is compatible with a stretched + ! (unevenly-spaced) grid. The weights are defined as follows: + ! + ! ===var_zm(k)============================================= m(k) + ! azm_weight(m_above) = factor + ! -----------var_zm(interp)-------------------------------- t(k) + ! azm_weight(m_below) = 1 - factor + ! ===var_zm(k-1)=========================================== m(k-1) + ! + ! The vertical indices m(k), t(k), and m(k-1) correspond with altitudes + ! zm(k), zt(k), and zm(k-1), respectively. The letter "t" is used for + ! thermodynamic levels and the letter "m" is used for momentum levels. + ! + ! For all levels k > 1: + ! + ! The formula for a linear interpolation is given by: + ! + ! var_zm( interp to zt(k) ) + ! = [ ( var_zm(k) - var_zm(k-1) ) / ( zm(k) - zm(k-1) ) ] + ! * ( zt(k) - zm(k-1) ) + var_zm(k-1); + ! + ! which can be rewritten as: + ! + ! var_zm( interp to zt(k) ) + ! = [ ( zt(k) - zm(k-1) ) / ( zm(k) - zm(k-1) ) ] + ! * ( var_zm(k) - var_zm(k-1) ) + var_zm(k-1). + ! + ! Furthermore, the formula can be rewritten as: + ! + ! var_zm( interp to zt(k) ) + ! = factor * var_zm(k) + ( 1 - factor ) * var_zm(k-1); + ! + ! where: + ! + ! factor = ( zt(k) - zm(k-1) ) / ( zm(k) - zm(k-1) ). + ! + ! One of the important uses of this function is in situations where the + ! variable to be interpolated is being treated IMPLICITLY in an equation. + ! Usually, the variable to be interpolated is involved in a derivative (such + ! as d(var_zm)/dz in the diagram below). For the term of the equation + ! containing the derivative, grid weights are needed for two interpolations, + ! rather than just one interpolation. Thus, four grid weights (labeled + ! A(k), B(k), C(k), and D(k) in the diagram below) are needed. + ! + ! ===var_zm(k+1)=========================================== m(k+1) + ! A(k) + ! -----------var_zm(interp)-------------------------------- t(k+1) + ! B(k) = 1 - A(k) + ! ===var_zm(k)===========d(var_zm)/dz====================== m(k) + ! C(k) + ! -----------var_zm(interp)-------------------------------- t(k) + ! D(k) = 1 - C(k) + ! ===var_zm(k-1)=========================================== m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! The grid weights, indexed around the central momentum level (k), are + ! defined as follows: + ! + ! A(k) = ( zt(k+1) - zm(k) ) / ( zm(k+1) - zm(k) ); + ! + ! which is the same as "factor" for the interpolation to thermodynamic + ! level (k+1). In the code, this interpolation is referenced as + ! gr%weights_zm2zt(m_above,tkp1), which can be read as "grid weight in a + ! zm2zt interpolation of the momentum level above thermodynamic + ! level (k+1) (applied to thermodynamic level (k+1))". + ! + ! B(k) = 1 - [ ( zt(k+1) - zm(k) ) / ( zm(k+1) - zm(k) ) ] + ! = 1 - A(k); + ! + ! which is the same as "1 - factor" for the interpolation to thermodynamic + ! level (k+1). In the code, this interpolation is referenced as + ! gr%weights_zm2zt(m_below,tkp1), which can be read as "grid weight in a + ! zm2zt interpolation of the momentum level below thermodynamic + ! level (k+1) (applied to thermodynamic level (k+1))". + ! + ! C(k) = ( zt(k) - zm(k-1) ) / ( zm(k) - zm(k-1) ); + ! + ! which is the same as "factor" for the interpolation to thermodynamic + ! level (k). In the code, this interpolation is referenced as + ! gr%weights_zm2zt(m_above,tk), which can be read as "grid weight in a zm2zt + ! interpolation of the momentum level above thermodynamic level (k) (applied + ! to thermodynamic level (k))". + ! + ! D(k) = 1 - [ ( zt(k) - zm(k-1) ) / ( zm(k) - zm(k-1) ) ] + ! = 1 - C(k); + ! + ! which is the same as "1 - factor" for the interpolation to thermodynamic + ! level (k). In the code, this interpolation is referenced as + ! gr%weights_zm2zt(m_below,tk), which can be read as "grid weight in a zm2zt + ! interpolation of the momentum level below thermodynamic level (k) (applied + ! to thermodynamic level (k))". + ! + ! Additionally, as long as the central momentum level (k) in the above + ! scenario is not the lowermost momentum level or the uppermost momentum + ! level (k /= 1 and k /= gr%nz), the four weighting factors have the + ! following relationships: A(k) = C(k+1) and B(k) = D(k+1). + ! + ! + ! Special condition for lowermost grid level, k = 1: + ! + ! The lowermost thermodynamic grid level is below the lowermost momentum + ! grid level. Thus, a linear extension is used at this level. It should + ! be noted that the thermodynamic level k = 1 is considered to be below the + ! model lower boundary, which is defined to be at momentum level k = 1. + ! Thus, the values of most variables at thermodynamic level k = 1 are not + ! often needed or referenced. + ! + ! For level k = 1: + ! + ! The formula for a linear extension is given by: + ! + ! var_zm( extend to zt(k) ) + ! = [ ( var_zm(k+1) - var_zm(k) ) / ( zm(k+1) - zm(k) ) ] + ! * ( zt(k) - zm(k) ) + var_zm(k); + ! + ! which can be rewritten as: + ! + ! var_zm( extend to zt(k) ) + ! = [ ( zt(k) - zm(k) ) / ( zm(k+1) - zm(k) ) ] + ! * ( var_zm(k+1) - var_zm(k) ) + var_zm(k). + ! + ! Furthermore, the formula can be rewritten as: + ! + ! var_zm( extend to zt(k) ) + ! = factor * var_zm(k+1) + ( 1 - factor ) * var_zm(k); + ! + ! where: + ! + ! factor = ( zt(k) - zm(k) ) / ( zm(k+1) - zm(k) ). + ! + ! Due to the fact that a linear extension is being used, the value of factor + ! will be less than 0. The weight of the upper momentum level, which is + ! momentum level k = 2, on thermodynamic level k = 1 equals the value of + ! factor. The weight of the lower momentum level, which is momentum level + ! k = 1, on thermodynamic level k = 1 equals 1 - factor, which is greater + ! than 1. However, the sum of the weights equals 1. + ! + ! + ! Brian Griffin; September 12, 2008. + ! + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + m_above = 1, & ! Upper momentum level. + m_below = 2 ! Lower momentum level. + + ! Input Variable + integer, intent(in) :: t_lev ! Thermodynamic level index. + + ! Output Variable + real( kind = core_rknd ), dimension(2) :: & + azm_weight ! Weights of the momentum levels. + + ! Local Variables + real( kind = core_rknd ) :: factor + + integer :: k + + + ! Compute the weighting factors at thermodynamic level k. + k = t_lev + + if ( k /= 1 ) then + ! At most levels, the thermodynamic level is found in-between two + ! momentum levels. Linear interpolation is used. + factor = ( gr%zt(k) - gr%zm(k-1) ) / ( gr%zm(k) - gr%zm(k-1) ) + else + ! The bottom model level (1) is formulated differently because the bottom + ! thermodynamic level is below the bottom momentum level. A linear + ! extension is required, rather than linear interpolation. + ! Note: Variable "factor" will have a negative sign in this situation. + factor = ( gr%zt(1) - gr%zm(1) ) / ( gr%zm(2) - gr%zm(1) ) + endif + + ! Weight of upper momentum level on thermodynamic level. + azm_weight(m_above) = factor + ! Weight of lower momentum level on thermodynamic level. + azm_weight(m_below) = one - factor + + + return + + end function interpolated_aztk_imp + + !============================================================================= + pure function gradzm( azm ) + + ! Description: + ! Function to compute the vertical derivative of a variable (azm) located on + ! the momentum grid. The results are returned in an array defined on the + ! thermodynamic grid. + !----------------------------------------------------------------------- + +! use constants_clubb, only: & +! zero ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azm ! Variable on momentum grid levels [units vary] + + ! Return Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + gradzm ! Vertical derivative of azm [units vary / m] + + ! Local Variable + integer :: k ! Grid level loop index + + + ! Set the value of the vertical derivative of a momentum-level variable over + ! the thermodynamic grid level at the lowermost level of the model. + k = 1 +! ! Thermodynamic level 1 is located below momentum level 1, so there is not +! ! enough information to calculate the derivative over thermodynamic +! ! level 1. Thus, the value of the derivative at thermodynamic level 1 is +! ! set equal to 0. This formulation is consistent with setting the value of +! ! the variable azm below the model grid to the value of the variable azm at +! ! the lowest grid level. +! gradzm(k) = zero + ! Thermodynamic level 1 is located below momentum level 1, so there is not + ! enough information to calculate the derivative over thermodynamic level 1. + ! Thus, the value of the derivative at thermodynamic level 1 is set equal to + ! the value of the derivative at thermodynamic level 2. This formulation is + ! consistent with using a linear extension to find the values of the + ! variable azm below the model grid. + gradzm(k) = ( azm(k+1) - azm(k) ) * gr%invrs_dzt(k+1) + + ! Calculate the vertical derivative of a momentum-level variable between two + ! successive momentum grid levels. + forall( k = gr%nz : 2 : -1 ) + ! Take derivative of momentum-level variable azm over the central + ! thermodynamic level (k). + gradzm(k) = ( azm(k) - azm(k-1) ) * gr%invrs_dzt(k) + end forall ! k = gr%nz : 2 : -1 + + + return + + end function gradzm + + !============================================================================= + pure function gradzt( azt ) + + ! Description: + ! Function to compute the vertical derivative of a variable (azt) located on + ! the thermodynamic grid. The results are returned in an array defined on + ! the momentum grid. + !----------------------------------------------------------------------- + +! use constants_clubb, only: & +! zero ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + azt ! Variable on thermodynamic grid levels [units vary] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz) :: & + gradzt ! Vertical derivative of azt [units vary / m] + + ! Local Variable + integer :: k ! Grid level loop index + + + ! Set the value of the vertical derivative of a thermodynamic-level variable + ! over the momentum grid level at the uppermost level of the model. + k = gr%nz +! ! Momentum level gr%nz is located above thermodynamic level gr%nz, so +! ! there is not enough information to calculate the derivative over momentum +! ! level gr%nz. Thus, the value of the derivative at momentum level +! ! gr%nz is set equal to 0. This formulation is consistent with setting +! ! the value of the variable azt above the model grid to the value of the +! ! variable azt at the highest grid level. +! gradzt(k) = zero + ! Momentum level gr%nz is located above thermodynamic level gr%nz, so + ! there is not enough information to calculate the derivative over momentum + ! level gr%nz. Thus, the value of the derivative at momentum level + ! gr%nz is set equal to the value of the derivative at momentum level + ! gr%nz-1. This formulation is consistent with using a linear extension + ! to find the values of the variable azt above the model grid. + gradzt(k) = ( azt(k) - azt(k-1) ) * gr%invrs_dzm(k-1) + + ! Calculate the vertical derivative of a thermodynamic-level variable + ! between two successive thermodynamic grid levels. + forall( k = 1 : gr%nz-1 : 1 ) + ! Take derivative of thermodynamic-level variable azt over the central + ! momentum level (k). + gradzt(k) = ( azt(k+1) - azt(k) ) * gr%invrs_dzm(k) + end forall ! k = 1 : gr%nz-1 : 1 + + + return + + end function gradzt + + !============================================================================= + pure function flip( x, xdim ) + + ! Description: + ! Flips a single dimension array (i.e. a vector), so the first element + ! becomes the last and vice versa for the whole column. This is a + ! necessary part of the code because BUGSrad and CLUBB store altitudes in + ! reverse order. + ! + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + integer, intent(in) :: xdim + + real(kind = dp), dimension(xdim), intent(in) :: x + + ! Output Variables + real(kind = dp), dimension(xdim) :: flip + + ! Local Variables + real(kind = dp), dimension(xdim) :: tmp + + integer :: indx + + + ! Get rid of an annoying compiler warning. + indx = 1 + indx = indx + + forall ( indx = 1 : xdim ) + tmp(indx) = x((xdim+1) - (indx)) + end forall + + flip = tmp + + + return + + end function flip + +!=============================================================================== + +end module grid_class diff --git a/src/physics/clubb/hydromet_pdf_parameter_module.F90 b/src/physics/clubb/hydromet_pdf_parameter_module.F90 new file mode 100644 index 0000000000..0cd5c6501a --- /dev/null +++ b/src/physics/clubb/hydromet_pdf_parameter_module.F90 @@ -0,0 +1,112 @@ +!--------------------------------------------------------------------------- +! $Id: hydromet_pdf_parameter_module.F90 7284 2014-09-11 02:52:58Z bmg2@uwm.edu $ +!=============================================================================== +module hydromet_pdf_parameter_module + + ! Description: + ! This module defines the derived type hydromet_pdf_parameter. + + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Default scope + + public :: hydromet_pdf_parameter, & ! Variable type + init_hydromet_pdf_params ! Procedure + + integer, parameter, private :: & + max_hydromet_dim = 8 + + type hydromet_pdf_parameter + + real( kind = core_rknd ), dimension(max_hydromet_dim) :: & + hm_1, & ! Mean of hydrometeor, hm (1st PDF component) [un vary] + hm_2, & ! Mean of hydrometeor, hm (2nd PDF component) [un vary] + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [un vary] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [un vary] + sigma_hm_1, & ! Standard deviation of hm (1st PDF comp.) ip [un vary] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF comp.) ip [un vary] + corr_w_hm_1, & ! Correlation of w and hm (1st PDF component) ip [-] + corr_w_hm_2, & ! Correlation of w and hm (2nd PDF component) ip [-] + corr_chi_hm_1, & ! Correlation of chi and hm (1st PDF component) ip [-] + corr_chi_hm_2, & ! Correlation of chi and hm (2nd PDF component) ip [-] + corr_eta_hm_1, & ! Correlation of eta and hm (1st PDF component) ip [-] + corr_eta_hm_2 ! Correlation of eta and hm (2nd PDF component) ip [-] + + real( kind = core_rknd ), dimension(max_hydromet_dim,max_hydromet_dim) :: & + corr_hmx_hmy_1, & ! Correlation of hmx and hmy (1st PDF component) ip [-] + corr_hmx_hmy_2 ! Correlation of hmx and hmy (2nd PDF component) ip [-] + + real( kind = core_rknd ) :: & + mu_Ncn_1, & ! Mean of Ncn (1st PDF component) [num/kg] + mu_Ncn_2, & ! Mean of Ncn (2nd PDF component) [num/kg] + sigma_Ncn_1, & ! Standard deviation of Ncn (1st PDF component) [num/kg] + sigma_Ncn_2 ! Standard deviation of Ncn (2nd PDF component) [num/kg] + + real( kind = core_rknd ) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + end type hydromet_pdf_parameter + +contains + + !============================================================================= + subroutine init_hydromet_pdf_params( hydromet_pdf_params ) + + ! Description: + ! Initialize the elements of hydromet_pdf_params. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant(s) + + implicit none + + ! Output Variable + type(hydromet_pdf_parameter), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + ! Initialize hydromet_pdf_params. + hydromet_pdf_params%hm_1 = zero + hydromet_pdf_params%hm_2 = zero + hydromet_pdf_params%mu_hm_1 = zero + hydromet_pdf_params%mu_hm_2 = zero + hydromet_pdf_params%sigma_hm_1 = zero + hydromet_pdf_params%sigma_hm_2 = zero + hydromet_pdf_params%corr_w_hm_1 = zero + hydromet_pdf_params%corr_w_hm_2 = zero + hydromet_pdf_params%corr_chi_hm_1 = zero + hydromet_pdf_params%corr_chi_hm_2 = zero + hydromet_pdf_params%corr_eta_hm_1 = zero + hydromet_pdf_params%corr_eta_hm_2 = zero + + hydromet_pdf_params%corr_hmx_hmy_1 = zero + hydromet_pdf_params%corr_hmx_hmy_2 = zero + + hydromet_pdf_params%mu_Ncn_1 = zero + hydromet_pdf_params%mu_Ncn_2 = zero + hydromet_pdf_params%sigma_Ncn_1 = zero + hydromet_pdf_params%sigma_Ncn_2 = zero + + hydromet_pdf_params%precip_frac = zero + hydromet_pdf_params%precip_frac_1 = zero + hydromet_pdf_params%precip_frac_2 = zero + + + return + + end subroutine init_hydromet_pdf_params + +!=============================================================================== + +end module hydromet_pdf_parameter_module diff --git a/src/physics/clubb/index_mapping.F90 b/src/physics/clubb/index_mapping.F90 new file mode 100644 index 0000000000..7127f62226 --- /dev/null +++ b/src/physics/clubb/index_mapping.F90 @@ -0,0 +1,363 @@ +!--------------------------------------------------------------------------- +! $Id: index_mapping.F90 7118 2014-07-25 00:12:15Z raut@uwm.edu $ +!=============================================================================== +module index_mapping + + ! Description: + ! Functions to map back and forth between the PDF arrays and the hydrometeor + ! arrays. + + ! References: + ! None + !------------------------------------------------------------------------- + + ! Hydrometeor array indices + use array_index, only: & + iirrm, & ! Hydrometeor array index for rain water mixing ratio, rr + iirsm, & ! Hydrometeor array index for snow mixing ratio, rs + iirim, & ! Hydrometeor array index for ice mixing ratio, ri + iirgm, & ! Hydrometeor array index for graupel mixing ratio, rg + iiNrm, & ! Hydrometeor array index for rain drop concentration, Nr + iiNsm, & ! Hydrometeor array index for snow concentration, Ns + iiNim, & ! Hydrometeor array index for ice concentration, Ni + iiNgm ! Hydrometeor array index for graupel concentration, Ng + + ! PDF array indices + use corr_varnce_module, only: & + iiPDF_rr, & ! PDF array index for rain water mixing ratio, rr + iiPDF_rs, & ! PDF array index for snow mixing ratio, rs + iiPDF_ri, & ! PDF array index for ice mixing ratio, ri + iiPDF_rg, & ! PDF array index for graupel mixing ratio, rg + iiPDF_Nr, & ! PDF array index for rain drop concentration, Nr + iiPDF_Ns, & ! PDF array index for snow concentration, Ns + iiPDF_Ni, & ! PDF array index for ice concentration, Ni + iiPDF_Ng ! PDF array index for graupel concentration, Ng + + implicit none + + private ! Default Scope + + public :: pdf2hydromet_idx, & + hydromet2pdf_idx, & + rx2Nx_hm_idx, & + Nx2rx_hm_idx, & + mvr_hm_max + +contains + + !============================================================================= + function pdf2hydromet_idx( pdf_idx ) result( hydromet_idx ) + + ! Description: + ! Returns the position of a specific precipitating hydrometeor corresponding + ! to the PDF index (pdf_idx) in the precipitating hydrometeor array + ! (hydromet_idx). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + integer, intent(in) :: & + pdf_idx ! Index of a hydrometeor in the PDF array. + + ! Return Variable + integer :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + + ! Initialize hydromet_idx + hydromet_idx = 0 + + if ( pdf_idx == iiPDF_rr ) then + + ! Index for rain water mixing ratio, rr. + hydromet_idx = iirrm + + elseif ( pdf_idx == iiPDF_Nr ) then + + ! Index for rain drop concentration, Nr. + hydromet_idx = iiNrm + + elseif ( pdf_idx == iiPDF_rs ) then + + ! Index for snow mixing ratio, rs. + hydromet_idx = iirsm + + elseif ( pdf_idx == iiPDF_Ns ) then + + ! Index for snow flake concentration, Ns. + hydromet_idx = iiNsm + + elseif ( pdf_idx == iiPDF_rg ) then + + ! Index for graupel mixing ratio, rg. + hydromet_idx = iirgm + + elseif ( pdf_idx == iiPDF_Ng ) then + + ! Index for graupel concentration, Ng. + hydromet_idx = iiNgm + + elseif ( pdf_idx == iiPDF_ri ) then + + ! Index for ice mixing ratio, ri. + hydromet_idx = iirim + + elseif ( pdf_idx == iiPDF_Ni ) then + + ! Index for ice concentration, Ni. + hydromet_idx = iiNim + + endif + + + return + + end function pdf2hydromet_idx + + !============================================================================= + function hydromet2pdf_idx( hydromet_idx ) result( pdf_idx ) + + ! Description: + ! Returns the position of a specific precipitating hydrometeor corresponding + ! to the precipitating hydrometeor index (hydromet_idx) in the PDF array + ! (pdf_idx). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + ! Return Variable + integer :: & + pdf_idx ! Index of a hydrometeor in the PDF array. + + + ! Initialize pdf_idx. + pdf_idx = 0 + + if ( hydromet_idx == iirrm ) then + + ! Index for rain water mixing ratio, rr. + pdf_idx = iiPDF_rr + + elseif ( hydromet_idx == iiNrm ) then + + ! Index for rain drop concentration, Nr. + pdf_idx = iiPDF_Nr + + elseif ( hydromet_idx == iirim ) then + + ! Index for ice mixing ratio, ri. + pdf_idx = iiPDF_ri + + elseif ( hydromet_idx == iiNim ) then + + ! Index for ice concentration, Ni. + pdf_idx = iiPDF_Ni + + elseif ( hydromet_idx == iirsm ) then + + ! Index for snow mixing ratio, rs. + pdf_idx = iiPDF_rs + + elseif ( hydromet_idx == iiNsm ) then + + ! Index for snow flake concentration, Ns. + pdf_idx = iiPDF_Ns + + elseif ( hydromet_idx == iirgm ) then + + ! Index for graupel mixing ratio, rg. + pdf_idx = iiPDF_rg + + elseif ( hydromet_idx == iiNgm ) then + + ! Index for graupel concentration, Ng. + pdf_idx = iiPDF_Ng + + endif + + + return + + end function hydromet2pdf_idx + + !============================================================================= + function rx2Nx_hm_idx( rx_idx ) result( Nx_idx ) + + ! Description: + ! Returns the position in the hydrometeor array of the specific + ! precipitating hydrometeor concentration (Nx_idx) corresponding to the + ! precipitating hydrometeor mixing ratio (rx_idx) of the same species of + ! precipitating hydrometeor (rain, ice, snow, or graupel). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + rx_idx ! Index of the mixing ratio in the hydrometeor array. + + ! Return Variable + integer :: & + Nx_idx ! Index of the concentration in the hydrometeor array. + + + ! Initialize Nx_idx. + Nx_idx = 0 + + if ( rx_idx == iirrm ) then + + ! Index for rain drop concentration, Nr. + Nx_idx = iiNrm + + elseif ( rx_idx == iirim ) then + + ! Index for ice crystal concentration, Ni. + Nx_idx = iiNim + + elseif ( rx_idx == iirsm ) then + + ! Index for snow flake concentration, Ns. + Nx_idx = iiNsm + + elseif ( rx_idx == iirgm ) then + + ! Index for graupel concentration, Ng. + Nx_idx = iiNgm + + endif + + + return + + end function rx2Nx_hm_idx + + !============================================================================= + function Nx2rx_hm_idx( Nx_idx ) result( rx_idx ) + + ! Description: + ! Returns the position in the hydrometeor array of the specific + ! precipitating hydrometeor mixing ratio (rx_idx) corresponding to the + ! precipitating hydrometeor concentration (Nx_idx) of the same species of + ! precipitating hydrometeor (rain, ice, snow, or graupel). + + ! References: + !----------------------------------------------------------------------- + + implicit none + + ! Input Variable + integer, intent(in) :: & + Nx_idx ! Index of the concentration in the hydrometeor array. + + ! Return Variable + integer :: & + rx_idx ! Index of the mixing ratio in the hydrometeor array. + + + ! Initialize rx_idx. + rx_idx = 0 + + if ( Nx_idx == iiNrm ) then + + ! Index for rain water mixing ratio, rr. + rx_idx = iirrm + + elseif ( Nx_idx == iiNim ) then + + ! Index for ice mixing ratio, ri. + rx_idx = iirim + + elseif ( Nx_idx == iiNsm ) then + + ! Index for snow mixing ratio, rs. + rx_idx = iirsm + + elseif ( Nx_idx == iiNgm ) then + + ! Index for graupel mixing ratio, rg. + rx_idx = iirgm + + endif + + + return + + end function Nx2rx_hm_idx + + !============================================================================= + function mvr_hm_max( hydromet_idx ) result( mvr_hydromet_max ) + + ! Description: + ! Returns the maximum allowable mean volume radius of a specific + ! precipitating hydrometeor type (rain, ice, snow, or graupel) corresponding + ! to the precipitating hydrometeor index, whether that index is for the + ! mixing ratio or concentration associated with that hydrometeor type. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + mvr_rain_max, & ! Constant(s) + mvr_ice_max, & + mvr_snow_max, & + mvr_graupel_max, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + integer, intent(in) :: & + hydromet_idx ! Index of a hydrometeor in the hydromet array. + + ! Return Variable + real( kind = core_rknd ) :: & + mvr_hydromet_max ! Maximum allowable mean volume radius [m] + + + ! Initialize mvr_hydromet_max. + mvr_hydromet_max = zero + + if ( hydromet_idx == iirrm .or. hydromet_idx == iiNrm ) then + + ! Maximum allowable mean volume radius for rain drops. + mvr_hydromet_max = mvr_rain_max + + elseif ( hydromet_idx == iirim .or. hydromet_idx == iiNim ) then + + ! Maximum allowable mean volume radius for ice crystals. + mvr_hydromet_max = mvr_ice_max + + elseif ( hydromet_idx == iirsm .or. hydromet_idx == iiNsm ) then + + ! Maximum allowable mean volume radius for snow flakes. + mvr_hydromet_max = mvr_snow_max + + elseif ( hydromet_idx == iirgm .or. hydromet_idx == iiNgm ) then + + ! Maximum allowable mean volume radius for graupel. + mvr_hydromet_max = mvr_graupel_max + + endif + + + return + + end function mvr_hm_max + +!=============================================================================== + +end module index_mapping diff --git a/src/physics/clubb/input_names.F90 b/src/physics/clubb/input_names.F90 new file mode 100644 index 0000000000..ad4df85df4 --- /dev/null +++ b/src/physics/clubb/input_names.F90 @@ -0,0 +1,83 @@ +!----------------------------------------------------------------------- +!$Id: input_names.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module input_names +! +! Description: This module contains all of the strings used to define the +! headers for input_reader.F90 compatable files. +! +!--------------------------------------------------------------------------------------------------- + implicit none + ! Column identifiers + character(len=*), public, parameter :: & + z_name = 'z[m]' + + character(len=*), public, parameter :: & + pressure_name = 'Press[Pa]', & + press_mb_name = "Press[mb]" + + character(len=*), public, parameter :: & + temperature_name = 'T[K]', & + theta_name = 'thm[K]', & + thetal_name = 'thlm[K]' + + character(len=*), public, parameter :: & + temperature_f_name = 'T_f[K\s]', & + thetal_f_name = 'thlm_f[K\s]', & + theta_f_name = 'thm_f[K\s]' + + character(len=*), public, parameter :: & + rt_name = 'rt[kg\kg]', & + sp_humidity_name = "sp_hmdty[kg\kg]" + + character(len=*), public, parameter :: & + rt_f_name = 'rtm_f[kg\kg\s]', & + sp_humidity_f_name = 'sp_hmdty_f[kg\kg\s]' + + character(len=*), public, parameter :: & + um_name = 'u[m\s]', & + vm_name = 'v[m\s]' + + character(len=*), public, parameter :: & + ug_name = 'ug[m\s]', & + vg_name = 'vg[m\s]' + + character(len=*), public, parameter :: & + um_ref_name = 'um_ref[m\s]', & + vm_ref_name = 'vm_ref[m\s]' + + character(len=*), public, parameter :: & + um_f_name = 'um_f[m\s^2]', & + vm_f_name = 'vm_f[m\s^2]' + + character(len=*), public, parameter :: & + wm_name = 'w[m\s]', & + omega_name = 'omega[Pa\s]', & + omega_mb_hr_name = 'omega[mb\hr]' + + character(len=*), public, parameter :: & + CO2_name = 'CO2[ppmv]', & + CO2_umol_name = 'CO2[umol\m^2\s]', & + ozone_name = "o3[kg\kg]" + + character(len=*), public, parameter :: & + time_name = 'Time[s]' + + character(len=*), public, parameter :: & + latent_ht_name = 'latent_ht[W\m^2]', & + sens_ht_name = 'sens_ht[W\m^2]' + + character(len=*), public, parameter :: & + upwp_sfc_name = 'upwp_sfc[(m\s)^2]', & + vpwp_sfc_name = 'vpwp_sfc[(m\s)^2]' + + character(len=*), public, parameter :: & + T_sfc_name = 'T_sfc[K]' + + character(len=*), public, parameter :: & + wpthlp_sfc_name = 'wpthlp_sfc[mK\s]', & + wpqtp_sfc_name = 'wpqtp_sfc[(kg\kg)m\s]' + + private ! Default Scope + +end module input_names diff --git a/src/physics/clubb/input_reader.F90 b/src/physics/clubb/input_reader.F90 new file mode 100644 index 0000000000..d90da770d8 --- /dev/null +++ b/src/physics/clubb/input_reader.F90 @@ -0,0 +1,865 @@ +!----------------------------------------------------------------------- +!$Id: input_reader.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module input_reader + +! Description: +! This module is respondsible for the procedures and structures necessary to +! read in "SAM-Like" case specific files. Currently only the +! _sounding.in file is formatted to be used by this module. +! +! References: +! None +!--------------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private + + public :: one_dim_read_var, & + read_one_dim_file, & + two_dim_read_var, & + read_two_dim_file, & + fill_blanks_one_dim_vars, & + fill_blanks_two_dim_vars, & + deallocate_one_dim_vars, & + deallocate_two_dim_vars, & + read_x_table, & + read_x_profile, & + get_target_index, & + count_columns + + ! Derived type for representing a rank 1 variable that has been read in by one + ! of the procedures. + type one_dim_read_var + + character(len=30) :: name ! Name of the variable + + character(len=30) :: dim_name ! Name of the dimension that the + ! variable varies along + + real( kind = core_rknd ), dimension(:), allocatable :: values ! Values of that variable + + end type one_dim_read_var + + ! Derived type for representing a rank 2 variable that has been read in by one + ! of the procedures. + type two_dim_read_var + + character(len=30) :: name ! Name of the variable + + character(len=30) :: dim1_name ! Name of one of the dimensions + ! that the variable varies along + + character(len=30) :: dim2_name ! Name of the other variable that + ! the variable varies along + + real( kind = core_rknd ), dimension(:,:), allocatable :: values ! Values of that variable + + end type two_dim_read_var + + + ! Constant Parameter(s) + real( kind = core_rknd ), parameter, private :: & + blank_value = -999.9_core_rknd ! Used to denote if a value is missing from the file + + contains + + !------------------------------------------------------------------------------------------------- + subroutine read_two_dim_file( iunit, nCol, filename, read_vars, other_dim ) + ! + ! Description: This subroutine reads from a file containing data that varies + ! in two dimensions. These are dimensions are typically height + ! and time. + ! + !----------------------------------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Constant(s) + + use input_names, only: & + time_name ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: trim, index + + ! Input Variable(s) + + integer, intent(in) :: iunit ! File I/O unit + + integer, intent(in) :: nCol ! Number of columns expected in the data file + + + character(len=*), intent(in) :: filename ! Name of the file being read from + + ! Output Variable(s) + type (two_dim_read_var), dimension(nCol),intent(out) :: read_vars ! Structured information + ! from the file + + type (one_dim_read_var), intent(out) :: other_dim ! Structured information + ! on the dimesion not stored in read_vars + + ! Local Variables + character(len=30),dimension(nCol) :: names ! Names of variables + + integer nRowI ! Inner row + + integer nRowO ! Outer row + + integer :: k, j, i + + logical :: isComment + + character(len=200) :: tmpline + + real( kind = core_rknd ), dimension(nCol) :: tmp + + integer :: input_status ! The status of a read statement + + ! ---- Begin Code ---- + + ! First run through, take names and determine how large the data file is. + open(unit=iunit, file=trim( filename ), status = 'old', action='read' ) + + isComment = .true. + + ! Skip all the comments at the top of the file + do while ( isComment ) + read(iunit,fmt='(A)') tmpline + k = index( tmpline, "!" ) + isComment = .false. + if ( k > 0 ) then + isComment = .true. + end if + end do + + ! Go back to the line that wasn't a comment. + backspace(iunit) + + read(iunit, fmt=*) names + + nRowO = 0 + do while(.true.) + read(iunit, *, iostat=input_status) tmp(1), nRowI + + ! If input_status shows an end of data, then exit the loop + if( input_status < 0 ) then + exit + else if ( input_status > 0 ) then + write(fstderr,*) "Error reading data from file: " //trim( filename ) + stop "Fatal error input_reader" + end if + + if( nRowI < 1 ) then + stop "Number of elements must be an integer and greater than zero in two-dim input file." + end if + + do k =1, nRowI + read(iunit, *) tmp + end do + nRowO = nRowO + 1 + end do + + do i=1, nRowO + + backspace(iunit) + + do j=1, nRowI + + backspace(iunit) + + end do + + end do + + backspace(iunit) + + ! Store the names into the structure and allocate accordingly + do k =1, nCol + read_vars(k)%name = names(k) + read_vars(k)%dim1_name = time_name + read_vars(k)%dim2_name = names(1) + + allocate( read_vars(k)%values(nRowI, nRowO) ) + end do + + other_dim%name = time_name + other_dim%dim_name = time_name + + allocate( other_dim%values(nRowO) ) + + ! Read in the data again to the newly allocated arrays + do k=1, nRowO + read(iunit,*) other_dim%values(k) + do j=1, nRowI + read(iunit,*) ( read_vars(i)%values(j,k), i=1, nCol) + end do + end do + + close(iunit) + + ! Eliminate a compiler warning + if ( .false. ) print *, tmp + + return + end subroutine read_two_dim_file + + !------------------------------------------------------------------------------------------------ + subroutine read_one_dim_file( iunit, nCol, filename, read_vars ) + ! + ! Description: + ! This subroutine reads from a file containing data that varies + ! in one dimension. The dimension is typically time. + ! + ! References: + ! None + !---------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + + intrinsic :: trim, index + + ! Input Variable(s) + + integer, intent(in) :: iunit ! I/O unit + + integer, intent(in) :: nCol ! Number of columns expected in the data file + + character(len=*), intent(in) :: filename ! Name of the file being read from + + ! Output Variable(s) + + type (one_dim_read_var), dimension(nCol),intent(out) :: & + read_vars ! Structured information from the file + + ! Local Variable(s) + character(len=30),dimension(nCol) :: names + + character(len=200) :: tmpline + + integer nRow + + integer :: k, j + + real( kind = core_rknd ), dimension(nCol) :: tmp + + logical :: isComment + + integer :: input_status ! The status of a read statement + + ! ---- Begin Code ---- + + isComment = .true. + + ! First run through, take names and determine how large the data file is. + open(unit=iunit, file=trim( filename ), status = 'old' ) + + ! Skip all the comments at the top of the file + do while(isComment) + read(iunit,fmt='(A)') tmpline + k = index( tmpline, "!" ) + isComment = .false. + if(k > 0) then + isComment = .true. + end if + end do + + ! Go back to the line that wasn't a comment. + backspace(iunit) + + read(iunit, fmt=*) names + + ! Count up the number of rows + nRow = 0 + do while(.true.) + read(iunit, *, iostat=input_status) tmp + + ! If input_status shows an end of file, exit the loop + if( input_status < 0 ) then + exit + end if + + nRow = nRow+1 + end do + + ! Rewind that many rows + do k = 0, nRow + backspace(iunit) + end do + + ! Store the names into the structure and allocate accordingly + do k = 1, nCol + read_vars(k)%name = names(k) + read_vars(k)%dim_name = names(1) + allocate( read_vars(k)%values(nRow) ) + end do + + ! Read in the data again to the newly allocated arrays + do k=1, nRow + read(iunit,*) ( read_vars(j)%values(k), j=1, nCol) + end do + + close(iunit) + + ! Avoiding compiler warning + if ( .false. ) print *, tmp + + return + + end subroutine read_one_dim_file + + !------------------------------------------------------------------------------------------------ + subroutine fill_blanks_one_dim_vars( num_vars, one_dim_vars ) + ! + ! Description: + ! This subroutine fills in the blank spots (signified by constant blank_value) + ! with values linearly interpolated using the first element of the array as a + ! guide. + ! + ! References: + ! None + !---------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: size + + ! Input Variable(s) + integer, intent(in) :: num_vars ! Number of elements in one_dim_vars + + ! Input/Output Variable(s) + type(one_dim_read_var), dimension(num_vars), intent(inout) :: & + one_dim_vars ! Read data that may have gaps. + + ! Local variable(s) + integer :: i + + ! ---- Begin Code ---- + + do i=1, num_vars + one_dim_vars(i)%values = linear_fill_blanks( size( one_dim_vars(i)%values ), & + one_dim_vars(1)%values, one_dim_vars(i)%values, & + 0.0_core_rknd ) + end do + + return + + end subroutine fill_blanks_one_dim_vars + + !------------------------------------------------------------------------------------------------ + subroutine fill_blanks_two_dim_vars( num_vars, other_dim, two_dim_vars ) + ! + ! Description: + ! This subroutine fills in the blank spots (signified by the + ! constant blank_value with values linearly interpolated using the first + ! element of the array and the values in the other_dim argument as a guide. + ! + ! This is a two step process. First we assume that the other_dim values + ! have no holes, but there are blanks for that variable across that + ! dimension. Then we fill holes across the dimension whose values are first + ! in the array of two_dim_vars. + ! + ! Ex. Time is the 'other_dim' and Height in meters is the first element in + ! two_dim_vars. + ! + ! References: + ! None + !---------------------------------------------------------------------------------------------- + + implicit none + + ! External + intrinsic :: size + + ! Input Variable(s) + integer, intent(in) :: num_vars ! Number of elements in one_dim_vars + + ! Input/Output Variable(s) + type(one_dim_read_var), intent(in) :: other_dim ! Read data + + type(two_dim_read_var), dimension(num_vars), intent(inout) :: & + two_dim_vars ! Read data that may have gaps. + + ! Local variables + integer :: i,j ! Loop iterators + + integer :: & + dim_size, & ! 1st dimension size + other_dim_size ! 2nd dimension size + + ! ---- Begin Code ---- + + dim_size = size( two_dim_vars(1)%values, 1 ) + + other_dim_size = size( other_dim%values ) + + do i=2, num_vars + ! Interpolate along main dim + do j=1, other_dim_size + two_dim_vars(i)%values(:,j) = linear_fill_blanks( dim_size, & + two_dim_vars(1)%values(:,j), & + two_dim_vars(i)%values(:,j), blank_value ) + end do ! j = 1 .. other_dim_size + + ! Interpolate along other dim + do j=1, dim_size + two_dim_vars(i)%values(j,:) = linear_fill_blanks( other_dim_size, & + other_dim%values, & + two_dim_vars(i)%values(j,:), blank_value ) + end do ! j = 1 .. dim_size + + end do ! i = 2 .. num_vars + + return + + end subroutine fill_blanks_two_dim_vars + + + !------------------------------------------------------------------------------------------------ + function linear_fill_blanks( dim_grid, grid, var, default_value ) & + result( var_out ) + ! + ! Description: + ! This function fills blanks in array var using the grid + ! as a guide. Blank values in var are signified by being + ! less than or equal to the constant blank_value. + ! + ! References: + ! None + !----------------------------------------------------------------------------------------------- + + use interpolation, only: zlinterp_fnc + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable(s) + integer, intent(in) :: dim_grid ! Size of grid + + real( kind = core_rknd ), dimension(dim_grid), intent(in) :: & + grid ! Array that var is being interpolated to. + + real( kind = core_rknd ), dimension(dim_grid), intent(in) :: & + var ! Array that may contain gaps. + + real( kind = core_rknd ), intent(in) :: & + default_value ! Default value if entire profile == blank_value + + ! Output Variable(s) + real( kind = core_rknd ), dimension(dim_grid) :: & + var_out ! Return variable + + ! Local Variables + real( kind = core_rknd ), dimension(dim_grid) :: temp_grid + real( kind = core_rknd ), dimension(dim_grid) :: temp_var + + integer :: i + integer :: amt + + logical :: reversed + + ! ---- Begin Code ---- + + reversed = .false. + + ! Essentially this code leverages the previously written zlinterp function. + ! A smaller temporary grid and var variable are being created to pass to + ! zlinterp. zlinterp then performs the work of taking the temporary var + ! array and interpolating it to the actual grid array. + + amt = 0 + do i=1, dim_grid + if ( var(i) > blank_value ) then + amt = amt + 1 + temp_var(amt) = var(i) + temp_grid(amt) = grid(i) + end if + if ( i > 1 ) then + if ( grid(i) < grid(i-1) ) then + reversed = .true. + end if + end if + end do + + + if ( amt == 0 ) then + var_out = default_value + else if (amt < dim_grid) then + if ( reversed ) then + var_out = zlinterp_fnc( dim_grid, amt, -grid, -temp_grid(1:amt), temp_var(1:amt) ) + else + var_out = zlinterp_fnc( dim_grid, amt, grid, temp_grid(1:amt), temp_var(1:amt) ) + end if + else + var_out = var + end if + + return + end function linear_fill_blanks + !---------------------------------------------------------------------------- + subroutine deallocate_one_dim_vars( num_vars, one_dim_vars ) + ! + ! Description: + ! This subroutine deallocates the pointer stored in + ! one_dim_vars%value for the whole array. + ! + !------------------------------------------------------------------------------ + implicit none + + ! External functions + intrinsic :: allocated + + ! Input Variable(s) + integer, intent(in) :: num_vars ! Number of elements in one_dim_vars + + type(one_dim_read_var), dimension(num_vars), intent(inout) :: & + one_dim_vars ! Read data that may have gaps. + + ! Local Variable(s) + integer :: i + + ! Begin Code + + do i=1, num_vars + + if ( allocated( one_dim_vars(i)%values ) ) then + + deallocate( one_dim_vars(i)%values ) + + end if + + end do ! 1 .. num_vars + + return + end subroutine deallocate_one_dim_vars + + !------------------------------------------------------------------------------------------------ + subroutine deallocate_two_dim_vars( num_vars, two_dim_vars, other_dim ) + ! + ! Description: + ! This subroutine deallocates the pointer stored in + ! two_dim_vars%value for the whole array + ! + ! References: + ! None + !---------------------------------------------------------------------------------------------- + implicit none + + ! External Functions + intrinsic :: allocated + + ! Input Variable(s) + integer, intent(in) :: num_vars ! Number of elements in one_dim_vars + + ! Input/Output Variables + type(one_dim_read_var), intent(inout) :: other_dim + + type(two_dim_read_var), dimension(num_vars), intent(inout) :: & + two_dim_vars ! Read data that may have gaps. + + ! Local Variable(s) + integer :: i + + ! ---- Begin Code ---- + + do i=1, num_vars + + if ( allocated( two_dim_vars(i)%values ) ) then + + deallocate(two_dim_vars(i)%values) + + end if + + end do + + if ( allocated( other_dim%values ) ) then + + deallocate(other_dim%values) + + end if + + return + end subroutine deallocate_two_dim_vars + !------------------------------------------------------------------------------------------------ + function read_x_table( nvar, xdim, ydim, target_name, retVars ) result( x ) + ! + ! Description: + ! Searches for the variable specified by target_name in the + ! collection of retVars. If the function finds the variable then it returns + ! it. If it does not the program using this function will exit gracefully + ! with a warning message. + ! + ! References: + ! None + !----------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + fstderr ! Constant(s) + + implicit none + + ! External Functions + intrinsic :: trim + + ! Input Variable(s) + integer, intent(in) :: nvar ! Number of variables in retVars + + integer, intent(in) :: xdim, ydim + + character(len=*), intent(in) :: & + target_name ! Name of the variable that is being searched for + + type(two_dim_read_var), dimension(nvar), intent(in) :: & + retVars ! Collection of data being searched through + + ! Output Variable(s) + real( kind = core_rknd ), dimension( xdim, ydim ) :: x + + ! Local Variables + integer :: i ! Loop iterator + + logical :: l_found + + ! ---- Begin Code ---- + + l_found = .false. + + i = 1 + + do while( i <= nvar .and. .not. l_found) + + if( retVars(i)%name == target_name ) then + + l_found = .true. + + x = retVars(i)%values + + end if + + i=i+1 + + end do ! i <= nvar .and. not l_found + + if ( .not. l_found ) then + + write(fstderr,*) trim( target_name )//" could not be found." + + stop "Fatal error in function read_x_table" + + end if + + return + + end function read_x_table + + + !------------------------------------------------------------------------------------------------ + function read_x_profile( nvar, dim_size, target_name, retVars, & + input_file ) result( x ) + ! + ! Description: + ! Searches for the variable specified by target_name in the + ! collection of retVars. If the function finds the variable then it returns + ! it. If it does not the program using this function will exit gracefully + ! with a warning message. + ! + ! Modified by Cavyn, June 2010 + !---------------------------------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Variable for writing to error stream + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External Functions + intrinsic :: present, size, trim + + ! Input Variable(s) + integer, intent(in) :: & + nvar, & ! Number of variables in retVars + dim_size ! Size of the array returned + + character(len=*), intent(in) :: & + target_name ! Name of the variable that is being searched for + + type(one_dim_read_var), dimension(nvar), intent(in) :: & + retVars ! Collection being searched + + character(len=*), optional, intent(in) :: & + input_file ! Name of the input file containing the variables + + ! Output Variable(s) + real( kind = core_rknd ), dimension(dim_size) :: x + + ! Local Variables + integer :: i + + ! ---- Begin Code ---- + + i = get_target_index( nvar, target_name, retVars ) + + if ( i > 0 ) then + x(1:size(retVars(i)%values)) = retVars(i)%values + + else + if( present( input_file ) ) then + write(fstderr,*) trim( target_name ), ' could not be found. Check the file ', input_file + else + write(fstderr,*) trim( target_name ), ' could not be found. Check your sounding.in file.' + end if ! present( input_file ) + stop "Fatal error in read_x_profile" + + end if ! target_exists_in_array + + return + + end function read_x_profile + + !------------------------------------------------------------------------------ + function get_target_index( nvar, target_name, retVars) result( i ) + ! + ! Description: + ! Returns the index of the variable specified by target_name in the + ! collection of retVars. Returns -1 if variable does not exist in retVars + ! + ! References: + ! None + ! + ! Created by Cavyn, July 2010 + !---------------------------------------------------------------------------------------------- + + implicit none + + ! Input Variable(s) + integer, intent(in) :: nvar ! Number of variables in retVars + character(len=*), intent(in) :: target_name ! Variable being searched for + type(one_dim_read_var), dimension(nvar), intent(in) :: retVars ! Collection being searched + + ! Output Variable + integer :: i + + ! Local Variable(s) + logical :: l_found + + !----------------BEGIN CODE------------------ + + l_found = .false. + + i = 0 + do while ( i < nvar .and. .not. l_found ) + i = i+1 + if( retVars(i)%name == target_name ) then + l_found = .true. + end if + end do + + if( .not. l_found ) then + i = -1 + end if + + return + + end function get_target_index + + !============================================================================= + function count_columns( iunit, filename ) result( nCols ) + ! Description: + ! This function counts the number of columns in a file, assuming that the + ! first line of the file contains only column headers. (Comments are OK) + + ! References: + ! None + + ! Created by Cavyn, July 2010 + !----------------------------------------------------------------------------- + + implicit none + + ! External + intrinsic :: index, trim, size + + ! Input Variables + integer, intent(in) :: iunit ! I/O unit + character(len=*), intent(in) :: filename ! Name of the file being read from + + ! Output Variable + integer :: nCols ! The number of data columns in the selected file + + ! Local Variables + integer :: i, k ! Loop Counter + character(len=200) :: tmp ! Temporary char buffer + character(len=200), dimension(50) :: colArray ! Max of 50 columns + logical :: isComment + integer :: status_var ! IO status for read statement + + + ! -------------------------BEGIN CODE------------------------------------- + + isComment = .true. + + open(unit=iunit, file=trim( filename ), status = 'old' ) + + ! Skip all the comments at the top of the file + do while(isComment) + read(iunit,fmt='(A)') tmp + k = index( tmp, "!" ) + isComment = .false. + if(k > 0) then + isComment = .true. + end if + end do + + ! Go back to the line that wasn't a comment. + backspace(iunit) + + ! Count the number of columns + nCols = 0 + colArray = "" + read(iunit,fmt='(A)',iostat=status_var) tmp + ! Only continue if there was no IO error or end of data + if( status_var == 0 ) then + ! Move all words into an array + read(tmp,*,iostat=status_var) (colArray(i), i=1,size( colArray )) + + else if ( status_var > 0 ) then + ! Handle the case where we have an error before the EOF marker is found + stop "Fatal error reading data in time_dependent_input function count_columns" + + end if + + do i=1,size( colArray ) + if( colArray(i) /= "" ) then ! Increment number of columns until array is blank + nCols = nCols+1 + end if + end do + + close(iunit) + + end function count_columns + +!------------------------------------------------------------------------------ +end module input_reader diff --git a/src/physics/clubb/interpolation.F90 b/src/physics/clubb/interpolation.F90 new file mode 100644 index 0000000000..e3e6e494f3 --- /dev/null +++ b/src/physics/clubb/interpolation.F90 @@ -0,0 +1,677 @@ +!------------------------------------------------------------------------------- +!$Id: interpolation.F90 7200 2014-08-13 15:15:12Z betlej@uwm.edu $ +!=============================================================================== +module interpolation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Default Scope + + public :: lin_interpolate_two_points, binary_search, zlinterp_fnc, & + lin_interpolate_on_grid, linear_interp_factor, mono_cubic_interp, plinterp_fnc, & + pvertinterp + + contains + +!------------------------------------------------------------------------------- + function lin_interpolate_two_points( height_int, height_high, height_low, & + var_high, var_low ) + +! Description: +! This function computes a linear interpolation of the value of variable. +! Given two known values of a variable at two height values, the value +! of that variable at a height between those two height levels (rather +! than a height outside of those two height levels) is computed. +! +! Here is a diagram: +! +! ################################ Height high, know variable value +! +! +! +! -------------------------------- Height to be interpolated to; linear interpolation +! +! +! +! +! +! ################################ Height low, know variable value +! +! +! FORMULA: +! +! variable(@ Height interpolation) = +! +! [ (variable(@ Height high) - variable(@ Height low)) / (Height high - Height low) ] +! * (Height interpolation - Height low) + variable(@ Height low) + +! Comments from WRF-HOC, Brian Griffin. + +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: fstderr ! Constant + + implicit none + + ! Input Variables + + real( kind = core_rknd ), intent(in) :: & + height_int, & ! Height to be interpolated to [m] + height_high, & ! Height above the interpolation [m] + height_low, & ! Height below the interpolation [m] + var_high, & ! Variable above the interpolation [units vary] + var_low ! Variable below the interpolation [units vary] + + ! Output Variables + real( kind = core_rknd ) :: lin_interpolate_two_points + + ! Check for valid input + if ( abs(height_low - height_high) < 1.0e-12_core_rknd ) then + write(fstderr,*) "lin_interpolate_two_points: height_high and height_low cannot be equal." + stop + end if + + ! Compute linear interpolation + + lin_interpolate_two_points = ( ( height_int - height_low )/( height_high - height_low ) ) & + * ( var_high - var_low ) + var_low + + return + end function lin_interpolate_two_points + + !------------------------------------------------------------------------------------------------- + elemental real( kind = core_rknd ) function linear_interp_factor( factor, var_high, var_low ) + ! Description: + ! Determines the coefficient for a linear interpolation + ! + ! References: + ! None + !------------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + real( kind = core_rknd ), intent(in) :: & + factor, & ! Factor [units vary] + var_high, & ! Variable above the interpolation [units vary] + var_low ! Variable below the interpolation [units vary] + + linear_interp_factor = factor * ( var_high - var_low ) + var_low + + return + end function linear_interp_factor + !------------------------------------------------------------------------------------------------- + function mono_cubic_interp & + ( z_in, km1, k00, kp1, kp2, zm1, z00, zp1, zp2, fm1, f00, fp1, fp2 ) result ( f_out ) + + ! Description: + ! Steffen's monotone cubic interpolation method + ! Returns monotone cubic interpolated value between x00 and xp1 + + ! Original Author: + ! Takanobu Yamaguchi + ! tak.yamaguchi@noaa.gov + ! + ! This version has been modified slightly for CLUBB's coding standards and + ! adds the 3/2 from eqn 21. -dschanen 26 Oct 2011 + ! We have also added a quintic polynomial option. + ! + ! References: + ! M. Steffen, Astron. Astrophys. 239, 443-450 (1990) + !------------------------------------------------------------------------------------------------- + + use constants_clubb, only: & + three_halves, & ! Constant(s) + eps + + use clubb_precision, only: & + core_rknd ! Constant + + use model_flags, only: & + l_quintic_poly_interp ! Variable(s) + + implicit none + + ! Constant Parameters + logical, parameter :: & + l_equation_21 = .true. + + ! External + intrinsic :: sign, abs, min + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + z_in ! The altitude to be interpolated to [m] + + ! k-levels; their meaning depends on whether we're extrapolating or interpolating + integer, intent(in) :: & + km1, k00, kp1, kp2 + + real( kind = core_rknd ), intent(in) :: & + zm1, z00, zp1, zp2, & ! The altitudes for km1, k00, kp1, kp2 [m] + fm1, f00, fp1, fp2 ! The field at km1, k00, kp1, and kp2 [units vary] + + ! Output Variables + real( kind = core_rknd ) :: f_out ! The interpolated field + + ! Local Variables + real( kind = core_rknd ) :: & + hm1, h00, hp1, & + sm1, s00, sp1, & + p00, pp1, & + dfdx00, dfdxp1, & + c1, c2, c3, c4, & + w00, wp1, & + coef1, coef2, & + zprime, beta, alpha, zn + + ! ---- Begin Code ---- + + if ( l_equation_21 ) then + ! Use the formula from Steffen (1990), which should make the interpolation + ! less restrictive + coef1 = three_halves + coef2 = 1.0_core_rknd/three_halves + else + coef1 = 1.0_core_rknd + coef2 = 1.0_core_rknd + end if + + if ( km1 <= k00 ) then + hm1 = z00 - zm1 + h00 = zp1 - z00 + hp1 = zp2 - zp1 + + if ( km1 == k00 ) then + s00 = ( fp1 - f00 ) / ( zp1 - z00 ) + sp1 = ( fp2 - fp1 ) / ( zp2 - zp1 ) + dfdx00 = s00 + pp1 = ( s00 * hp1 + sp1 * h00 ) / ( h00 + hp1 ) + dfdxp1 = coef1*( sign( 1.0_core_rknd, s00 ) + sign( 1.0_core_rknd, sp1 ) ) & + * min( abs( s00 ), abs( sp1 ), coef2*0.5_core_rknd*abs( pp1 ) ) + + else if ( kp1 == kp2 ) then + sm1 = ( f00 - fm1 ) / ( z00 - zm1 ) + s00 = ( fp1 - f00 ) / ( zp1 - z00 ) + p00 = ( sm1 * h00 + s00 * hm1 ) / ( hm1 + h00 ) + dfdx00 = coef1*( sign( 1.0_core_rknd, sm1 ) + sign( 1.0_core_rknd, s00 ) ) & + * min( abs( sm1 ), abs( s00 ), coef2*0.5_core_rknd*abs( p00 ) ) + dfdxp1 = s00 + + else + sm1 = ( f00 - fm1 ) / ( z00 - zm1 ) + s00 = ( fp1 - f00 ) / ( zp1 - z00 ) + sp1 = ( fp2 - fp1 ) / ( zp2 - zp1 ) + p00 = ( sm1 * h00 + s00 * hm1 ) / ( hm1 + h00 ) + pp1 = ( s00 * hp1 + sp1 * h00 ) / ( h00 + hp1 ) + dfdx00 = coef1*( sign( 1.0_core_rknd, sm1 ) + sign( 1.0_core_rknd, s00 ) ) & + * min( abs( sm1 ), abs( s00 ), coef2*0.5_core_rknd*abs( p00 ) ) + dfdxp1 = coef1*( sign( 1.0_core_rknd, s00 ) + sign( 1.0_core_rknd, sp1 ) ) & + * min( abs( s00 ), abs( sp1 ), coef2*0.5_core_rknd*abs( pp1 ) ) + + end if + + c1 = ( dfdx00 + dfdxp1 - 2._core_rknd * s00 ) / ( h00 ** 2 ) + c2 = ( 3._core_rknd * s00 - 2._core_rknd * dfdx00 - dfdxp1 ) / h00 + c3 = dfdx00 + c4 = f00 + + if ( .not. l_quintic_poly_interp ) then + + ! Old formula + !f_out = c1 * ( (z_in - z00)**3 ) + c2 * ( (z_in - z00)**2 ) + c3 * (z_in - z00) + c4 + + ! Faster nested multiplication + zprime = z_in - z00 + f_out = c4 + zprime*( c3 + zprime*( c2 + ( zprime*c1 ) ) ) + + else + + ! Use a quintic polynomial interpolation instead instead of the Steffen formula. + ! Unlike the formula above, this formula does not guarantee monotonicity. + + beta = 120._core_rknd * ( (fp1-f00) - 0.5_core_rknd * h00 * (dfdx00 + dfdxp1) ) + + ! Prevent an underflow by using a linear interpolation + if ( abs( beta ) < eps ) then + f_out = lin_interpolate_two_points( z00, zp1, zm1, & + fp1, fm1 ) + + else + alpha = (6._core_rknd/beta) * h00 * (dfdxp1-dfdx00) + 0.5_core_rknd + zn = (z_in-z00)/h00 + + f_out = ( & + (( (beta/20._core_rknd)*zn - (beta*(1._core_rknd+alpha) & + / 12._core_rknd)) * zn + (beta*alpha/6._core_rknd)) & + * zn**2 + dfdx00*h00 & + ) * zn + f00 + end if ! beta < eps + end if ! ~quintic_polynomial + + else + ! Linear extrapolation + wp1 = ( z_in - z00 ) / ( zp1 - z00 ) + w00 = 1._core_rknd - wp1 + f_out = wp1 * fp1 + w00 * f00 + + end if + + return + end function mono_cubic_interp + +!------------------------------------------------------------------------------- + pure integer function binary_search( n, array, var ) & + result( i ) + + ! Description: + ! This subroutine performs a binary search to find the closest value greater + ! than or equal to var in the array. This function returns the index of the + ! closest value of array that is greater than or equal to var. It returns a + ! value of -1 if var is outside the bounds of array. + ! + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + + ! Size of the array + integer, intent(in) :: n + + ! The array being searched (must be sorted from least value to greatest + ! value). + real( kind = core_rknd ), dimension(n), intent(in) :: array + + ! The value being searched for + real( kind = core_rknd ), intent(in) :: var + + ! Local Variables + + ! Has an index been found? + logical :: l_found + + ! Bounds of the search + integer :: high + integer :: low + + ! Initialize local variables + + l_found = .false. + + ! The initial value of low has been changed from 1 to 2 due to a problem + ! that was occuring when var was close to the lower bound. + ! + ! The lowest value in the array (which is sorted by increasing values) is + ! found at index 1, while the highest value in the array is found at + ! index n. Unless the value of var exactly corresponds with one of the + ! values found in the array, or unless the value of var is found outside of + ! the array, the value of var will be found between two levels of the array. + ! In this scenario, the output of function binary_search is the index of the + ! HIGHER level. For example, if the value of var is found between array(1) + ! and array(2), the output of function binary_search will be 2. + ! + ! Therefore, the lowest index of a HIGHER level in an interpolation is 2. + ! Thus, the initial value of low has been changed to 2. This will prevent + ! the value of variable "i" below from becoming 1. If the value of "i" + ! becomes 1, the code below tries to access array(0) (which is array(i-1) + ! when i = 1) and produces an error. + + low = 2 + + high = n + + ! This line is here to avoid a false compiler warning about "i" being used + ! uninitialized in this function. + i = (low + high) / 2 + + do while( .not. l_found .and. low <= high ) + + i = (low + high) / 2 + + if ( var > array( i - 1 ) .and. var <= array( i ) ) then + + l_found = .true. + + elseif ( var == array(1) ) then + + ! Special case where var falls exactly on the lowest value in the + ! array, which is array(1). This case is not covered by the statement + ! above. + l_found = .true. + ! The value of "i" must be set to 2 because an interpolation is + ! performed in the subroutine that calls this function that uses + ! indices "i" and "i-1". + i = 2 + + elseif ( var < array( i ) ) then + + high = i - 1 + + elseif ( var > array( i ) ) then + + low = i + 1 + + endif + + enddo ! while ( ~l_found & low <= high ) + + if ( .not. l_found ) i = -1 + + return + + end function binary_search + +!------------------------------------------------------------------------------- + function plinterp_fnc( dim_out, dim_src, grid_out, & + grid_src, var_src ) & + result( var_out ) +! Description: +! Do a linear interpolation in the vertical with pressures. Assumes +! values that are less than lowest source point are zero and above the +! highest source point are zero. Also assumes altitude increases linearly. +! This function just calls zlinterp_fnc, but negates grid_out and grid_src. + +! References: +! function LIN_INT from WRF-HOC +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: dim_out, dim_src + + real( kind = core_rknd ), dimension(dim_src), intent(in) :: & + grid_src, & ! [m] + var_src ! [units vary] + + real( kind = core_rknd ), dimension(dim_out), intent(in) :: & + grid_out ! [m] + + ! Output variable + real( kind = core_rknd ), dimension(dim_out) :: & + var_out ! [units vary] + + ! ---- Begin Code ---- + + var_out = zlinterp_fnc( dim_out, dim_src, -grid_out, & + -grid_src, var_src ) + + return + end function plinterp_fnc +!------------------------------------------------------------------------------- + function zlinterp_fnc( dim_out, dim_src, grid_out, & + grid_src, var_src ) & + result( var_out ) +! Description: +! Do a linear interpolation in the vertical. Assumes values that +! are less than lowest source point are zero and above the highest +! source point are zero. Also assumes altitude increases linearly. + +! References: +! function LIN_INT from WRF-HOC +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: dim_out, dim_src + + real( kind = core_rknd ), dimension(dim_src), intent(in) :: & + grid_src, & ! [m] + var_src ! [units vary] + + real( kind = core_rknd ), dimension(dim_out), intent(in) :: & + grid_out ! [m] + + ! Output variable + real( kind = core_rknd ), dimension(dim_out) :: & + var_out ! [units vary] + + ! Local variables + integer :: k, kint, km1 + +! integer :: tst, kp1 + + ! ---- Begin Code ---- + + k = 1 + + do kint = 1, dim_out, 1 + + ! Set to 0 if we're below the input data's lowest point + if ( grid_out(kint) < grid_src(1) ) then + var_out(kint) = 0.0_core_rknd + cycle + end if + + ! Increment k until the level is correct +! do while ( grid_out(kint) > grid_src(k) +! . .and. k < dim_src ) +! k = k + 1 +! end do + + ! Changed so a binary search is used instead of a sequential search +! tst = binary_search(dim_src, grid_src, grid_out(kint)) + k = binary_search(dim_src, grid_src, grid_out(kint)) + ! Joshua Fasching April 2008 + +! print *, "k = ", k +! print *, "tst = ", tst +! print *, "dim_src = ", dim_src +! print *,"------------------------------" + + ! If the increment leads to a level above the data, set this + ! point and all those above it to zero + !if( k > dim_src ) then + if ( k == -1 ) then + var_out(kint:dim_out) = 0.0_core_rknd + exit + end if + + km1 = max( 1, k-1 ) + !kp1 = min( k+1, dim_src ) + + ! Interpolate + var_out(kint) = lin_interpolate_two_points( grid_out(kint), grid_src(k), & + grid_src(km1), var_src(k), var_src(km1) ) + +! ( var_src(k) - var_src(km1) ) / & +! ( grid_src(k) - grid_src(km1) ) & +! * ( grid_out(kint) - grid_src(km1) ) + var_src(km1) & +! Changed to use a standard function for interpolation + + !! Note this ends up changing the results slightly because + !the placement of variables has been changed. + +! Joshua Fasching April 2008 + + end do ! kint = 1..dim_out + + return + end function zlinterp_fnc + +!------------------------------------------------------------------------------- + subroutine pvertinterp & + ( nlev, pmid, pout, arrin, arrout ) + + implicit none + + !------------------------------Arguments-------------------------------- + integer , intent(in) :: nlev ! vertical dimension + real( kind = core_rknd ), intent(in) :: pmid(nlev) ! input level pressure levels + real( kind = core_rknd ), intent(in) :: pout ! output pressure level + real( kind = core_rknd ), intent(in) :: arrin(nlev) ! input array + real( kind = core_rknd ), intent(out) :: arrout ! output array (interpolated) + + !---------------------------Local variables----------------------------- + integer :: k ! indices + integer :: kupper ! Level indices for interpolation + real( kind = core_rknd ) :: dpu ! upper level pressure difference + real( kind = core_rknd ) :: dpl ! lower level pressure difference + logical :: found ! true if input levels found + logical :: error ! true if error + !----------------------------------------------------------------- + ! + ! Initialize index array and logical flags + ! + + found = .false. + kupper = 1 + + error = .false. + ! + ! Store level indices for interpolation. + ! If all indices for this level have been found, + ! do the interpolation + ! + do k=1,nlev-1 + if ((.not. found) .and. pmid(k)>pout .and. pout>=pmid(k+1)) then + found = .true. + kupper = k + end if + end do + ! + ! If we've fallen through the k=1,nlev-1 loop, we cannot interpolate and + ! must extrapolate from the bottom or top data level for at least some + ! of the longitude points. + ! + if (pout >= pmid(1)) then + arrout = arrin(1) + else if (pout <= pmid(nlev)) then + arrout = arrin(nlev) + else if (found) then + dpu = pmid(kupper) - pout + dpl = pout - pmid(kupper+1) + arrout = (arrin(kupper)*dpl + arrin(kupper+1)*dpu)/(dpl + dpu) + else + error = .true. + end if + + return + end subroutine pvertinterp + +!------------------------------------------------------------------------------- + subroutine lin_interpolate_on_grid & + ( nparam, xlist, tlist, xvalue, tvalue ) + +! Description: +! Linear interpolation for 25 June 1996 altocumulus case. + +! For example, to interpolate between two temperatures in space, put +! your spatial coordinates in x-list and your temperature values in +! tlist. The point in question should have its spatial value stored +! in xvalue, and tvalue will be the temperature at that point. + +! Author: Michael Falk for COAMPS. +!------------------------------------------------------------------------------- + + use error_code, only: & + clubb_debug, & ! Procedure(s) + clubb_at_least_debug_level + + use constants_clubb, only: fstderr ! Constant + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: nparam ! Number of parameters in xlist and tlist + + ! Input/Output Variables + real( kind = core_rknd ), intent(inout), dimension(nparam) :: & + xlist, & ! List of x-values (independent variable) + tlist ! List of t-values (dependent variable) + + real( kind = core_rknd ), intent(in) :: & + xvalue ! x-value at which to interpolate + + real( kind = core_rknd ), intent(inout) :: & + tvalue ! t-value solved by interpolation + + ! Local variables + integer :: & + i ! Loop control variable + + integer :: & + bottombound, & ! Index of the smaller value in the linear interpolation + topbound ! Index of the larger value in the linear interpolation + +!------------------------------------------------------------------------------- +! +! Assure that the elements are in order so that the interpolation is between +! the two closest points to the point in question. +! +!------------------------------------------------------------------------------- + + if ( clubb_at_least_debug_level( 2 ) ) then + do i=2,nparam + if ( xlist(i) <= xlist(i-1) ) then + write(fstderr,*) "xlist must be sorted for lin_interpolate_on_grid." + stop + end if + end do + end if +!------------------------------------------------------------------------------- +! +! If the point in question is larger than the largest x-value or +! smaller than the smallest x-value, crash. +! +!------------------------------------------------------------------------------- + + if ( (xvalue < xlist(1)) .or. (xvalue > xlist(nparam)) ) then + write(fstderr,*) "lin_interpolate_on_grid: Value out of range" + stop + end if + +!------------------------------------------------------------------------------- +! +! Find the correct top and bottom bounds, do the interpolation, return c +! the value. +! +!------------------------------------------------------------------------------- + + topbound = -1 + bottombound = -1 + + do i=2,nparam + if ( (xvalue >= xlist(i-1)) .and. (xvalue <= xlist(i)) ) then + bottombound = i-1 + topbound = i + end if + end do + + if ( topbound == -1 .or. bottombound == -1 ) then + call clubb_debug( 1, "Sanity check failed! xlist is not properly sorted" ) + call clubb_debug( 1, "in lin_interpolate_on_grid.") + end if + + tvalue = & + lin_interpolate_two_points( xvalue, xlist(topbound), xlist(bottombound), & + tlist(topbound), tlist(bottombound) ) + + return + end subroutine lin_interpolate_on_grid + +end module interpolation diff --git a/src/physics/clubb/lapack_wrap.F90 b/src/physics/clubb/lapack_wrap.F90 new file mode 100644 index 0000000000..5cc726de82 --- /dev/null +++ b/src/physics/clubb/lapack_wrap.F90 @@ -0,0 +1,768 @@ +!----------------------------------------------------------------------- +! $Id: lapack_wrap.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module lapack_wrap + +! Description: +! Wrappers for the band diagonal and tridiagonal direct matrix +! solvers contained in the LAPACK library. + +! References: +! LAPACK--Linear Algebra PACKage +! URL: +!----------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_singular_matrix, & ! Variable(s) + clubb_bad_lapack_arg, & + clubb_var_equals_NaN, & + clubb_no_error + + use clubb_precision, only: & + core_rknd, & ! Variable(s) + dp + + implicit none + + ! Simple routines + public :: tridag_solve, band_solve + + ! Expert routines + public :: tridag_solvex, band_solvex + + private :: lapack_isnan + + ! A best guess for what the precision of a single precision and double + ! precision float is in LAPACK. Hopefully this will work more portably on + ! architectures like Itanium than the old code -dschanen 11 Aug 2011 + integer, parameter, private :: & + sp = kind ( 0.0 ) + + private ! Set Default Scope + + contains + +!----------------------------------------------------------------------- + subroutine tridag_solvex( solve_type, ndim, nrhs, & + supd, diag, subd, rhs, & + solution, rcond, err_code ) + +! Description: +! Solves a tridiagonal system of equations (expert routine). + +! References: +! +! + +! Notes: +! More expensive than the simple routine, but tridiagonal +! decomposition is still relatively cheap. +!----------------------------------------------------------------------- + use error_code, only: & + clubb_at_least_debug_level ! Logical function + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + external :: & + sgtsvx, & ! Single-prec. General Tridiagonal Solver eXpert + dgtsvx ! Double-prec. General Tridiagonal Solver eXpert + + intrinsic :: kind + + ! Input variables + character(len=*), intent(in) :: & + solve_type ! Used to write a message if this fails + + integer, intent(in) :: & + ndim, & ! N-dimension of matrix + nrhs ! # of right hand sides to back subst. after LU-decomp. + + ! Input/Output variables + real( kind = core_rknd ), intent(inout), dimension(ndim) :: & + diag, & ! Main diagonal + subd, supd ! Sub and super diagonal + + real( kind = core_rknd ), intent(inout), dimension(ndim,nrhs) :: & + rhs ! RHS input + + ! The estimate of the reciprocal of the condition number on the LHS matrix. + ! If rcond is < machine precision the matrix is singular to working + ! precision, and info == ndim+1. If rcond == 0, then the LHS matrix + ! is singular. This condition is indicated by a return code of info > 0. + real( kind = core_rknd ), intent(out) :: rcond + + integer, intent(out) :: & + err_code ! Used to determine when a decomp. failed + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(ndim,nrhs) :: & + solution ! Solution + + ! Local Variables + ! These contain the decomposition of the matrix + real( kind = core_rknd ), dimension(ndim-1) :: dlf, duf + real( kind = core_rknd ), dimension(ndim) :: df + real( kind = core_rknd ), dimension(ndim-2) :: du2 + + integer, dimension(ndim) :: & + ipivot ! Index of pivots done during decomposition + + integer, dimension(ndim) :: & + iwork ! `scrap' array + + + real( kind = core_rknd ), dimension(nrhs) :: & + ferr, & ! Forward error estimate + berr ! Backward error estimate + + real( kind = core_rknd ), dimension(3*ndim) :: & + work ! `Scrap' array + + integer :: info ! Diagnostic output + + integer :: i ! Array index + +!----------------------------------------------------------------------- +! *** The LAPACK Routine *** +! SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, +! $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, +! $ WORK, IWORK, INFO ) +!----------------------------------------------------------------------- + + if ( kind( diag(1) ) == dp ) then + call dgtsvx( "Not Factored", "No Transpose lhs", ndim, nrhs, & + subd(2:ndim), diag, supd(1:ndim-1), & + dlf, df, duf, du2, ipivot, & + rhs, ndim, solution, ndim, rcond, & + ferr, berr, work, iwork, info ) + + else if ( kind( diag(1) ) == sp ) then + call sgtsvx( "Not Factored", "No Transpose lhs", ndim, nrhs, & + subd(2:ndim), diag, supd(1:ndim-1), & + dlf, df, duf, du2, ipivot, & + rhs, ndim, solution, ndim, rcond, & + ferr, berr, work, iwork, info ) + + else + stop "tridag_solvex: Cannot resolve the precision of real datatype" + + end if + + ! Print diagnostics for when ferr is large + if ( clubb_at_least_debug_level( 2 ) .and. any( ferr > 1.e-3_core_rknd ) ) then + + write(fstderr,*) "Warning, large error est. for: " // trim( solve_type ) + + do i = 1, nrhs, 1 + write(fstderr,*) "rhs # ", i, "tridag forward error est. =", ferr(i) + write(fstderr,*) "rhs # ", i, "tridag backward error est. =", berr(i) + end do + + write(fstderr,'(2(a20,e15.6))') "rcond est. = ", rcond, & + "machine epsilon = ", epsilon( diag(1) ) + end if + + select case( info ) + case( :-1 ) + write(fstderr,*) trim( solve_type )// & + "illegal value in argument", -info + err_code = clubb_bad_lapack_arg + + case( 0 ) + ! Success! + if ( lapack_isnan( ndim, nrhs, solution ) ) then + err_code = clubb_var_equals_NaN + else + err_code = clubb_no_error + end if + + case( 1: ) + if ( info == ndim+1 ) then + write(fstderr,*) trim( solve_type) // & + " Warning: matrix is singular to working precision." + write(fstderr,'(a,e12.5)') & + "Estimate of the reciprocal of the condition number: ", rcond + err_code = clubb_no_error + else + write(fstderr,*) solve_type// & + " singular matrix." + err_code = clubb_singular_matrix + end if + + end select + + return + end subroutine tridag_solvex + +!----------------------------------------------------------------------- + subroutine tridag_solve & + ( solve_type, ndim, nrhs, & + supd, diag, subd, rhs, & + solution, err_code ) + +! Description: +! Solves a tridiagonal system of equations (simple routine) + +! References: +! +! +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + external :: & + sgtsv, & ! Single-prec. General Tridiagonal Solver eXpert + dgtsv ! Double-prec. General Tridiagonal Solver eXpert + + intrinsic :: kind + + ! Input variables + character(len=*), intent(in) :: & + solve_type ! Used to write a message if this fails + + integer, intent(in) :: & + ndim, & ! N-dimension of matrix + nrhs ! # of right hand sides to back subst. after LU-decomp. + + ! Input/Output variables + real( kind = core_rknd ), intent(inout), dimension(ndim) :: & + diag, & ! Main diagonal + subd, supd ! Sub and super diagonal + + real( kind = core_rknd ), intent(inout), dimension(ndim,nrhs) :: & + rhs ! RHS input + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(ndim,nrhs) :: & + solution ! Solution + + + integer, intent(out) :: & + err_code ! Used to determine when a decomp. failed + + ! Local Variables + + real( kind = dp ), dimension(ndim) :: & + subd_dp, supd_dp, diag_dp + + real( kind = dp ), dimension(ndim,nrhs) :: & + rhs_dp + + integer :: info ! Diagnostic output + +!----------------------------------------------------------------------- +! *** The LAPACK Routine *** +! SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) +!----------------------------------------------------------------------- + + if ( kind( diag(1) ) == dp ) then + call dgtsv( ndim, nrhs, subd(2:ndim), diag, supd(1:ndim-1), & + rhs, ndim, info ) + + else if ( kind( diag(1) ) == sp ) then + call sgtsv( ndim, nrhs, subd(2:ndim), diag, supd(1:ndim-1), & + rhs, ndim, info ) + + else + !stop "tridag_solve: Cannot resolve the precision of real datatype" + ! Eric Raut Aug 2013: Force double precision + subd_dp = real( subd, kind=dp ) + diag_dp = real( diag, kind=dp ) + supd_dp = real( supd, kind=dp ) + rhs_dp = real( rhs, kind=dp ) + call dgtsv( ndim, nrhs, subd_dp(2:ndim), diag_dp, supd_dp(1:ndim-1), & + rhs_dp, ndim, info ) + subd = real( subd_dp, kind=core_rknd ) + diag = real( diag_dp, kind=core_rknd ) + supd = real( supd_dp, kind=core_rknd ) + rhs = real( rhs_dp, kind=core_rknd ) + end if + + select case( info ) + case( :-1 ) + write(fstderr,*) trim( solve_type )// & + " illegal value in argument", -info + err_code = clubb_bad_lapack_arg + + solution = -999._core_rknd + + case( 0 ) + ! Success! + if ( lapack_isnan( ndim, nrhs, rhs ) ) then + err_code = clubb_var_equals_NaN + else + err_code = clubb_no_error + end if + + solution = rhs + + case( 1: ) + write(fstderr,*) trim( solve_type )//" singular matrix." + err_code = clubb_singular_matrix + + solution = -999._core_rknd + + end select + + return + end subroutine tridag_solve + +!----------------------------------------------------------------------- + subroutine band_solvex( solve_type, nsup, nsub, ndim, nrhs, & + lhs, rhs, solution, rcond, err_code ) +! Description: +! Restructure and then solve a band diagonal system, with +! diagnostic output + +! References: +! +! + +! Notes: +! I found that due to the use of sgbcon/dgbcon it is much +! more expensive to use this on most systems than the simple +! driver. Use this version only if you don't case about compute time. +! Also note that this version equilibrates the lhs and does an iterative +! refinement of the solutions, which results in a slightly different answer +! than the simple driver does. -dschanen 24 Sep 2008 +!----------------------------------------------------------------------- + use error_code, only: & + clubb_at_least_debug_level ! Logical function + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + external :: & + sgbsvx, & ! Single-prec. General Band Solver eXpert + dgbsvx ! Double-prec. General Band Solver eXpert + + intrinsic :: eoshift, kind, trim + + ! Input Variables + character(len=*), intent(in) :: solve_type + + integer, intent(in) :: & + nsup, & ! Number of superdiagonals + nsub, & ! Number of subdiagonals + ndim, & ! The order of the LHS Matrix, i.e. the # of linear equations + nrhs ! Number of RHS's to back substitute for + + real( kind = core_rknd ), dimension(nsup+nsub+1,ndim), intent(inout) :: & + lhs ! Left hand side + real( kind = core_rknd ), dimension(ndim,nrhs), intent(inout) :: & + rhs ! Right hand side(s) + + ! Output Variables + real( kind = core_rknd ), dimension(ndim,nrhs), intent(out) :: & + solution + + ! The estimate of the reciprocal condition number of matrix + ! after equilibration (if done). + real( kind = core_rknd ), intent(out) :: & + rcond + + integer, intent(out) :: err_code ! Valid calculation? + + ! Local Variables + + ! Workspaces + real( kind = core_rknd ), dimension(3*ndim) :: work + integer, dimension(ndim) :: iwork + + real( kind = core_rknd ), dimension(2*nsub+nsup+1,ndim) :: & + lulhs ! LU Decomposition of the LHS + + integer, dimension(ndim) :: & + ipivot + + real( kind = core_rknd ), dimension(nrhs) :: & + ferr, berr ! Forward and backward error estimate + + real( kind = core_rknd ), dimension(ndim) :: & + rscale, cscale ! Row and column scale factors for the LHS + + integer :: & + info, & ! If this doesn't come back as 0, something went wrong + offset, & ! Loop iterator + imain, & ! Main diagonal of the matrix + i ! Loop iterator + + character :: & + equed ! Row equilibration status + + +!----------------------------------------------------------------------- +! Reorder Matrix to use LAPACK band matrix format (5x6) + +! Shift example: + +! [ * * lhs(1,1) lhs(1,2) lhs(1,3) lhs(1,4) ] (2)=> +! [ * lhs(2,1) lhs(2,2) lhs(2,3) lhs(2,4) lhs(2,5) ] (1)=> +! [ lhs(3,1) lhs(3,2) lhs(3,3) lhs(3,4) lhs(3,5) lhs(3,6) ] +! <=(1) [ lhs(4,2) lhs(4,3) lhs(4,4) lhs(4,5) lhs(4,6) * ] +! <=(2) [ lhs(5,3) lhs(5,4) lhs(5,5) lhs(5,6) * * ] + +! The '*' indicates unreferenced elements. +! For additional bands above and below the main diagonal, the +! shifts to the left or right increases by the distance from the +! main diagonal of the matrix. +!----------------------------------------------------------------------- + + imain = nsup + 1 + + ! For the offset, (+) is left, and (-) is right + + ! Sub diagonals + do offset = 1, nsub, 1 + lhs(imain+offset, 1:ndim) & + = eoshift( lhs(imain+offset, 1:ndim), offset ) + end do + + ! Super diagonals + do offset = 1, nsup, 1 + lhs(imain-offset, 1:ndim) & + = eoshift( lhs(imain-offset, 1:ndim), -offset ) + end do + +!----------------------------------------------------------------------- +! *** The LAPACK Routine *** +! SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, +! $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, +! $ RCOND, FERR, BERR, WORK, IWORK, INFO ) +!----------------------------------------------------------------------- + + if ( kind( lhs(1,1) ) == dp ) then + call dgbsvx( 'Equilibrate lhs', 'No Transpose lhs', & + ndim, nsub, nsup, nrhs, & + lhs, nsup+nsub+1, lulhs, 2*nsub+nsup+1, & + ipivot, equed, rscale, cscale, & + rhs, ndim, solution, ndim, & + rcond, ferr, berr, work, iwork, info ) + + else if ( kind( lhs(1,1) ) == sp ) then + call sgbsvx( 'Equilibrate lhs', 'No Transpose lhs', & + ndim, nsub, nsup, nrhs, & + lhs, nsup+nsub+1, lulhs, 2*nsub+nsup+1, & + ipivot, equed, rscale, cscale, & + rhs, ndim, solution, ndim, & + rcond, ferr, berr, work, iwork, info ) + + else + stop "band_solvex: Cannot resolve the precision of real datatype" + ! One implication of this is that CLUBB cannot be used with quad + ! precision variables without a quad precision band diagonal solver + end if + +! %% debug +! select case ( equed ) +! case ('N') +! print *, "No equilib. was required for lhs." +! case ('R') +! print *, "Row equilib. was done on lhs." +! case ('C') +! print *, "Column equilib. was done on lhs." +! case ('B') +! print *, "Row and column equilib. was done on lhs." +! end select + +! write(*,'(a,e12.5)') "Row scale : ", rscale +! write(*,'(a,e12.5)') "Column scale: ", cscale +! write(*,'(a,e12.5)') "Estimate of the reciprocal of the "// +! "condition number: ", rcond +! write(*,'(a,e12.5)') "Forward Error Estimate: ", ferr +! write(*,'(a,e12.5)') "Backward Error Estimate: ", berr +! %% end debug + + ! Diagnostic information + if ( clubb_at_least_debug_level( 2 ) .and. any( ferr > 1.e-3_core_rknd ) ) then + + write(fstderr,*) "Warning, large error est. for: " // trim( solve_type ) + + do i = 1, nrhs, 1 + write(fstderr,*) "rhs # ", i, "band_solvex forward error est. =", ferr(i) + write(fstderr,*) "rhs # ", i, "band_solvex backward error est. =", berr(i) + end do + + write(fstderr,'(2(a20,e15.6))') "rcond est. = ", rcond, & + "machine epsilon = ", epsilon( lhs(1,1) ) + end if + + select case( info ) + + case( :-1 ) + write(fstderr,*) trim( solve_type )// & + " illegal value for argument", -info + err_code = clubb_bad_lapack_arg + + case( 0 ) + ! Success! + if ( lapack_isnan( ndim, nrhs, solution ) ) then + err_code = clubb_var_equals_NaN + else + err_code = clubb_no_error + end if + + case( 1: ) + if ( info == ndim+1 ) then + write(fstderr,*) trim( solve_type )// & + " Warning: matrix singular to working precision." + write(fstderr,'(a,e12.5)') & + "Estimate of the reciprocal of the"// & + " condition number: ", rcond + err_code = clubb_no_error + else + write(fstderr,*) trim( solve_type )// & + " band solver: singular matrix" + err_code = clubb_singular_matrix + end if + + end select + + return + end subroutine band_solvex + +!----------------------------------------------------------------------- + subroutine band_solve( solve_type, nsup, nsub, ndim, nrhs, & + lhs, rhs, solution, err_code ) +! Description: +! Restructure and then solve a band diagonal system + +! References: +! +! +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + external :: & + sgbsv, & ! Single-prec. General Band Solver + dgbsv ! Double-prec. General Band Solver + + intrinsic :: eoshift, kind, trim + + ! Input Variables + character(len=*), intent(in) :: solve_type + + integer, intent(in) :: & + nsup, & ! Number of superdiagonals + nsub, & ! Number of subdiagonals + ndim, & ! The order of the LHS Matrix, i.e. the # of linear equations + nrhs ! Number of RHS's to solve for + + ! Note: matrix lhs is intent(in), not intent(inout) + ! as in the subroutine band_solvex( ) + real( kind = core_rknd ), dimension(nsup+nsub+1,ndim), intent(in) :: & + lhs ! Left hand side + real( kind = core_rknd ), dimension(ndim,nrhs), intent(inout) :: & + rhs ! Right hand side(s) + + ! Output Variables + real( kind = core_rknd ), dimension(ndim,nrhs), intent(out) :: solution + + integer, intent(out) :: err_code ! Valid calculation? + + ! Local Variables + + ! Workspaces + real( kind = core_rknd ), dimension(2*nsub+nsup+1,ndim) :: & + lulhs ! LU Decomposition of the LHS + + real( kind = dp ), dimension(2*nsub+nsup+1,ndim) :: & + lulhs_dp + + real( kind = dp ), dimension(ndim,nrhs) :: & + rhs_dp + + integer, dimension(ndim) :: & + ipivot + + integer :: & + info, & ! If this doesn't come back as 0, something went wrong + offset, & ! Loop iterator + imain ! Main diagonal of the matrix + + ! Copy LHS into Decomposition scratch space + lulhs = 0.0_core_rknd + lulhs(nsub+1:2*nsub+nsup+1, 1:ndim) = lhs(1:nsub+nsup+1, 1:ndim) + +!----------------------------------------------------------------------- +! Reorder LU Matrix to use LAPACK band matrix format + +! Shift example for lulhs matrix (note the extra bands): + +! [ + + + + + + ] +! [ + + + + + + ] +! [ * * lhs(1,1) lhs(1,2) lhs(1,3) lhs(1,4) ] (2)=> +! [ * lhs(2,1) lhs(2,2) lhs(2,3) lhs(2,4) lhs(2,5) ] (1)=> +! [ lhs(3,1) lhs(3,2) lhs(3,3) lhs(3,4) lhs(3,5) lhs(3,6) ] +! <=(1) [ lhs(4,2) lhs(4,3) lhs(4,4) lhs(4,5) lhs(4,6) * ] +! <=(2) [ lhs(5,3) lhs(5,4) lhs(5,5) lhs(5,6) * * ] +! [ + + + + + + ] +! [ + + + + + + ] + +! The '*' indicates unreferenced elements. +! The '+' indicates an element overwritten during decomposition. +! For additional bands above and below the main diagonal, the +! shifts to the left or right increases by the distance from the +! main diagonal of the matrix. +!----------------------------------------------------------------------- + + ! Reorder lulhs, omitting the additional 2*nsub bands + ! that are used for the LU decomposition of the matrix. + + imain = nsub + nsup + 1 + + ! For the offset, (+) is left, and (-) is right + + ! Sub diagonals + do offset = 1, nsub, 1 + lulhs(imain+offset, 1:ndim) & + = eoshift( lulhs(imain+offset, 1:ndim), offset ) + end do + + ! Super diagonals + do offset = 1, nsup, 1 + lulhs(imain-offset, 1:ndim) & + = eoshift( lulhs(imain-offset, 1:ndim), -offset ) + end do + +!----------------------------------------------------------------------- +! *** LAPACK routine *** +! SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) +!----------------------------------------------------------------------- + + if ( kind( lhs(1,1) ) == dp ) then + call dgbsv( ndim, nsub, nsup, nrhs, lulhs, nsub*2+nsup+1, & + ipivot, rhs, ndim, info ) + + else if ( kind( lhs(1,1) ) == sp ) then + call sgbsv( ndim, nsub, nsup, nrhs, lulhs, nsub*2+nsup+1, & + ipivot, rhs, ndim, info ) + + else + !stop "band_solve: Cannot resolve the precision of real datatype" + ! One implication of this is that CLUBB cannot be used with quad + ! precision variables without a quad precision band diagonal solver + ! Eric Raut Aug 2013: force double precision + lulhs_dp = real( lulhs, kind=dp ) + rhs_dp = real( rhs, kind=dp ) + call dgbsv( ndim, nsub, nsup, nrhs, lulhs_dp, nsub*2+nsup+1, & + ipivot, rhs_dp, ndim, info ) + rhs = real( rhs_dp, kind=core_rknd ) + end if + + select case( info ) + + case( :-1 ) + write(fstderr,*) trim( solve_type )// & + " illegal value for argument ", -info + err_code = clubb_bad_lapack_arg + + solution = -999._core_rknd + + case( 0 ) + ! Success! + if ( lapack_isnan( ndim, nrhs, rhs ) ) then + err_code = clubb_var_equals_NaN + else + err_code = clubb_no_error + end if + + solution = rhs + + case( 1: ) + write(fstderr,*) trim( solve_type )//" band solver: singular matrix" + err_code = clubb_singular_matrix + + solution = -999._core_rknd + + end select + + return + end subroutine band_solve + +!----------------------------------------------------------------------- + logical function lapack_isnan( ndim, nrhs, variable ) + +! Description: +! Check for NaN values in a variable using the LAPACK subroutines + +! References: +! +! +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none +#ifdef NO_LAPACK_ISNAN /* Used for older LAPACK libraries that don't have sisnan/disnan */ + + intrinsic :: any + + integer, intent(in) :: & + ndim, & ! Size of variable + nrhs ! Number of right hand sides + + real( kind = core_rknd ), dimension(ndim,nrhs), intent(in) :: & + variable ! Variable to check + + lapack_isnan = any( variable(:,1:nrhs) /= variable(:,1:nrhs) ) +#else + logical, external :: sisnan, disnan + + integer, intent(in) :: & + ndim, & ! Size of variable + nrhs ! Number of right hand sides + + real( kind = core_rknd ), dimension(ndim,nrhs), intent(in) :: & + variable ! Variable to check + + integer :: k, j + + ! ---- Begin Code ---- + + lapack_isnan = .false. + + if ( kind( variable ) == dp ) then + do k = 1, ndim + do j = 1, nrhs + lapack_isnan = disnan( variable(k,j) ) + if ( lapack_isnan ) exit + end do + if ( lapack_isnan ) exit + end do + else if ( kind( variable ) == sp ) then + do k = 1, ndim + do j = 1, nrhs + lapack_isnan = sisnan( variable(k,j) ) + if ( lapack_isnan ) exit + end do + if ( lapack_isnan ) exit + end do + else + stop "lapack_isnan: Cannot resolve the precision of real datatype" + end if +#endif /* NO_LAPACK_ISNAN */ + + return + end function lapack_isnan + +end module lapack_wrap diff --git a/src/physics/clubb/matrix_operations.F90 b/src/physics/clubb/matrix_operations.F90 new file mode 100644 index 0000000000..2e726d0204 --- /dev/null +++ b/src/physics/clubb/matrix_operations.F90 @@ -0,0 +1,584 @@ +!----------------------------------------------------------------------- +! $Id: matrix_operations.F90 7016 2014-07-07 16:48:40Z betlej@uwm.edu $ +!=============================================================================== +module matrix_operations + + implicit none + + + public :: symm_covar_matrix_2_corr_matrix, Cholesky_factor, & + row_mult_lower_tri_matrix, print_lower_triangular_matrix, & + get_lower_triangular_matrix, set_lower_triangular_matrix, & + mirror_lower_triangular_matrix + + private :: Symm_matrix_eigenvalues + + private ! Default scope + + contains + +!----------------------------------------------------------------------- + subroutine symm_covar_matrix_2_corr_matrix( ndim, covar, corr ) + +! Description: +! Convert a matrix of covariances in to a matrix of correlations. +! This only does the computation the lower triangular portion of the +! matrix. +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! double precision + + implicit none + + ! External + intrinsic :: sqrt + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & + covar ! Covariance Matrix [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(ndim,ndim), intent(out) :: & + corr ! Correlation Matrix [-] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + corr = 0._core_rknd ! Initialize to 0 + + do i = 1, ndim + do j = 1, i + corr(i,j) = covar(i,j) / sqrt( covar(i,i) * covar(j,j) ) + end do + end do + + return + end subroutine symm_covar_matrix_2_corr_matrix +!----------------------------------------------------------------------- + subroutine row_mult_lower_tri_matrix( ndim, xvector, tmatrix_in, tmatrix_out ) + +! Description: +! Do a row-wise multiply of the elements of a lower triangular matrix. +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! double precision + + implicit none + + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = core_rknd ), dimension(ndim), intent(in) :: & + xvector ! Factors to be multiplied across a row [units vary] + + ! Input Variables + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & + tmatrix_in ! nxn matrix (usually a correlation matrix) [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(ndim,ndim), intent(inout) :: & + tmatrix_out ! nxn matrix (usually a covariance matrix) [units vary] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + do i = 1, ndim + do j = 1, i + tmatrix_out(i,j) = tmatrix_in(i,j) * xvector(i) + end do + end do + + return + end subroutine row_mult_lower_tri_matrix + +!------------------------------------------------------------------------------- + subroutine Cholesky_factor( ndim, a_input, a_scaling, a_Cholesky, l_scaled ) +! Description: +! Create a Cholesky factorization of a_input. +! If the factorization fails we use a modified a_input matrix and attempt +! to factorize again. +! +! References: +! dpotrf +! dpoequ +! dlaqsy +!------------------------------------------------------------------------------- + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + use constants_clubb, only: & + fstderr ! Constant + + use clubb_precision, only: & + core_rknd + + implicit none + + ! External + external :: dpotrf, dpoequ, dlaqsy, & ! LAPACK subroutines + spotrf, spoequ, slaqsy + + ! Constant Parameters + integer, parameter :: itermax = 10 ! Max iterations of the modified method + + real( kind = core_rknd), parameter :: d_coef = 0.1_core_rknd + ! Coefficient applied if the decomposition doesn't work + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: a_input + + ! Output Variables + real( kind = core_rknd ), dimension(ndim), intent(out) :: a_scaling + + real( kind = core_rknd ), dimension(ndim,ndim), intent(out) :: a_Cholesky + + logical, intent(out) :: l_scaled + + ! Local Variables + real( kind = core_rknd ), dimension(ndim) :: a_eigenvalues + real( kind = core_rknd ), dimension(ndim,ndim) :: a_corr, a_scaled + + real( kind = core_rknd ) :: tau, d_smallest + + real( kind = core_rknd ) :: amax, scond + integer :: info + integer :: i, j, iter + + character :: equed + + logical :: l_dp + + ! ---- Begin code ---- + + a_scaled = a_input ! Copy input array into output array + +! do i = 1, n +! do j = 1, n +! write(6,'(e10.3)',advance='no') a(i,j) +! end do +! write(6,*) "" +! end do +! pause + + equed = 'N' + + if ( kind( 0.0_core_rknd ) == kind( 0.0d0 ) ) then + l_dp = .true. + else if ( kind( 0.0_core_rknd ) == kind( 0.0 ) ) then + l_dp = .false. + else + stop "Precision is not single or double precision in Cholesky_factor" + end if + + ! Compute scaling for a_input + if ( l_dp ) then + call dpoequ( ndim, a_input, ndim, a_scaling, scond, amax, info ) + else + call spoequ( ndim, a_input, ndim, a_scaling, scond, amax, info ) + end if + + if ( info == 0 ) then + ! Apply scaling to a_input + if ( l_dp ) then + call dlaqsy( 'Lower', ndim, a_scaled, ndim, a_scaling, scond, amax, equed ) + else + call slaqsy( 'Lower', ndim, a_scaled, ndim, a_scaling, scond, amax, equed ) + end if + end if + + ! Determine if scaling was necessary + if ( equed == 'Y' ) then + l_scaled = .true. + a_Cholesky = a_scaled + else + l_scaled = .false. + a_Cholesky = a_input + end if + + do iter = 1, itermax + + if ( l_dp ) then + call dpotrf( 'Lower', ndim, a_Cholesky, ndim, info ) + else + call spotrf( 'Lower', ndim, a_Cholesky, ndim, info ) + end if + + select case( info ) + case( :-1 ) + write(fstderr,*) "Cholesky_factor " // & + " illegal value for argument ", -info + stop + case( 0 ) + ! Success! + if ( clubb_at_least_debug_level( 1 ) .and. iter > 1 ) then + write(fstderr,*) "a_factored (worked)=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) + end do + write(fstderr,*) "" + end do + end if + exit + case( 1: ) + if ( clubb_at_least_debug_level( 1 ) ) then + ! This shouldn't happen now that the s and t Mellor(chi/eta) elements have been + ! modified to never be perfectly correlated, but it's here just in case. + ! -dschanen 10 Sept 2010 + write(fstderr,*) "Cholesky_factor: leading minor of order ", & + info, " is not positive definite." + write(fstderr,*) "factorization failed." + write(fstderr,*) "a_input=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_input(i,j) + end do + write(fstderr,*) "" + end do + write(fstderr,*) "a_Cholesky=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_Cholesky(i,j) + end do + write(fstderr,*) "" + end do + end if + + if ( clubb_at_least_debug_level( 2 ) ) then + call Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) + write(fstderr,*) "a_eigenvalues=" + do i = 1, ndim + write(fstderr,'(g10.3)',advance='no') a_eigenvalues(i) + end do + write(fstderr,*) "" + + call symm_covar_matrix_2_corr_matrix( ndim, a_input, a_corr ) + write(fstderr,*) "a_correlations=" + do i = 1, ndim + do j = 1, i + write(fstderr,'(g10.3)',advance='no') a_corr(i,j) + end do + write(fstderr,*) "" + end do + end if + + if ( iter == itermax ) then + write(fstderr,*) "iteration =", iter, "itermax =", itermax + stop "Fatal error in Cholesky_factor" + else if ( clubb_at_least_debug_level( 1 ) ) then + ! Adding a STOP statement to prevent this problem from slipping under + ! the rug. + stop "Fatal error in Cholesky_factor" + write(fstderr,*) "Attempting to modify matrix to allow factorization." + end if + + if ( l_scaled ) then + a_Cholesky = a_scaled + else + a_Cholesky = a_input + end if + ! The number used for tau here is case specific to the Sigma covariance + ! matrix in the latin hypercube code and is not at all general. + ! Tau should be a number that is small relative to the other diagonal + ! elements of the matrix to have keep the error caused by modifying 'a' low. + ! -dschanen 30 Aug 2010 + d_smallest = a_Cholesky(1,1) + do i = 2, ndim + if ( d_smallest > a_Cholesky(i,i) ) d_smallest = a_Cholesky(i,i) + end do + ! Use the smallest element * d_coef * iteration + tau = d_smallest * d_coef * real( iter, kind=core_rknd ) + +! print *, "tau =", tau, "d_smallest = ", d_smallest + + do i = 1, ndim + do j = 1, ndim + if ( i == j ) then + a_Cholesky(i,j) = a_Cholesky(i,j) + tau ! Add tau to the diagonal + else + a_Cholesky(i,j) = a_Cholesky(i,j) + end if + end do + end do + + if ( clubb_at_least_debug_level( 2 ) ) then + call Symm_matrix_eigenvalues( ndim, a_Cholesky, a_eigenvalues ) + write(fstderr,*) "a_modified eigenvalues=" + do i = 1, ndim + write(fstderr,'(e10.3)',advance='no') a_eigenvalues(i) + end do + write(fstderr,*) "" + end if + + end select ! info + end do ! 1..itermax + + return + end subroutine Cholesky_factor + +!---------------------------------------------------------------------- + subroutine Symm_matrix_eigenvalues( ndim, a_input, a_eigenvalues ) + +! Description: +! Computes the eigevalues of a_input +! +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant + + use clubb_precision, only: & + core_rknd ! double precision + + implicit none + + ! External + external :: dsyev, ssyev ! LAPACK subroutine(s) + + ! Parameters + integer, parameter :: & + lwork = 180 ! This is the optimal value I obtained for an n of 5 -dschanen 31 Aug 2010 + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: a_input + + ! Output Variables + real( kind = core_rknd ), dimension(ndim), intent(out) :: a_eigenvalues + + ! Local Variables + real( kind = core_rknd ), dimension(ndim,ndim) :: a_scratch + + real( kind = core_rknd ), dimension(lwork) :: work + + integer :: info +! integer :: i, j + ! ---- Begin code ---- + + a_scratch = a_input + +! do i = 1, ndim +! do j = 1, ndim +! write(6,'(e10.3)',advance='no') a(i,j) +! end do +! write(6,*) "" +! end do +! pause + + if ( kind( 0.0_core_rknd ) == kind( 0.0d0 ) ) then + call dsyev( 'No eigenvectors', 'Lower', ndim, a_scratch, ndim, & + a_eigenvalues, work, lwork, info ) + else if ( kind( 0.0_core_rknd ) == kind( 0.0 ) ) then + call ssyev( 'No eigenvectors', 'Lower', ndim, a_scratch, ndim, & + a_eigenvalues, work, lwork, info ) + else + stop "Precision is not single or double in Symm_matrix_eigenvalues" + end if + + select case( info ) + case( :-1 ) + write(fstderr,*) "Symm_matrix_eigenvalues:" // & + " illegal value for argument ", -info + stop + case( 0 ) + ! Success! + + case( 1: ) + write(fstderr,*) "Symm_matrix_eigenvalues: Algorithm failed to converge." + stop + end select + + return + end subroutine Symm_matrix_eigenvalues +!------------------------------------------------------------------------------- + subroutine set_lower_triangular_matrix( d_variables, index1, index2, xpyp, & + matrix ) +! Description: +! Set a value for the lower triangular portion of a matrix. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! user defined precision + + implicit none + + ! External + intrinsic :: max, min + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variates + index1, index2 ! Indices for 2 variates (the order doesn't matter) + + real( kind = core_rknd ), intent(in) :: & + xpyp ! Value for the matrix (usually a correlation or covariance) [units vary] + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(inout) :: & + matrix ! The lower triangular matrix + + integer :: i,j + + ! ---- Begin Code ---- + + ! Reverse these to set the values of upper triangular matrix + i = max( index1, index2 ) + j = min( index1, index2 ) + + if( i > 0 .and. j > 0 ) then + matrix(i,j) = xpyp + end if + + return + end subroutine set_lower_triangular_matrix +!------------------------------------------------------------------------------- + +!------------------------------------------------------------------------------- + subroutine get_lower_triangular_matrix( d_variables, index1, index2, matrix, & + xpyp ) +! Description: +! Returns a value from the lower triangular portion of a matrix. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + ! External + intrinsic :: max, min + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variates + index1, index2 ! Indices for 2 variates (the order doesn't matter) + + ! Input/Output Variables + real( kind = core_rknd ), dimension(d_variables,d_variables), intent(in) :: & + matrix ! The covariance matrix + + real( kind = core_rknd ), intent(out) :: & + xpyp ! Value from the matrix (usually a correlation or covariance) [units vary] + + integer :: i,j + + ! ---- Begin Code ---- + + ! Reverse these to set the values of upper triangular matrix + i = max( index1, index2 ) + j = min( index1, index2 ) + + xpyp = matrix(i,j) + + return + end subroutine get_lower_triangular_matrix + +!----------------------------------------------------------------------- + subroutine print_lower_triangular_matrix( iunit, ndim, matrix ) + +! Description: +! Print the values of lower triangular matrix to a file or console. + +! References: +! None +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + iunit, & ! File I/O logical unit (usually 6 for stdout and 0 for stderr) + ndim ! Dimension of the matrix + + real( kind = core_rknd ), dimension(ndim,ndim), intent(in) :: & + matrix ! Lower triangular matrix [units vary] + + ! Local Variables + integer :: i, j + + ! ---- Begin Code ---- + + do i = 1, ndim + do j = 1, i + write(iunit,fmt='(g15.6)',advance='no') matrix(i,j) + end do + write(iunit,fmt=*) "" ! newline + end do + + return + end subroutine print_lower_triangular_matrix + + !----------------------------------------------------------------------- + subroutine mirror_lower_triangular_matrix( nvars, matrix ) + + ! Description: + ! Mirrors the elements of a lower triangular matrix to the upper + ! triangle so that it is symmetric. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + integer, intent(in) :: & + nvars ! Number of variables in each dimension of square matrix + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nvars,nvars), intent(inout) :: & + matrix ! Lower triangluar square matrix + + ! Local Variables + integer :: row, col + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + if ( nvars > 1 ) then + + do col=2, nvars + do row=1, col-1 + + matrix(row,col) = matrix(col,row) + + end do + end do + + end if ! nvars > 1 + + return + + end subroutine mirror_lower_triangular_matrix + !----------------------------------------------------------------------- + +end module matrix_operations diff --git a/src/physics/clubb/mean_adv.F90 b/src/physics/clubb/mean_adv.F90 new file mode 100644 index 0000000000..d301c39c90 --- /dev/null +++ b/src/physics/clubb/mean_adv.F90 @@ -0,0 +1,559 @@ +!----------------------------------------------------------------------- +! $Id: mean_adv.F90 6805 2014-03-23 04:28:36Z bmg2@uwm.edu $ +!=============================================================================== +module mean_adv + + ! Description: + ! Module mean_adv computes the mean advection terms for all of the + ! time-tendency (prognostic) equations in the CLUBB parameterization. All of + ! the mean advection terms are solved for completely implicitly, and therefore + ! become part of the left-hand side of their respective equations. + ! + ! Function term_ma_zt_lhs handles the mean advection terms for the variables + ! located at thermodynamic grid levels. These variables are: rtm, thlm, wp3, + ! all hydrometeor species, and sclrm. + ! + ! Function term_ma_zm_lhs handles the mean advection terms for the variables + ! located at momentum grid levels. The variables are: wprtp, wpthlp, wp2, + ! rtp2, thlp2, rtpthlp, up2, vp2, wpsclrp, sclrprtp, sclrpthlp, and sclrp2. + + implicit none + + private ! Default scope + + public :: term_ma_zt_lhs, & + term_ma_zm_lhs + + contains + + !============================================================================= + pure function term_ma_zt_lhs( wm_zt, invrs_dzt, level, & + invrs_dzm_k, invrs_dzm_km1 ) & + result( lhs ) + + ! Description: + ! Mean advection of var_zt: implicit portion of the code. + ! + ! The variable "var_zt" stands for a variable that is located at + ! thermodynamic grid levels. + ! + ! The d(var_zt)/dt equation contains a mean advection term: + ! + ! - w * d(var_zt)/dz. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - w * d( var_zt(t+1) )/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed to + ! a "+". + ! + ! The timestep index (t+1) means that the value of var_zt being used is from + ! the next timestep, which is being advanced to in solving the d(var_zt)/dt + ! equation. + ! + ! This term is discretized as follows: + ! + ! The values of var_zt are found on the thermodynamic levels, as are the + ! values of wm_zt (mean vertical velocity on thermodynamic levels). The + ! variable var_zt is interpolated to the intermediate momentum levels. The + ! derivative of the interpolated values is taken over the central + ! thermodynamic level. The derivative is multiplied by wm_zt at the central + ! thermodynamic level to get the desired result. + ! + ! -----var_zt(kp1)----------------------------------------- t(k+1) + ! + ! =================var_zt(interp)========================== m(k) + ! + ! -----var_zt(k)------------------d(var_zt)/dz-----wm_zt--- t(k) + ! + ! =================var_zt(interp)========================== m(k-1) + ! + ! -----var_zt(km1)----------------------------------------- t(k-1) + ! + ! The vertical indices t(k+1), m(k), t(k), m(k-1), and t(k-1) correspond + ! with altitudes zt(k+1), zm(k), zt(k), zm(k-1), and zt(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ) + ! + ! + ! Special discretization for upper boundary level: + ! + ! Method 1: Constant derivative method (or "one-sided" method). + ! + ! The values of var_zt are found on the thermodynamic levels, as are the + ! values of wm_zt (mean vertical velocity on the thermodynamic levels). The + ! variable var_zt is interpolated to momentum level gr%nz-1, based on + ! the values of var_zt at thermodynamic levels gr%nz and gr%nz-1. + ! However, the variable var_zt cannot be interpolated to momentum level + ! gr%nz. Rather, a linear extension is used to find the value of var_zt + ! at momentum level gr%nz, based on the values of var_zt at thermodynamic + ! levels gr%nz and gr%nz-1. The derivative of the extended and + ! interpolated values, d(var_zt)/dz, is taken over the central thermodynamic + ! level. Of course, this derivative will be the same as the derivative of + ! var_zt between thermodynamic levels gr%nz and gr%nz-1. The derivative + ! is multiplied by wm_zt at the central thermodynamic level to get the + ! desired result. + ! + ! For the following diagram, k = gr%nz, which is the uppermost level of + ! the model: + ! + ! =================var_zt(extend)========================== m(k) Boundary + ! + ! -----var_zt(k)------------------d(var_zt)/dz-----wm_zt--- t(k) + ! + ! =================var_zt(interp)========================== m(k-1) + ! + ! -----var_zt(km1)----------------------------------------- t(k-1) + ! + ! + ! Method 2: Zero derivative method: + ! the derivative d(var_zt)/dz over the model top is set to 0. + ! + ! This method corresponds with the "zero-flux" boundary condition option + ! for eddy diffusion, where d(var_zt)/dz is set to 0 across the upper + ! boundary. + ! + ! In order to discretize the upper boundary condition, consider a new level + ! outside the model (thermodynamic level gr%nz+1) just above the upper + ! boundary level (thermodynamic level gr%nz). The value of var_zt at the + ! level just outside the model is defined to be the same as the value of + ! var_zt at thermodynamic level gr%nz. Therefore, the value of + ! d(var_zt)/dz between the level just outside the model and the uppermost + ! thermodynamic level is 0, staying consistent with the zero-flux boundary + ! condition option for the eddy diffusion portion of the code. Therefore, + ! the value of var_zt at momentum level gr%nz, which is the upper boundary + ! of the model, would be the same as the value of var_zt at the uppermost + ! thermodynamic level. + ! + ! The values of var_zt are found on the thermodynamic levels, as are the + ! values of wm_zt (mean vertical velocity on the thermodynamic levels). The + ! variable var_zt is interpolated to momentum level gr%nz-1, based on + ! the values of var_zt at thermodynamic levels gr%nz and gr%nz-1. The + ! value of var_zt at momentum level gr%nz is set equal to the value of + ! var_zt at thermodynamic level gr%nz, as described above. The derivative + ! of the set and interpolated values, d(var_zt)/dz, is taken over the + ! central thermodynamic level. The derivative is multiplied by wm_zt at the + ! central thermodynamic level to get the desired result. + ! + ! For the following diagram, k = gr%nz, which is the uppermost level of + ! the model: + ! + ! --[var_zt(kp1) = var_zt(k)]----(level outside model)----- t(k+1) + ! + ! ==[var_zt(top) = var_zt(k)]===[d(var_zt)/dz|_(top) = 0]== m(k) Boundary + ! + ! -----var_zt(k)------------------d(var_zt)/dz-----wm_zt--- t(k) + ! + ! =================var_zt(interp)========================== m(k-1) + ! + ! -----var_zt(km1)----------------------------------------- t(k-1) + ! + ! where (top) stands for the grid index of momentum level k = gr%nz, which + ! is the upper boundary of the model. + ! + ! This method of boundary discretization is also similar to the method + ! currently employed at the lower boundary for most thermodynamic-level + ! variables. Since thermodynamic level k = 1 is below the model bottom, + ! mean advection is not applied. Thus, thermodynamic level k = 2 becomes + ! the lower boundary level. Now, the mean advection term at thermodynamic + ! level 2 takes into account var_zt from levels 1, 2, and 3. However, in + ! most cases, the value of var_zt(1) is set equal to var_zt(2) after the + ! matrix of equations has been solved. Therefore, the derivative, + ! d(var_zt)/dz, over the model bottom (momentum level k = 1) becomes 0. + ! Thus, the method of setting d(var_zt)/dz to 0 over the model top keeps + ! the way the upper and lower boundaries are handled consistent with each + ! other. + + ! References: + ! None + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use model_flags, only: & + l_upwind_xm_ma ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + integer, parameter :: & + t_above = 1, & ! Index for upper thermodynamic level grid weight. + t_below = 2 ! Index for lower thermodynamic level grid weight. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wm_zt, & ! wm_zt(k) [m/s] + invrs_dzt, & ! Inverse of grid spacing (k) [1/m] + invrs_dzm_k, & ! Inverse of grid spacing (k) [1/m] + invrs_dzm_km1 ! Inverse of grid spacing (k-1) [1/m] + + + integer, intent(in) :: & + level ! Central thermodynamic level (on which calculation occurs). + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + ! Local Variables + logical, parameter :: & + l_ub_const_deriv = .true. ! Flag to use the "one-sided" upper boundary. + + integer :: & + mk, & ! Momentum level directly above central thermodynamic level. + mkm1 ! Momentum level directly below central thermodynamic level. + + + ! Momentum level (k) is between thermodynamic level (k+1) + ! and thermodynamic level (k). + mk = level + + ! Momentum level (k-1) is between thermodynamic level (k) + ! and thermodynamic level (k-1). + mkm1 = level - 1 + + if ( level == 1 ) then + + ! k = 1 (bottom level); lower boundary level. + ! Thermodynamic level k = 1 is below the model bottom, so all effects + ! are shut off. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = zero + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero + + + elseif ( level > 1 .and. level < gr%nz ) then + + ! Most of the interior model; normal conditions. + + if( .not. l_upwind_xm_ma ) then ! Use centered differencing + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = + wm_zt * invrs_dzt * gr%weights_zt2zm(t_above,mk) + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & + - gr%weights_zt2zm(t_above,mkm1) ) + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) + + else ! l_upwind_xm_ma == .true.; use "upwind" differencing + + if ( wm_zt >= zero ) then ! Mean wind is in upward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzm_km1 + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzm_km1 + + + else ! wm_zt < 0; Mean wind is in downward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = + wm_zt * invrs_dzm_k + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = - wm_zt * invrs_dzm_k + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero + + endif ! wm_zt > 0 + + + endif ! l_upwind_xm_ma + + + elseif ( level == gr%nz ) then + + ! k = gr%nz (top level); upper boundary level. + + if( .not. l_upwind_xm_ma ) then ! Use "centered" differencing + + if ( l_ub_const_deriv ) then + + ! Special discretization for constant derivative method (or + ! "one-sided" derivative method). + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_above,mk) & + - gr%weights_zt2zm(t_above,mkm1) ) + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = + wm_zt * invrs_dzt * ( gr%weights_zt2zm(t_below,mk) & + - gr%weights_zt2zm(t_below,mkm1) ) + + else + + ! Special discretization for zero derivative method, where the + ! derivative d(var_zt)/dz over the model top is set to 0, in order + ! to stay consistent with the zero-flux boundary condition option + ! in the eddy diffusion code. + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzt * ( one - gr%weights_zt2zm(t_above,mkm1) ) + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzt * gr%weights_zt2zm(t_below,mkm1) + + endif ! l_ub_const_deriv + + + else ! l_upwind_xm_ma == .true.; use "upwind" differencing + + if ( wm_zt >= zero ) then ! Mean wind is in upward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = + wm_zt * invrs_dzm_km1 + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = - wm_zt * invrs_dzm_km1 + + + else ! wm_zt < 0; Mean wind is in downward direction + + ! Thermodynamic superdiagonal: [ x var_zt(k+1,) ] + lhs(kp1_tdiag) & + = zero + + ! Thermodynamic main diagonal: [ x var_zt(k,) ] + lhs(k_tdiag) & + = zero + + ! Thermodynamic subdiagonal: [ x var_zt(k-1,) ] + lhs(km1_tdiag) & + = zero + + endif ! wm_zt > 0 + + + endif ! l_upwind_xm_ma + + + endif ! level = gr%nz + + + return + + end function term_ma_zt_lhs + + !============================================================================= + pure function term_ma_zm_lhs( wm_zm, invrs_dzm, level ) & + result( lhs ) + + ! Description: + ! Mean advection of var_zm: implicit portion of the code. + ! + ! The variable "var_zm" stands for a variable that is located at momentum + ! grid levels. + ! + ! The d(var_zm)/dt equation contains a mean advection term: + ! + ! - w * d(var_zm)/dz. + ! + ! This term is solved for completely implicitly, such that: + ! + ! - w * d( var_zm(t+1) )/dz. + ! + ! Note: When the term is brought over to the left-hand side, the sign + ! is reversed and the leading "-" in front of the term is changed to + ! a "+". + ! + ! The timestep index (t+1) means that the value of var_zm being used is from + ! the next timestep, which is being advanced to in solving the d(var_zm)/dt + ! equation. + ! + ! This term is discretized as follows: + ! + ! The values of var_zm are found on the momentum levels, as are the values + ! of wm_zm (mean vertical velocity on momentum levels). The variable var_zm + ! is interpolated to the intermediate thermodynamic levels. The derivative + ! of the interpolated values is taken over the central momentum level. The + ! derivative is multiplied by wm_zm at the central momentum level to get the + ! desired result. + ! + ! =====var_zm(kp1)========================================= m(k+1) + ! + ! -----------------var_zm(interp)-------------------------- t(k+1) + ! + ! =====var_zm(k)==================d(var_zm)/dz=====wm_zm=== m(k) + ! + ! -----------------var_zm(interp)-------------------------- t(k) + ! + ! =====var_zm(km1)========================================= m(k-1) + ! + ! The vertical indices m(k+1), t(k+1), m(k), t(k), and m(k-1) correspond + ! with altitudes zm(k+1), zt(k+1), zm(k), zt(k), and zm(k-1), respectively. + ! The letter "t" is used for thermodynamic levels and the letter "m" is used + ! for momentum levels. + ! + ! invrs_dzm(k) = 1 / ( zt(k+1) - zt(k) ) + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use constants_clubb, only: & + zero ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_mdiag = 1, & ! Momentum superdiagonal index. + k_mdiag = 2, & ! Momentum main diagonal index. + km1_mdiag = 3 ! Momentum subdiagonal index. + + integer, parameter :: & + m_above = 1, & ! Index for upper momentum level grid weight. + m_below = 2 ! Index for lower momentum level grid weight. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wm_zm, & ! wm_zm(k) [m/s] + invrs_dzm ! Inverse of grid spacing (k) [1/m] + + integer, intent(in) :: & + level ! Central momentum level (on which calculation occurs). + + ! Return Variable + real( kind = core_rknd ), dimension(3) :: lhs + + ! Local Variables + integer :: & + tkp1, & ! Thermodynamic level directly above central momentum level. + tk ! Thermodynamic level directly below central momentum level. + + + ! Thermodynamic level (k+1) is between momentum level (k+1) + ! and momentum level (k). + tkp1 = level + 1 + + ! Thermodynamic level (k) is between momentum level (k) + ! and momentum level (k-1). + tk = level + + if ( level == 1 ) then + + ! k = 1; lower boundery level at surface. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = zero + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = zero + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = zero + + + elseif ( level > 1 .and. level < gr%nz ) then + + ! Most of the interior model; normal conditions. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = + wm_zm * invrs_dzm * gr%weights_zm2zt(m_above,tkp1) + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = + wm_zm * invrs_dzm * ( gr%weights_zm2zt(m_below,tkp1) & + - gr%weights_zm2zt(m_above,tk) ) + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = - wm_zm * invrs_dzm * gr%weights_zm2zt(m_below,tk) + + + elseif ( level == gr%nz ) then + + ! k = gr%nz (top level); upper boundary level. + + ! Momentum superdiagonal: [ x var_zm(k+1,) ] + lhs(kp1_mdiag) & + = zero + + ! Momentum main diagonal: [ x var_zm(k,) ] + lhs(k_mdiag) & + = zero + + ! Momentum subdiagonal: [ x var_zm(k-1,) ] + lhs(km1_mdiag) & + = zero + + + endif + + + return + + end function term_ma_zm_lhs + +!=============================================================================== + +end module mean_adv diff --git a/src/physics/clubb/mixing_length.F90 b/src/physics/clubb/mixing_length.F90 new file mode 100644 index 0000000000..74f8d5aa2b --- /dev/null +++ b/src/physics/clubb/mixing_length.F90 @@ -0,0 +1,818 @@ +!----------------------------------------------------------------------- +! $Id: mixing_length.F90 7226 2014-08-19 15:52:41Z betlej@uwm.edu $ +!=============================================================================== +module mixing_length + + implicit none + + private ! Default Scope + + public :: compute_length + + contains + + !============================================================================= + subroutine compute_length( thvm, thlm, rtm, em, Lscale_max, & + p_in_Pa, exner, thv_ds, mu, l_implemented, & + err_code, & + Lscale, Lscale_up, Lscale_down ) + ! Description: + ! Larson's 5th moist, nonlocal length scale + + ! References: + ! Section 3b ( /Eddy length formulation/ ) of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + + !----------------------------------------------------------------------- + + ! mu = (1/M) dM/dz > 0. mu=0 for no entrainment. + ! Siebesma recommends mu=2e-3, although most schemes use mu=1e-4 + ! When mu was fixed, we used the value mu = 6.e-4 + + use constants_clubb, only: & ! Variable(s) + Cp, & ! Dry air specific heat at constant pressure [J/kg/K] + Rd, & ! Dry air gas constant [J/kg/K] + ep, & ! Rd / Rv [-] + ep1, & ! (1-ep)/ep [-] + ep2, & ! 1/ep [-] + Lv, & ! Latent heat of vaporiztion [J/kg/K] + grav, & ! Gravitational acceleration [m/s^2] + fstderr, & + zero_threshold + + use parameters_tunable, only: & ! Variable(s) + lmin ! Minimum value for Lscale [m] + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt ! Procedure(s) + + use numerical_check, only: & + length_check ! Procedure(s) + + use saturation, only: & + sat_mixrat_liq, & ! Procedure(s) + sat_mixrat_liq_lookup + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + fatal_error + + use error_code, only: & + clubb_no_error ! Constant + + use model_flags, only: & + l_sat_mixrat_lookup ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: min, max, sqrt + + ! Constant Parameters + real( kind = core_rknd ), parameter :: & + zlmin = 0.1_core_rknd, & ! Minimum value for Lscale [m] + Lscale_sfclyr_depth = 500._core_rknd ! [m] + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + thvm, & ! Virtual potential temp. on themodynamic level [K] + thlm, & ! Liquid potential temp. on themodynamic level [K] + rtm, & ! Total water mixing ratio on themodynamic level [kg/kg] + em, & ! em = 3/2 * w'^2; on momentum level [m^2/s^2] + exner, & ! Exner function on thermodynamic level [-] + p_in_Pa, & ! Pressure on thermodynamic level [Pa] + thv_ds ! Dry, base-state theta_v on thermodynamic level [K] + ! Note: thv_ds used as a reference theta_l here + + real( kind = core_rknd ), intent(in) :: & + Lscale_max ! Maximum allowable value for Lscale [m] + + real( kind = core_rknd ), intent(in) :: & + mu ! mu Fractional extrainment rate per unit altitude [1/m] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model + + ! Output Variables + integer, intent(inout) :: & + err_code + + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + Lscale, & ! Mixing length [m] + Lscale_up, & ! Mixing length up [m] + Lscale_down ! Mixing length down [m] + + ! Local Variables + + integer :: i, j, & + err_code_Lscale + + real( kind = core_rknd ) :: tke_i, CAPE_incr + + real( kind = core_rknd ) :: dCAPE_dz_j, dCAPE_dz_j_minus_1, dCAPE_dz_j_plus_1 + + ! Temporary arrays to store calculations to speed runtime + real( kind = core_rknd ), dimension(gr%nz) :: exp_mu_dzm, invrs_dzm_on_mu + + ! Minimum value for Lscale that will taper off with height + real( kind = core_rknd ) :: lminh + + ! Parcel quantities at grid level j + real( kind = core_rknd ) :: thl_par_j, rt_par_j, rc_par_j, thv_par_j + + ! Used in latent heating calculation + real( kind = core_rknd ) :: tl_par_j, rsatl_par_j, beta_par_j, & + s_par_j + + ! Parcel quantities at grid level j-1 + real( kind = core_rknd ) :: thl_par_j_minus_1, rt_par_j_minus_1 + + ! Parcel quantities at grid level j+1 + real( kind = core_rknd ) :: thl_par_j_plus_1, rt_par_j_plus_1 + + ! Variables to make L nonlocal + real( kind = core_rknd ) :: Lscale_up_max_alt, Lscale_down_min_alt + + ! ---- Begin Code ---- + + err_code_Lscale = clubb_no_error + + !---------- Mixing length computation ---------------------------------- + + ! Avoid uninitialized memory (these values are not used in Lscale) + ! -dschanen 12 March 2008 + Lscale_up(1) = 0.0_core_rknd + Lscale_down(1) = 0.0_core_rknd + + ! Initialize exp_mu_dzm--sets each exp_mu_dzm value to its corresponding + ! exp(-mu/gr%invrs_dzm) value. In theory, this saves 11 computations of + ! exp(-mu/gr%invrs_dzm) used below. + ! ~~EIHoppe//20090615 + exp_mu_dzm(:) = exp( -mu/gr%invrs_dzm(:) ) + + ! Initialize invrs_dzm_on_mu -- sets each invrs_dzm_on_mu value to its + ! corresponding (gr%invrs_dzm/mu) value. This will save computations of + ! this value below. + ! ~EIHoppe//20100728 + invrs_dzm_on_mu(:) = (gr%invrs_dzm(:))/mu + + !!!!! Compute Lscale_up for every vertical level. + + ! Upwards loop + + Lscale_up_max_alt = 0._core_rknd + do i = 2, gr%nz, 1 + + tke_i = zm2zt( em, i ) ! TKE interpolated to thermodynamic level + + Lscale_up(i) = zlmin + j = i + 1 + + thl_par_j_minus_1 = thlm(i) + rt_par_j_minus_1 = rtm(i) + dCAPE_dz_j_minus_1 = 0.0_core_rknd + + do while ((tke_i > 0._core_rknd) .and. (j < gr%nz)) + + ! thl, rt of parcel are conserved except for entrainment + + ! theta_l of the parcel at grid level j. + ! + ! The equation for the rate of change of theta_l of the parcel with + ! respect to height, due to entrainment, is: + ! + ! d(thl_par)/dz = - mu * ( thl_par - thl_env ); + ! + ! where thl_par is theta_l of the parcel, thl_env is theta_l of the + ! ambient (or environmental) air, and mu is the entrainment rate, + ! such that: + ! + ! mu = (1/m)*(dm/dz); + ! + ! where m is the mass of the parcel. The value of mu is set to be a + ! constant. + ! + ! The differential equation is solved for thl_par_j (thl_par at + ! height gr%zt(j)) given the boundary condition thl_par_j_minus_1 + ! (thl_par at height gr%zt(j-1)), and given the fact that the value + ! of thl_env is treated as changing linearly for a parcel of air + ! ascending from level j-1 (where thl_env has the value thlm(j-1)) to + ! level j (where thl_env has the value thlm(j)). + ! + ! For the special case where entrainment rate, mu, is set to 0, + ! thl_par remains constant as the parcel ascends. + + if ( mu /= 0.0_core_rknd ) then + + ! The ascending parcel is entraining at rate mu. + + ! Calculation changed to use pre-calculated exp(-mu/gr%invrs_dzm) + ! values. ~~EIHoppe//20090615 + + ! Calculation changed to use pre-calculated mu/gr%invrs_dzm values. + ! ~EIHoppe//20100728 + + thl_par_j = thlm(j) - thlm(j-1)*exp_mu_dzm(j-1) & + - ( 1.0_core_rknd - exp_mu_dzm(j-1)) & + * ( (thlm(j) - thlm(j-1)) & + * invrs_dzm_on_mu(j-1) ) & +! / (mu/gr%invrs_dzm(j-1)) ) & + + thl_par_j_minus_1 * exp_mu_dzm(j-1) + + else + + ! The ascending parcel is not entraining. + + thl_par_j = thl_par_j_minus_1 + + endif + + ! r_t of the parcel at grid level j. + ! + ! The equation for the rate of change of r_t of the parcel with + ! respect to height, due to entrainment, is: + ! + ! d(rt_par)/dz = - mu * ( rt_par - rt_env ); + ! + ! where rt_par is r_t of the parcel, rt_env is r_t of the ambient (or + ! environmental) air, and mu is the entrainment rate, such that: + ! + ! mu = (1/m)*(dm/dz); + ! + ! where m is the mass of the parcel. The value of mu is set to be a + ! constant. + ! + ! The differential equation is solved for rt_par_j (rt_par at height + ! gr%zt(j)) given the boundary condition rt_par_j_minus_1 (rt_par at + ! height gr%zt(j-1)), and given the fact that the value of rt_env is + ! treated as changing linearly for a parcel of air ascending from + ! level j-1 (where rt_env has the value rtm(j-1)) to level j (where + ! rt_env has the value rtm(j)). + ! + ! For the special case where entrainment rate, mu, is set to 0, + ! rt_par remains constant as the parcel ascends. + + if ( mu /= 0.0_core_rknd ) then + + ! The ascending parcel is entraining at rate mu. + + ! Calculation changed to use pre-calculated exp(-mu/gr%invrs_dzm) + ! values. ~~EIHoppe//20090615 + + ! Calculation changed to use pre-calculated mu/gr%invrs_dzm values. + ! ~EIHoppe//20100728 + + rt_par_j = rtm(j) - rtm(j-1)*exp_mu_dzm(j-1) & + - ( 1.0_core_rknd - exp_mu_dzm(j-1)) & + * ( (rtm(j) - rtm(j-1)) & + * invrs_dzm_on_mu(j-1) ) & +! / (mu/gr%invrs_dzm(j-1)) ) & + + rt_par_j_minus_1 * exp_mu_dzm(j-1) + + else + + ! The ascending parcel is not entraining. + + rt_par_j = rt_par_j_minus_1 + + endif + + ! Include effects of latent heating on Lscale_up 6/12/00 + ! Use thermodynamic formula of Bougeault 1981 JAS Vol. 38, 2416 + ! Probably should use properties of bump 1 in Gaussian, not mean!!! + + ! Calculate r_c of the parcel at grid level j based on the values of + ! theta_l of the parcel and r_t of the parcel at grid level j. + tl_par_j = thl_par_j*exner(j) + if ( l_sat_mixrat_lookup ) then + rsatl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) + else + rsatl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) + end if + ! SD's beta (eqn. 8) + beta_par_j = ep*(Lv/(Rd*tl_par_j))*(Lv/(cp*tl_par_j)) + ! s from Lewellen and Yoh 1993 (LY) eqn. 1 + s_par_j = (rt_par_j-rsatl_par_j)/(1._core_rknd+beta_par_j*rsatl_par_j) + rc_par_j = max( s_par_j, zero_threshold ) + + ! theta_v of entraining parcel at grid level j. + thv_par_j = thl_par_j + ep1 * thv_ds(j) * rt_par_j & + + ( Lv / (exner(j)*cp) - ep2 * thv_ds(j) ) * rc_par_j + + ! Lscale_up and CAPE increment. + ! + ! The equation for Lscale_up is: + ! + ! INT(z_i:z_i+Lscale_up) g * ( thv_par - thvm ) / thvm dz = -em(z_i); + ! + ! where thv_par is theta_v of the parcel, thvm is the mean + ! environmental value of theta_v, z_i is the altitude that the parcel + ! started its ascent from, and em is the mean value of TKE at + ! altitude z_i (which gives the parcel its initial upward boost). + ! + ! The increment of CAPE for any two successive vertical levels (z_0 + ! and z_1, such that z_0 < z_1, and where z_0 is gr%zt(j-1) and z_1 + ! is gr%zt(j)) is: + ! + ! CAPE_incr = INT(z_0:z_1) g * ( thv_par - thvm ) / thvm dz. + ! + ! Thus, the derivative of CAPE with respect to height is: + ! + ! dCAPE/dz = g * ( thv_par - thvm ) / thvm. + ! + ! A purely trapezoidal rule is used between levels z_0 and z_1, such + ! that dCAPE/dz is evaluated at levels z_0 and z_1, and is considered + ! to vary linearly at all altitudes z_0 <= z <= z_1. Thus, dCAPE/dz + ! is considered to be of the form: A * (z-zo) + dCAPE/dz|_(z_0), + ! where A = ( dCAPE/dz|_(z_1) - dCAPE/dz|_(z_0) ) / ( z_1 - z_0 ). + ! + ! The integral is evaluated to find the CAPE increment between two + ! successive vertical levels. The result either adds to or depletes + ! from the total amount of energy that keeps the parcel ascending. + + dCAPE_dz_j = ( grav/thvm(j) ) * ( thv_par_j - thvm(j) ) + + CAPE_incr = 0.5_core_rknd * ( dCAPE_dz_j + dCAPE_dz_j_minus_1 ) & + / gr%invrs_dzm(j-1) + + if ( tke_i + CAPE_incr > 0.0_core_rknd ) then + + ! The total amount of CAPE increment has not exhausted the initial + ! TKE (plus any additions by CAPE increments due to upward + ! buoyancy) that boosted and carried the parcel upward. The + ! thickness of the full grid level is added to Lscale_up. + + Lscale_up(i) = Lscale_up(i) + gr%zt(j) - gr%zt(j-1) + + else + + ! The total amount of CAPE increment has exhausted the initial TKE + ! (plus any additions by CAPE increments due to upward buoyancy) + ! that boosted and carried the parcel upward. Add the thickness + ! z - z_0 (where z_0 < z <= z_1) to Lscale_up. The calculation of + ! Lscale_up is complete. + + if ( dCAPE_dz_j == dCAPE_dz_j_minus_1 ) then + + ! Special case where dCAPE/dz|_(z_1) - dCAPE/dz|_(z_0) = 0, + ! thus making factor A (above) equal to 0. Find the remaining + ! distance z - z_0 that it takes to exhaust the remaining TKE + ! (tke_i). + + Lscale_up(i) & + = Lscale_up(i) & + + ( - tke_i / dCAPE_dz_j ) + + else + + ! Case used for most scenarios where dCAPE/dz|_(z_1) + ! /= dCAPE/dz|_(z_0), thus making factor A /= 0. Find the + ! remaining distance z - z_0 that it takes to exhaust the + ! remaining TKE (tke_i), using the quadratic formula (only the + ! negative (-) root works in this scenario). + + Lscale_up(i) & + = Lscale_up(i) & + + ( - dCAPE_dz_j_minus_1 / & + ( dCAPE_dz_j - dCAPE_dz_j_minus_1 ) ) & + / gr%invrs_dzm(j-1) & + - sqrt( dCAPE_dz_j_minus_1**2 & + - 2.0_core_rknd * tke_i * gr%invrs_dzm(j-1) & + * ( dCAPE_dz_j - dCAPE_dz_j_minus_1 ) ) & + / ( dCAPE_dz_j - dCAPE_dz_j_minus_1 ) & + / gr%invrs_dzm(j-1) + + endif + + endif + + ! Reset values for use during the next vertical level up. + + thl_par_j_minus_1 = thl_par_j + rt_par_j_minus_1 = rt_par_j + dCAPE_dz_j_minus_1 = dCAPE_dz_j + + tke_i = tke_i + CAPE_incr + j = j + 1 + + enddo + + ! Make Lscale_up nonlocal + ! + ! This code makes the value of Lscale_up nonlocal. Thus, if a parcel + ! starting from a lower altitude can ascend to altitude + ! Lscale_up_max_alt, then a parcel starting from a higher altitude should + ! also be able to ascend to at least altitude Lscale_up_max_alt, even if + ! the local result of Lscale_up for the parcel that started at a higher + ! altitude is not sufficient for the parcel to reach altitude + ! Lscale_up_max_alt. + ! + ! For example, if it was found that a parcel starting at an altitude of + ! 100 m. ascended to an altitude of 2100 m. (an Lscale_up value of + ! 2000 m.), then a parcel starting at an altitude of 200 m. should also + ! be able to ascend to an altitude of at least 2100 m. If Lscale_up + ! was found to be only 1800 m. for the parcel starting at 200 m. + ! (resulting in the parcel only being able to ascend to an altitude of + ! 2000 m.), then this code will overwrite the 1800 m. value with a + ! Lscale_up value of 1900 m. (so that the parcel reaches an altitude of + ! 2100 m.). + ! + ! This feature insures that the profile of Lscale_up will be very smooth, + ! thus reducing numerical instability in the model. + + Lscale_up_max_alt = max( Lscale_up_max_alt, Lscale_up(i)+gr%zt(i) ) + + if ( ( gr%zt(i) + Lscale_up(i) ) < Lscale_up_max_alt ) then + Lscale_up(i) = Lscale_up_max_alt - gr%zt(i) + endif + + enddo + + + !!!!! Compute Lscale_down for every vertical level. + + ! Do it again for downwards particle motion. + ! For now, do not include latent heat + + ! Chris Golaz modification to include effects on latent heating + ! on Lscale_down + + Lscale_down_min_alt = gr%zt(gr%nz) + do i = gr%nz, 2, -1 + + tke_i = zm2zt( em, i ) ! TKE interpolated to thermodynamic level + + Lscale_down(i) = zlmin + j = i - 1 + + thl_par_j_plus_1 = thlm(i) + rt_par_j_plus_1 = rtm(i) + dCAPE_dz_j_plus_1 = 0.0_core_rknd + + do while ( (tke_i > 0._core_rknd) .and. (j >= 2) ) + + ! thl, rt of parcel are conserved except for entrainment + + ! theta_l of the parcel at grid level j. + ! + ! The equation for the rate of change of theta_l of the parcel with + ! respect to height, due to entrainment, is: + ! + ! d(thl_par)/dz = - mu * ( thl_par - thl_env ); + ! + ! where thl_par is theta_l of the parcel, thl_env is theta_l of the + ! ambient (or environmental) air, and mu is the entrainment rate, + ! such that: + ! + ! mu = (1/m)*(dm/dz); + ! + ! where m is the mass of the parcel. The value of mu is set to be a + ! constant. + ! + ! NOTE: For an entraining, descending parcel, parcel mass will + ! increase as height decreases. Thus dm/dz < 0, and therefore + ! mu < 0. However, in the equation for thl_par_j, mu is always + ! multiplied by the delta_z factor ( gr%zt(j) - gr%zt(j+1) ), + ! which always has the propery delta_z < 0 for a descending + ! parcel. Thus, mu*delta_z > 0, just as for an entraining, + ! ascending parcel. Therefore, the same general form of the + ! entrainment equation (only with differing grid level indices) + ! can be used for both the ascending and descending parcels. + ! + ! The differential equation is solved for thl_par_j (thl_par at + ! height gr%zt(j)) given the boundary condition thl_par_j_plus_1 + ! (thl_par at height gr%zt(j+1)), and given the fact that the value + ! of thl_env is treated as changing linearly for a parcel of air + ! descending from level j+1 (where thl_env has the value thlm(j+1)) to + ! level j (where thl_env has the value thlm(j)). + ! + ! For the special case where entrainment rate, mu, is set to 0, + ! thl_par remains constant as the parcel descends. + + if ( mu /= 0.0_core_rknd ) then + + ! The descending parcel is entraining at rate mu. + + ! Calculation changed to use pre-calculated exp(-mu/gr%invrs_dzm) + ! values. ~~EIHoppe//20090615 + + ! Calculation changed to use pre-calculated mu/gr%invrs_dzm values. + ! ~EIHoppe//20100728 + + thl_par_j = thlm(j) - thlm(j+1)*exp_mu_dzm(j) & + - ( 1.0_core_rknd - exp_mu_dzm(j)) & + * ( (thlm(j) - thlm(j+1)) & + * invrs_dzm_on_mu(j) ) & +! / (mu/gr%invrs_dzm(j)) ) & + + thl_par_j_plus_1 * exp_mu_dzm(j) + + else + + ! The descending parcel is not entraining. + + thl_par_j = thl_par_j_plus_1 + + endif + + ! r_t of the parcel at grid level j. + ! + ! The equation for the rate of change of r_t of the parcel with + ! respect to height, due to entrainment, is: + ! + ! d(rt_par)/dz = - mu * ( rt_par - rt_env ); + ! + ! where rt_par is r_t of the parcel, rt_env is r_t of the ambient (or + ! environmental) air, and mu is the entrainment rate, such that: + ! + ! mu = (1/m)*(dm/dz); + ! + ! where m is the mass of the parcel. The value of mu is set to be a + ! constant. + ! + ! NOTE: For an entraining, descending parcel, parcel mass will + ! increase as height decreases. Thus dm/dz < 0, and therefore + ! mu < 0. However, in the equation for rt_par_j, mu is always + ! multiplied by the delta_z factor ( gr%zt(j) - gr%zt(j+1) ), + ! which always has the propery delta_z < 0 for a descending + ! parcel. Thus, mu*delta_z > 0, just as for an entraining, + ! ascending parcel. Therefore, the same general form of the + ! entrainment equation (only with differing grid level indices) + ! can be used for both the ascending and descending parcels. + ! + ! The differential equation is solved for rt_par_j (rt_par at height + ! gr%zt(j)) given the boundary condition rt_par_j_plus_1 (rt_par at + ! height gr%zt(j+1)), and given the fact that the value of rt_env is + ! treated as changing linearly for a parcel of air descending from + ! level j+1 (where rt_env has the value rtm(j+1)) to level j (where + ! rt_env has the value rtm(j)). + ! + ! For the special case where entrainment rate, mu, is set to 0, + ! rt_par remains constant as the parcel descends. + + if ( mu /= 0.0_core_rknd ) then + + ! The descending parcel is entraining at rate mu. + + ! Calculation changed to use pre-calculated exp(-mu/gr%invrs_dzm) + ! values. ~~EIHoppe//20090615 + + ! Calculation changed to use pre-calculated mu/gr%invrs_dzm values. + ! ~EIHoppe//20100728 + + rt_par_j = rtm(j) - rtm(j+1)*exp_mu_dzm(j) & + - ( 1.0_core_rknd - exp_mu_dzm(j) ) & + * ( (rtm(j) - rtm(j+1)) & +! / (mu/gr%invrs_dzm(j)) ) & + * invrs_dzm_on_mu(j) ) & + + rt_par_j_plus_1 * exp_mu_dzm(j) + + else + + ! The descending parcel is not entraining. + + rt_par_j = rt_par_j_plus_1 + + endif + + ! Include effects of latent heating on Lscale_down + ! Use thermodynamic formula of Bougeault 1981 JAS Vol. 38, 2416 + ! Probably should use properties of bump 1 in Gaussian, not mean!!! + + ! Calculate r_c of the parcel at grid level j based on the values of + ! theta_l of the parcel and r_t of the parcel at grid level j. + tl_par_j = thl_par_j*exner(j) + if ( l_sat_mixrat_lookup ) then + rsatl_par_j = sat_mixrat_liq_lookup( p_in_Pa(j), tl_par_j ) + else + rsatl_par_j = sat_mixrat_liq( p_in_Pa(j), tl_par_j ) + end if + ! SD's beta (eqn. 8) + beta_par_j = ep*(Lv/(Rd*tl_par_j))*(Lv/(cp*tl_par_j)) + ! s from Lewellen and Yoh 1993 (LY) eqn. 1 + s_par_j = (rt_par_j-rsatl_par_j)/(1._core_rknd+beta_par_j*rsatl_par_j) + rc_par_j = max( s_par_j, zero_threshold ) + + ! theta_v of the entraining parcel at grid level j. + thv_par_j = thl_par_j + ep1 * thv_ds(j) * rt_par_j & + + ( Lv / (exner(j)*cp) - ep2 * thv_ds(j) ) * rc_par_j + + ! Lscale_down and CAPE increment. + ! + ! The equation for Lscale_down (where Lscale_down is the absolute + ! value of downward distance) is: + ! + ! INT(z_i-Lscale_down:z_i) g * ( thv_par - thvm ) / thvm dz = em(z_i); + ! + ! where thv_par is theta_v of the parcel, thvm is the mean + ! environmental value of theta_v, z_i is the altitude that the parcel + ! started its descent from, and em is the mean value of TKE at + ! altitude z_i (which gives the parcel its initial downward boost). + ! + ! The increment of CAPE for any two successive vertical levels (z_0 + ! and z_(-1), such that z_(-1) < z_0, and where z_0 is gr%zt(j+1) and + ! z_(-1) is gr%zt(j)) is: + ! + ! CAPE_incr = INT(z_(-1):z_0) g * ( thv_par - thvm ) / thvm dz. + ! + ! Thus, the derivative of CAPE with respect to height is: + ! + ! dCAPE/dz = g * ( thv_par - thvm ) / thvm. + ! + ! A purely trapezoidal rule is used between levels z_(-1) and z_0, + ! such that dCAPE/dz is evaluated at levels z_(-1) and z_0, and is + ! considered to vary linearly at all altitudes z_(-1) <= z <= z_0. + ! Thus, dCAPE/dz is considered to be of the form: + ! A * (z-zo) + dCAPE/dz|_(z_0), where + ! A = ( dCAPE/dz|_(z_(-1)) - dCAPE/dz|_(z_0) ) / ( z_(-1) - z_0 ). + ! + ! The integral is evaluated to find the CAPE increment between two + ! successive vertical levels. The result either adds to or depletes + ! from the total amount of energy that keeps the parcel descending. + + dCAPE_dz_j = ( grav/thvm(j) ) * ( thv_par_j - thvm(j) ) + + CAPE_incr = 0.5_core_rknd * ( dCAPE_dz_j + dCAPE_dz_j_plus_1 ) / gr%invrs_dzm(j) + + if ( tke_i - CAPE_incr > 0.0_core_rknd ) then + + ! The total amount of CAPE increment has not exhausted the initial + ! TKE (plus any additions by CAPE increments due to downward + ! buoyancy) that boosted and carried the parcel downward. The + ! thickness of the full grid level is added to Lscale_down. + + Lscale_down(i) = Lscale_down(i) + gr%zt(j+1) - gr%zt(j) + + else + + ! The total amount of CAPE increment has exhausted the initial TKE + ! (plus any additions by CAPE increments due to downward buoyancy) + ! that boosted and carried the parcel downward. Add the thickness + ! z_0 - z (where z_(-1) <= z < z_0) to Lscale_down. The + ! calculation of Lscale_down is complete. + + if ( dCAPE_dz_j == dCAPE_dz_j_plus_1 ) then + + ! Special case where dCAPE/dz|_(z_(-1)) - dCAPE/dz|_(z_0) = 0, + ! thus making factor A (above) equal to 0. Find the remaining + ! distance z_0 - z that it takes to exhaust the remaining TKE + ! (tke_i). + + Lscale_down(i) & + = Lscale_down(i) & + + ( tke_i / dCAPE_dz_j ) + + else + + ! Case used for most scenarios where dCAPE/dz|_(z_(-1)) + ! /= dCAPE/dz|_(z_0), thus making factor A /= 0. Find the + ! remaining distance z_0 - z that it takes to exhaust the + ! remaining TKE (tke_i), using the quadratic formula (only the + ! negative (-) root works in this scenario -- however, the + ! negative (-) root is divided by another negative (-) factor, + ! which results in an overall plus (+) sign in front of the + ! square root term in the equation below). + + Lscale_down(i) & + = Lscale_down(i) & + + ( - dCAPE_dz_j_plus_1 / & + ( dCAPE_dz_j - dCAPE_dz_j_plus_1 ) ) & + / gr%invrs_dzm(j) & + + sqrt( dCAPE_dz_j_plus_1**2 & + + 2.0_core_rknd * tke_i * gr%invrs_dzm(j) & + * ( dCAPE_dz_j - dCAPE_dz_j_plus_1 ) ) & + / ( dCAPE_dz_j - dCAPE_dz_j_plus_1 ) & + / gr%invrs_dzm(j) + + endif + + endif + + ! Reset values for use during the next vertical level down. + + thl_par_j_plus_1 = thl_par_j + rt_par_j_plus_1 = rt_par_j + dCAPE_dz_j_plus_1 = dCAPE_dz_j + + tke_i = tke_i - CAPE_incr + j = j - 1 + + enddo + + ! Make Lscale_down nonlocal + ! + ! This code makes the value of Lscale_down nonlocal. Thus, if a parcel + ! starting from a higher altitude can descend to altitude + ! Lscale_down_min_alt, then a parcel starting from a lower altitude + ! should also be able to descend to at least altitude + ! Lscale_down_min_alt, even if the local result of Lscale_down for the + ! parcel that started at a lower altitude is not sufficient for the + ! parcel to reach altitude Lscale_down_min_alt. + ! + ! For example, if it was found that a parcel starting at an altitude of + ! 1100 m. descended to an altitude of 100 m. (an Lscale_down value of + ! 1000 m.), then a parcel starting at an altitude of 1000 m. should also + ! be able to descend to an altitude of at least 100 m. If Lscale_down + ! was found to be only 800 m. for the parcel starting at 1000 m. + ! (resulting in the parcel only being able to descend to an altitude of + ! 200 m.), then this code will overwrite the 800 m. value with a + ! Lscale_down value of 900 m. (so that the parcel reaches an altitude of + ! 100 m.). + ! + ! This feature insures that the profile of Lscale_down will be very + ! smooth, thus reducing numerical instability in the model. + + Lscale_down_min_alt = min( Lscale_down_min_alt, gr%zt(i)-Lscale_down(i) ) + + if ( (gr%zt(i)-Lscale_down(i)) > Lscale_down_min_alt ) then + Lscale_down(i) = gr%zt(i) - Lscale_down_min_alt + endif + + enddo + + + !!!!! Compute Lscale for every vertical level. + + do i = 2, gr%nz, 1 + + ! The equation for Lscale is: + ! + ! Lscale = sqrt( Lscale_up * Lscale_down ). + + ! Make lminh a linear function starting at value lmin at the bottom + ! and going to zero at 500 meters in altitude. + ! -dschanen 27 April 2007 + if( l_implemented ) then + ! Within a host model, increase mixing length in 500 m layer above *ground* + lminh = max( zero_threshold, Lscale_sfclyr_depth - (gr%zt(i) - gr%zm(1)) ) & + * ( lmin / Lscale_sfclyr_depth ) + else + ! In standalone mode, increase mixing length in 500 m layer above *mean sea level* + lminh = max( zero_threshold, Lscale_sfclyr_depth - gr%zt(i) ) & + * ( lmin / Lscale_sfclyr_depth ) + end if + + Lscale_up(i) = max( lminh, Lscale_up(i) ) + Lscale_down(i) = max( lminh, Lscale_down(i) ) + + Lscale(i) = sqrt( Lscale_up(i)*Lscale_down(i) ) + + enddo + + ! Set the value of Lscale at the upper and lower boundaries. + Lscale(1) = Lscale(2) + Lscale(gr%nz) = Lscale(gr%nz-1) + + ! Vince Larson limited Lscale to allow host + ! model to take over deep convection. 13 Feb 2008. + + !Lscale = min( Lscale, 1e5 ) + Lscale = min( Lscale, Lscale_max ) + + if( clubb_at_least_debug_level( 2 ) ) then + + ! Ensure that the output from this subroutine is valid. + call length_check( Lscale, Lscale_up, Lscale_down, err_code_Lscale ) + ! Joshua Fasching January 2008 + + ! Error Reporting + ! Joshua Fasching February 2008 + + if ( fatal_error( err_code_Lscale ) ) then + + write(fstderr,*) "Errors in length subroutine" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "thvm = ", thvm + write(fstderr,*) "thlm = ", thlm + write(fstderr,*) "rtm = ", rtm + write(fstderr,*) "em = ", em + write(fstderr,*) "exner = ", exner + write(fstderr,*) "p_in_Pa = ", p_in_Pa + write(fstderr,*) "thv_ds = ", thv_ds + + write(fstderr,*) "Intent(out)" + + write(fstderr,*) "Lscale = ", Lscale + write(fstderr,*) "Lscale_up = ", Lscale_up + + ! Overwrite the last error code with this new fatal error + err_code = err_code_Lscale + + endif ! Fatal error + + endif ! clubb_debug_level + + return + + end subroutine compute_length + +!=============================================================================== + +end module mixing_length diff --git a/src/physics/clubb/model_flags.F90 b/src/physics/clubb/model_flags.F90 new file mode 100644 index 0000000000..b0c11a8c54 --- /dev/null +++ b/src/physics/clubb/model_flags.F90 @@ -0,0 +1,461 @@ +!----------------------------------------------------------------------- +! $Id: model_flags.F90 7367 2014-11-06 18:29:49Z schemena@uwm.edu $ +!=============================================================================== +module model_flags + +! Description: +! Various model options that can be toggled off and on as desired. + +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + public :: setup_model_flags, read_model_flags_from_file, setup_configurable_model_flags, & + get_configurable_model_flags, write_model_flags_to_file + + private ! Default Scope + + logical, parameter, public :: & + l_pos_def = .false., & ! Flux limiting positive definite scheme on rtm + l_hole_fill = .true., & ! Hole filling pos def scheme on wp2,up2,rtp2,etc + l_clip_semi_implicit = .false., & ! Semi-implicit clipping scheme on wpthlp and wprtp + l_clip_turb_adv = .false., & ! Corrects thlm/rtm when w'th_l'/w'r_t' is clipped + l_gmres = .false., & ! Use GMRES iterative solver rather than LAPACK + l_sat_mixrat_lookup = .false. ! Use a lookup table for mixing length + ! saturation vapor pressure calculations + + logical, parameter, public :: & +#ifdef BYTESWAP_IO + l_byteswap_io = .true., & ! Don't use the native byte ordering in GrADS output +#else + l_byteswap_io = .false., & ! Use the native byte ordering in GrADS output +#endif + l_gamma_Skw = .true. ! Use a Skw dependent gamma parameter + + logical, parameter, public :: & + l_use_boussinesq = .false. ! Flag to use the Boussinesq form of the + ! predictive equations. The predictive + ! equations are anelastic by default. + + logical, public :: & + l_use_precip_frac = .true. ! Flag to use precipitation fraction in KK + ! microphysics. The precipitation fraction + ! is automatically set to 1 when this flag + ! is turned off. + +!$omp threadprivate( l_use_precip_frac ) + + ! These flags determine whether or not we want CLUBB to do diffusion + ! on thlm and rtm and if a stability correction is applied + logical, public :: & + l_diffuse_rtm_and_thlm = .false., & ! Diffuses rtm and thlm + l_stability_correct_Kh_N2_zm = .false. ! Divides Kh_N2_zm by a stability factor + +!$omp threadprivate( l_diffuse_rtm_and_thlm, l_stability_correct_Kh_N2_zm ) + + logical, parameter, public :: & + l_morr_xp2_mc = .false. !Flag to include the effects of rain evaporation + !on rtp2 and thlp2. The moister (rt_1 or rt_2) + !and colder (thl_1 or thl_2) will be fed into + !the morrison microphys, and rain evaporation will + !be allowed to increase variances + + logical, parameter, public :: & + l_evaporate_cold_rcm = .false. ! Flag to evaporate cloud water at temperatures + ! colder than -37C. This is to be used for + ! Morrison microphysics, to prevent excess ice + + logical, parameter, public :: & + l_cubic_interp = .false. ! Flag to convert grid points with cubic monotonic + ! spline interpolation as opposed to linear interpolation. + + ! See clubb:ticket:632 for details + logical, public :: & + l_calc_thlp2_rad = .true. ! Include the contribution of radiation to thlp2 +!$omp threadprivate( l_calc_thlp2_rad ) + + ! These are the integer constants that represent the various saturation + ! formulas. To add a new formula, add an additional constant here, + ! add the logic to check the strings for the new formula in clubb_core and + ! this module, and add logic in saturation to call the proper function-- + ! the control logic will be based on these named constants. + + integer, parameter, public :: & + saturation_bolton = 1, & ! Constant for Bolton approximations of saturation + saturation_gfdl = 2, & ! Constant for the GFDL approximation of saturation + saturation_flatau = 3 ! Constant for Flatau approximations of saturation + + !----------------------------------------------------------------------------- + ! Options that can be changed at runtime + ! The default values are chosen below and overwritten if desired by the user + !----------------------------------------------------------------------------- + + ! These flags determine whether we want to use an upwind differencing approximation + ! rather than a centered differencing for turbulent or mean advection terms. + ! wpxp_ta affects wprtp, wpthlp, & wpsclrp + ! xpyp_ta affects rtp2, thlp2, up2, vp2, sclrp2, rtpthlp, sclrprtp, & sclrpthlp + ! xm_ma affects rtm, thlm, sclrm, um and vm. + logical, public :: & + l_upwind_wpxp_ta = .false., & + l_upwind_xpyp_ta = .true., & + l_upwind_xm_ma = .true. + +!$omp threadprivate(l_upwind_wpxp_ta, l_upwind_xpyp_ta, l_upwind_xm_ma) + + logical, public :: & + l_quintic_poly_interp = .false. ! Use a quintic polynomial in mono_cubic_interp + +!$omp threadprivate(l_quintic_poly_interp) + + + logical, public :: & + l_uv_nudge = .false., & ! For wind speed nudging. - Michael Falk + l_rtm_nudge = .false., & ! For rtm nudging + l_tke_aniso = .true. ! For anisotropic turbulent kinetic energy, + ! i.e. TKE = 1/2 (u'^2 + v'^2 + w'^2) +!$omp threadprivate(l_uv_nudge, l_tke_aniso, l_rtm_nudge) + + ! Use 2 calls to pdf_closure and the trapezoidal rule to compute the + ! varibles that are output from high order closure + logical, private :: & + l_vert_avg_closure = .true. +!$omp threadprivate(l_vert_avg_closure) + + ! These are currently set based on l_vert_avg_closure + logical, public :: & + l_trapezoidal_rule_zt = .true., & ! If true, the trapezoidal rule is called for + ! the thermodynamic-level variables output + ! from pdf_closure. + l_trapezoidal_rule_zm = .true., & ! If true, the trapezoidal rule is called for + ! three momentum-level variables - wpthvp, + ! thlpthvp, and rtpthvp - output from pdf_closure. + l_call_pdf_closure_twice = .true., & ! This logical flag determines whether or not to + ! call subroutine pdf_closure twice. If true, + ! pdf_closure is called first on thermodynamic levels + ! and then on momentum levels so that each variable is + ! computed on its native level. If false, pdf_closure + ! is only called on thermodynamic levels, and variables + ! which belong on momentum levels are interpolated. + l_single_C2_Skw = .false. ! Use a single Skewness dependent C2 for rtp2, thlp2, and rtpthlp + +!$omp threadprivate(l_trapezoidal_rule_zt, l_trapezoidal_rule_zm, & +!$omp l_call_pdf_closure_twice, l_single_C2_Skw) + + logical, public :: & + l_standard_term_ta = .false. ! Use the standard discretization for the + ! turbulent advection terms. Setting to + ! .false. means that a_1 and a_3 are pulled + ! outside of the derivative in advance_wp2_wp3_module.F90 + ! and in advance_xp2_xpyp_module.F90. +!$omp threadprivate(l_standard_term_ta) + + ! Use to determine whether a host model has already applied the surface flux, + ! to avoid double counting. + logical, public :: & + l_host_applies_sfc_fluxes = .false. + +!$omp threadprivate(l_host_applies_sfc_fluxes) + + ! Use cloud_cover and rcm_in_layer to help boost cloud_frac and rcm to help increase cloudiness + ! at coarser grid resolutions. + logical, public :: & + l_use_cloud_cover = .true. +!$omp threadprivate(l_use_cloud_cover) + + integer, public :: & + saturation_formula = saturation_flatau ! Integer that stores the saturation formula to be used + +!$omp threadprivate(saturation_formula) + + ! See clubb:ticket:514 for details + logical, public :: & + l_diagnose_correlations = .false., & ! Diagnose correlations instead of using fixed ones + l_calc_w_corr = .false. ! Calculate the correlations between w and the hydrometeors +!$omp threadprivate(l_diagnose_correlations, l_calc_w_corr) + + logical, parameter, public :: & + l_silhs_rad = .false. ! Resolve radiation over subcolumns using SILHS + + logical, public :: & + l_const_Nc_in_cloud = .false., & ! Use a constant cloud droplet conc. within cloud (K&K) + l_fix_chi_eta_correlations = .true. ! Use a fixed correlation for s and t Mellor(chi/eta) +!$omp threadprivate( l_const_Nc_in_cloud, l_fix_chi_eta_correlations ) + + logical, public :: & + l_use_ADG2 = .false. ! Use Luhar et al. (2002) to close the w Gaussians. + ! Allows for each w Gaussian to have a different + ! width +!$omp threadprivate(l_use_ADG2) + + logical, public :: & + l_use_3D_closure = .false., & ! Use Luhar et al. (2002) to close the w, thl, and rt Gaussians. + l_stability_correct_tau_zm = .true., & ! Use tau_N2_zm instead of tau_zm in wpxp_pr1 + ! stability correction + l_damp_wp2_using_em = .false., & ! In wp2 equation, use a dissipation + ! formula of -(2/3)*em/tau_zm, as in Bougeault (1981) + l_do_expldiff_rtm_thlm = .false., & ! Diffuse rtm and thlm explicitly + l_Lscale_plume_centered = .false., & ! Alternate that uses the PDF to + ! compute the perturbed values + l_use_ice_latent = .false., & ! Includes the effects of ice latent heating in + ! turbulence terms + l_use_C7_Richardson = .false., & ! Parameterize C7 based on Richardson number + l_brunt_vaisala_freq_moist = .false. ! Use a different formula for the Brunt-Vaisala + ! frequency in saturated atmospheres + ! (from Durran and Klemp, 1982) + +!$omp threadprivate( l_use_3D_closure, l_stability_correct_tau_zm, l_damp_wp2_using_em, & +!$omp l_do_expldiff_rtm_thlm, & +!$omp l_Lscale_plume_centered, l_use_ice_latent, l_use_C7_Richardson, & +!$omp l_brunt_vaisala_freq_moist ) + +#ifdef GFDL + logical, public :: & + I_sat_sphum ! h1g, 2010-06-15 +!$omp threadprivate( I_sat_sphum ) +#endif + + namelist /configurable_clubb_flags_nl/ & + l_upwind_wpxp_ta, l_upwind_xpyp_ta, l_upwind_xm_ma, l_quintic_poly_interp, & + l_tke_aniso, l_vert_avg_closure, l_single_C2_Skw, l_standard_term_ta, & + l_use_cloud_cover, l_calc_thlp2_rad, l_use_ADG2, l_use_3D_closure + + contains + +!=============================================================================== + subroutine setup_model_flags & + ( l_host_applies_sfc_fluxes_in, & + l_uv_nudge_in, saturation_formula_in & +#ifdef GFDL + , I_sat_sphum_in & ! h1g, 2010-06-15 +#endif + ) + +! Description: +! Setup flags that influence the numerics, etc. of CLUBB core + +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + ! External + intrinsic :: trim + + ! Input Variables + logical, intent(in) :: & + l_host_applies_sfc_fluxes_in, & + l_uv_nudge_in + + character(len=*), intent(in) :: & + saturation_formula_in + +#ifdef GFDL + logical, intent(in) :: & + I_sat_sphum_in ! h1g, 2010-06-15 +#endif + + !---- Begin Code ---- + + ! Logicals + + l_uv_nudge = l_uv_nudge_in + + l_host_applies_sfc_fluxes = l_host_applies_sfc_fluxes_in + + ! Integers + + ! Set up the saturation formula value + select case ( trim( saturation_formula_in ) ) + case ( "bolton", "Bolton" ) + saturation_formula = saturation_bolton + + case ( "flatau", "Flatau" ) + saturation_formula = saturation_flatau + + case ( "gfdl", "GFDL" ) + saturation_formula = saturation_gfdl + + ! Add new saturation formulas after this. + end select + +#ifdef GFDL + I_sat_sphum = I_sat_sphum_in ! h1g, 2010-06-15 +#endif + return + end subroutine setup_model_flags + +!=============================================================================== + subroutine read_model_flags_from_file( iunit, filename ) + +! Description: +! Read in some of the model flags of interest from a namelist file. If the +! variable isn't in the file it will just be the default value. +! +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: & + iunit ! File I/O unit to use + + character(len=*), intent(in) :: & + filename ! Name of the file with the namelist + + ! Read the namelist + open(unit=iunit, file=filename, status='old', action='read') + + read(unit=iunit, nml=configurable_clubb_flags_nl) + + close(unit=iunit) + + if ( l_vert_avg_closure ) then + l_trapezoidal_rule_zt = .true. + l_trapezoidal_rule_zm = .true. + l_call_pdf_closure_twice = .true. + else + l_trapezoidal_rule_zt = .false. + l_trapezoidal_rule_zm = .false. + l_call_pdf_closure_twice = .false. + end if + + return + end subroutine read_model_flags_from_file + +!=============================================================================== + subroutine write_model_flags_to_file( iunit, filename ) + +! Description: +! Write a new namelist for the configurable model flags +! +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + integer, intent(in) :: & + iunit ! File I/O unit to use + + character(len=*), intent(in) :: & + filename ! Name of the file with the namelist + + ! Read the namelist + open(unit=iunit, file=filename, status='unknown', action='write') + + write(unit=iunit, nml=configurable_clubb_flags_nl) + + close(unit=iunit) + + return + end subroutine write_model_flags_to_file +!=============================================================================== + subroutine setup_configurable_model_flags & + ( l_upwind_wpxp_ta_in, l_upwind_xpyp_ta_in, & + l_upwind_xm_ma_in, l_quintic_poly_interp_in, & + l_vert_avg_closure_in, & + l_single_C2_Skw_in, l_standard_term_ta_in, & + l_tke_aniso_in, l_use_cloud_cover_in, l_use_ADG2_in, & + l_use_3D_closure_in ) + +! Description: +! Set a model flag based on the input arguments for the purposes of trying +! all possible combinations in the clubb_tuner. +! +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + ! Input Variables + logical, intent(in) :: & + l_upwind_wpxp_ta_in, & ! Model flags + l_upwind_xpyp_ta_in, & + l_upwind_xm_ma_in, & + l_quintic_poly_interp_in, & + l_vert_avg_closure_in, & + l_single_C2_Skw_in, & + l_standard_term_ta_in, & + l_tke_aniso_in, & + l_use_cloud_cover_in, & + l_use_ADG2_in, & + l_use_3D_closure_in + ! ---- Begin Code ---- + + l_upwind_wpxp_ta = l_upwind_wpxp_ta_in + l_upwind_xpyp_ta = l_upwind_xpyp_ta_in + l_upwind_xm_ma = l_upwind_xm_ma_in + l_quintic_poly_interp = l_quintic_poly_interp_in + l_vert_avg_closure = l_vert_avg_closure_in + l_single_C2_Skw = l_single_C2_Skw_in + l_standard_term_ta = l_standard_term_ta_in + l_tke_aniso = l_tke_aniso_in + l_use_cloud_cover = l_use_cloud_cover_in + l_use_ADG2 = l_use_ADG2_in + l_use_3D_closure = l_use_3D_closure_in + if ( l_vert_avg_closure ) then + l_trapezoidal_rule_zt = .true. + l_trapezoidal_rule_zm = .true. + l_call_pdf_closure_twice = .true. + else + l_trapezoidal_rule_zt = .false. + l_trapezoidal_rule_zm = .false. + l_call_pdf_closure_twice = .false. + end if + + return + end subroutine setup_configurable_model_flags + +!=============================================================================== + subroutine get_configurable_model_flags & + ( l_upwind_wpxp_ta_out, l_upwind_xpyp_ta_out, & + l_upwind_xm_ma_out, l_quintic_poly_interp_out, & + l_vert_avg_closure_out, & + l_single_C2_Skw_out, l_standard_term_ta_out, & + l_tke_aniso_out, l_use_cloud_cover_out, l_use_ADG2_out, & + l_use_3D_closure_out ) + +! Description: +! Get the current model flags. +! +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + ! Input Variables + logical, intent(out) :: & + l_upwind_wpxp_ta_out, & ! Model flags + l_upwind_xpyp_ta_out, & + l_upwind_xm_ma_out, & + l_quintic_poly_interp_out, & + l_vert_avg_closure_out, & + l_single_C2_Skw_out, & + l_standard_term_ta_out, & + l_tke_aniso_out, & + l_use_cloud_cover_out, & + l_use_ADG2_out, & + l_use_3D_closure_out + ! ---- Begin Code ---- + + l_upwind_wpxp_ta_out = l_upwind_wpxp_ta + l_upwind_xpyp_ta_out = l_upwind_xpyp_ta + l_upwind_xm_ma_out = l_upwind_xm_ma + l_quintic_poly_interp_out = l_quintic_poly_interp + l_vert_avg_closure_out = l_vert_avg_closure + l_single_C2_Skw_out = l_single_C2_Skw + l_standard_term_ta_out = l_standard_term_ta + l_tke_aniso_out = l_tke_aniso + l_use_cloud_cover_out = l_use_cloud_cover + l_use_ADG2_out = l_use_ADG2 + l_use_3D_closure_out = l_use_3D_closure + return + end subroutine get_configurable_model_flags + +end module model_flags diff --git a/src/physics/clubb/mono_flux_limiter.F90 b/src/physics/clubb/mono_flux_limiter.F90 new file mode 100644 index 0000000000..18676497c0 --- /dev/null +++ b/src/physics/clubb/mono_flux_limiter.F90 @@ -0,0 +1,1833 @@ +!----------------------------------------------------------------------- +! $Id: mono_flux_limiter.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module mono_flux_limiter + + implicit none + + private ! Default Scope + + public :: monotonic_turbulent_flux_limit, & + calc_turb_adv_range + + private :: mfl_xm_lhs, & + mfl_xm_rhs, & + mfl_xm_solve, & + mean_vert_vel_up_down + + ! Private named constants to avoid string comparisons + ! NOTE: These values must match the values for xm_wpxp_thlm + ! and xm_wpxp_rtm given in advance_xm_wpxp_module! + integer, parameter, private :: & + mono_flux_thlm = 1, & ! Named constant for thlm mono_flux calls + mono_flux_rtm = 2 ! Named constant for rtm mono_flux calls + + contains + + !============================================================================= + subroutine monotonic_turbulent_flux_limit( solve_type, dt, xm_old, & + xp2, wm_zt, xm_forcing, & + rho_ds_zm, rho_ds_zt, & + invrs_rho_ds_zm, invrs_rho_ds_zt, & + xp2_threshold, l_implemented, & + low_lev_effect, high_lev_effect, & + xm, xm_tol, wpxp, err_code ) + + ! Description: + ! Limits the value of w'x' and corrects the value of xm when the xm turbulent + ! advection term is not monotonic. A monotonic turbulent advection scheme + ! will not create new extrema for variable x, based only on turbulent + ! advection (not considering mean advection and xm forcings). + ! + ! Montonic turbulent advection + ! ---------------------------- + ! + ! A monotonic turbulent advection scheme does not allow new extrema for + ! variable x to be created (by means of turbulent advection). In a + ! monotonic turbulent advection scheme, when only the effects of turbulent + ! advection are considered (neglecting forcings and mean advection), the + ! value of variable x at a given point should not increase above the + ! greatest value of variable x at nearby points, nor decrease below the + ! smallest value of variable x at nearby points. Nearby points are points + ! that are close enough to the given point so that the value of variable x + ! at the given point is effected by the values of variable x at the nearby + ! points by means of transfer by turbulent winds during a time step. Again, + ! a monotonic scheme insures that advection only transfers around values of + ! variable x and does not create new extrema for variable x. A monotonic + ! turbulent advection scheme is useful because the turbulent advection term + ! (w'x') may go numerically unstable, resulting in large instabilities in + ! the mean field (xm). A monotonic turbulent advection scheme will limit + ! the change in xm, and also in w'x'. + ! + ! The following example illustrates the concept of monotonic turbulent + ! advection. Three successive vertical grid levels are shown (k-1, k, and + ! k+1). Three point values of theta-l are listed at every vertical grid + ! level. All three vertical levels have a mean theta-l (thlm) of 288.0 K. + ! A circulation is occuring (in the direction of the arrows) in the vertical + ! (w wind component) and in the horizontal (u and/or v wind components), + ! such that the mean value of vertical velocity (wmm) is 0, but there is a + ! turbulent component such that w'^2 > 0. + ! + ! level = k+1 || --- 287.0 K --- 288.0 K --- 289.0 K --- || thlm = 288.0 + ! || / \--------------------->| || + ! || | | || wmm = 0; wp2 > 0 + ! || |<---------------------\ / || + ! level = k || --- 288.0 K --- 288.0 K --- 288.0 K --- || thlm = 288.0 + ! || |<---------------------/ \ || + ! || | | || wmm = 0; wp2 > 0 + ! || \ /--------------------->| || + ! level = k-1 || --- 287.5 K --- 288.0 K --- 288.5 K --- || thlm = 288.0 + ! + ! Neglecting any contributions from thlm forcings (effects of radiation, + ! microphysics, large-scale horizontal advection, etc.), the values of + ! theta-l as shown will be altered by only turbulent advection. As a side + ! note, the contribution of mean advection will be 0 since wmm = 0. The + ! diagram shows that the value of theta-l at the point on the right at level + ! k will increase. However, the values of theta-l at the other two points + ! at level k will remain the same. Thus, the value of thlm at level k will + ! become greater than 288.0 K. In the same manner, the values of thlm at + ! the other two vertical levels (k-1 and k+1) will become smaller than + ! 288.0 K. However, the monotonic turbulent advection scheme insures that + ! any theta-l point value cannot become smaller than the smallest theta-l + ! point value (287.0 K) or larger than the largest theta-l point value + ! (289.0 K). Since all theta-l point values must fall between 287.0 K and + ! 289.0 K, the level averages of theta-l (thlm) must fall between 287.0 K + ! and 289.0 K. Thus, any values of the turbulent flux, w'th_l', that would + ! cause thlm to rise above 289.0 K or fall below 287.0 K, not considering + ! the effect of other terms on thlm (such as forcings), are faulty and need + ! to be limited appropriately. The values of thlm also need to be corrected + ! appropriately. + ! + ! Formula for the limitation of w'x' and xm + ! ----------------------------------------- + ! + ! The equation for change in the mean field, xm, over time is: + ! + ! d(xm)/dt = -w*d(xm)/dz - (1/rho_ds) * d( rho_ds * w'x' )/dz + xm_forcing; + ! + ! where w*d(xm)/dz is the mean advection component, + ! (1/rho_ds) * d( rho_ds * w'x' )/dz is the turbulent advection component, + ! and xm_forcing is the xm forcing component. The d(xm)/dt time tendency + ! component is discretized as: + ! + ! xm(k,)/dt = xm(k,)/dt - w*d(xm)/dz + ! - (1/rho_ds) * d( rho_ds * w'x' )/dz + xm_forcing. + ! + ! The value of xm after it has been advanced to timestep (t+1) must be in an + ! appropriate range based on the values of xm at timestep (t), the amount of + ! xm forcings applied over the ensuing time step, and the amount of mean + ! advection applied over the ensuing time step. This is exactly the same + ! thing as saying that the value of xm(k,), with the contribution of + ! turbulent advection included, must fall into a certain range based on the + ! value of xm(k,) without the contribution of the turbulent advection + ! component over the last time step. The following inequality is used to + ! limit the value of xm(k,): + ! + ! MIN{ xm(k-1,) + dt*xm_forcing(k-1) - dt*wm_zt(k-1)*d(xm)/dz|_(k-1) + ! - x_max_dev_low(k-1,), + ! xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - x_max_dev_low(k,), + ! xm(k+1,) + dt*xm_forcing(k+1) - dt*wm_zt(k+1)*d(xm)/dz|_(k+1) + ! - x_max_dev_low(k+1,) } + ! <= xm(k,) <= + ! MAX{ xm(k-1,) + dt*xm_forcing(k-1) - dt*wm_zt(k-1)*d(xm)/dz|_(k-1) + ! + x_max_dev_high(k-1,), + ! xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! + x_max_dev_high(k,), + ! xm(k+1,) + dt*xm_forcing(k+1) - dt*wm_zt(k+1)*d(xm)/dz|_(k+1) + ! + x_max_dev_high(k+1,) }; + ! + ! where x_max_dev_low is the absolute value of the deviation from the mean + ! of the smallest point value of variable x at the given vertical level and + ! timestep; and where x_max_dev_high is the deviation from the mean of the + ! largest point value of variable x at the given vertical level and + ! timestep. For example, at vertical level (k+1) and timestep (t): + ! + ! x_max_dev_low(k+1,) = | MIN( x(k+1,) ) - xm(k+1,) |; + ! x_max_dev_high(k+1,) = MAX( x(k+1,) ) - xm(k+1,). + ! + ! The inequality shown above only takes into account values from the central + ! level, one-level-below the central level, and one-level-above the central + ! level. This is the minimal amount of vertical levels that can have their + ! values taken into consideration. Any vertical level that can have it's + ! properties advect to the given level during the course of a single time + ! step can be taken into consideration. However, only three levels will be + ! considered in this example for the sake of simplicity. + ! + ! The inequality will be written in more simple terms: + ! + ! xm_lower_lim_allowable(k) <= xm(k,) <= xm_upper_lim_allowable(k). + ! + ! The inequality can now be related to the turbulent flux, w'x'(k,), + ! through a substitution that is made for xm(k,), such that: + ! + ! xm(k,) = xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - dt * (1/rho_ds) * d( rho_ds * w'x' )/dz|_(k). + ! + ! The inequality becomes: + ! + ! xm_lower_lim_allowable(k) + ! <= + ! xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - dt * (1/rho_ds) * d( rho_ds * w'x' )/dz|_(k) + ! <= + ! xm_upper_lim_allowable(k). + ! + ! The inequality is rearranged, and the turbulent advection term, + ! d(w'x')/dz, is discretized: + ! + ! xm_lower_lim_allowable(k) + ! - [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) ] + ! <= + ! - dt * (1/rho_ds_zt(k)) + ! * invrs_dzt(k) + ! * [ rho_ds_zm(k) * w'x'(k,) + ! - rho_ds_zm(k-1) * w'x'(k-1,) ] + ! <= + ! xm_upper_lim_allowable(k) + ! - [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) ]; + ! + ! where invrs_dzt(k) = 1 / ( zm(k) - zm(k-1) ). + ! + ! Multiplying the inequality by -rho_ds_zt(k)/(dz*invrs_dzt(k)): + ! + ! rho_ds_zt(k)/(dz*invrs_dzt(k)) + ! * [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_lower_lim_allowable(k) ] + ! >= + ! rho_ds_zm(k) * w'x'(k,) - rho_ds_zm(k-1) * w'x'(k-1,) + ! >= + ! rho_ds_zt(k)/(dz*invrs_dzt(k)) + ! * [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_upper_lim_allowable(k) ]. + ! + ! Note: The inequality symbols have been flipped due to multiplication + ! involving a (-) sign. + ! + ! Adding rho_ds_zm(k-1) * w'x'(k-1,) to the inequality: + ! + ! rho_ds_zt(k)/(dz*invrs_dzt(k)) + ! * [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_lower_lim_allowable(k) ] + ! + rho_ds_zm(k-1) * w'x'(k-1,) + ! >= rho_ds_zm(k) * w'x'(k,) >= + ! rho_ds_zt(k)/(dz*invrs_dzt(k)) + ! * [ xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_upper_lim_allowable(k) ] + ! + rho_ds_zm(k-1) * w'x'(k-1,). + ! + ! The inequality is then rearranged to be based around w'x'(k,): + ! + ! (1/rho_ds_zm(k)) + ! * [ rho_ds_zt(k)/(dt*invrs_dzt(k)) + ! * { xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_lower_lim_allowable(k) } + ! + rho_ds_zm(k-1) * w'x'(k-1,) ] + ! >= w'x'(k,) >= + ! (1/rho_ds_zm(k)) + ! * [ rho_ds_zt(k)/(dt*invrs_dzt(k)) + ! * { xm(k,) + dt*xm_forcing(k) - dt*wm_zt(k)*d(xm)/dz|_(k) + ! - xm_upper_lim_allowable(k) } + ! + rho_ds_zm(k-1) * w'x'(k-1,) ]. + ! + ! The values of w'x' are found on the momentum levels, while the values of + ! xm are found on the thermodynamic levels. Additionally, the values of + ! rho_ds_zm are found on the momentum levels, and the values of rho_ds_zt + ! are found on the thermodynamic levels. The inequality is applied to + ! w'x'(k,) from vertical levels 2 through the second-highest level + ! (gr%nz-1). The value of w'x' at level 1 is a set surface (or lowest + ! level) flux. The value of w'x' at the highest level is also a set value, + ! and therefore is not altered. + ! + ! Approximating maximum and minimum values of x at any given vertical level + ! ------------------------------------------------------------------------- + ! + ! The CLUBB code provides means, variances, and covariances for certain + ! variables at all vertical levels. However, there is no way to find the + ! maximum or minimum point value of any variable on any vertical level. + ! Without that information, x_max_dev_low and x_max_dev_high can't be found, + ! and the inequality above is useless. However, there is a way to + ! approximate the maximum and minimum point values at any given vertical + ! level. The maximum and minimum point values can be approximated through + ! the use of the variance, x'^2. + ! + ! Just as the mean value of x, which is xm, and the turbulent flux of x, + ! which is w'x', are known, so is the variance of x, which is x'^2. The + ! standard deviation of x is the square root of the variance of x. The + ! distribution of x along the horizontal plane (at vertical level k) is + ! approximated to be the sum of two normal (or Gaussian) distributions. + ! Most of the values in a normal distribution are found within 2 standard + ! deviations from the mean. Thus, the maximum point value of x along the + ! horizontal plance at any vertical level can be approximated as: + ! xm + 2*sqrt(x'^2). Likewise, the minimum value of x along the horizontal + ! plane at any vertical level can be approximated as: xm - 2*sqrt(x'^2). + ! + ! The values of x'^2 are found on the momentum levels. The values of xm + ! are found on the thermodynamic levels. Thus, the values of x'^2 are + ! interpolated to the thermodynamic levels in order to find the maximum + ! and minimum point values of variable x. + ! + ! The one downfall of this method is that instabilities can arise in the + ! model where unphysically large values of x'^2 are produced. Thus, this + ! allows for an unphysically large deviation of xm from its values at the + ! previous time step due to turbulent advection. Thus, for purposes of + ! determining the maximum and minimum point values of x, a upper limit + ! is placed on x'^2, in order to limit the standard deviation of x. This + ! limit is only applied in this subroutine, and is not applied to x'^2 + ! elsewhere in the model code. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt ! Procedure(s) + + use constants_clubb, only: & + zero_threshold, & + eps, & + fstderr + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + fatal_error, & ! Procedure(s) + clubb_no_error ! Constant + + use fill_holes, only: & + vertical_integral ! Procedure(s) + + use stats_type_utilities, only: & + stat_begin_update, & ! Procedure(s) + stat_end_update, & + stat_update_var + + use stats_variables, only: & + stats_zm, & ! Variable(s) + stats_zt, & + iwprtp_mfl, & + irtm_mfl, & + iwpthlp_mfl, & + ithlm_mfl, & + ithlm_old, & + ithlm_without_ta, & + ithlm_mfl_min, & + ithlm_mfl_max, & + irtm_old, & + irtm_without_ta, & + irtm_mfl_min, & + irtm_mfl_max, & + ithlm_enter_mfl, & + ithlm_exit_mfl, & + irtm_enter_mfl, & + irtm_exit_mfl, & + iwpthlp_mfl_min, & + iwpthlp_mfl_max, & + iwpthlp_entermfl, & + iwpthlp_exit_mfl, & + iwprtp_mfl_min, & + iwprtp_mfl_max, & + iwprtp_enter_mfl, & + iwprtp_exit_mfl, & + l_stats_samp + + implicit none + + ! Constant Parameters + + ! Flag for using a semi-implicit, tridiagonal method to solve for xm(t+1) + ! when xm(t+1) needs to be changed. + logical, parameter :: l_mfl_xm_imp_adj = .true. + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variables being solved for. + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm_old, & ! xm at previous time step (thermo. levs.) [units vary] + xp2, & ! x'^2 (momentum levels) [units vary] + wm_zt, & ! w wind component on thermodynamic levels [m/s] + xm_forcing, & ! xm forcings (thermodynamic levels) [units vary] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ moment. levs. [m^3/kg] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + real( kind = core_rknd ), intent(in) :: & + xp2_threshold, & ! Lower limit of x'^2 [units vary] + xm_tol ! Lower limit of maxdev [units vary] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + integer, dimension(gr%nz), intent(in) :: & + low_lev_effect, & ! Index of lowest level that has an effect (for lev. k) + high_lev_effect ! Index of highest level that has an effect (for lev. k) + + ! Input/Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + xm, & ! xm at current time step (thermodynamic levels) [units vary] + wpxp ! w'x' (momentum levels) [units vary] + + ! Output Variable + integer, intent(out) :: & + err_code ! Returns an error code in the event of a singular matrix + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + xp2_zt, & ! x'^2 interpolated to thermodynamic levels [units vary] + xm_enter_mfl, & ! xm as it enters the MFL [units vary] + xm_without_ta, & ! Value of xm without turb. adv. contrib. [units vary] + wpxp_net_adjust, & ! Net amount of adjustment needed on w'x' [units vary] + dxm_dt_mfl_adjust ! Rate of change of adjustment to xm [units vary] + + real( kind = core_rknd ), dimension(gr%nz) :: & + min_x_allowable_lev, & ! Smallest usuable value of x at lev k [units vary] + max_x_allowable_lev, & ! Largest usuable value of x at lev k [units vary] + min_x_allowable, & ! Smallest usuable x within k +/- num_levs [units vary] + max_x_allowable, & ! Largest usuable x within k +/- num_levs [units vary] + wpxp_mfl_max, & ! Upper limit on w'x'(k) [units vary] + wpxp_mfl_min ! Lower limit on w'x'(k) [units vary] + + real( kind = core_rknd ) :: & + max_xp2, & ! Maximum allowable x'^2 [units vary] + stnd_dev_x, & ! Standard deviation of x [units vary] + max_dev, & ! Determines approximate upper/lower limit of x [units vary] + m_adv_term, & ! Contribution of mean advection to d(xm)/dt [units vary] + xm_density_weighted, & ! Density weighted xm at domain top [units vary] + xm_adj_coef, & ! Coeffecient to eliminate spikes at domain top [units vary] + xm_vert_integral, & ! Vertical integral of xm [units_vary] + dz ! zm grid spacing at top of domain [m] + + real( kind = core_rknd ), dimension(3,gr%nz) :: & + lhs_mfl_xm ! Left hand side of tridiagonal matrix + + real( kind = core_rknd ), dimension(gr%nz) :: & + rhs_mfl_xm ! Right hand side of tridiagonal matrix equation + + integer :: & + k, km1 ! Array indices + +! integer, parameter :: & +! num_levs = 10 ! Number of levels above and below level k to look for +! ! maxima and minima of variable x. + + integer :: & + low_lev, & ! Lowest level (from level k) to look for x minima and maxima + high_lev ! Highest level (from level k) to look for x minima and maxima + + integer :: & + iwpxp_mfl, & + ixm_mfl + + !--- Begin Code --- + err_code = clubb_no_error ! Initialize to the value for no errors + + ! Default Initialization required due to G95 compiler warning + max_xp2 = 0.0_core_rknd + dz = 0.0_core_rknd + + select case( solve_type ) + case ( mono_flux_rtm ) ! rtm/wprtp + iwpxp_mfl = iwprtp_mfl + ixm_mfl = irtm_mfl + max_xp2 = 5.0e-6_core_rknd + case ( mono_flux_thlm ) ! thlm/wpthlp + iwpxp_mfl = iwpthlp_mfl + ixm_mfl = ithlm_mfl + max_xp2 = 5.0_core_rknd + case default ! passive scalars are involved + iwpxp_mfl = 0 + ixm_mfl = 0 + max_xp2 = 5.0_core_rknd + end select + + + if ( l_stats_samp ) then + call stat_begin_update( iwpxp_mfl, wpxp / dt, stats_zm ) + call stat_begin_update( ixm_mfl, xm / dt, stats_zt ) + endif + if ( l_stats_samp .and. solve_type == mono_flux_thlm ) then + call stat_update_var( ithlm_enter_mfl, xm, stats_zt ) + call stat_update_var( ithlm_old, xm_old, stats_zt ) + call stat_update_var( iwpthlp_entermfl, xm, stats_zm ) + elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then + call stat_update_var( irtm_enter_mfl, xm, stats_zt ) + call stat_update_var( irtm_old, xm_old, stats_zt ) + call stat_update_var( iwprtp_enter_mfl, xm, stats_zm ) + endif + + ! Initialize arrays. + wpxp_net_adjust = 0.0_core_rknd + dxm_dt_mfl_adjust = 0.0_core_rknd + + ! Store the value of xm as it enters the mfl + xm_enter_mfl = xm + + ! Interpolate x'^2 to thermodynamic levels. + xp2_zt = max( zm2zt( xp2 ), xp2_threshold ) + + ! Place an upper limit on xp2_zt. + ! For purposes of this subroutine, an upper limit has been placed on the + ! variance, x'^2. This does not effect the value of x'^2 anywhere else in + ! the model code. The upper limit is a reasonable upper limit. This is + ! done to prevent unphysically large standard deviations caused by numerical + ! instabilities in the x'^2 profile. + xp2_zt = min( xp2_zt, max_xp2 ) + + ! Find the maximum and minimum usuable values of variable x at each + ! vertical level. Start from level 2, which is the first level above + ! the ground (or above the model surface). This computation needs to be + ! performed for all vertical levels above the ground (or model surface). + do k = 2, gr%nz, 1 + + km1 = max( k-1, 1 ) + !kp1 = min( k+1, gr%nz ) + + ! Standard deviation is the square root of the variance. + stnd_dev_x = sqrt( xp2_zt(k) ) + + ! Most values are found within +/- 2 standard deviations from the mean. + ! Use +/- 2 standard deviations from the mean as the maximum/minimum + ! values. + ! max_dev = 2.0_core_rknd*stnd_dev_x + + ! Set a minimum on max_dev + max_dev = max(2.0_core_rknd * stnd_dev_x, xm_tol) + + ! Calculate the contribution of the mean advection term: + ! m_adv_term = -wm_zt(k)*d(xm)/dz|_(k). + ! Note: mean advection is not applied to xm at level gr%nz. + !if ( .not. l_implemented .and. k < gr%nz ) then + ! tmp(1:3) = term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k ) + ! m_adv_term = - tmp(1) * xm(kp1) & + ! - tmp(2) * xm(k) & + ! - tmp(3) * xm(km1) + !else + ! m_adv_term = 0.0_core_rknd + !endif + + ! Shut off to avoid using new, possibly corrupt mean advection term + m_adv_term = 0.0_core_rknd + + ! Find the value of xm without the contribution from the turbulent + ! advection term. + ! Note: the contribution of xm_forcing at level gr%nz should be 0. + xm_without_ta(k) = xm_old(k) + dt*xm_forcing(k) & + + dt*m_adv_term + + ! Find the minimum usuable value of variable x at each vertical level. + ! Since variable x must be one of theta_l, r_t, or a scalar, all of + ! which are positive definite quantities, the value must be >= 0. + min_x_allowable_lev(k) & + = max( xm_without_ta(k) - max_dev, zero_threshold ) + + ! Find the maximum usuable value of variable x at each vertical level. + max_x_allowable_lev(k) = xm_without_ta(k) + max_dev + + enddo + + ! Boundary condition on xm_without_ta + k = 1 + xm_without_ta(k) = xm(k) + min_x_allowable_lev(k) = min_x_allowable_lev(k+1) + max_x_allowable_lev(k) = max_x_allowable_lev(k+1) + + ! Find the maximum and minimum usuable values of x that can effect the value + ! of x at level k. Then, find the upper and lower limits of w'x'. Reset + ! the value of w'x' if it is outside of those limits, and store the amount + ! of adjustment that was needed to w'x'. + ! The values of w'x' at level 1 and at level gr%nz are set values and + ! are not altered. + do k = 2, gr%nz-1, 1 + + km1 = max( k-1, 1 ) + + low_lev = max( low_lev_effect(k), 2 ) + high_lev = min( high_lev_effect(k), gr%nz ) + !low_lev = max( k-num_levs, 2 ) + !high_lev = min( k+num_levs, gr%nz ) + + ! Find the smallest value of all relevant level minima for variable x. + min_x_allowable(k) = minval( min_x_allowable_lev(low_lev:high_lev) ) + + ! Find the largest value of all relevant level maxima for variable x. + max_x_allowable(k) = maxval( max_x_allowable_lev(low_lev:high_lev) ) + + ! Find the upper limit for w'x' for a monotonic turbulent flux. + wpxp_mfl_max(k) & + = invrs_rho_ds_zm(k) & + * ( ( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) & + * ( xm_without_ta(k) - min_x_allowable(k) ) & + + rho_ds_zm(km1) * wpxp(km1) ) + + ! Find the lower limit for w'x' for a monotonic turbulent flux. + wpxp_mfl_min(k) & + = invrs_rho_ds_zm(k) & + * ( ( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) & + * ( xm_without_ta(k) - max_x_allowable(k) ) & + + rho_ds_zm(km1) * wpxp(km1) ) + + if ( wpxp(k) > wpxp_mfl_max(k) ) then + + ! This block of print statements can be uncommented for debugging. + !print *, "k = ", k + !print *, "wpxp too large (mfl)" + !print *, "xm(t) = ", xm_old(k) + !print *, "xm(t+1) entering mfl = ", xm(k) + !print *, "xm(t+1) without ta = ", xm_without_ta(k) + !print *, "max x allowable = ", max_x_allowable(k) + !print *, "min x allowable = ", min_x_allowable(k) + !print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k) + !print *, "rho_ds_zt(k) = ", rho_ds_zt(k) + !print *, "rho_ds_zt(k)*(delta_zt/dt) = ", & + ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) + !print *, "xm without ta - min x allow = ", & + ! xm_without_ta(k) - min_x_allowable(k) + !print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1) + !print *, "wpxp(km1) = ", wpxp(km1) + !print *, "rho_ds_zm(km1) * wpxp(km1) = ", rho_ds_zm(km1) * wpxp(km1) + !print *, "wpxp upper lim = ", wpxp_mfl_max(k) + !print *, "wpxp before adjustment = ", wpxp(k) + + ! Determine the net amount of adjustment needed for w'x'. + wpxp_net_adjust(k) = wpxp_mfl_max(k) - wpxp(k) + + ! Reset the value of w'x' to the upper limit allowed by the + ! monotonic flux limiter. + wpxp(k) = wpxp_mfl_max(k) + + elseif ( wpxp(k) < wpxp_mfl_min(k) ) then + + ! This block of print statements can be uncommented for debugging. + !print *, "k = ", k + !print *, "wpxp too small (mfl)" + !print *, "xm(t) = ", xm_old(k) + !print *, "xm(t+1) entering mfl = ", xm(k) + !print *, "xm(t+1) without ta = ", xm_without_ta(k) + !print *, "max x allowable = ", max_x_allowable(k) + !print *, "min x allowable = ", min_x_allowable(k) + !print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k) + !print *, "rho_ds_zt(k) = ", rho_ds_zt(k) + !print *, "rho_ds_zt(k)*(delta_zt/dt) = ", & + ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) + !print *, "xm without ta - max x allow = ", & + ! xm_without_ta(k) - max_x_allowable(k) + !print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1) + !print *, "wpxp(km1) = ", wpxp(km1) + !print *, "rho_ds_zm(km1) * wpxp(km1) = ", rho_ds_zm(km1) * wpxp(km1) + !print *, "wpxp lower lim = ", wpxp_mfl_min(k) + !print *, "wpxp before adjustment = ", wpxp(k) + + ! Determine the net amount of adjustment needed for w'x'. + wpxp_net_adjust(k) = wpxp_mfl_min(k) - wpxp(k) + + ! Reset the value of w'x' to the lower limit allowed by the + ! monotonic flux limiter. + wpxp(k) = wpxp_mfl_min(k) + + ! This block of code can be uncommented for debugging. + !else + ! + ! ! wpxp(k) is okay. + ! if ( wpxp_net_adjust(km1) /= 0.0_core_rknd ) then + ! print *, "k = ", k + ! print *, "wpxp is in an acceptable range (mfl)" + ! print *, "xm(t) = ", xm_old(k) + ! print *, "xm(t+1) entering mfl = ", xm(k) + ! print *, "xm(t+1) without ta = ", xm_without_ta(k) + ! print *, "max x allowable = ", max_x_allowable(k) + ! print *, "min x allowable = ", min_x_allowable(k) + ! print *, "1/rho_ds_zm(k) = ", invrs_rho_ds_zm(k) + ! print *, "rho_ds_zt(k) = ", rho_ds_zt(k) + ! print *, "rho_ds_zt(k)*(delta_zt/dt) = ", & + ! real( rho_ds_zt(k) / (dt*gr%invrs_dzt(k)) ) + ! print *, "xm without ta - min x allow = ", & + ! xm_without_ta(k) - min_x_allowable(k) + ! print *, "xm without ta - max x allow = ", & + ! xm_without_ta(k) - max_x_allowable(k) + ! print *, "rho_ds_zm(km1) = ", rho_ds_zm(km1) + ! print *, "wpxp(km1) = ", wpxp(km1) + ! print *, "rho_ds_zm(km1) * wpxp(km1) = ", & + ! rho_ds_zm(km1) * wpxp(km1) + ! print *, "wpxp upper lim = ", wpxp_mfl_max(k) + ! print *, "wpxp lower lim = ", wpxp_mfl_min(k) + ! print *, "wpxp (stays the same) = ", wpxp(k) + ! endif + ! + endif + + enddo + + ! Boundary conditions + min_x_allowable(1) = 0._core_rknd + max_x_allowable(1) = 0._core_rknd + + min_x_allowable(gr%nz) = 0._core_rknd + max_x_allowable(gr%nz) = 0._core_rknd + + wpxp_mfl_min(1) = 0._core_rknd + wpxp_mfl_max(1) = 0._core_rknd + + wpxp_mfl_min(gr%nz) = 0._core_rknd + wpxp_mfl_max(gr%nz) = 0._core_rknd + + if ( l_stats_samp .and. solve_type == mono_flux_thlm ) then + call stat_update_var( ithlm_without_ta, xm_without_ta, stats_zt ) + call stat_update_var( ithlm_mfl_min, min_x_allowable, stats_zt ) + call stat_update_var( ithlm_mfl_max, max_x_allowable, stats_zt ) + call stat_update_var( iwpthlp_mfl_min, wpxp_mfl_min, stats_zm ) + call stat_update_var( iwpthlp_mfl_max, wpxp_mfl_max, stats_zm ) + elseif ( l_stats_samp .and. solve_type == mono_flux_rtm ) then + call stat_update_var( irtm_without_ta, xm_without_ta, stats_zt ) + call stat_update_var( irtm_mfl_min, min_x_allowable, stats_zt ) + call stat_update_var( irtm_mfl_max, max_x_allowable, stats_zt ) + call stat_update_var( iwprtp_mfl_min, wpxp_mfl_min, stats_zm ) + call stat_update_var( iwprtp_mfl_max, wpxp_mfl_max, stats_zm ) + endif + + + if ( any( wpxp_net_adjust(:) /= 0.0_core_rknd ) ) then + + ! Reset the value of xm to compensate for the change to w'x'. + + if ( l_mfl_xm_imp_adj ) then + + ! A tridiagonal matrix is used to semi-implicitly re-solve for the + ! values of xm at timestep index (t+1). + + ! Set up the left-hand side of the tridiagonal matrix equation. + call mfl_xm_lhs( dt, wm_zt, l_implemented, & + lhs_mfl_xm ) + + ! Set up the right-hand side of tridiagonal matrix equation. + call mfl_xm_rhs( dt, xm_old, wpxp, xm_forcing, & + rho_ds_zm, invrs_rho_ds_zt, & + rhs_mfl_xm ) + + ! Solve the tridiagonal matrix equation. + call mfl_xm_solve( solve_type, lhs_mfl_xm, rhs_mfl_xm, & + xm, err_code ) + + ! Check for errors + if ( fatal_error( err_code ) ) return + + else ! l_mfl_xm_imp_adj = .false. + + ! An explicit adjustment is made to the values of xm at timestep + ! index (t+1), which is based upon the array of the amounts of w'x' + ! adjustments. + + do k = 2, gr%nz, 1 + + km1 = max( k-1, 1 ) + + ! The rate of change of the adjustment to xm due to the monotonic + ! flux limiter. + dxm_dt_mfl_adjust(k) & + = - invrs_rho_ds_zt(k) & + * gr%invrs_dzt(k) & + * ( rho_ds_zm(k) * wpxp_net_adjust(k) & + - rho_ds_zm(km1) * wpxp_net_adjust(km1) ) + + ! The net change to xm due to the monotonic flux limiter is the + ! rate of change multiplied by the time step length. Add the + ! product to xm to find the new xm resulting from the monotonic + ! flux limiter. + xm(k) = xm(k) + dxm_dt_mfl_adjust(k) * dt + + enddo + + ! Boundary condition on xm + xm(1) = xm(2) + + endif ! l_mfl_xm_imp_adj + + ! This code can be uncommented for debugging. + !do k = 1, gr%nz, 1 + ! print *, "k = ", k, "xm(t) = ", xm_old(k), "new xm(t+1) = ", xm(k) + !enddo + + !Ensure there are no spikes at the top of the domain + if (abs( xm(gr%nz) - xm_enter_mfl(gr%nz) ) > 10._core_rknd * xm_tol) then + dz = gr%zm(gr%nz) - gr%zm(gr%nz - 1) + + xm_density_weighted = rho_ds_zt(gr%nz) & + * (xm(gr%nz) - xm_enter_mfl(gr%nz)) & + * dz + + xm_vert_integral & + = vertical_integral & + ( ((gr%nz - 1) - 2 + 1), rho_ds_zt(2:gr%nz - 1), & + xm(2:gr%nz - 1), gr%invrs_dzt(2:gr%nz - 1) ) + + !Check to ensure the vertical integral is not zero to avoid a divide + !by zero error + if (xm_vert_integral < eps) then + write(fstderr,*) "Vertical integral of xm is zero;", & + "mfl will remove spike at top of domain,", & + "but it will not conserve xm." + + !Remove the spike at the top of the domain + xm(gr%nz) = xm_enter_mfl(gr%nz) + else + xm_adj_coef = xm_density_weighted / xm_vert_integral + + !xm_adj_coef can not be smaller than -1 + if (xm_adj_coef < -0.99_core_rknd) then + write(fstderr,*) "xm_adj_coef in mfl less than -0.99, " & + // "mx_adj_coef set to -0.99" + xm_adj_coef = -0.99_core_rknd + endif + + !Apply the adjustment + xm = xm * (1._core_rknd + xm_adj_coef) + + !Remove the spike at the top of the domain + xm(gr%nz) = xm_enter_mfl(gr%nz) + + !This code can be uncommented to ensure conservation + !if (abs(sum(rho_ds_zt(2:gr%nz) * xm(2:gr%nz) / gr%invrs_dzt(2:gr%nz)) - & + ! sum(rho_ds_zt(2:gr%nz) * xm_enter_mfl(2:gr%nz) / gr%invrs_dzt(2:gr%nz)))& + ! > (1000 * xm_tol)) then + ! write(fstderr,*) "NON-CONSERVATION in MFL", trim( solve_type ), & + ! abs(sum(rho_ds_zt(2:gr%nz) * xm(2:gr%nz) / gr%invrs_dzt(2:gr%nz)) - & + ! sum(rho_ds_zt(2:gr%nz) * xm_enter_mfl(2:gr%nz) / & + ! gr%invrs_dzt(2:gr%nz))) + ! + ! write(fstderr,*) "XM_ENTER_MFL=", xm_enter_mfl + ! write(fstderr,*) "XM_AFTER_SPIKE_REMOVAL", xm + ! write(fstderr,*) "XM_TOL", xm_tol + ! write(fstderr,*) "XM_ADJ_COEF", xm_adj_coef + !endif + + endif ! xm_vert_integral < eps + endif ! spike at domain top + + endif ! any( wpxp_net_adjust(:) /= 0.0_core_rknd ) + + + if ( l_stats_samp ) then + + call stat_end_update( iwpxp_mfl, wpxp / dt, stats_zm ) + + call stat_end_update( ixm_mfl, xm / dt, stats_zt ) + + if ( solve_type == mono_flux_thlm ) then + call stat_update_var( ithlm_exit_mfl, xm, stats_zt ) + call stat_update_var( iwpthlp_exit_mfl, xm, stats_zm ) + elseif ( solve_type == mono_flux_rtm ) then + call stat_update_var( irtm_exit_mfl, xm, stats_zt ) + call stat_update_var( iwprtp_exit_mfl, xm, stats_zm ) + endif + + endif + + + return + end subroutine monotonic_turbulent_flux_limit + + !============================================================================= + subroutine mfl_xm_lhs( dt, wm_zt, l_implemented, & + lhs ) + + ! Description: + ! This subroutine is part of the process of re-solving for xm at timestep + ! index (t+1). This is done because the original solving process produced + ! values outside of what is deemed acceptable by the monotonic flux limiter. + ! Unlike the original formulation for advancing xm one timestep, which + ! combines w'x' and xm in a band-diagonal solver, this formulation uses a + ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1) + ! is known. + ! + ! Subroutine mfl_xm_lhs sets up the left-hand side of the matrix equation. + + use grid_class, only: & + gr ! Variable(s) + + use mean_adv, only: & + term_ma_zt_lhs ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + wm_zt ! w wind component on thermodynamic levels [m/s] + + logical, intent(in) :: & + l_implemented ! Flag for CLUBB being implemented in a larger model. + + ! Output Variables + real( kind = core_rknd ), dimension(3,gr%nz), intent(out) :: & + lhs ! Left hand side of tridiagonal matrix + + ! Local Variables + integer :: k, km1 ! Array index + + + !----------------------------------------------------------------------- + + ! Initialize the left-hand side matrix to 0. + lhs = 0.0_core_rknd + + + ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at + ! level k = 1, which is below the model surface, is simply set equal to the + ! value of xm at level k = 2 after the solve has been completed. + + ! Setup LHS of the tridiagonal system + do k = 2, gr%nz, 1 + + km1 = max( k-1,1 ) + + ! LHS xm mean advection (ma) term. + if ( .not. l_implemented ) then + + lhs(kp1_tdiag:km1_tdiag,k) & + = lhs(kp1_tdiag:km1_tdiag,k) & + + term_ma_zt_lhs( wm_zt(k), gr%invrs_dzt(k), k, gr%invrs_dzm(k), gr%invrs_dzm(km1) ) + + else + + lhs(kp1_tdiag:km1_tdiag,k) & + = lhs(kp1_tdiag:km1_tdiag,k) + 0.0_core_rknd + + endif + + ! LHS xm time tendency. + lhs(k_tdiag,k) & + = lhs(k_tdiag,k) + 1.0_core_rknd / dt + + enddo ! xm loop: 2..gr%nz + + ! Boundary conditions. + + ! Lower boundary + k = 1 + lhs(:,k) = 0.0_core_rknd + lhs(k_tdiag,k) = 1.0_core_rknd + + return + end subroutine mfl_xm_lhs + + !============================================================================= + subroutine mfl_xm_rhs( dt, xm_old, wpxp, xm_forcing, & + rho_ds_zm, invrs_rho_ds_zt, & + rhs ) + + ! Description: + ! This subroutine is part of the process of re-solving for xm at timestep + ! index (t+1). This is done because the original solving process produced + ! values outside of what is deemed acceptable by the monotonic flux limiter. + ! Unlike the original formulation for advancing xm one timestep, which + ! combines w'x' and xm in a band-diagonal solver, this formulation uses a + ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1) + ! is known. + ! + ! Subroutine mfl_xm_rhs sets up the right-hand side of the matrix equation. + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm_old, & ! xm; timestep (t) (thermodynamic levels) [units vary] + wpxp, & ! w'x'; timestep (t+1); limited (m-levs.) [units vary] + xm_forcing, & ! xm forcings (thermodynamic levels) [units vary] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + invrs_rho_ds_zt ! Inv. dry, static density @ thermo. levs. [m^3/kg] + + ! Output Variable + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + rhs ! Right hand side of tridiagonal matrix equation + + ! Local Variables + integer :: k, km1 ! Array indices + + !----------------------------------------------------------------------- + + ! Initialize the right-hand side vector to 0. + rhs = 0.0_core_rknd + + + ! The xm loop runs between k = 2 and k = gr%nz. The value of xm at + ! level k = 1, which is below the model surface, is simply set equal to the + ! value of xm at level k = 2 after the solve has been completed. + + do k = 2, gr%nz, 1 + + ! Define indices + km1 = max( k-1, 1 ) + + ! RHS xm time tendency. + rhs(k) = rhs(k) + xm_old(k) / dt + + ! RHS xm turbulent advection (ta) term. + ! Note: Normally, the turbulent advection (ta) term is treated + ! implicitly when advancing xm one timestep, as both xm and w'x' + ! are advanced together from timestep index (t) to timestep + ! index (t+1). However, in this case, both xm and w'x' have + ! already been advanced one timestep. However, w'x'(t+1) has been + ! limited after the fact, and therefore it's values at timestep + ! index (t+1) are known. Thus, in re-solving for xm(t+1), the + ! derivative of w'x'(t+1) can be placed on the right-hand side of + ! the d(xm)/dt equation. + rhs(k) & + = rhs(k) & + - invrs_rho_ds_zt(k) & + * gr%invrs_dzt(k) & + * ( rho_ds_zm(k) * wpxp(k) - rho_ds_zm(km1) * wpxp(km1) ) + + ! RHS xm forcings. + ! Note: xm forcings include the effects of microphysics, + ! cloud water sedimentation, radiation, and any + ! imposed forcings on xm. + rhs(k) = rhs(k) + xm_forcing(k) + + enddo ! xm loop: 2..gr%nz + + ! Boundary conditions + + ! Lower Boundary + k = 1 + ! The value of xm at the lower boundary will remain the same. However, the + ! value of xm at the lower boundary gets overwritten after the matrix is + ! solved for the next timestep, such that xm(1) = xm(2). + rhs(k) = xm_old(k) + + return + end subroutine mfl_xm_rhs + + !============================================================================= + subroutine mfl_xm_solve( solve_type, lhs, rhs, & + xm, err_code ) + + ! Description: + ! This subroutine is part of the process of re-solving for xm at timestep + ! index (t+1). This is done because the original solving process produced + ! values outside of what is deemed acceptable by the monotonic flux limiter. + ! Unlike the original formulation for advancing xm one timestep, which + ! combines w'x' and xm in a band-diagonal solver, this formulation uses a + ! tridiagonal solver to solve for only the value of xm(t+1), for w'x'(t+1) + ! is known. + ! + ! Subroutine mfl_xm_solve solves the tridiagonal matrix equation for xm at + ! timestep index (t+1). + + use grid_class, only: & + gr ! Variable(s) + + use lapack_wrap, only: & + tridag_solve ! Procedure(s) + + use error_code, only: & + fatal_error, & ! Procedure(s) + clubb_no_error ! Constant + + use clubb_precision, only: & + core_rknd + + implicit none + + ! Constant parameters + integer, parameter :: & + kp1_tdiag = 1, & ! Thermodynamic superdiagonal index. + k_tdiag = 2, & ! Thermodynamic main diagonal index. + km1_tdiag = 3 ! Thermodynamic subdiagonal index. + + ! Input Variables + integer, intent(in) :: & + solve_type ! Variables being solved for. + + real( kind = core_rknd ), dimension(3,gr%nz), intent(inout) :: & + lhs ! Left hand side of tridiagonal matrix + + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + rhs ! Right hand side of tridiagonal matrix equation + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(inout) :: & + xm ! Value of variable being solved for at timestep (t+1) [units vary] + + integer, intent(out) :: & + err_code ! Returns an error code in the event of a singular matrix + + ! Local variable + character(len=10) :: & + solve_type_str ! solve_type as a string for debug output purposes + + !----------------------------------------------------------------------- + + err_code = clubb_no_error ! Initialize to the value for no errors + + select case( solve_type ) + case ( mono_flux_rtm ) + solve_type_str = "rtm" + case ( mono_flux_thlm ) + solve_type_str = "thlm" + case default + solve_type_str = "scalars" + end select + + ! Solve for xm at timestep index (t+1) using the tridiagonal solver. + call tridag_solve & + ( solve_type_str, gr%nz, 1, lhs(kp1_tdiag,:), & ! Intent(in) + lhs(k_tdiag,:), lhs(km1_tdiag,:), rhs, & ! Intent(inout) + xm, err_code ) ! Intent(out) + + ! Check for errors + if ( fatal_error( err_code ) ) return + + ! Boundary condition on xm + xm(1) = xm(2) + + return + end subroutine mfl_xm_solve + + !============================================================================= + subroutine calc_turb_adv_range( dt, w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, & + low_lev_effect, high_lev_effect ) + + ! Description: + ! Calculates the lowermost and uppermost thermodynamic grid levels that can + ! effect the base (or central) thermodynamic level through the effects of + ! turbulent advection over the course of one time step. This is used as + ! part of the monotonic turbulent advection scheme. + ! + ! One method is to use the vertical velocity at each level to determine the + ! amount of time that it takes to travel across that particular grid level. + ! The method is to keep on advancing one grid level until either (a) the + ! total sum of time taken reaches or exceeds the model time step length, + ! (b) the top or bottom of the model is reached, or (c) a level is reached + ! where the vertical velocity component (with turbulence included) is + ! oriented completely opposite of the direction of travel towards the base + ! (or central) thermodynamic level. An example of situation (c) would be, + ! while starting from a higher altitude and searching downward for all + ! upward vertical velocity components, encountering a strong downdraft + ! where the vertical velocity at every single point is oriented downward. + ! Such a situation would occur when the mean vertical velocity (wm_zm) + ! exceeds any turbulent component (w') that would be oriented upwards. + ! + ! Another method is to simply set the thickness (in meters) of the layer + ! that turbulent advection is allowed to act over, for purposes of the + ! monotonic turbulent advection scheme. The lowermost and uppermost + ! grid level that can effect the base (or central) thermodynamic level + ! is computed based on the thickness and altitude of each level. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + logical, parameter :: & + l_constant_thickness = .false. ! Toggle constant or variable thickness. + + real( kind = core_rknd ), parameter :: & + const_thick = 150.0_core_rknd ! Constant thickness value [m] + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep length [s] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] + + ! Output Variables + integer, dimension(gr%nz), intent(out) :: & + low_lev_effect, & ! Index of lowest level that has an effect (for lev. k) + high_lev_effect ! Index of highest level that has an effect (for lev. k) + + ! Local Variables + real( kind = core_rknd ), dimension(gr%nz) :: & + vert_vel_up, & ! Average upwards vertical velocity component [m/s] + vert_vel_down ! Average downwards vertical velocity component [m/s] + + real(kind = core_rknd ) :: & + dt_one_grid_lev, & ! Amount of time to travel one grid box [s] + dt_all_grid_levs ! Running count of amount of time taken to travel [s] + + integer :: k, j + + ! ---- Begin Code ---- + + if ( l_constant_thickness ) then ! thickness is a constant value. + + ! The value of w'x' may only be altered between levels 3 and gr%nz-2. + do k = 3, gr%nz-2, 1 + + ! Compute the number of levels that effect the central thermodynamic + ! level through upwards motion (traveling from lower levels to reach + ! the central thermodynamic level). + + ! Start with the index of the thermodynamic level immediately below + ! the central thermodynamic level. + j = k - 1 + + do ! loop downwards until answer is found. + + if ( gr%zt(k) - gr%zt(j) >= const_thick ) then + + ! Stop, the current grid level is the lowest level that can + ! be considered. + low_lev_effect(k) = j + + exit + + else + + ! Thermodynamic level 1 cannot be considered because it is + ! located below the surface or below the bottom of the model. + ! The lowest level that can be considered is thermodynamic + ! level 2. + if ( j == 2 ) then + + ! The current level (level 2) is the lowest level that can + ! be considered. + low_lev_effect(k) = j + + exit + + else + + ! Increment to the next vertical level down. + j = j - 1 + + endif + + endif + + enddo ! downwards loop + + + ! Compute the number of levels that effect the central thermodynamic + ! level through downwards motion (traveling from higher levels to + ! reach the central thermodynamic level). + + ! Start with the index of the thermodynamic level immediately above + ! the central thermodynamic level. + j = k + 1 + + do ! loop upwards until answer is found. + + if ( gr%zt(j) - gr%zt(k) >= const_thick ) then + + ! Stop, the current grid level is the highest level that can + ! be considered. + high_lev_effect(k) = j + + exit + + else + + ! The highest level that can be considered is thermodynamic + ! level gr%nz. + if ( j == gr%nz ) then + + ! The current level (level gr%nz) is the highest level + ! that can be considered. + high_lev_effect(k) = j + + exit + + else + + ! Increment to the next vertical level up. + j = j + 1 + + endif + + endif + + enddo ! upwards loop + + enddo ! k = 3, gr%nz-2 + + + else ! thickness based on vertical velocity and time step length. + + ! Find the average upwards vertical velocity and the average downwards + ! vertical velocity. + ! Note: A level that has all vertical wind moving downwards will have a + ! vert_vel_up value that is 0, and vice versa. + call mean_vert_vel_up_down( w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & ! In + mixt_frac_zm, 0.0_core_rknd, & ! In + vert_vel_down, vert_vel_up ) + + ! The value of w'x' may only be altered between levels 3 and gr%nz-2. + do k = 3, gr%nz-2, 1 + + ! Compute the number of levels that effect the central thermodynamic + ! level through upwards motion (traveling from lower levels to reach + ! the central thermodynamic level). + + ! Start with the index of the thermodynamic level immediately below + ! the central thermodynamic level. + j = k - 1 + + ! Initialize the overall delta t counter to 0. + dt_all_grid_levs = 0.0_core_rknd + + do ! loop downwards until answer is found. + + ! Continue if there is some component of upwards vertical velocity. + if ( vert_vel_up(j) > 0.0_core_rknd ) then + + ! Compute the amount of time it takes to travel one grid level + ! upwards: delta_t = delta_z / vert_vel_up. + dt_one_grid_lev = (1.0_core_rknd/gr%invrs_dzm(j)) / vert_vel_up(j) + + + ! Total time elapsed for crossing all grid levels that have been + ! passed, thus far. + dt_all_grid_levs = dt_all_grid_levs + dt_one_grid_lev + + ! Stop if has taken more than one model time step (overall) to + ! travel the entire extent of the current vertical grid level. + if ( dt_all_grid_levs >= dt ) then + + ! The current level is the lowest level that can be + ! considered. + low_lev_effect(k) = j + + exit + + ! Continue if the total elapsed time has not reached or exceeded + ! one model time step. + else + + ! Thermodynamic level 1 cannot be considered because it is + ! located below the surface or below the bottom of the model. + ! The lowest level that can be considered is thermodynamic + ! level 2. + if ( j == 2 ) then + + ! The current level (level 2) is the lowest level that can + ! be considered. + low_lev_effect(k) = j + + exit + + else + + ! Increment to the next vertical level down. + j = j - 1 + + endif + + endif + + ! Stop if there isn't a component of upwards vertical velocity. + else + + ! The current level cannot be considered. The lowest level that + ! can be considered is one-level-above the current level. + low_lev_effect(k) = j + 1 + + exit + + endif + + enddo ! downwards loop + + + ! Compute the number of levels that effect the central thermodynamic + ! level through downwards motion (traveling from higher levels to + ! reach the central thermodynamic level). + + ! Start with the index of the thermodynamic level immediately above + ! the central thermodynamic level. + j = k + 1 + + ! Initialize the overall delta t counter to 0. + dt_all_grid_levs = 0.0_core_rknd + + do ! loop upwards until answer is found. + + ! Continue if there is some component of downwards vertical velocity. + if ( vert_vel_down(j-1) < 0.0_core_rknd ) then + + ! Compute the amount of time it takes to travel one grid level + ! downwards: delta_t = - delta_z / vert_vel_down. + ! Note: There is a (-) sign in front of delta_z because the + ! distance traveled is downwards. Since vert_vel_down + ! has a negative value, dt_one_grid_lev will be a + ! positive value. + dt_one_grid_lev = -(1.0_core_rknd/gr%invrs_dzm(j-1)) / vert_vel_down(j-1) + + ! Total time elapsed for crossing all grid levels that have been + ! passed, thus far. + dt_all_grid_levs = dt_all_grid_levs + dt_one_grid_lev + + ! Stop if has taken more than one model time step (overall) to + ! travel the entire extent of the current vertical grid level. + if ( dt_all_grid_levs >= dt ) then + + ! The current level is the highest level that can be + ! considered. + high_lev_effect(k) = j + + exit + + ! Continue if the total elapsed time has not reached or exceeded + ! one model time step. + else + + ! The highest level that can be considered is thermodynamic + ! level gr%nz. + if ( j == gr%nz ) then + + ! The current level (level gr%nz) is the highest level + ! that can be considered. + high_lev_effect(k) = j + + exit + + else + + ! Increment to the next vertical level up. + j = j + 1 + + endif + + endif + + ! Stop if there isn't a component of downwards vertical velocity. + else + + ! The current level cannot be considered. The highest level + ! that can be considered is one-level-below the current level. + high_lev_effect(k) = j - 1 + + exit + + endif + + enddo ! upwards loop + + enddo ! k = 3, gr%nz-2 + + endif ! l_constant_thickness + + + ! Information for levels 1, 2, gr%nz-1, and gr%nz is not needed. + ! However, set the values at these levels for purposes of not having odd + ! values in the arrays. + low_lev_effect(1) = 1 + high_lev_effect(1) = 1 + low_lev_effect(2) = 2 + high_lev_effect(2) = 2 + low_lev_effect(gr%nz-1) = gr%nz-1 + high_lev_effect(gr%nz-1) = gr%nz + low_lev_effect(gr%nz) = gr%nz + high_lev_effect(gr%nz) = gr%nz + + + return + end subroutine calc_turb_adv_range + + !============================================================================= + subroutine mean_vert_vel_up_down( w_1_zm, w_2_zm, varnce_w_1_zm, varnce_w_2_zm, & + mixt_frac_zm, w_ref, & + mean_w_down, mean_w_up ) + + ! Description + ! The values of vertical velocity, along a horizontal plane at any given + ! vertical level, are not allowed by CLUBB to be uniform. In other words, + ! there must be some variance in vertical velocity. This subroutine + ! calculates the mean of all values of vertical velocity, at any given + ! vertical level, that are greater than a certain reference velocity. This + ! subroutine also calculates the mean of all values of vertical velocity, at + ! any given vertical level, that are less than a certain reference velocity. + ! The reference velocity is usually 0 m/s, in which case this subroutine + ! calculates the average positive (upward) velocity and the average negative + ! (downward) velocity. However, the reference velocity may be other values, + ! such as wm_zm, which is the overall mean vertical velocity. If the + ! reference velocity is wm_zm, this subroutine calculates the average of all + ! values of w that are on the positive ("upward") side of the mean and the + ! average of all values of w that are on the negative ("downward") side of + ! the mean. These mean positive and negative vertical velocities are useful + ! in determining how long, on average, it takes a parcel of air, being + ! driven by subgrid updrafts or downdrafts, to traverse the length of the + ! vertical grid level. + ! + ! Method + ! ------ + ! + ! The CLUBB model uses a joint PDF of vertical velocity, liquid water + ! potential temperature, and total water mixing ratio to determine subgrid + ! variability. + ! + ! The values of vertical velocity, w, along an undefined horizontal plane + ! at any vertical level, are considered to approximately follow a + ! distribution that is a mixture of two normal (or Gaussian) distributions. + ! The values of w that are a part of the 1st normal distribution are + ! referred to as w_1, and the values of w that are part of the 2nd normal + ! distribution are referred to as w_2. Note that these distributions + ! overlap, and there are many values of w that are found in both w_1 and w_2. + ! + ! The probability density function (PDF) for w, P(w), is: + ! + ! P(w) = mixt_frac*P(w_1) + (1-mixt_frac)*P(w_2); + ! + ! where "mixt_frac" is the weight of the 1st normal distribution, and P(w_1) and + ! P(w_2) are the equations for the 1st and 2nd normal distributions, + ! respectively: + ! + ! P(w_1) = 1 / ( sigma_w_1 * sqrt(2*PI) ) + ! * EXP[ -(w_1-mu_w_1)^2 / (2*sigma_w_1^2) ]; and + ! + ! P(w_2) = 1 / ( sigma_w_2 * sqrt(2*PI) ) + ! * EXP[ -(w_2-mu_w_2)^2 / (2*sigma_w_2^2) ]. + ! + ! The mean of the 1st normal distribution is mu_w_1, and the standard + ! deviation of the 1st normal distribution is sigma_w_1. The mean of the + ! 2nd normal distribution is mu_w_2, and the standard deviation of the 2nd + ! normal distribution is sigma_w_2. + ! + ! The average value of w, distributed according to the probability + ! distribution, between limits alpha and beta, is: + ! + ! = INT(alpha:beta) w P(w) dw. + ! + ! The average value of w over a certain domain is used to determine the + ! average positive and negative (as compared to the reference velocity) + ! values of w at any vertical level. + ! + ! Average Negative Vertical Velocity + ! ---------------------------------- + ! + ! The average of all values of w in the distribution that are below the + ! reference velocity, w|_ref, is the mean value of w over the domain + ! -inf <= w <= w|_ref, such that: + ! + ! = INT(-inf:w|_ref) w P(w) dw. + ! = mixt_frac * INT(-inf:w|_ref) w_1 P(w_1) dw_1 + ! + (1-mixt_frac) * INT(-inf:w|_ref) w_2 P(w_2) dw_2. + ! + ! For each normal distribution in the mixture of normal distribution, i + ! (where "i" can be 1 or 2): + ! + ! INT(-inf:w|_ref) wi P(wi) dwi = + ! - ( sigma_wi / sqrt(2*PI) ) * EXP[ -(w|_ref-mu_wi)^2 / (2*sigma_wi^2) ] + ! + mu_wi * (1/2)*[ 1 + erf( (w|_ref-mu_wi) / (sqrt(2)*sigma_wi) ) ]; + ! + ! where mu_wi is the mean of w for the ith normal distribution, sigma_wi is + ! the standard deviations of w for the ith normal distribution, and erf( ) + ! is the error function. + ! + ! The mean of all values of w <= w|_ref is: + ! + ! = + ! mixt_frac * { - ( sigma_w_1 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ] + ! + mu_w_1 * (1/2) + ! *[1 + erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] } + ! + (1-mixt_frac) * { - ( sigma_w_2 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ] + ! + mu_w_2 * (1/2) + ! *[1 + erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }. + ! + ! Average Positive Vertical Velocity + ! ---------------------------------- + ! + ! The average of all values of w in the distribution that are above the + ! reference velocity, w|_ref, is the mean value of w over the domain + ! w|_ref <= w <= inf, such that: + ! + ! = INT(w|_ref:inf) w P(w) dw. + ! = mixt_frac * INT(w|_ref:inf) w_1 P(w_1) dw_1 + ! + (1-mixt_frac) * INT(w|_ref:inf) w_2 P(w_2) dw_2. + ! + ! For each normal distribution in the mixture of normal distribution, i + ! (where "i" can be 1 or 2): + ! + ! INT(w|_ref:inf) wi P(wi) dwi = + ! ( sigma_wi / sqrt(2*PI) ) * EXP[ -(w|_ref-mu_wi)^2 / (2*sigma_wi^2) ] + ! + mu_wi * (1/2)*[ 1 - erf( (w|_ref-mu_wi) / (sqrt(2)*sigma_wi) ) ]; + ! + ! where mu_wi is the mean of w for the ith normal distribution, sigma_wi is + ! the standard deviations of w for the ith normal distribution, and erf( ) + ! is the error function. + ! + ! The mean of all values of w >= w|_ref is: + ! + ! = + ! mixt_frac * { ( sigma_w_1 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_1)^2 / (2*sigma_w_1^2) ] + ! + mu_w_1 * (1/2) + ! *[1 - erf( (w|_ref-mu_w_1) / (sqrt(2)*sigma_w_1) )] } + ! + (1-mixt_frac) * { ( sigma_w_2 / sqrt(2*PI) ) + ! * EXP[ -(w|_ref-mu_w_2)^2 / (2*sigma_w_2^2) ] + ! + mu_w_2 * (1/2) + ! *[1 - erf( (w|_ref-mu_w_2) / (sqrt(2)*sigma_w_2) )] }. + ! + ! Special Limitations: + ! -------------------- + ! + ! A normal distribution has a domain from -inf to inf. However, the mixture + ! of normal distributions is an approximation of the distribution of values + ! of w along a horizontal plane at any given vertical level. Vertical + ! velocity, w, has absolute minimum and maximum values (that cannot be + ! predicted by the PDF). The absolute maximum and minimum for each normal + ! distribution is most likely found within 2 or 3 standard deviations of the + ! mean for the relevant normal distribution. In other words, for each + ! normal distribution in the mixture of normal distributions, all the values + ! of w are found within 2 or 3 standard deviations on both sides of the + ! mean. Therefore, if one (or both) of the normal distributions has a mean + ! that is more than 3 standard deviations away from the reference velocity, + ! then that entire w distribution is found on ONE side of the reference + ! velocity. + ! + ! Therefore: + ! + ! a) where mu_wi + 3*sigma_wi <= w|_ref: + ! + ! The entire ith normal distribution of w is on the negative side of + ! w|_ref; and + ! + ! INT(-inf:w|_ref) wi P(wi) dwi = mu_wi; and + ! INT(inf:w|_ref) wi P(wi) dwi = 0. + ! + ! b) where mu_wi - 3*sigma_wi >= w|_ref: + ! + ! The entire ith normal distribution of w is on the positive side of + ! w|_ref; and + ! + ! INT(-inf:w|_ref) wi P(wi) dwi = 0; and + ! INT(inf:w|_ref) wi P(wi) dwi = mu_wi. + ! + ! Note: A value of 3 standard deviations above and below the mean of the + ! ith normal distribution was chosen for the approximate maximum and + ! minimum values of the ith normal distribution because 99.7% of + ! values in a normal distribution are found within 3 standard + ! deviations from the mean (compared to 95.4% for 2 standard + ! deviations). The value of 3 standard deviations provides for a + ! reasonable estimate of the absolute maximum and minimum of w, while + ! covering a great majority of the normal distribution. + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr, & ! Variable(s) + zt2zm ! Procedure(s) + + use constants_clubb, only: & + sqrt_2pi, & + sqrt_2 + + use anl_erf, only: & + erf ! Procedure(s) + ! The error function + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only: & + stats_zm, & ! Variable(s) + imean_w_up, & + imean_w_down, & + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + w_1_zm, & ! Mean w (1st PDF component) [m/s] + w_2_zm, & ! Mean w (2nd PDF component) [m/s] + varnce_w_1_zm, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2_zm, & ! Variance of w (2nd PDF component) [m^2/s^2] + mixt_frac_zm ! Weight of 1st PDF component (Sk_w dependent) [-] + + real( kind = core_rknd ), intent(in) :: & + w_ref ! Reference velocity, w|_ref (normally = 0) [m/s] + + ! Output Variables + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + mean_w_down, & ! Overall mean w (<= w|_ref) [m/s] + mean_w_up ! Overall mean w (>= w|_ref) [m/s] + + ! Local Variables + + real( kind = core_rknd ) :: & + sigma_w_1, & ! Standard deviation of w for 1st normal distribution [m/s] + sigma_w_2, & ! Standard deviation of w for 2nd normal distribution [m/s] + mean_w_down_1st, & ! Mean w (<= w|_ref) from 1st normal distribution [m/s] + mean_w_down_2nd, & ! Mean w (<= w|_ref) from 2nd normal distribution [m/s] + mean_w_up_1st, & ! Mean w (>= w|_ref) from 1st normal distribution [m/s] + mean_w_up_2nd, & ! Mean w (>= w|_ref) from 2nd normal distribution [m/s] + exp_cache, & ! Cache of exponential calculations to reduce runtime + erf_cache ! Cache of error function calculations to reduce runtime + + integer :: k ! Vertical loop index + + ! ---- Begin Code ---- + + ! Loop over momentum levels from 2 to gr%nz-1. Levels 1 and gr%nz + ! are not needed. + do k = 2, gr%nz-1, 1 + + ! Standard deviation of w for the 1st normal distribution. + sigma_w_1 = sqrt( varnce_w_1_zm(k) ) + + ! Standard deviation of w for the 2nd normal distribution. + sigma_w_2 = sqrt( varnce_w_2_zm(k) ) + + + ! Contributions from the 1st normal distribution. + if ( w_1_zm(k) + 3._core_rknd*sigma_w_1 <= w_ref ) then + + ! The entire 1st normal is on the negative side of w|_ref. + mean_w_down_1st = w_1_zm(k) + mean_w_up_1st = 0.0_core_rknd + + elseif ( w_1_zm(k) - 3._core_rknd*sigma_w_1 >= w_ref ) then + + ! The entire 1st normal is on the positive side of w|_ref. + mean_w_down_1st = 0.0_core_rknd + mean_w_up_1st = w_1_zm(k) + + else + + ! The exponential calculation is pulled out as it is reused in both + ! equations. This should save one calculation of the + ! exp( -(w_ref-w_1_zm(k))**2 ... etc. part of the formula. + ! ~~EIHoppe//20090618 + exp_cache = exp( -(w_ref-w_1_zm(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) + + ! Added cache of the error function calculations. + ! This should save one calculation of the erf(...) part + ! of the formula. + ! ~~EIHoppe//20090623 + erf_cache = erf( (w_ref-w_1_zm(k)) / (sqrt_2*sigma_w_1) ) + + ! The 1st normal has values on both sides of w_ref. + mean_w_down_1st = & + - (sigma_w_1/sqrt_2pi) & +! * exp( -(w_ref-w_1_zm(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) & + * exp_cache & +! + w_1(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w_1(k)) / (sqrt_2*sigma_w_1) ) ) + + w_1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) + + mean_w_up_1st = & + + (sigma_w_1/sqrt_2pi) & +! * exp( -(w_ref-w_1(k))**2 / (2.0_core_rknd*sigma_w_1**2) ) & + * exp_cache & +! + w_1(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w_1(k)) / (sqrt_2*sigma_w_1) ) ) + + w_1_zm(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) + + ! /EIHoppe changes + + endif + + + ! Contributions from the 2nd normal distribution. + if ( w_2_zm(k) + 3._core_rknd*sigma_w_2 <= w_ref ) then + + ! The entire 2nd normal is on the negative side of w|_ref. + mean_w_down_2nd = w_2_zm(k) + mean_w_up_2nd = 0.0_core_rknd + + elseif ( w_2_zm(k) - 3._core_rknd*sigma_w_2 >= w_ref ) then + + ! The entire 2nd normal is on the positive side of w|_ref. + mean_w_down_2nd = 0.0_core_rknd + mean_w_up_2nd = w_2_zm(k) + + else + + ! The exponential calculation is pulled out as it is reused in both + ! equations. This should save one calculation of the + ! exp( -(w_ref-w_1(k))**2 ... etc. part of the formula. + ! ~~EIHoppe//20090618 + exp_cache = exp( -(w_ref-w_2_zm(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) + + ! Added cache of the error function calculations. + ! This should save one calculation of the erf(...) part + ! of the formula. + ! ~~EIHoppe//20090623 + erf_cache = erf( (w_ref-w_2_zm(k)) / (sqrt_2*sigma_w_2) ) + + ! The 2nd normal has values on both sides of w_ref. + mean_w_down_2nd = & + - (sigma_w_2/sqrt_2pi) & +! * exp( -(w_ref-w_2_zm(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) & + * exp_cache & +! + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf( (w_ref-w_2(k)) / (sqrt_2*sigma_w_2) ) ) + + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd + erf_cache) + + mean_w_up_2nd = & + + (sigma_w_2/sqrt_2pi) & +! * exp( -(w_ref-w_2(k))**2 / (2.0_core_rknd*sigma_w_2**2) ) & + * exp_cache & +! + w_2(k) * 0.5_core_rknd*( 1.0_core_rknd - erf( (w_ref-w_2(k)) / (sqrt_2*sigma_w_2) ) ) + + w_2_zm(k) * 0.5_core_rknd*( 1.0_core_rknd - erf_cache) + + ! /EIHoppe changes + + endif + + ! Overall mean of downwards w. + mean_w_down(k) = mixt_frac_zm(k) * mean_w_down_1st & + + ( 1.0_core_rknd - mixt_frac_zm(k) ) * mean_w_down_2nd + + ! Overall mean of upwards w. + mean_w_up(k) = mixt_frac_zm(k) * mean_w_up_1st & + + ( 1.0_core_rknd - mixt_frac_zm(k) ) * mean_w_up_2nd + + if ( l_stats_samp ) then + + call stat_update_var_pt( imean_w_up, k, mean_w_up(k), stats_zm ) + + call stat_update_var_pt( imean_w_down, k, mean_w_down(k), stats_zm ) + + endif ! l_stats_samp + + enddo ! k = 2, gr%nz, 1 + + + return + end subroutine mean_vert_vel_up_down + +!=============================================================================== + +end module mono_flux_limiter diff --git a/src/physics/clubb/mt95.f90 b/src/physics/clubb/mt95.f90 new file mode 100644 index 0000000000..cdbb5270ae --- /dev/null +++ b/src/physics/clubb/mt95.f90 @@ -0,0 +1,1319 @@ +! A C-program for MT19937, with initialization improved 2002/1/26. +! Coded by Takuji Nishimura and Makoto Matsumoto. + +! Code converted to Fortran 95 by José Rui Faustino de Sousa +! Date: 2002-02-01 + +! Enhanced version by José Rui Faustino de Sousa +! Date: 2003-04-30 + +! Interface: +! +! Kinds: +! genrand_intg +! Integer kind used must be at least 32 bits. +! genrand_real +! Real kind used +! +! Types: +! genrand_state +! Internal representation of the RNG state. +! genrand_srepr +! Public representation of the RNG state. Should be used to save the RNG state. +! +! Procedures: +! assignment(=) +! Converts from type genrand_state to genrand_srepr and vice versa. +! genrand_init +! Internal RNG state initialization subroutine accepts either an genrand_intg integer +! or a vector as seed or a new state using "put=" returns the present state using +! "get=". If it is called with "get=" before being seeded with "put=" returns a state +! initialized with a default seed. +! genrand_int32 +! Subroutine returns an array or scalar whose elements are random integer on the +! [0,0xffffffff] interval. +! genrand_int31 +! Subroutine returns an array or scalar whose elements are random integer on the +! [0,0x7fffffff] interval. +! genrand_real1 +! Subroutine returns an array or scalar whose elements are random real on the +! [0,1] interval. +! genrand_real2 +! Subroutine returns an array or scalar whose elements are random real on the +! [0,1[ interval. +! genrand_real3 +! Subroutine returns an array or scalar whose elements are random real on the +! ]0,1[ interval. +! genrand_res53 +! Subroutine returns an array or scalar whose elements are random real on the +! [0,1[ interval with 53-bit resolution. + +! Before using, initialize the state by using genrand_init( put=seed ) + +! This library is free software. +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +! Copyright (C) 1997, 2002 Makoto Matsumoto and Takuji Nishimura. +! Any feedback is very welcome. +! http://www.math.keio.ac.jp/matumoto/emt.html +! email: matumoto@math.keio.ac.jp +module mt95 + + implicit none + + public :: genrand_init, assignment(=) + public :: genrand_int32, genrand_int31, genrand_real1 + public :: genrand_real2, genrand_real3, genrand_res53 + private :: uiadd, uisub, uimlt, uidiv, uimod + private :: init_by_type, init_by_scalar, init_by_array, next_state + private :: genrand_encode, genrand_decode, genrand_load_state, genrand_dump_state + private :: genrand_int32_0d, genrand_int32_1d, genrand_int32_2d, genrand_int32_3d + private :: genrand_int32_4d, genrand_int32_5d, genrand_int32_6d, genrand_int32_7d + private :: genrand_int31_0d, genrand_int31_1d, genrand_int31_2d, genrand_int31_3d + private :: genrand_int31_4d, genrand_int31_5d, genrand_int31_6d, genrand_int31_7d + private :: genrand_real1_0d, genrand_real1_1d, genrand_real1_2d, genrand_real1_3d + private :: genrand_real1_4d, genrand_real1_5d, genrand_real1_6d, genrand_real1_7d + private :: genrand_real2_0d, genrand_real2_1d, genrand_real2_2d, genrand_real2_3d + private :: genrand_real2_4d, genrand_real2_5d, genrand_real2_6d, genrand_real2_7d + private :: genrand_real3_0d, genrand_real3_1d, genrand_real3_2d, genrand_real3_3d + private :: genrand_real3_4d, genrand_real3_5d, genrand_real3_6d, genrand_real3_7d + private :: genrand_res53_0d, genrand_res53_1d, genrand_res53_2d, genrand_res53_3d + private :: genrand_res53_4d, genrand_res53_5d, genrand_res53_6d, genrand_res53_7d + + intrinsic :: selected_int_kind, selected_real_kind + + integer, public, parameter :: genrand_intg = selected_int_kind( 9 ) + integer, public, parameter :: genrand_real = selected_real_kind( 15 ) + + integer, private, parameter :: wi = genrand_intg + integer, private, parameter :: wr = genrand_real + + ! Period parameters + integer(kind=wi), private, parameter :: n = 624_wi + integer(kind=wi), private, parameter :: m = 397_wi + + integer(kind=wi), private, parameter :: default_seed = 5489_wi + + integer(kind=wi), private, parameter :: fbs = 32_wi + integer(kind=wi), private, parameter :: hbs = fbs / 2_wi + integer(kind=wi), private, parameter :: qbs = hbs / 2_wi + integer(kind=wi), private, parameter :: tbs = 3_wi * qbs + + real(kind=wr), private, parameter :: p231 = 2147483648.0_wr + real(kind=wr), private, parameter :: p232 = 4294967296.0_wr + real(kind=wr), private, parameter :: p232_1 = p232 - 1.0_wr + real(kind=wr), private, parameter :: pi232 = 1.0_wr / p232 + real(kind=wr), private, parameter :: pi232_1 = 1.0_wr / p232_1 + real(kind=wr), private, parameter :: pi227 = 1.0_wr / 134217728.0_wr + real(kind=wr), private, parameter :: pi253 = 1.0_wr / 9007199254740992.0_wr + real(kind=wr), private, parameter :: p231d232_1 = p231 / p232_1 + real(kind=wr), private, parameter :: p231_5d232 = ( p231 + 0.5_wr ) / p232 + + character(len=*), private, parameter :: alph = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + character(len=*), private, parameter :: sepr = "&" + integer(kind=wi), private, parameter :: alps = 62_wi + integer(kind=wi), private, parameter :: clen = ( n + 1_wi ) * 7_wi !n * ( ceiling( fbs * log( 2.0_core_rknd ) / log( alps ) ) + 1 ) + + type, public :: genrand_state + private + logical(kind=wi) :: ini = .false._wi + integer(kind=wi) :: cnt = n+1_wi + integer(kind=wi), dimension(n) :: val = 0_wi + end type genrand_state + + type, public :: genrand_srepr + character(len=clen) :: repr + end type genrand_srepr + + type(genrand_state), private, save :: state + ! 23 Feb 2015: Threadprivate statement added by NCAR for CAM +!$omp threadprivate( state ) + + interface assignment( = ) + module procedure genrand_load_state + module procedure genrand_dump_state + end interface assignment( = ) + + interface genrand_init + module procedure init_by_type + module procedure init_by_scalar + module procedure init_by_array + end interface genrand_init + + interface genrand_int32 + module procedure genrand_int32_0d + module procedure genrand_int32_1d + module procedure genrand_int32_2d + module procedure genrand_int32_3d + module procedure genrand_int32_4d + module procedure genrand_int32_5d + module procedure genrand_int32_6d + module procedure genrand_int32_7d + end interface genrand_int32 + + interface genrand_int31 + module procedure genrand_int31_0d + module procedure genrand_int31_1d + module procedure genrand_int31_2d + module procedure genrand_int31_3d + module procedure genrand_int31_4d + module procedure genrand_int31_5d + module procedure genrand_int31_6d + module procedure genrand_int31_7d + end interface genrand_int31 + + interface genrand_real1 + module procedure genrand_real1_0d + module procedure genrand_real1_1d + module procedure genrand_real1_2d + module procedure genrand_real1_3d + module procedure genrand_real1_4d + module procedure genrand_real1_5d + module procedure genrand_real1_6d + module procedure genrand_real1_7d + end interface genrand_real1 + + interface genrand_real2 + module procedure genrand_real2_0d + module procedure genrand_real2_1d + module procedure genrand_real2_2d + module procedure genrand_real2_3d + module procedure genrand_real2_4d + module procedure genrand_real2_5d + module procedure genrand_real2_6d + module procedure genrand_real2_7d + end interface genrand_real2 + + interface genrand_real3 + module procedure genrand_real3_0d + module procedure genrand_real3_1d + module procedure genrand_real3_2d + module procedure genrand_real3_3d + module procedure genrand_real3_4d + module procedure genrand_real3_5d + module procedure genrand_real3_6d + module procedure genrand_real3_7d + end interface genrand_real3 + + interface genrand_res53 + module procedure genrand_res53_0d + module procedure genrand_res53_1d + module procedure genrand_res53_2d + module procedure genrand_res53_3d + module procedure genrand_res53_4d + module procedure genrand_res53_5d + module procedure genrand_res53_6d + module procedure genrand_res53_7d + end interface genrand_res53 + + contains + + elemental function uiadd( a, b ) result( c ) + + intrinsic :: ibits, ior, ishft + + integer( kind = wi ), intent( in ) :: a, b + + integer( kind = wi ) :: c + + integer( kind = wi ) :: a1, a2, b1, b2, s1, s2 + + a1 = ibits( a, 0, hbs ) + a2 = ibits( a, hbs, hbs ) + b1 = ibits( b, 0, hbs ) + b2 = ibits( b, hbs, hbs ) + s1 = a1 + b1 + s2 = a2 + b2 + ibits( s1, hbs, hbs ) + c = ior( ishft( s2, hbs ), ibits( s1, 0, hbs ) ) + return + + end function uiadd + + elemental function uisub( a, b ) result( c ) + + intrinsic :: ibits, ior, ishft + + integer( kind = wi ), intent( in ) :: a, b + + integer( kind = wi ) :: c + + integer( kind = wi ) :: a1, a2, b1, b2, s1, s2 + + a1 = ibits( a, 0, hbs ) + a2 = ibits( a, hbs, hbs ) + b1 = ibits( b, 0, hbs ) + b2 = ibits( b, hbs, hbs ) + s1 = a1 - b1 + s2 = a2 - b2 + ibits( s1, hbs, hbs ) + c = ior( ishft( s2, hbs ), ibits( s1, 0, hbs ) ) + return + + end function uisub + + elemental function uimlt( a, b ) result( c ) + + intrinsic :: ibits, ior, ishft + + integer(kind=wi), intent(in) :: a, b + + integer(kind=wi) :: c + + integer(kind=wi) :: a0, a1, a2, a3 + integer(kind=wi) :: b0, b1, b2, b3 + integer(kind=wi) :: p0, p1, p2, p3 + + a0 = ibits( a, 0, qbs ) + a1 = ibits( a, qbs, qbs ) + a2 = ibits( a, hbs, qbs ) + a3 = ibits( a, tbs, qbs ) + b0 = ibits( b, 0, qbs ) + b1 = ibits( b, qbs, qbs ) + b2 = ibits( b, hbs, qbs ) + b3 = ibits( b, tbs, qbs ) + p0 = a0 * b0 + p1 = a1 * b0 + a0 * b1 + ibits( p0, qbs, tbs ) + p2 = a2 * b0 + a1 * b1 + a0 * b2 + ibits( p1, qbs, tbs ) + p3 = a3 * b0 + a2 * b1 + a1 * b2 + a0 * b3 + ibits( p2, qbs, tbs ) + c = ior( ishft( p1, qbs ), ibits( p0, 0, qbs ) ) + c = ior( ishft( p2, hbs ), ibits( c, 0, hbs ) ) + c = ior( ishft( p3, tbs ), ibits( c, 0, tbs ) ) + return + + end function uimlt + + elemental function uidiv( a, b ) result( c ) + + intrinsic :: btest, ishft + + integer(kind=wi), intent(in) :: a, b + + integer(kind=wi) :: c + + integer(kind=wi) :: dl, rl + + if ( btest( a, fbs-1 ) ) then + if ( btest( b, fbs-1 ) ) then + if ( a < b ) then + c = 0 + else + c = 1 + end if + else + dl = ishft( ishft( a, -1 ) / b, 1 ) + rl = uisub( a, uimlt( b, dl ) ) + if ( rl < b ) then + c = dl + else + c = uiadd( dl, 1 ) + end if + end if + else + if ( btest( b, fbs-1 ) ) then + c = 0 + else + c = a / b + end if + end if + return + + end function uidiv + + elemental function uimod( a, b ) result( c ) + + intrinsic :: modulo, btest, ishft + + integer(kind=wi), intent(in) :: a, b + + integer(kind=wi) :: c + + integer(kind=wi) :: dl, rl + + if ( btest( a, fbs-1 ) ) then + if ( btest( b, fbs-1 ) ) then + if ( a < b ) then + c = a + else + c = uisub( a, b ) + end if + else + dl = ishft( ishft( a, -1 ) / b, 1 ) + rl = uisub( a, uimlt( b, dl ) ) + if ( rl < b ) then + c = rl + else + c = uisub( rl, b ) + end if + end if + else + if ( btest( b, fbs-1 ) ) then + c = a + else + c = modulo( a, b ) + end if + end if + return + + end function uimod + + subroutine init_by_type( put, get ) + + intrinsic :: present + + type(genrand_state), optional, intent(in ) :: put + type(genrand_state), optional, intent(out) :: get + + if ( present( put ) ) then + if ( put%ini ) state = put + else if ( present( get ) ) then + if ( .not. state%ini ) call init_by_scalar( default_seed ) + get = state + else + call init_by_scalar( default_seed ) + end if + return + + end subroutine init_by_type + + ! initializes mt[N] with a seed + subroutine init_by_scalar( put ) + + intrinsic :: ishft, ieor, ibits + + integer(kind=wi), parameter :: mult_a = 1812433253_wi !z'6C078965' + + integer(kind=wi), intent(in) :: put + + integer(kind=wi) :: i + + state%ini = .true._wi + state%val(1) = ibits( put, 0, fbs ) + do i = 2, n, 1 + state%val(i) = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) ) + state%val(i) = uimlt( state%val(i), mult_a ) + state%val(i) = uiadd( state%val(i), i-1_wi ) + ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. + ! In the previous versions, MSBs of the seed affect + ! only MSBs of the array mt[]. + ! 2002/01/09 modified by Makoto Matsumoto + state%val(i) = ibits( state%val(i), 0, fbs ) + ! for >32 bit machines + end do + state%cnt = n + 1_wi + return + + end subroutine init_by_scalar + + ! initialize by an array with array-length + ! init_key is the array for initializing keys + ! key_length is its length + subroutine init_by_array( put ) + + intrinsic :: size, max, ishft, ieor, ibits + + integer(kind=wi), parameter :: seed_d = 19650218_wi !z'12BD6AA' + integer(kind=wi), parameter :: mult_a = 1664525_wi !z'19660D' + integer(kind=wi), parameter :: mult_b = 1566083941_wi !z'5D588B65' + integer(kind=wi), parameter :: msb1_d = ishft( 1_wi, fbs-1 ) !z'80000000' + + integer(kind=wi), dimension(:), intent(in) :: put + + integer(kind=wi) :: i, j, k, tp, key_length + + call init_by_scalar( seed_d ) + key_length = size( put, dim=1 ) + i = 2_wi + j = 1_wi + do k = max( n, key_length ), 1, -1 + tp = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) ) + tp = uimlt( tp, mult_a ) + state%val(i) = ieor( state%val(i), tp ) + state%val(i) = uiadd( state%val(i), uiadd( put(j), j-1_wi ) ) ! non linear + state%val(i) = ibits( state%val(i), 0, fbs ) ! for WORDSIZE > 32 machines + i = i + 1_wi + j = j + 1_wi + if ( i > n ) then + state%val(1) = state%val(n) + i = 2_wi + end if + if ( j > key_length) j = 1_wi + end do + do k = n-1, 1, -1 + tp = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) ) + tp = uimlt( tp, mult_b ) + state%val(i) = ieor( state%val(i), tp ) + state%val(i) = uisub( state%val(i), i-1_wi ) ! non linear + state%val(i) = ibits( state%val(i), 0, fbs ) ! for WORDSIZE > 32 machines + i = i + 1_wi + if ( i > n ) then + state%val(1) = state%val(n) + i = 2_wi + end if + end do + state%val(1) = msb1_d ! MSB is 1; assuring non-zero initial array + return + + end subroutine init_by_array + + subroutine next_state( ) + + intrinsic :: ishft, ieor, btest, ibits, mvbits + + integer(kind=wi), parameter :: matrix_a = -1727483681_wi !z'9908b0df' + + integer(kind=wi) :: i, mld + + if ( .not. state%ini ) call init_by_scalar( default_seed ) + do i = 1, n-m, 1 + mld = ibits( state%val(i+1), 0, 31 ) + call mvbits( state%val(i), 31, 1, mld, 31 ) + state%val(i) = ieor( state%val(i+m), ishft( mld, -1 ) ) + if ( btest( state%val(i+1), 0 ) ) state%val(i) = ieor( state%val(i), matrix_a ) + end do + do i = n-m+1, n-1, 1 + mld = ibits( state%val(i+1), 0, 31 ) + call mvbits( state%val(i), 31, 1, mld, 31 ) + state%val(i) = ieor( state%val(i+m-n), ishft( mld, -1 ) ) + if ( btest( state%val(i+1), 0 ) ) state%val(i) = ieor( state%val(i), matrix_a ) + end do + mld = ibits( state%val(1), 0, 31 ) + call mvbits( state%val(n), 31, 1, mld, 31 ) + state%val(n) = ieor( state%val(m), ishft( mld, -1 ) ) + if ( btest( state%val(1), 0 ) ) state%val(n) = ieor( state%val(n), matrix_a ) + state%cnt = 1_wi + return + + end subroutine next_state + + elemental subroutine genrand_encode( chr, val ) + + intrinsic :: len + + character(len=*), intent(out) :: chr + integer(kind=wi), intent(in ) :: val + + integer(kind=wi) :: i, m, d + + d = val + chr = "" + do i = 1, len( chr ), 1 + m = uimod( d, alps ) + 1 + chr(i:i) = alph(m:m) + d = uidiv( d, alps ) + if ( d == 0 ) exit + end do + return + + end subroutine genrand_encode + + elemental subroutine genrand_decode( val, chr ) + + intrinsic :: len, len_trim, trim, adjustl, scan + + integer(kind=wi), intent(out) :: val + character(len=*), intent(in ) :: chr + + integer(kind=wi) :: i, e, p + character(len=len(chr)) :: c + + e = 1 + c = trim( adjustl( chr ) ) + val = 0 + do i = 1, len_trim( c ), 1 + p = scan( alph, c(i:i) ) - 1 + if( p >= 0 ) then + val = uiadd( val, uimlt( p, e ) ) + e = uimlt( e, alps ) + end if + end do + return + + end subroutine genrand_decode + + elemental subroutine genrand_load_state( stt, rpr ) + + intrinsic :: scan + + type(genrand_state), intent(out) :: stt + type(genrand_srepr), intent(in ) :: rpr + + integer(kind=wi) :: i, j + character(len=clen) :: c + + i = 1 + c = rpr%repr + do + j = scan( c, sepr ) + if ( j /= 0 ) then + call genrand_decode( stt%val(i), c(:j-1) ) + i = i + 1 + c = c(j+1:) + else + exit + end if + end do + call genrand_decode( stt%cnt, c ) + stt%ini = .true._wi + return + + end subroutine genrand_load_state + + elemental subroutine genrand_dump_state( rpr, stt ) + + intrinsic :: len_trim + + type(genrand_srepr), intent(out) :: rpr + type(genrand_state), intent(in ) :: stt + + integer(kind=wi) :: i, j + + j = 1 + rpr%repr = "" + do i = 1, n, 1 + call genrand_encode( rpr%repr(j:), stt%val(i) ) + j = len_trim( rpr%repr ) + 1 + rpr%repr(j:j) = sepr + j = j + 1 + end do + call genrand_encode( rpr%repr(j:), stt%cnt ) + return + + end subroutine genrand_dump_state + + ! generates a random number on [0,0xffffffff]-interval + subroutine genrand_int32_0d( y ) + + intrinsic :: ieor, iand, ishft + + integer(kind=wi), parameter :: temper_a = -1658038656_wi !z'9D2C5680' + integer(kind=wi), parameter :: temper_b = -272236544_wi !z'EFC60000' + + integer(kind=wi), intent(out) :: y + + if ( state%cnt > n ) call next_state( ) + y = state%val(state%cnt) + state%cnt = state%cnt + 1_wi + ! Tempering + y = ieor( y, ishft( y, -11 ) ) + y = ieor( y, iand( ishft( y, 7 ), temper_a ) ) + y = ieor( y, iand( ishft( y, 15 ), temper_b ) ) + y = ieor( y, ishft( y, -18 ) ) + return + + end subroutine genrand_int32_0d + + subroutine genrand_int32_1d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 1 ), 1 + call genrand_int32_0d( y(i) ) + end do + return + + end subroutine genrand_int32_1d + + subroutine genrand_int32_2d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 2 ), 1 + call genrand_int32_1d( y(:,i) ) + end do + return + + end subroutine genrand_int32_2d + + subroutine genrand_int32_3d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 3 ), 1 + call genrand_int32_2d( y(:,:,i) ) + end do + return + + end subroutine genrand_int32_3d + + subroutine genrand_int32_4d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 4 ), 1 + call genrand_int32_3d( y(:,:,:,i) ) + end do + return + + end subroutine genrand_int32_4d + + subroutine genrand_int32_5d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 5 ), 1 + call genrand_int32_4d( y(:,:,:,:,i) ) + end do + return + + end subroutine genrand_int32_5d + + subroutine genrand_int32_6d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 6 ), 1 + call genrand_int32_5d( y(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_int32_6d + + subroutine genrand_int32_7d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 7 ), 1 + call genrand_int32_6d( y(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_int32_7d + + ! generates a random number on [0,0x7fffffff]-interval + subroutine genrand_int31_0d( y ) + + intrinsic :: ishft + + integer(kind=wi), intent(out) :: y + + call genrand_int32_0d( y ) + y = ishft( y, -1 ) + return + + end subroutine genrand_int31_0d + + subroutine genrand_int31_1d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 1 ), 1 + call genrand_int31_0d( y(i) ) + end do + return + + end subroutine genrand_int31_1d + + subroutine genrand_int31_2d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 2 ), 1 + call genrand_int31_1d( y(:,i) ) + end do + return + + end subroutine genrand_int31_2d + + subroutine genrand_int31_3d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 3 ), 1 + call genrand_int31_2d( y(:,:,i) ) + end do + return + + end subroutine genrand_int31_3d + + subroutine genrand_int31_4d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 4 ), 1 + call genrand_int31_3d( y(:,:,:,i) ) + end do + return + + end subroutine genrand_int31_4d + + subroutine genrand_int31_5d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 5 ), 1 + call genrand_int31_4d( y(:,:,:,:,i) ) + end do + return + + end subroutine genrand_int31_5d + + subroutine genrand_int31_6d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 6 ), 1 + call genrand_int31_5d( y(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_int31_6d + + subroutine genrand_int31_7d( y ) + + intrinsic :: size + + integer(kind=wi), dimension(:,:,:,:,:,:,:), intent(out) :: y + + integer(kind=wi) :: i + + do i = 1, size( y, 7 ), 1 + call genrand_int31_6d( y(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_int31_7d + + ! generates a random number on [0,1]-real-interval + subroutine genrand_real1_0d( r ) + + intrinsic :: real + + real(kind=wr), intent(out) :: r + + integer(kind=wi) :: a + + call genrand_int32_0d( a ) + r = real( a, kind=wr ) * pi232_1 + p231d232_1 + ! divided by 2^32-1 + return + + end subroutine genrand_real1_0d + + subroutine genrand_real1_1d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 1 ), 1 + call genrand_real1_0d( r(i) ) + end do + return + + end subroutine genrand_real1_1d + + subroutine genrand_real1_2d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 2 ), 1 + call genrand_real1_1d( r(:,i) ) + end do + return + + end subroutine genrand_real1_2d + + subroutine genrand_real1_3d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 3 ), 1 + call genrand_real1_2d( r(:,:,i) ) + end do + return + + end subroutine genrand_real1_3d + + subroutine genrand_real1_4d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 4 ), 1 + call genrand_real1_3d( r(:,:,:,i) ) + end do + return + + end subroutine genrand_real1_4d + + subroutine genrand_real1_5d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 5 ), 1 + call genrand_real1_4d( r(:,:,:,:,i) ) + end do + return + + end subroutine genrand_real1_5d + + subroutine genrand_real1_6d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 6 ), 1 + call genrand_real1_5d( r(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real1_6d + + subroutine genrand_real1_7d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 7 ), 1 + call genrand_real1_6d( r(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real1_7d + + ! generates a random number on [0,1)-real-interval + subroutine genrand_real2_0d( r ) + + intrinsic :: real + + real(kind=wr), intent(out) :: r + + integer(kind=wi) :: a + + call genrand_int32_0d( a ) + r = real( a, kind=wr ) * pi232 + 0.5_wr + ! divided by 2^32 + return + + end subroutine genrand_real2_0d + + subroutine genrand_real2_1d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 1 ), 1 + call genrand_real2_0d( r(i) ) + end do + return + + end subroutine genrand_real2_1d + + subroutine genrand_real2_2d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 2 ), 1 + call genrand_real2_1d( r(:,i) ) + end do + return + + end subroutine genrand_real2_2d + + subroutine genrand_real2_3d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 3 ), 1 + call genrand_real2_2d( r(:,:,i) ) + end do + return + + end subroutine genrand_real2_3d + + subroutine genrand_real2_4d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 4 ), 1 + call genrand_real2_3d( r(:,:,:,i) ) + end do + return + + end subroutine genrand_real2_4d + + subroutine genrand_real2_5d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 5 ), 1 + call genrand_real2_4d( r(:,:,:,:,i) ) + end do + return + + end subroutine genrand_real2_5d + + subroutine genrand_real2_6d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 6 ), 1 + call genrand_real2_5d( r(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real2_6d + + subroutine genrand_real2_7d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 7 ), 1 + call genrand_real2_6d( r(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real2_7d + + ! generates a random number on (0,1)-real-interval + subroutine genrand_real3_0d( r ) + + intrinsic :: real + + real(kind=wr), intent(out) :: r + + integer(kind=wi) :: a + + call genrand_int32_0d( a ) + r = real( a, kind=wr ) * pi232 + p231_5d232 + ! divided by 2^32 + return + + end subroutine genrand_real3_0d + + subroutine genrand_real3_1d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 1 ), 1 + call genrand_real3_0d( r(i) ) + end do + return + + end subroutine genrand_real3_1d + + subroutine genrand_real3_2d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 2 ), 1 + call genrand_real3_1d( r(:,i) ) + end do + return + + end subroutine genrand_real3_2d + + subroutine genrand_real3_3d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 3 ), 1 + call genrand_real3_2d( r(:,:,i) ) + end do + return + + end subroutine genrand_real3_3d + + subroutine genrand_real3_4d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 4 ), 1 + call genrand_real3_3d( r(:,:,:,i) ) + end do + return + + end subroutine genrand_real3_4d + + subroutine genrand_real3_5d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 5 ), 1 + call genrand_real3_4d( r(:,:,:,:,i) ) + end do + return + + end subroutine genrand_real3_5d + + subroutine genrand_real3_6d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 6 ), 1 + call genrand_real3_5d( r(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real3_6d + + subroutine genrand_real3_7d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 7 ), 1 + call genrand_real3_6d( r(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_real3_7d + + ! generates a random number on [0,1) with 53-bit resolution + subroutine genrand_res53_0d( r ) + + intrinsic :: ishft, real + + real(kind=wr), intent(out) :: r + + integer(kind=wi) :: a, b + + call genrand_int32_0d( a ) + call genrand_int32_0d( b ) + a = ishft( a, -5 ) + b = ishft( b, -6 ) + r = real( a, kind=wr ) * pi227 + real( b, kind=wr ) * pi253 + return + + end subroutine genrand_res53_0d + + subroutine genrand_res53_1d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 1 ), 1 + call genrand_res53_0d( r(i) ) + end do + return + + end subroutine genrand_res53_1d + + subroutine genrand_res53_2d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 2 ), 1 + call genrand_res53_1d( r(:,i) ) + end do + return + + end subroutine genrand_res53_2d + + subroutine genrand_res53_3d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 3 ), 1 + call genrand_res53_2d( r(:,:,i) ) + end do + return + + end subroutine genrand_res53_3d + + subroutine genrand_res53_4d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 4 ), 1 + call genrand_res53_3d( r(:,:,:,i) ) + end do + return + + end subroutine genrand_res53_4d + + subroutine genrand_res53_5d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 5 ), 1 + call genrand_res53_4d( r(:,:,:,:,i) ) + end do + return + + end subroutine genrand_res53_5d + + subroutine genrand_res53_6d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 6 ), 1 + call genrand_res53_5d( r(:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_res53_6d + + subroutine genrand_res53_7d( r ) + + intrinsic :: size + + real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r + + integer(kind=wi) :: i + + do i = 1, size( r, 7 ), 1 + call genrand_res53_6d( r(:,:,:,:,:,:,i) ) + end do + return + + end subroutine genrand_res53_7d + ! These real versions are due to Isaku Wada, 2002/01/09 added + ! Altered by José Sousa genrand_real[1-3] will not return exactely + ! the same values but should have the same properties and are faster + +end module mt95 + diff --git a/src/physics/clubb/numerical_check.F90 b/src/physics/clubb/numerical_check.F90 new file mode 100644 index 0000000000..b5f8cbf078 --- /dev/null +++ b/src/physics/clubb/numerical_check.F90 @@ -0,0 +1,1071 @@ +!------------------------------------------------------------------------ +! $Id: numerical_check.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module numerical_check + + implicit none + +! Made is_nan_2d public so it may be used +! for finding code that cause NaNs +! Joshua Fasching November 2007 + +! *_check subroutines were added to ensure that the +! subroutines they are checking perform correctly +! Joshua Fasching February 2008 + +! rad_clipping has been replaced by rad_check as the new +! subroutine only reports if there are invalid values. +! Joshua Fasching March 2008 + + private ! Default scope + + public :: invalid_model_arrays, is_nan_2d, & + rad_check, parameterization_check, & + surface_varnce_check, pdf_closure_check, & + length_check, is_nan_sclr, calculate_spurious_source + + private :: check_negative, check_nan + + + ! Abstraction of check_nan + interface check_nan + module procedure check_nan_sclr, check_nan_2d + end interface + + ! Abstraction of check_negative + interface check_negative + module procedure check_negative_total, check_negative_index + end interface + + + contains +!--------------------------------------------------------------------------------- + subroutine length_check( Lscale, Lscale_up, Lscale_down, err_code ) +! +! Description: This subroutine determines if any of the output +! variables for the length_new subroutine carry values that +! are NaNs. +! +! Joshua Fasching February 2008 +!--------------------------------------------------------------------------------- + use grid_class, only: & + gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant Parameters + character(*), parameter :: proc_name = "compute_length" + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + Lscale, & ! Mixing length [m] + Lscale_up, & ! Upward mixing length [m] + Lscale_down ! Downward mixing length [m] + + ! Output Variable + integer, intent(inout) :: & + err_code + +!----------------------------------------------------------------------------- + + call check_nan( Lscale, "Lscale", proc_name, err_code ) + call check_nan( Lscale_up, "Lscale_up", proc_name, err_code ) + call check_nan( Lscale_down, "Lscale_down", proc_name, err_code ) + + return + end subroutine length_check + +!--------------------------------------------------------------------------- + subroutine pdf_closure_check( wp4, wprtp2, wp2rtp, wpthlp2, & + wp2thlp, cloud_frac, rcm, wpthvp, wp2thvp, & + rtpthvp, thlpthvp, wprcp, wp2rcp, & + rtprcp, thlprcp, rcp2, wprtpthlp, & + crt_1, crt_2, cthl_1, cthl_2, pdf_params, & + sclrpthvp, sclrprcp, wpsclrp2, & + wpsclrprtp, wpsclrpthlp, wp2sclrp, & + err_code ) + +! Description: This subroutine determines if any of the output +! variables for the pdf_closure subroutine carry values that +! are NaNs. +! +! Joshua Fasching February 2008 +!--------------------------------------------------------------------------- + + use parameters_model, only: & + sclr_dim ! Variable + + use pdf_parameter_module, only: & + pdf_parameter ! type + + use stats_variables, only: & + iwp4, & ! Variables + ircp2, & + iwprtp2, & + iwprtpthlp, & + iwpthlp2 + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Parameter Constants + character(len=*), parameter :: proc_name = & + "pdf_closure" + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wp4, & ! w'^4 [m^4/s^4] + wprtp2, & ! w' r_t' [(m kg)/(s kg)] + wp2rtp, & ! w'^2 r_t' [(m^2 kg)/(s^2 kg)] + wpthlp2, & ! w' th_l'^2 [(m K^2)/s] + wp2thlp, & ! w'^2 th_l' [(m^2 K)/s^2] + cloud_frac, & ! Cloud fraction [-] + rcm, & ! Mean liquid water [kg/kg] + wpthvp, & ! Buoyancy flux [(K m)/s] + wp2thvp, & ! w'^2 th_v' [(m^2 K)/s^2] + rtpthvp, & ! r_t' th_v' [(kg K)/kg] + thlpthvp, & ! th_l' th_v' [K^2] + wprcp, & ! w' r_c' [(m kg)/(s kg)] + wp2rcp, & ! w'^2 r_c' [(m^2 kg)/(s^2 kg)] + rtprcp, & ! r_t' r_c' [(kg^2)/(kg^2)] + thlprcp, & ! th_l' r_c' [(K kg)/kg] + rcp2, & ! r_c'^2 [(kg^2)/(kg^2)] + wprtpthlp, & ! w' r_t' th_l' [(m kg K)/(s kg)] + crt_1, crt_2, & + cthl_1, cthl_2 + + type(pdf_parameter), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + ! Input (Optional passive scalar variables) + real( kind = core_rknd ), dimension(sclr_dim), intent(in) :: & + sclrpthvp, & + sclrprcp, & + wpsclrp2, & + wpsclrprtp, & + wpsclrpthlp, & + wp2sclrp + + ! Output Variable + integer, intent(inout) :: & + err_code ! Returns appropriate error code + +!------------------------------------------------------------------------------- + + ! ---- Begin Code ---- + + if ( iwp4 > 0 ) call check_nan( wp4,"wp4", proc_name, err_code ) + if ( iwprtp2 > 0 ) call check_nan( wprtp2,"wprtp2", proc_name, err_code ) + call check_nan( wp2rtp,"wp2rtp", proc_name, err_code ) + if ( iwpthlp2 > 0 ) call check_nan( wpthlp2,"wpthlp2", proc_name, err_code ) + call check_nan( wp2thlp,"wp2thlp", proc_name, err_code ) + call check_nan( cloud_frac,"cloud_frac", proc_name, err_code ) + call check_nan( rcm,"rcm", proc_name, err_code ) + call check_nan( wpthvp, "wpthvp", proc_name, err_code ) + call check_nan( wp2thvp, "wp2thvp", proc_name, err_code ) + call check_nan( rtpthvp, "rtpthvp", proc_name, err_code ) + call check_nan( thlpthvp, "thlpthvp", proc_name, err_code ) + call check_nan( wprcp, "wprcp", proc_name, err_code ) + call check_nan( wp2rcp, "wp2rcp", proc_name, err_code ) + call check_nan( rtprcp, "rtprcp", proc_name, err_code ) + call check_nan( thlprcp, "thlprcp", proc_name, err_code ) + if ( ircp2 > 0 ) call check_nan( rcp2, "rcp2", proc_name, err_code) + if ( iwprtpthlp > 0 ) call check_nan( wprtpthlp, "wprtpthlp", proc_name, err_code ) + call check_nan( crt_1, "crt_1", proc_name, err_code ) + call check_nan( crt_2, "crt_2", proc_name, err_code ) + call check_nan( cthl_1, "cthl_1", proc_name, err_code ) + call check_nan( cthl_2, "cthl_2", proc_name, err_code ) + ! Check each PDF parameter at the grid level sent in. + call check_nan( pdf_params%w_1, "pdf_params%w_1", proc_name, err_code ) + call check_nan( pdf_params%w_2, "pdf_params%w_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_w_1, "pdf_params%varnce_w_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_w_2, "pdf_params%varnce_w_2", proc_name, err_code ) + call check_nan( pdf_params%rt_1, "pdf_params%rt_1", proc_name, err_code ) + call check_nan( pdf_params%rt_2, "pdf_params%rt_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_rt_1, "pdf_params%varnce_rt_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_rt_2, "pdf_params%varnce_rt_2", proc_name, err_code ) + call check_nan( pdf_params%thl_1, "pdf_params%thl_1", proc_name, err_code ) + call check_nan( pdf_params%thl_2, "pdf_params%thl_2", proc_name, err_code ) + call check_nan( pdf_params%varnce_thl_1, "pdf_params%varnce_thl_1", proc_name, err_code ) + call check_nan( pdf_params%varnce_thl_2, "pdf_params%varnce_thl_2", proc_name, err_code ) + call check_nan( pdf_params%mixt_frac, "pdf_params%mixt_frac", proc_name, err_code ) + call check_nan( pdf_params%rrtthl, "pdf_params%rrtthl", proc_name, err_code ) + call check_nan( pdf_params%rc_1, "pdf_params%rc_1", proc_name, err_code ) + call check_nan( pdf_params%rc_2, "pdf_params%rc_2", proc_name, err_code ) + call check_nan( pdf_params%rsatl_1, "pdf_params%rsatl_1", proc_name, err_code ) + call check_nan( pdf_params%rsatl_2, "pdf_params%rsatl_2", proc_name, err_code ) + call check_nan( pdf_params%cloud_frac_1, "pdf_params%cloud_frac_1", proc_name, err_code ) + call check_nan( pdf_params%cloud_frac_2, "pdf_params%cloud_frac_2", proc_name, err_code ) + call check_nan( pdf_params%chi_1, "pdf_params%chi_1", proc_name, err_code ) + call check_nan( pdf_params%chi_2, "pdf_params%chi_2", proc_name, err_code ) + call check_nan( pdf_params%stdev_chi_1, "pdf_params%stdev_chi_1", proc_name, err_code ) + call check_nan( pdf_params%stdev_chi_2, "pdf_params%stdev_chi_2", proc_name, err_code ) + call check_nan( pdf_params%alpha_thl, "pdf_params%alpha_thl", proc_name, err_code ) + call check_nan( pdf_params%alpha_rt, "pdf_params%alpha_rt", proc_name, err_code ) + + if ( sclr_dim > 0 ) then + call check_nan( sclrpthvp,"sclrpthvp", & + proc_name, err_code) + call check_nan( sclrprcp, "sclrprcp", & + proc_name, err_code ) + call check_nan( wpsclrprtp, "wpsclrprtp", & + proc_name, err_code ) + call check_nan( wpsclrp2, "wpsclrp2", & + proc_name, err_code ) + call check_nan( wpsclrpthlp, "wpsclrtlp", & + proc_name, err_code ) + call check_nan( wp2sclrp, "wp2sclrp", & + proc_name, err_code ) + end if + + return + end subroutine pdf_closure_check + +!------------------------------------------------------------------------------- + subroutine parameterization_check & + ( thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & + wm_zm, wm_zt, p_in_Pa, rho_zm, rho, exner, & + rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & + wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc, & + um, upwp, vm, vpwp, up2, vp2, & + rtm, wprtp, thlm, wpthlp, & + wp2, wp3, rtp2, thlp2, rtpthlp, & + prefix, & + wpsclrp_sfc, wpedsclrp_sfc, & + sclrm, wpsclrp, sclrp2, sclrprtp, sclrpthlp, & + sclrm_forcing, edsclrm, edsclrm_forcing, err_code ) +! +! Description: +! This subroutine determines what input variables may have NaN values. +! In addition it checks to see if rho_zm, rho, exner, up2, vp2, rtm, thlm, +! wp2, rtp2, thlp2, or tau_zm have negative values. +!------------------------------------------------------------------------------- + + use grid_class, only: & + gr ! Variable + + use parameters_model, only: & + sclr_dim, & ! Variable + edsclr_dim + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant Parameters + ! Name of the procedure using parameterization_check + character(len=25), parameter :: & + proc_name = "parameterization_timestep" + + ! Input variables + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + thlm_forcing, & ! theta_l forcing (thermodynamic levels) [K/s] + rtm_forcing, & ! r_t forcing (thermodynamic levels) [(kg/kg)/s] + um_forcing, & ! u wind forcing (thermodynamic levels) [m/s/s] + vm_forcing, & ! v wind forcing (thermodynamic levels) [m/s/s] + wm_zm, & ! w mean wind component on momentum levels [m/s] + wm_zt, & ! w mean wind component on thermo. levels [m/s] + p_in_Pa, & ! Air pressure (thermodynamic levels) [Pa] + rho_zm, & ! Air density on momentum levels [kg/m^3] + rho, & ! Air density on thermodynamic levels [kg/m^3] + exner, & ! Exner function (thermodynamic levels) [-] + rho_ds_zm, & ! Dry, static density on momentum levels [kg/m^3] + rho_ds_zt, & ! Dry, static density on thermo. levels [kg/m^3] + invrs_rho_ds_zm, & ! Inv. dry, static density @ momentum levs. [m^3/kg] + invrs_rho_ds_zt, & ! Inv. dry, static density @ thermo. levs. [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v on momentum levs. [K] + thv_ds_zt ! Dry, base-state theta_v on thermo. levs. [K] + + real( kind = core_rknd ), intent(in) :: & + wpthlp_sfc, & ! w' theta_l' at surface. [(m K)/s] + wprtp_sfc, & ! w' r_t' at surface. [(kg m)/( kg s)] + upwp_sfc, & ! u'w' at surface. [m^2/s^2] + vpwp_sfc ! v'w' at surface. [m^2/s^2] + + ! These are prognostic or are planned to be in the future + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + um, & ! u mean wind component (thermodynamic levels) [m/s] + upwp, & ! u'w' (momentum levels) [m^2/s^2] + vm, & ! v mean wind component (thermodynamic levels) [m/s] + vpwp, & ! v'w' (momentum levels) [m^2/s^2] + up2, & ! u'^2 (momentum levels) [m^2/s^2] + vp2, & ! v'^2 (momentum levels) [m^2/s^2] + rtm, & ! total water mixing ratio, r_t (thermo. levels) [kg/kg] + wprtp, & ! w' r_t' (momentum levels) [(kg/kg) m/s] + thlm, & ! liq. water pot. temp., th_l (thermo. levels) [K] + wpthlp, & ! w' th_l' (momentum levels) [(m/s) K] + rtp2, & ! r_t'^2 (momentum levels) [(kg/kg)^2] + thlp2, & ! th_l'^2 (momentum levels) [K^2] + rtpthlp, & ! r_t' th_l' (momentum levels) [(kg/kg) K] + wp2, & ! w'^2 (momentum levels) [m^2/s^2] + wp3 ! w'^3 (thermodynamic levels) [m^3/s^3] + + character(len=*), intent(in) :: prefix ! Location where subroutine is called + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Scalar flux at surface [units m/s] + + real( kind = core_rknd ), intent(in), dimension(edsclr_dim) :: & + wpedsclrp_sfc ! Eddy-Scalar flux at surface [units m/s] + + real( kind = core_rknd ), intent(in),dimension(gr%nz,sclr_dim) :: & + sclrm, & ! Passive scalar mean [units vary] + wpsclrp, & ! w'sclr' [units vary] + sclrp2, & ! sclr'^2 [units vary] + sclrprtp, & ! sclr'rt' [units vary] + sclrpthlp, & ! sclr'thl' [units vary] + sclrm_forcing ! Passive scalar forcing [units / s] + + real( kind = core_rknd ), intent(in),dimension(gr%nz,edsclr_dim) :: & + edsclrm, & ! Eddy passive scalar mean [units vary] + edsclrm_forcing ! Eddy passive scalar forcing [units / s] + + ! In / Out Variables + integer, intent(inout) :: & + err_code ! Error code + + ! Local Variables + integer :: i ! Loop iterator for the scalars + +!-------- Input Nan Check ---------------------------------------------- + + call check_nan( thlm_forcing, "thlm_forcing", prefix//proc_name, err_code) + call check_nan( rtm_forcing,"rtm_forcing", prefix//proc_name, err_code ) + call check_nan( um_forcing,"um_forcing", prefix//proc_name, err_code ) + call check_nan( vm_forcing,"vm_forcing", prefix//proc_name, err_code ) + + call check_nan( wm_zm, "wm_zm", prefix//proc_name, err_code ) + call check_nan( wm_zt, "wm_zt", prefix//proc_name, err_code ) + call check_nan( p_in_Pa, "p_in_Pa", prefix//proc_name, err_code ) + call check_nan( rho_zm, "rho_zm", prefix//proc_name, err_code ) + call check_nan( rho, "rho", prefix//proc_name, err_code ) + call check_nan( exner, "exner", prefix//proc_name, err_code ) + call check_nan( rho_ds_zm, "rho_ds_zm", prefix//proc_name, err_code ) + call check_nan( rho_ds_zt, "rho_ds_zt", prefix//proc_name, err_code ) + call check_nan( invrs_rho_ds_zm, "invrs_rho_ds_zm", prefix//proc_name, err_code ) + call check_nan( invrs_rho_ds_zt, "invrs_rho_ds_zt", prefix//proc_name, err_code ) + call check_nan( thv_ds_zm, "thv_ds_zm", prefix//proc_name, err_code ) + call check_nan( thv_ds_zt, "thv_ds_zt", prefix//proc_name, err_code ) + + call check_nan( um, "um", prefix//proc_name, err_code ) + call check_nan( upwp, "upwp", prefix//proc_name, err_code ) + call check_nan( vm, "vm", prefix//proc_name, err_code ) + call check_nan( vpwp, "vpwp", prefix//proc_name, err_code ) + call check_nan( up2, "up2", prefix//proc_name, err_code ) + call check_nan( vp2, "vp2", prefix//proc_name, err_code ) + call check_nan( rtm, "rtm", prefix//proc_name, err_code ) + call check_nan( wprtp, "wprtp", prefix//proc_name, err_code ) + call check_nan( thlm, "thlm", prefix//proc_name, err_code ) + call check_nan( wpthlp, "wpthlp", prefix//proc_name, err_code ) + call check_nan( wp2, "wp2", prefix//proc_name, err_code ) + call check_nan( wp3, "wp3", prefix//proc_name, err_code ) + call check_nan( rtp2, "rtp2", prefix//proc_name, err_code ) + call check_nan( thlp2, "thlp2", prefix//proc_name, err_code ) + call check_nan( rtpthlp, "rtpthlp", prefix//proc_name, err_code ) + + call check_nan( wpthlp_sfc, "wpthlp_sfc", prefix//proc_name, err_code ) + call check_nan( wprtp_sfc, "wprtp_sfc", prefix//proc_name, err_code ) + call check_nan( upwp_sfc, "upwp_sfc", prefix//proc_name, err_code ) + call check_nan( vpwp_sfc, "vpwp_sfc", prefix//proc_name, err_code ) + + do i = 1, sclr_dim + + call check_nan( sclrm_forcing(:,i),"sclrm_forcing", & + prefix//proc_name, err_code ) + + call check_nan( wpsclrp_sfc(i),"wpsclrp_sfc", & + prefix//proc_name, err_code ) + + call check_nan( sclrm(:,i),"sclrm", prefix//proc_name, err_code ) + call check_nan( wpsclrp(:,i),"wpsclrp", prefix//proc_name, err_code ) + call check_nan( sclrp2(:,i),"sclrp2", prefix//proc_name, err_code ) + call check_nan( sclrprtp(:,i),"sclrprtp", prefix//proc_name, err_code ) + call check_nan( sclrpthlp(:,i),"sclrpthlp", prefix//proc_name, err_code ) + + end do + + + do i = 1, edsclr_dim + + call check_nan( edsclrm_forcing(:,i),"edsclrm_forcing", prefix//proc_name, err_code ) + + call check_nan( wpedsclrp_sfc(i),"wpedsclrp_sfc", & + prefix//proc_name, err_code ) + + call check_nan( edsclrm(:,i),"edsclrm", prefix//proc_name, err_code ) + + enddo + +!--------------------------------------------------------------------- + + + call check_negative( rtm, gr%nz ,"rtm", prefix//proc_name, err_code ) + call check_negative( p_in_Pa, gr%nz ,"p_in_Pa", prefix//proc_name, err_code ) + call check_negative( rho, gr%nz ,"rho", prefix//proc_name, err_code ) + call check_negative( rho_zm, gr%nz ,"rho_zm", prefix//proc_name, err_code ) + call check_negative( exner, gr%nz ,"exner", prefix//proc_name, err_code ) + call check_negative( rho_ds_zm, gr%nz ,"rho_ds_zm", prefix//proc_name, err_code ) + call check_negative( rho_ds_zt, gr%nz ,"rho_ds_zt", prefix//proc_name, err_code ) + call check_negative( invrs_rho_ds_zm, gr%nz ,"invrs_rho_ds_zm", & + prefix//proc_name, err_code ) + call check_negative( invrs_rho_ds_zt, gr%nz ,"invrs_rho_ds_zt", & + prefix//proc_name, err_code ) + call check_negative( thv_ds_zm, gr%nz ,"thv_ds_zm", prefix//proc_name, err_code ) + call check_negative( thv_ds_zt, gr%nz ,"thv_ds_zt", prefix//proc_name, err_code ) + call check_negative( up2, gr%nz ,"up2", prefix//proc_name, err_code ) + call check_negative( vp2, gr%nz ,"vp2", prefix//proc_name, err_code ) + call check_negative( wp2, gr%nz ,"wp2", prefix//proc_name, err_code ) + call check_negative( rtm, gr%nz ,"rtm", prefix//proc_name, err_code ) + call check_negative( thlm, gr%nz ,"thlm", prefix//proc_name, err_code ) + call check_negative( rtp2, gr%nz ,"rtp2", prefix//proc_name, err_code ) + call check_negative( thlp2, gr%nz ,"thlp2", prefix//proc_name, err_code ) + + return + end subroutine parameterization_check + +!----------------------------------------------------------------------- + subroutine surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, thlp2_sfc, & + rtp2_sfc, rtpthlp_sfc, & + sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc, & + err_code ) +! +! Description:This subroutine determines if any of the output +! variables for the surface_varnce subroutine carry values that +! are nans. +! +! Joshua Fasching February 2008 +! +! +!----------------------------------------------------------------------- + use parameters_model, only: & + sclr_dim ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant Parameters + ! Name of the subroutine calling the check + character(len=*), parameter :: & + proc_name = "surface_varnce" + + ! Input Variables + real( kind = core_rknd ),intent(in) :: & + wp2_sfc, & ! Vertical velocity variance [m^2/s^2] + up2_sfc, & ! u'^2 [m^2/s^2] + vp2_sfc, & ! u'^2 [m^2/s^2] + thlp2_sfc, & ! thetal variance [K^2] + rtp2_sfc, & ! rt variance [(kg/kg)^2] + rtpthlp_sfc ! thetal rt covariance [kg K/kg] + + + real( kind = core_rknd ), dimension(sclr_dim), intent(in) :: & + sclrp2_sfc, & ! Passive scalar variance [units^2] + sclrprtp_sfc, & ! Passive scalar r_t covariance [units kg/kg] + sclrpthlp_sfc ! Passive scalar theta_l covariance [units K] + + ! Input/Output Variable + integer, intent(inout) :: err_code ! Are these outputs valid? + +!----------------------------------------------------------------------- + + ! ---- Begin Code ---- + + call check_nan( wp2_sfc, "wp2_sfc", proc_name, err_code) + call check_nan( up2_sfc, "up2_sfc", proc_name, err_code) + call check_nan( vp2_sfc, "vp2_sfc", proc_name, err_code) + call check_nan( thlp2_sfc, "thlp2_sfc", proc_name, err_code) + call check_nan( rtp2_sfc, "rtp2_sfc", proc_name, err_code) + call check_nan( rtpthlp_sfc, "rtpthlp_sfc", & + proc_name, err_code) + + if ( sclr_dim > 0 ) then + call check_nan( sclrp2_sfc, "sclrp2_sfc", & + proc_name, err_code ) + + call check_nan( sclrprtp_sfc, "sclrprtp_sfc", & + proc_name, err_code ) + + call check_nan( sclrpthlp_sfc, "sclrpthlp_sfc", & + proc_name, err_code ) + end if + + return + end subroutine surface_varnce_check + +!----------------------------------------------------------------------- + subroutine rad_check( thlm, rcm, rtm, rim, & + cloud_frac, p_in_Pa, exner, rho_zm ) +! Description: +! Checks radiation input variables. If they are < 0 it reports +! to the console. +!------------------------------------------------------------------------ + + use grid_class, only: & + gr ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant Parameters + character(len=*), parameter :: & + proc_name = "Before BUGSrad." + + ! Input/Output variables + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + thlm, & ! Liquid Water Potential Temperature [K/s] + rcm, & ! Liquid Water Mixing Ratio [kg/kg] + rtm, & ! Total Water Mixing Ratio [kg/kg] + rim, & ! Ice Water Mixing Ratio [kg/kg] + cloud_frac, & ! Cloud Fraction [-] + p_in_Pa, & ! Pressure [Pa] + exner, & ! Exner Function [-] + rho_zm ! Air Density [kg/m^3] + + ! Local variables + real( kind = core_rknd ),dimension(gr%nz) :: rvm + +!------------------------------------------------------------------------- + + rvm = rtm - rcm + + call check_negative( thlm, gr%nz ,"thlm", proc_name ) + call check_negative( rcm, gr%nz ,"rcm", proc_name ) + call check_negative( rtm, gr%nz ,"rtm", proc_name ) + call check_negative( rvm, gr%nz ,"rvm", proc_name ) + call check_negative( rim, gr%nz ,"rim", proc_name ) + call check_negative( cloud_frac, gr%nz ,"cloud_frac", proc_name ) + call check_negative( p_in_Pa, gr%nz ,"p_in_Pa", proc_name ) + call check_negative( exner, gr%nz ,"exner", proc_name ) + call check_negative( rho_zm, gr%nz ,"rho_zm", proc_name ) + + return + + end subroutine rad_check + +!----------------------------------------------------------------------- + logical function invalid_model_arrays( ) + +! Description: +! Checks for invalid floating point values in select model arrays. + +! References: +! None +!------------------------------------------------------------------------ + + use variables_diagnostic_module, only: & + hydromet, & ! Variable(s) + wp2thvp, & + rtpthvp, & + thlpthvp + + use variables_prognostic_module, only: & + um, & ! Variable(s) + vm, & + wp2, & + wp3, & + rtm, & + thlm, & + rtp2, & + thlp2, & + wprtp, & + wpthlp, & + rtpthlp, & + sclrm, & + edsclrm + + use constants_clubb, only: & + fstderr ! Constant(s) + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim, & + hydromet_dim + + use array_index, only: & + hydromet_list ! Variable(s) + + implicit none + + ! Local Variables + integer :: i + + invalid_model_arrays = .false. + + ! Check whether any variable array contains a NaN for + ! um, vm, thlm, rtm, rtp2, thlp2, wprtp, wpthlp, rtpthlp, + ! wp2, & wp3. + if ( is_nan_2d( um ) ) then + write(fstderr,*) "NaN in um model array" +! write(fstderr,*) "um= ", um + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( vm ) ) then + write(fstderr,*) "NaN in vm model array" +! write(fstderr,*) "vm= ", vm + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( wp2 ) ) then + write(fstderr,*) "NaN in wp2 model array" +! write(fstderr,*) "wp2= ", wp2 + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( wp3 ) ) then + write(fstderr,*) "NaN in wp3 model array" +! write(fstderr,*) "wp3= ", wp3 + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( rtm ) ) then + write(fstderr,*) "NaN in rtm model array" +! write(fstderr,*) "rtm= ", rtm + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( thlm ) ) then + write(fstderr,*) "NaN in thlm model array" +! write(fstderr,*) "thlm= ", thlm + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( rtp2 ) ) then + write(fstderr,*) "NaN in rtp2 model array" +! write(fstderr,*) "rtp2= ", rtp2 + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( thlp2 ) ) then + write(fstderr,*) "NaN in thlp2 model array" +! write(fstderr,*) "thlp2= ", thlp2 + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( wprtp ) ) then + write(fstderr,*) "NaN in wprtp model array" +! write(fstderr,*) "wprtp= ", wprtp + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( wpthlp ) ) then + write(fstderr,*) "NaN in wpthlp model array" +! write(fstderr,*) "wpthlp= ", wpthlp + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( rtpthlp ) ) then + write(fstderr,*) "NaN in rtpthlp model array" +! write(fstderr,*) "rtpthlp= ", rtpthlp + invalid_model_arrays = .true. +! return + end if + + if ( hydromet_dim > 0 ) then + do i = 1, hydromet_dim, 1 + if ( is_nan_2d( hydromet(:,i) ) ) then + write(fstderr,*) "NaN in a hydrometeor model array "// & + trim( hydromet_list(i) ) +! write(fstderr,*) "hydromet= ", hydromet + invalid_model_arrays = .true. +! return + end if + end do + end if + +! if ( is_nan_2d( wm_zt ) ) then +! write(fstderr,*) "NaN in wm_zt model array" +! write(fstderr,*) "wm_zt= ", wm_zt +! invalid_model_arrays = .true. +! return +! end if + + if ( is_nan_2d( wp2thvp ) ) then + write(fstderr,*) "NaN in wp2thvp model array" +! write(fstderr,*) "wp2thvp = ", wp2thvp + invalid_model_arrays = .true. +! return + end if + + if ( is_nan_2d( rtpthvp ) ) then + write(fstderr,*) "NaN in rtpthvp model array" +! write(fstderr,*) "rtpthvp = ", rtpthvp + invalid_model_arrays = .true. + end if + + if ( is_nan_2d( thlpthvp ) ) then + write(fstderr,*) "NaN in thlpthvp model array" +! write(fstderr,*) "thlpthvp = ", thlpthvp + invalid_model_arrays = .true. + end if + + do i = 1, sclr_dim, 1 + if ( is_nan_2d( sclrm(:,i) ) ) then + write(fstderr,*) "NaN in sclrm", i, "model array" +! write(fstderr,'(a6,i2,a1)') "sclrm(", i, ")" +! write(fstderr,*) sclrm(:,i) + invalid_model_arrays = .true. + end if + end do + + do i = 1, edsclr_dim, 1 + if ( is_nan_2d( edsclrm(:,i) ) ) then + write(fstderr,*) "NaN in edsclrm", i, "model array" +! write(fstderr,'(a8,i2,a1)') "edsclrm(", i, ")" +! write(fstderr,*) edsclrm(:,i) + invalid_model_arrays = .true. + end if + end do + + return + end function invalid_model_arrays + +!------------------------------------------------------------------------ + logical function is_nan_sclr( xarg ) + +! Description: +! Checks if a given scalar real is a NaN, +inf or -inf. + +! Notes: +! I was advised by Andy Vaught to use a data statement and the transfer( ) +! intrinsic rather than using a hex number in a parameter for portability. + +! Certain compiler optimizations may cause variables with invalid +! results to flush to zero. Avoid these! +! -dschanen 16 Dec 2010 + +!------------------------------------------------------------------------ + +#ifndef __GFORTRAN__ + use parameters_model, only: & + PosInf ! Variable(s) +#endif + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: xarg + +#ifdef __GFORTRAN__ /* if the isnan extension is available, we use it here */ + is_nan_sclr = isnan( xarg ) +#else + ! ---- Begin Code --- + + ! This works on compilers with standardized floating point, + ! because the IEEE 754 spec defines that subnormals and nans + ! should not equal themselves. + ! However, all compilers do not seem to follow this. + if (xarg /= xarg ) then + is_nan_sclr = .true. + + ! This a second check, assuming the above does not work as + ! expected. + else if ( xarg == PosInf ) then + is_nan_sclr = .true. + + else + is_nan_sclr = .false. ! Our result should be a standard float + + end if +#endif + + return + end function is_nan_sclr +!------------------------------------------------------------------------ + +!------------------------------------------------------------------------ + logical function is_nan_2d( x2d ) + +! Description: +! Checks if a given real vector is a NaN, +inf or -inf. + +!------------------------------------------------------------------------ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: any + + ! Input Variables + real( kind = core_rknd ), dimension(:), intent(in) :: x2d + + ! Local Variables + integer :: k + + ! ---- Begin Code ---- + + is_nan_2d = .false. + + do k = 1, size( x2d ) + if ( is_nan_sclr( x2d(k) ) ) then + is_nan_2d = .true. + exit + end if + end do + + return + + end function is_nan_2d + +!------------------------------------------------------------------------ + subroutine check_negative_total & + ( var, varname, operation, err_code ) +! +! Description: +! Checks for negative values in the var array and reports them. +! +!----------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_var_less_than_zero ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: any, present + + ! Input Variables + real( kind = core_rknd ), intent(in), dimension(:) :: var + + character(len=*), intent(in):: & + varname, & ! Varible being examined + operation ! Procedure calling check_zero + + ! Optional In/Out Variable + integer, optional, intent(inout) :: err_code + + if ( any( var < 0.0_core_rknd ) ) then + + write(fstderr,*) varname, " < 0 in ", operation + if ( present( err_code ) ) then + if (err_code < clubb_var_less_than_zero ) then + err_code = clubb_var_less_than_zero + end if + end if + + end if ! any ( var < 0 ) + + return + + end subroutine check_negative_total + + +!------------------------------------------------------------------------ + subroutine check_negative_index & + ( var, ndim, varname, operation, err_code ) +! +! Description: +! Checks for negative values in the var array and reports +! the index in which the negative values occur. +! +!----------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Variable + + use error_code, only: & + clubb_var_less_than_zero ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: any, present + + ! Input Variables + integer, intent(in) :: ndim + + real( kind = core_rknd ), intent(in), dimension(ndim) :: var + + character(len=*), intent(in):: & + varname, & ! Varible being examined + operation ! Procedure calling check_zero + + ! Optional In/Out Variable + integer, optional, intent(inout) :: err_code + + ! Local Variable + integer :: k ! Loop iterator + + do k=1,ndim,1 + + if ( var(k) < 0.0_core_rknd ) then + + write(fstderr,*) varname, " < 0 in ", operation, & + " at k = ", k + + if ( present( err_code ) ) then + if (err_code < clubb_var_less_than_zero ) then + err_code = clubb_var_less_than_zero + end if + end if + + end if + + end do ! 1..n + + return + + end subroutine check_negative_index + + +!------------------------------------------------------------------------ + subroutine check_nan_2d( var, varname, operation, err_code ) +! +! Description: +! Checks for a NaN in the var array and reports it. +! +! +!------------------------------------------------------------------------ + use constants_clubb, only: & + fstderr ! Variable(s) + use error_code, only: & + clubb_var_equals_NaN ! Variable(s) + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: present + + ! Input variables + real( kind = core_rknd ), intent(in), dimension(:) :: var ! Variable being examined + + character(len=*), intent(in):: & + varname, & ! Name of variable + operation ! Procedure calling check_nan + + ! Optional In/Out Variable + integer, optional, intent(inout) :: err_code + + if ( is_nan_2d( var ) ) then + write(fstderr,*) varname, " is NaN in ",operation + if ( present( err_code ) ) then + if( err_code < clubb_var_equals_NaN ) then + err_code = clubb_var_equals_NaN + end if + end if + end if + + return + end subroutine check_nan_2d + +!----------------------------------------------------------------------- + subroutine check_nan_sclr( var, varname, operation, err_code ) +! +! Description: +! Checks for a NaN in the scalar var then reports it. +! +!----------------------------------------------------------------------- + use constants_clubb, only: & + fstderr ! Variable + use error_code, only: & + clubb_var_equals_NaN ! Variable + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: present + + ! Input Variables + real( kind = core_rknd ), intent(in) :: var ! Variable being examined + + character(len=*), intent(in):: & + varname, & ! Name of variable being examined + operation ! Procedure calling check_nan + + ! Optional In/Out variable + integer, optional, intent(inout) :: err_code +!-------------------------------------------------------------------- + if ( is_nan_sclr( var ) ) then + write(fstderr,*) varname, " is NaN in ",operation + if ( present( err_code ) ) then + if( err_code < clubb_var_equals_NaN ) then + err_code = clubb_var_equals_NAN + end if + end if + end if + + return + + end subroutine check_nan_sclr +!------------------------------------------------------------------------- + +!----------------------------------------------------------------------- + pure function calculate_spurious_source( integral_after, integral_before, & + flux_top, flux_sfc, & + integral_forcing, dt ) & + result( spurious_source ) +! +! Description: +! Checks whether there is conservation within the column and returns any +! imbalance as spurious_source where spurious_source is defined negative +! for a spurious sink. +! +!----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + integral_after, & ! Vertically-integrated quantity after dt time [units vary] + integral_before, & ! Vertically-integrated quantity before dt time [units vary] + flux_top, & ! Total flux at the top of the domain [units vary] + flux_sfc, & ! Total flux at the bottom of the domain [units vary] + integral_forcing, & ! Vertically-integrated forcing [units vary] + dt ! Timestep size [s] + + ! Return Variable + real( kind = core_rknd ) :: spurious_source ! [units vary] + +!-------------------------------------------------------------------- + + ! ---- Begin Code ---- + + spurious_source = (integral_after - integral_before) / dt & + + flux_top - flux_sfc - integral_forcing + + return + + end function calculate_spurious_source +!------------------------------------------------------------------------- +end module numerical_check diff --git a/src/physics/clubb/output_grads.F90 b/src/physics/clubb/output_grads.F90 new file mode 100644 index 0000000000..ccd219ca30 --- /dev/null +++ b/src/physics/clubb/output_grads.F90 @@ -0,0 +1,795 @@ +!------------------------------------------------------------------------------- +! $Id: output_grads.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== +module output_grads + + +! Description: +! This module contains structure and subroutine definitions to +! create GrADS output data files for one dimensional arrays. +! +! The structure type (stat_file) contains all necessay information +! to generate a GrADS file and a list of variables to be output +! in the data file. +! +! References: +! None +! +! Original Author: +! Chris Golaz, updated 2/18/2003 +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + public :: open_grads, write_grads + + private :: format_date, check_grads, & + determine_time_inc + + ! Undefined value + real( kind = core_rknd ), private, parameter :: undef = -9.99e33_core_rknd + + private ! Default scope + + contains + +!------------------------------------------------------------------------------- + subroutine open_grads( iunit, fdir, fname, & + ia, iz, nlat, nlon, z, & + day, month, year, rlat, rlon, & + time, dtwrite, & + nvar, grads_file ) +! Description: +! Opens and initialize variable components for derived type 'grads_file' +! If the GrADS file already exists, open_grads will overwrite it. + +! References: +! None +!------------------------------------------------------------------------------- + use constants_clubb, only: & + fstderr, & ! Constant(s) + sec_per_min + + use stat_file_module, only: & + stat_file ! Type + + use clubb_precision, only: & + time_precision ! Variable + + use stats_variables, only: & + l_allow_small_stats_tout + + implicit none + + ! Input Variables + + integer, intent(in) :: iunit ! File unit being written to [-] + + character(len=*), intent(in) :: & + fdir, & ! Directory where file is stored [-] + fname ! Name of file [-] + + integer, intent(in) :: & + ia, & ! Lower Bound of z (altitude) [-] + iz, & ! Upper Bound of z (altitude) [-] + nlat, & ! Number of points in the y direction (latitude) [-] + nlon ! Number of points in the x direction (longitude) [-] + + real( kind = core_rknd ), dimension(:), intent(in) :: & + z ! Vertical levels [m] + + integer, intent(in) :: & + day, & ! Day of Month at Model Start [dd] + month, & ! Month of Year at Model start [mm] + year ! Year at Model Start [yyyy] + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude [Degrees E] + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time ! Time since Model start [s] + real( kind = core_rknd ), intent(in) :: & + dtwrite ! Time interval for output [s] + + ! Number of GrADS variables to store [#] + integer, intent(in) :: nvar + + ! Input/Output Variables + type (stat_file), intent(inout) :: & + grads_file ! File data [-] + + ! Local Variables + + integer :: k + logical :: l_ctl, l_dat, l_error + + ! ---- Begin Code ---- + + ! Define parameters for the GrADS ctl and dat files + + grads_file%iounit = iunit + grads_file%fdir = fdir + grads_file%fname = fname + grads_file%ia = ia + grads_file%iz = iz + + ! Determine if the altitudes are ascending or descending and setup the + ! variable z accordingly. + if ( ia <= iz ) then + do k=1,iz-ia+1 + grads_file%z(k) = z(ia+k-1) + end do + else + do k=1,ia-iz+1 + grads_file%z(k) = z(ia-k+1) + end do + end if + + grads_file%day = day + grads_file%month = month + grads_file%year = year + + grads_file%nlat = nlat + grads_file%nlon = nlon + + allocate( grads_file%rlat(nlat), grads_file%rlon(nlon) ) + + grads_file%rlat = rlat + grads_file%rlon = rlon + + grads_file%dtwrite = dtwrite + + grads_file%nvar = nvar + + ! Check to make sure the timestep is appropriate. GrADS does not support an + ! output timestep less than 1 minute. + if (dtwrite < sec_per_min) then + write(fstderr,*) "Warning: GrADS requires an output timestep of at least & + &one minute, but the requested output timestep & + &(stats_tout) is less than one minute." + if (.not. l_allow_small_stats_tout) then + write(fstderr,*) "To override this warning, set l_allow_small_stats_tout = & + &.true. in the stats_setting namelist in the & + &appropriate *_model.in file." + stop "Fatal error in open_grads" + end if + end if + + ! Check whether GrADS files already exists + + ! We don't use this feature for the single-column model. The + ! clubb_standalone program will simply overwrite existing data files if they + ! exist. The restart function will create a new GrADS file starting from + ! the restart time in the output directory. + + ! inquire( file=trim(fdir)//trim(fname)//'.ctl', exist=l_ctl ) + ! inquire( file=trim(fdir)//trim(fname)//'.dat', exist=l_dat ) + + l_ctl = .false. + l_dat = .false. + + ! If none of the files exist, set ntimes and nrecord and + ! to initial values and return + + if ( .not.l_ctl .and. .not.l_dat ) then + + grads_file%time = time + grads_file%ntimes = 0 + grads_file%nrecord = 1 + return + + ! If both files exists, attempt to append to existing files + + else if ( l_ctl .and. l_dat ) then + + ! Check existing ctl file + + call check_grads( iunit, fdir, fname, & + ia, iz, & + day, month, year, time, dtwrite, & + nvar, & + l_error, grads_file%ntimes, grads_file%nrecord, & + grads_file%time ) + + if ( l_error ) then + write(unit=fstderr,fmt=*) "Error in open_grads:" + write(unit=fstderr,fmt=*) & + "Attempt to append to existing files failed" +! call stopcode('open_grads') + stop 'open_grads' + end if + + return + +! If one file exists, but not the other, give up + + else + write(unit=fstderr,fmt=*) 'Error in open_grads:' + write(unit=fstderr,fmt=*) & + "Attempt to append to existing files failed,"// & + " because only one of the two GrADS files was found." + stop "open_grads" + + end if + + return + end subroutine open_grads + +!------------------------------------------------------------------------------- + subroutine check_grads( iunit, fdir, fname, & + ia, iz, & + day, month, year, time, dtwrite, & + nvar, & + l_error, ntimes, nrecord, time_grads ) +! Description: +! Given a GrADS file that already exists, this subroutine will attempt +! to determine whether data can be safely appended to existing file. +! References: +! None +!------------------------------------------------------------------------------- + use stat_file_module, only: & + variable ! Type + + use clubb_precision, only: & + time_precision ! Variable + + use constants_clubb, only: & + fstderr, & ! Variable + sec_per_hr, & + sec_per_min + + implicit none + + ! Input Variables + + integer, intent(in) :: & + iunit, & ! Fortran file unit + ia, iz, & ! First and last level + day, month, year, & ! Day, month and year numbers + nvar ! Number of variables in the file + + character(len=*), intent(in) :: & + fdir, fname ! File directory and name + + real( kind = time_precision ), intent(in) :: & + time ! Current model time [s] + + real( kind = core_rknd ), intent(in) :: & + dtwrite ! Time interval between writes to the file [s] + + ! Output Variables + logical, intent(out) :: & + l_error + + integer, intent(out) :: & + ntimes, nrecord + + real(kind=time_precision), intent(out) :: time_grads + + ! Local Variables + logical :: l_done + integer :: ierr + character(len = 256) :: line, tmp, date, dt + + integer :: & + i, nx, ny, nzmax, & + ihour, imin, & + ia_in, iz_in, ntimes_in, nvar_in, & + day_in, month_in, year_in + + real( kind = core_rknd ) :: dtwrite_in + + real( kind = core_rknd ), dimension(:), allocatable :: z_in + + type (variable), dimension(:), allocatable :: var_in + +!------------------------------------------------------------------------------- + + ! ---- Begin Code ---- + + ! Initialize logical variables + l_error = .false. + l_done = .false. + + ! Open control file + open( unit = iunit, & + file = trim( fdir )//trim( fname )//'.ctl', & + status = 'old', iostat = ierr ) + if ( ierr < 0 ) l_done = .true. + + ! Read and process it + + read(unit=iunit,iostat=ierr,fmt='(a256)') line + if ( ierr < 0 ) l_done = .true. + + do while ( .not. l_done ) + + if ( index(line,'XDEF') > 0 ) then + + read(unit=line,fmt=*) tmp, nx + if ( nx /= 1 ) then + write(unit=fstderr,fmt=*) 'Error: XDEF can only be 1' + l_error = .true. + end if + + else if ( index(line,'YDEF') > 0 ) then + + read(unit=line,fmt=*) tmp, ny + if ( ny /= 1 ) then + write(unit=fstderr,fmt=*) "Error: YDEF can only be 1" + l_error = .true. + end if + + else if ( index(line,'ZDEF') > 0 ) then + + read(unit=line,fmt=*) tmp, iz_in + + if ( index(line,'LEVELS') > 0 ) then + ia_in = 1 + allocate( z_in(ia_in:iz_in) ) + read(unit=iunit,fmt=*) (z_in(i),i=ia_in,iz_in) + end if + + else if ( index(line,'TDEF') > 0 ) then + + read(unit=line,fmt=*) tmp, ntimes_in, tmp, date, dt + read(unit=date(1:2),fmt=*) ihour + read(unit=date(4:5),fmt=*) imin + time_grads = real( ihour, kind=time_precision) * real(sec_per_hr,kind=time_precision) & + + real( imin, kind=time_precision ) * real(sec_per_min,kind=time_precision) + read(unit=date(7:8),fmt=*) day_in + read(unit=date(12:15),fmt=*) year_in + + select case( date(9:11) ) + case( 'JAN' ) + month_in = 1 + case( 'FEB' ) + month_in = 2 + case( 'MAR' ) + month_in = 3 + case( 'APR' ) + month_in = 4 + case( 'MAY' ) + month_in = 5 + case( 'JUN' ) + month_in = 6 + case( 'JUL' ) + month_in = 7 + case( 'AUG' ) + month_in = 8 + case( 'SEP' ) + month_in = 9 + case( 'OCT' ) + month_in = 10 + case( 'NOV' ) + month_in = 11 + case( 'DEC' ) + month_in = 12 + case default + write(unit=fstderr,fmt=*) "Unknown month: "//date(9:11) + l_error = .true. + end select + + read(unit=dt(1:len_trim(dt)-2),fmt=*) dtwrite_in + dtwrite_in = dtwrite_in * sec_per_min + + else if ( index(line,'ENDVARS') > 0 ) then + + l_done = .true. + + else if ( index(line,'VARS') > 0 ) then + + read(line,*) tmp, nvar_in + allocate( var_in(nvar_in) ) + do i=1, nvar_in + read(unit=iunit,iostat=ierr,fmt='(a256)') line + read(unit=line,fmt=*) var_in(i)%name, nzmax + if ( nzmax /= iz_in ) then + write(unit=fstderr,fmt=*) & + "Error reading ", trim( var_in(i)%name ) + l_error = .true. + end if ! nzmax /= iz_in + end do ! 1..nvar_in + end if + + read(unit=iunit,iostat=ierr,fmt='(a256)') line + if ( ierr < 0 ) l_done = .true. + + end do ! while ( .not. l_done ) + + close( unit=iunit ) + + ! Perform some error check + + if ( abs(ia_in - iz_in) /= abs(ia - iz) ) then + write(unit=fstderr,fmt=*) "check_grads: size mismatch" + l_error = .true. + end if + + if ( day_in /= day ) then + write(unit=fstderr,fmt=*) "check_grads: day mismatch" + l_error = .true. + end if + + if ( month_in /= month ) then + write(unit=fstderr,fmt=*) "check_grads: month mismatch" + l_error = .true. + end if + + if ( year_in /= year ) then + write(unit=fstderr,fmt=*) "check_grads: year mismatch" + l_error = .true. + end if + + if ( int( time_grads ) + ntimes_in*int( dtwrite_in ) & + /= int( time ) ) then + write(unit=fstderr,fmt=*) "check_grads: time mismatch" + l_error = .true. + end if + + if ( int( dtwrite_in ) /= int( dtwrite) ) then + write(unit=fstderr,fmt=*) 'check_grads: dtwrite mismatch' + l_error = .true. + end if + + if ( nvar_in /= nvar ) then + write(unit=fstderr,fmt=*) 'check_grads: nvar mismatch' + l_error = .true. + end if + + if ( l_error ) then + write(unit=fstderr,fmt=*) "check_grads diagnostic" + write(unit=fstderr,fmt=*) "ia = ", ia_in, ia + write(unit=fstderr,fmt=*) "iz = ", iz_in, iz + write(unit=fstderr,fmt=*) "day = ", day_in, day + write(unit=fstderr,fmt=*) "month = ", month_in, month + write(unit=fstderr,fmt=*) "year = ", year_in, year + write(unit=fstderr,fmt=*) "time_grads / time = ", time_grads, time + write(unit=fstderr,fmt=*) "dtwrite = ", dtwrite_in, dtwrite + write(unit=fstderr,fmt=*) "nvar = ", nvar_in, nvar + end if + + ! Set ntimes and nrecord to append to existing files + + ntimes = ntimes_in + nrecord = ntimes_in * nvar_in * iz_in + 1 + + deallocate( z_in ) + + ! The purpose of this statement is to avoid a compiler warning + ! for tmp + if (tmp =="") then + end if + ! Joshua Fasching June 2008 + + return + end subroutine check_grads + +!------------------------------------------------------------------------------- + subroutine write_grads( grads_file ) + +! Description: +! Write part of a GrADS file to data (.dat) file update control file (.ctl. +! Can be called as many times as necessary +! References: +! None +!------------------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Variable(s) + + use model_flags, only: & + l_byteswap_io ! Variable + + use endian, only: & + big_endian, & ! Variable + little_endian + + use stat_file_module, only: & + stat_file ! Type + + use clubb_precision, only: & + time_precision ! Variable(s) + +! use stat_file_module, only: & +! clubb_i, clubb_j ! Variable(s) + + implicit none + + ! External + intrinsic :: selected_real_kind + + ! Constant parameters + integer, parameter :: & + r4 = selected_real_kind( p=5 ) ! Specify 5 decimal digits of precision + + ! Input Variables + type (stat_file), intent(inout) :: & + grads_file ! Contains all information on the files to be written to + + ! Local Variables + integer :: & + ivar, & ! Loop indices + ios ! I/O status indicator + + character(len=15) :: date + + integer :: dtwrite_ctl ! Time increment for the ctl file + character(len=2) :: dtwrite_units ! Units on dtwrite_ctl + + ! ---- Begin Code ---- + ! Check number of variables and write nothing if less than 1 + + if ( grads_file%nvar < 1 ) return + +#include "recl.inc" + + ! Output data to file + open( unit=grads_file%iounit, & + file=trim( grads_file%fdir )//trim( grads_file%fname )//'.dat', & + form='unformatted', access='direct', & + recl=F_RECL*abs( grads_file%iz-grads_file%ia+1 )*grads_file%nlon*grads_file%nlat, & + status='unknown', iostat=ios ) + if ( ios /= 0 ) then + write(unit=fstderr,fmt=*) & + "write_grads: error opening binary file" + write(unit=fstderr,fmt=*) "iostat = ", ios + stop + end if + + if ( grads_file%ia <= grads_file%iz ) then + do ivar=1,grads_file%nvar + write(grads_file%iounit,rec=grads_file%nrecord) & + real( grads_file%var(ivar)%ptr(1:grads_file%nlon, & + 1:grads_file%nlat,grads_file%ia:grads_file%iz), kind=r4) + grads_file%nrecord = grads_file%nrecord + 1 + end do + + else + do ivar=1, grads_file%nvar + write(grads_file%iounit,rec=grads_file%nrecord) & + real( grads_file%var(ivar)%ptr(1:grads_file%nlon, & + 1:grads_file%nlat,grads_file%ia:grads_file%iz:-1), kind=r4) + grads_file%nrecord = grads_file%nrecord + 1 + end do + + end if ! grads_file%ia <= grads_file%iz + + close( unit=grads_file%iounit, iostat = ios ) + + if ( ios /= 0 ) then + write(unit=fstderr,fmt=*) & + "write_grads: error closing binary file" + write(unit=fstderr,fmt=*) "iostat = ", ios + stop + end if + + grads_file%ntimes = grads_file%ntimes + 1 + + ! Write control file + + open(unit=grads_file%iounit, & + file=trim( grads_file%fdir )//trim( grads_file%fname )//'.ctl', & + status='unknown', iostat=ios) + if ( ios > 0 ) then + write(unit=fstderr,fmt=*) & + "write_grads: error opening control file" + write(unit=fstderr,fmt=*) "iostat = ", ios + stop + end if + + ! Write file header + if ( ( big_endian .and. .not. l_byteswap_io ) & + .or. ( little_endian .and. l_byteswap_io ) ) then + write(unit=grads_file%iounit,fmt='(a)') 'OPTIONS BIG_ENDIAN' + + else + write(unit=grads_file%iounit,fmt='(a)') 'OPTIONS LITTLE_ENDIAN' + + end if + + write(unit=grads_file%iounit,fmt='(a)') 'DSET ^'//trim( grads_file%fname )//'.dat' + write(unit=grads_file%iounit,fmt='(a,e12.5)') 'UNDEF ',undef + + if ( grads_file%nlon == 1 ) then ! Use linear for a singleton X dimesion + write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'XDEF 1 LINEAR ', grads_file%rlon, ' 1.' + else + write(unit=grads_file%iounit,fmt='(a,i5,a)') 'XDEF', grads_file%nlon,' LEVELS ' + write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%rlon + end if + + if ( grads_file%nlat == 1 ) then ! Use linear for a singleton Y dimension + write(unit=grads_file%iounit,fmt='(a,f8.3,a)') 'YDEF 1 LINEAR ', grads_file%rlat, ' 1.' + else + write(unit=grads_file%iounit,fmt='(a,i5,a)') 'YDEF', grads_file%nlat,' LEVELS ' + write(unit=grads_file%iounit,fmt='(6f13.4)') grads_file%rlat + end if + + if ( grads_file%ia == grads_file%iz ) then ! If ia == iz, then Z is also singleton + write(unit=grads_file%iounit,fmt='(a)') 'ZDEF 1 LEVELS 0.' + else if ( grads_file%ia < grads_file%iz ) then + write(unit=grads_file%iounit,fmt='(a,i5,a)') & + 'ZDEF', abs(grads_file%iz-grads_file%ia)+1,' LEVELS ' + write(unit=grads_file%iounit,fmt='(6f13.4)') & + (grads_file%z(ivar-grads_file%ia+1),ivar=grads_file%ia,grads_file%iz) + else + write(unit=grads_file%iounit,fmt='(a,i5,a)') & + 'ZDEF',abs(grads_file%iz-grads_file%ia)+1,' LEVELS ' + write(grads_file%iounit,'(6f13.4)') (grads_file%z(grads_file%ia-ivar+1), & + ivar=grads_file%ia,grads_file%iz,-1) + end if + + call format_date( grads_file%day, grads_file%month, grads_file%year, grads_file%time, & ! In + date ) ! Out + + call determine_time_inc( grads_file%dtwrite, & ! In + dtwrite_ctl, dtwrite_units ) ! Out + + write(unit=grads_file%iounit,fmt='(a,i6,a,a,i5,a)') 'TDEF ', & + grads_file%ntimes, ' LINEAR ', date, dtwrite_ctl, dtwrite_units + + ! Variables description + write(unit=grads_file%iounit,fmt='(a,i5)') 'VARS', grads_file%nvar + + do ivar=1, grads_file%nvar, 1 + write(unit=grads_file%iounit,fmt='(a,i5,a,a)') & + grads_file%var(ivar)%name(1:len_trim(grads_file%var(ivar)%name)), & + abs(grads_file%iz-grads_file%ia)+1,' 99 ', & + grads_file%var(ivar)%description(1:len_trim(grads_file%var(ivar)%description)) + end do + + write(unit=grads_file%iounit,fmt='(a)') 'ENDVARS' + + close( unit=grads_file%iounit, iostat=ios ) + if ( ios > 0 ) then + write(unit=fstderr,fmt=*) & + "write_grads: error closing control file" + write(unit=fstderr,fmt=*) "iostat = ",ios + stop + end if + + return + end subroutine write_grads + +!--------------------------------------------------------- + subroutine format_date( day_in, month_in, year_in, time_in, & + date ) +! +! Description: +! This subroutine formats the current time of the model (given in seconds +! since the start time) to a date format usable as GrADS output. +! References: +! None +!--------------------------------------------------------- + use clubb_precision, only: & + time_precision ! Variable(s) + + use calendar, only: & + compute_current_date ! Procedure(s) + + use calendar, only: & + month_names ! Variable(s) + + use constants_clubb, only: & + sec_per_hr, & ! Variable(s) + min_per_hr + + implicit none + + ! Input Variables + integer, intent(in) :: & + day_in, & ! Day of the Month at Model Start [dd] + month_in, & ! Month of the Year at Model Start [mm] + year_in ! Year at Model Start [yyyy] + + real(kind=time_precision), intent(in) :: & + time_in ! Time since Model Start [s] + + ! Output Variables + character(len=15), intent(out) :: & + date ! Current Date in format 'hh:mmZddmmmyyyy' + + ! Local Variables + integer :: iday, imonth, iyear ! Day, month, year + real(kind=time_precision) :: time ! time [s] + + ! ---- Begin Code ---- + + ! Copy input arguments into local variables + + iday = day_in + imonth = month_in + iyear = year_in + time = time_in + + call compute_current_date( day_in, month_in, & ! In + year_in, & ! In + time_in, & ! In + iday, imonth, & ! Out + iyear, & ! Out + time ) ! Out + + date = 'hh:mmZddmmmyyyy' + write(unit=date(7:8),fmt='(i2.2)') iday + write(unit=date(9:11),fmt='(a3)') month_names(imonth) + write(unit=date(12:15),fmt='(i4.4)') iyear + write(unit=date(1:2),fmt='(i2.2)') floor(time/real(sec_per_hr,kind=time_precision )) + write(unit=date(4:5),fmt='(i2.2)') & + int( mod( nint( time ), nint(sec_per_hr) ) / nint(min_per_hr) ) + + return + end subroutine format_date + +!------------------------------------------------------------------------------- + subroutine determine_time_inc( dtwrite_sec, & + dtwrite_ctl, units ) +! Description: +! Determine the units on the time increment, since GrADS only allows a 2 digit +! time increment. +! References: +! None +!------------------------------------------------------------------------------- + use constants_clubb, only: & + sec_per_day, & ! Constants + sec_per_hr, & + sec_per_min + + + implicit none + + ! External + intrinsic :: max, floor + + ! Input Variables + real(kind=core_rknd), intent(in) :: & + dtwrite_sec ! Time increment in GrADS [s] + + ! Output Variables + integer, intent(out) :: & + dtwrite_ctl ! Time increment in GrADS [units vary] + + character(len=2), intent(out) :: units ! Units on dtwrite_ctl + + ! Local variables + real(kind=core_rknd) :: & + dtwrite_min, & ! Time increment [minutes] + dtwrite_hrs, & ! Time increment [hours] + dtwrite_days ! Time increment [days] + + ! ---- Begin Code ---- + + ! Since GrADs can't handle a time increment of less than a minute we assume + ! 1 minute output for an output frequency of less than a minute. + dtwrite_min = real( floor( dtwrite_sec/sec_per_min ), kind=core_rknd ) + dtwrite_min = max( 1._core_rknd, dtwrite_min ) + + if ( dtwrite_min <= 99._core_rknd ) then + dtwrite_ctl = int( dtwrite_min ) + units = 'mn' + else + dtwrite_hrs = dtwrite_sec / sec_per_hr + if ( dtwrite_hrs <= 99._core_rknd ) then + dtwrite_ctl = int( dtwrite_hrs ) + units = 'hr' + else + dtwrite_days = dtwrite_sec / sec_per_day + if ( dtwrite_days <= 99._core_rknd ) then + dtwrite_ctl = int( dtwrite_days ) + units = 'dy' + else + stop "Fatal error in determine_time_inc" + end if ! dwrite_days <= 99. + end if ! dtwrite_hrs <= 99. + end if ! dtwrite_min <= 99. + + return + end subroutine determine_time_inc + +end module output_grads +!------------------------------------------------------------------------------- diff --git a/src/physics/clubb/output_netcdf.F90 b/src/physics/clubb/output_netcdf.F90 new file mode 100644 index 0000000000..e24a906cc3 --- /dev/null +++ b/src/physics/clubb/output_netcdf.F90 @@ -0,0 +1,889 @@ +!----------------------------------------------------------------------- +! $Id: output_netcdf.F90 7169 2014-08-05 21:42:25Z dschanen@uwm.edu $ +!=============================================================================== +module output_netcdf +#ifdef NETCDF + +! Description: +! Functions and subroutines for writing NetCDF files + +! References: +! +!------------------------------------------------------------------------------- + + implicit none + + public :: open_netcdf_for_writing, write_netcdf, close_netcdf + + private :: define_netcdf, write_grid, first_write, format_date + + ! Constant parameters + ! This will truncate all timesteps smaller than 1 mn to a minute for + ! the purposes of viewing the data in grads + logical, parameter, private :: & + l_grads_netcdf_boost_ts = .false. + + private ! Default scope + + contains +!------------------------------------------------------------------------------- + subroutine open_netcdf_for_writing( nlat, nlon, fdir, fname, ia, iz, zgrid, & + day, month, year, rlat, rlon, & + time, dtwrite, nvar, ncf ) + +! Description: +! Defines the structure used to reference the file `ncf' + +! References: +! None +!------------------------------------------------------------------------------- + use netcdf, only: & + NF90_CLOBBER, & ! Variable(s) + NF90_NOERR, & + nf90_create, & ! Procedure + nf90_strerror + + use stat_file_module, only: & + stat_file ! Type + + use clubb_precision, only: & + time_precision, & ! Variable(s) + core_rknd + + use constants_clubb, only: & + fstderr, & ! Variable(s) + sec_per_min + + use stats_variables, only: & + l_allow_small_stats_tout + + implicit none + + ! Input Variables + character(len=*), intent(in) :: & + fdir, & ! Directory name of file + fname ! File name + + integer, intent(in) :: & + nlat, nlon, & ! Number of points in the X and Y + day, month, year, & ! Time + ia, iz, & ! First and last grid point + nvar ! Number of variables + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitudes [degrees_E] + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitudes [degrees_N] + + real( kind = core_rknd ), intent(in) :: & + dtwrite ! Time between write intervals [s] + + real( kind = time_precision ), intent(in) :: & + time ! Current time [s] + + real( kind = core_rknd ), dimension(:), intent(in) :: & + zgrid ! The model grid [m] + + ! Input/output Variables + type (stat_file), intent(inout) :: ncf + + ! Local Variables + integer :: stat ! Error status + integer :: k ! Array index + + ! ---- Begin Code ---- + + ncf%nvar = nvar + + ! If there is no data to write, then return + if ( ncf%nvar == 0 ) then + return + end if + + ! Initialization for NetCDF + ncf%l_defined = .false. + + ! Define file (compatability with GrADS writing) + ncf%fdir = fdir + ncf%fname = fname + ncf%ia = ia + ncf%iz = iz + ncf%day = day + ncf%month = month + ncf%year = year + ncf%nlat = nlat + ncf%nlon = nlon + ncf%time = time + + ncf%dtwrite = dtwrite + + ! Check to make sure the timestep is appropriate. The GrADS program does not support an + ! output timestep less than 1 minute. Other programs can read netCDF files like this + if ( dtwrite < sec_per_min ) then + write(fstderr,*) "Warning: GrADS program requires an output timestep of at least & + &one minute, but the requested output timestep & + &(stats_tout) is less than one minute." + if ( .not. l_allow_small_stats_tout ) then + write(fstderr,*) "To override this warning, set l_allow_small_stats_tout = & + &.true. in the stats_setting namelist in the & + &appropriate *_model.in file." + stop "Fatal error in open_netcdf_for_writing" + end if + end if ! dtwrite < sec_per_min + + ! From open_grads. + ! This probably for the case of a reversed grid as in COAMPS + if ( ia <= iz ) then + do k=1,iz-ia+1 + ncf%z(k) = zgrid(ia+k-1) + end do + else ! Always this for CLUBB + do k=1,ia-iz+1 + ncf%z(k) = zgrid(ia-k+1) + end do + end if + + allocate( ncf%rlat(1:nlat), ncf%rlon(1:nlon) ) + + ncf%rlat = rlat + ncf%rlon = rlon + + ! Create NetCDF dataset: enter define mode + stat = nf90_create( path = trim( fdir )//trim( fname )//'.nc', & + cmode = NF90_CLOBBER, & ! overwrite existing file + ncid = ncf%iounit ) + if ( stat /= NF90_NOERR ) then + write(unit=fstderr,fmt=*) "Error opening file: ", & + trim( fdir )//trim( fname )//'.nc', & + trim( nf90_strerror( stat ) ) + stop "Fatal Error" + end if + + call define_netcdf( ncf%iounit, ncf%nlat, ncf%nlon, ncf%iz, & ! In + ncf%day, ncf%month, ncf%year, ncf%time, & ! In + ncf%LatDimId, ncf%LongDimId, ncf%AltDimId, ncf%TimeDimId, & ! Out + ncf%LatVarId, ncf%LongVarId, ncf%AltVarId, ncf%TimeVarId ) ! Out + + return + end subroutine open_netcdf_for_writing + +!------------------------------------------------------------------------------- + + subroutine write_netcdf( ncf ) + +! Description: +! Writes some data to the NetCDF dataset, but doesn't close it. +! +! References: +! None +!------------------------------------------------------------------------------- + + use netcdf, only: & + NF90_NOERR, & ! Variable(s) + nf90_put_var, & ! Procedure + nf90_strerror + + use stat_file_module, only: & + stat_file ! Variable + + use constants_clubb, only: & + fstderr, & ! Variable + sec_per_min + + use clubb_precision, only: & + time_precision ! Constant(s) + + implicit none + + ! Input + type (stat_file), intent(inout) :: ncf ! The file + + ! Local Variables + integer, dimension(:), allocatable :: stat ! Error status + real(kind=8), dimension(1) :: time ! Time [s] + + integer :: i ! Array index + + ! ---- Begin Code ---- + + ! If there is no data to write, then return + if ( ncf%nvar == 0 ) then + return + end if + + ncf%ntimes = ncf%ntimes + 1 + + if ( .not. ncf%l_defined ) then + call first_write( ncf ) ! finalize the variable definitions + call write_grid( ncf ) ! define lat., long., and grid + ncf%l_defined = .true. + end if + + allocate( stat( ncf%nvar ) ) + if ( l_grads_netcdf_boost_ts ) then + time = real( nint( real(ncf%ntimes, kind=time_precision) & + * real(ncf%dtwrite / sec_per_min, time_precision) ), & + kind=time_precision ) ! minutes(rounded) + else + time = real( ncf%ntimes, kind=time_precision ) & + * real( ncf%dtwrite, kind=time_precision ) ! seconds + end if + + stat(1) = nf90_put_var( ncid=ncf%iounit, varid=ncf%TimeVarId, & + values=time(1), start=(/ncf%ntimes/) ) + if ( stat(1) /= NF90_NOERR ) then + stop "time variable nf90_put_var failed" + end if + + do i = 1, ncf%nvar, 1 + stat(i) & + = nf90_put_var( ncid=ncf%iounit, varid=ncf%var(i)%indx, & + values=ncf%var(i)%ptr(:,:,ncf%ia:ncf%iz), & + start=(/1,1,1,ncf%ntimes/), & + count=(/ncf%nlon,ncf%nlat,ncf%iz,1/) ) + + end do ! i=1..nvar + + if ( any (stat /= NF90_NOERR ) ) then + do i=1,ncf%nvar,1 + if( stat(i) /= NF90_NOERR ) then + write(unit=fstderr,fmt=*) ncf%var(i)%name, & + trim( nf90_strerror( stat(i) ) ) + end if + end do + stop "nf90_put_var error" + end if + + + deallocate( stat ) + + return + end subroutine write_netcdf + +!------------------------------------------------------------------------------- + subroutine define_netcdf( ncid, nlat, nlon, iz, & + day, month, year, time, & + LatDimId, LongDimId, AltDimId, TimeDimId, & + LatVarId, LongVarId, AltVarId, TimeVarId ) + +! Description: +! Used internally to create a definition for the NetCDF dataset +! +! References: +! None +!------------------------------------------------------------------------------- + use netcdf, only: & + NF90_NOERR, & ! Constants + NF90_FLOAT, & + NF90_DOUBLE, & + NF90_UNLIMITED + + use netcdf, only: & + nf90_def_dim, & ! Functions + nf90_strerror, & + nf90_def_var, & + nf90_put_att + + use clubb_precision, only: & + time_precision ! Variable(s) + + use constants_clubb, only: & + fstderr ! Variable(s) + + implicit none + + integer, intent(in) :: & + nlat, & ! Number of points in the N/S direction + nlon ! Number of points in the E/W direction + + ! Input Variables + integer, intent(in) :: & + day, month, year, & ! Time of year + ncid, & ! Number used by NetCDF for ref. the file + iz ! Dimension in z + + real(kind=time_precision), intent(in) :: & + time ! Current model time [s] + + ! Output Variables + integer, intent(out) :: & + LatDimId, LongDimId, AltDimId, TimeDimId ! NetCDF id's for dimensions + + ! NetCDF id's for data (e.g. longitude) associated with each dimension + integer, intent(out) :: & + LatVarId, LongVarId, AltVarId, TimeVarId + + ! Local variables + integer :: stat + character(len=35) :: TimeUnits + + ! ---- Begin Code ---- + + ! Define the dimensions for the variables + stat = nf90_def_dim( ncid, "longitude", nlon, LongDimId ) + + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining longitude: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_def_dim( ncid, "latitude", nlat, LatDimId ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining latitude: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_def_dim( ncid, "altitude", iz, AltDimId ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining altitude: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_def_dim( ncid, "time", NF90_UNLIMITED, TimeDimId ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining time: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + ! Define the initial variables for the dimensions + ! Longitude = deg_E = X + stat = nf90_def_var( ncid, "longitude", NF90_DOUBLE, & + (/LongDimId/), LongVarId ) + + ! Latitude = deg_N = Y + stat = nf90_def_var( ncid, "latitude", NF90_DOUBLE, & + (/LatDimId/), LatVarId ) + + ! Altitude = meters above the surface = Z + stat = nf90_def_var( ncid, "altitude", NF90_DOUBLE, & + (/AltDimId/), AltVarId ) + + ! grads2nc stores time as a double prec. value, so we follow that + stat = nf90_def_var( ncid, "time", NF90_DOUBLE, & + (/TimeDimId/), TimeVarId ) + + ! Assign attribute values + + ! Time attribute + stat = nf90_put_att( ncid, TimeVarId, "cartesian_axis", "T" ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining time: ", trim( nf90_strerror( stat ) ) + stop + end if + + call format_date( day, month, year, time, TimeUnits ) + + stat = nf90_put_att( ncid, TimeVarId, "units", TimeUnits ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining time: ", trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_put_att( ncid, TimeVarId, "ipositive", 1 ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining time: ", trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_put_att( ncid, TimeVarId, "calendar_type", "Gregorian" ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error defining time", trim( nf90_strerror( stat ) ) + stop + end if + + ! Define Location + ! X & Y coordinates + stat = nf90_put_att( ncid, LongVarId, "cartesian_axis", "X" ) + + stat = nf90_put_att( ncid, LongVarId, "units", "degrees_E" ) + + stat = nf90_put_att( ncid, LongVarId, "ipositive", 1 ) + + stat = nf90_put_att( ncid, LatVarId, "cartesian_axis", "Y" ) + + stat = nf90_put_att( ncid, LatVarId, "units", "degrees_N" ) + + stat = nf90_put_att( ncid, LatVarId, "ipositive", 1 ) + + ! Altitude, Z coordinate + stat = nf90_put_att( ncid, AltVarId, "cartesian_axis", "Z" ) + + stat = nf90_put_att( ncid, AltVarId, "units", "meters" ) + + stat = nf90_put_att( ncid, AltVarId, "positive", "up" ) + + stat = nf90_put_att( ncid, AltVarId, "ipositive", 1 ) + + return + end subroutine define_netcdf + +!------------------------------------------------------------------------------- + subroutine close_netcdf( ncf ) + +! Description: +! Close a previously opened stats file. + +! Notes: +! I assume nf90_close() exists so that the NetCDF libraries can do a +! form of buffered I/O, but I don't know the implementation +! details. -dschanen +!------------------------------------------------------------------------------- + + use stat_file_module, only: & + stat_file ! Type + + use netcdf, only: & + NF90_NOERR, & ! Variable + nf90_close, & ! Procedure(s) + nf90_strerror + + use constants_clubb, only: & + fstderr ! Variable + + implicit none + + ! Input/Output Variables + type (stat_file), intent(inout) :: ncf + + ! Local Variables + integer :: stat + + ! ---- Begin Code ---- + + ! If there is no data to write, then return + if ( ncf%nvar == 0 ) then + return + end if + + stat = nf90_close( ncf%iounit ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error closing file "// & + trim( ncf%fname )//": ", trim( nf90_strerror( stat ) ) + stop "Fatal error" + end if + + return + end subroutine close_netcdf + +!------------------------------------------------------------------------------- + subroutine first_write( ncf ) + +! Description: +! Used on the first call to write_nc to finalize definitions +! for the dataset, including the attributes for variable records. +! References: +! None +!------------------------------------------------------------------------------- + + use netcdf, only: & + NF90_NOERR, & ! Constants + NF90_FLOAT, & + NF90_DOUBLE, & + NF90_GLOBAL, & + nf90_def_var, & ! Procedure(s) + nf90_strerror, & + nf90_put_att, & + nf90_enddef + + use stat_file_module, only: & + stat_file ! Derived type + + use constants_clubb, only: & + fstderr ! Variable + + use parameters_model, only: & + T0, & ! Real variables + ts_nudge, & + sclr_tol ! Real array variable + + use parameters_tunable, only: & + params_list ! Variable names (characters) + + use parameters_tunable, only: & + get_parameters ! Subroutine + + use parameter_indices, only: & + nparams ! Integer + + use model_flags, only: & + l_pos_def, & + l_hole_fill, & + l_clip_semi_implicit, & + l_standard_term_ta, & + l_single_C2_Skw, & + l_gamma_Skw, & + l_uv_nudge, & + l_tke_aniso + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: date_and_time, huge, selected_real_kind, size, any, trim + + ! Enabling l_output_file_run_date allows the date and time that the netCDF + ! output file is created to be included in the netCDF output file. + ! Disabling l_output_file_run_date means that this information will not be + ! included in the netCDF output file. The advantage of disabling this + ! output is that it allows for a check for binary differences between two + ! netCDF output files. + logical, parameter :: & + l_output_file_run_date = .false. + + ! Input/Output Variables + type (stat_file), intent(inout) :: ncf + + ! Local Variables + integer, dimension(:), allocatable :: stat + + integer :: netcdf_precision ! Level of precision for netCDF output + + real( kind = core_rknd ), dimension(nparams) :: params ! Tunable parameters + + integer :: i ! Array index + logical :: l_error ! Error stat + + character(len=10) :: current_time + character(len=8) :: current_date + ! Range for NetCDF variables + real( kind = core_rknd ), dimension(2) :: var_range + + ! Dimensions for variables + integer, dimension(4) :: var_dim + + +!------------------------------------------------------------------------------- +! Typical valid ranges (IEEE 754) + +! real(kind=4): +/- 3.4028235E+38 +! real(kind=8): +/- 1.797693134862316E+308 +! real(kind=16):+/- 1.189731495357231765085759326628007E+4932 + +!------------------------------------------------------------------------------- + + ! ---- Begin Code ---- + + var_range(1) = -huge( var_range(1) ) + var_range(2) = huge( var_range(2) ) + +! var_range = (/ -1.e31, 1.e31 /) + +! Explanation: The NetCDF documentation claims the NF90_UNLIMITED +! variable should be the first dimension, but def_var is somehow +! inverted and requires the opposite. After writing, these +! dimensions are all in the opposite order of this in the file. +! -dschanen + + var_dim(1) = ncf%LongDimId ! X + var_dim(2) = ncf%LatDimId ! Y + var_dim(3) = ncf%AltDimId ! Z + var_dim(4) = ncf%TimeDimId ! The NF90_UNLIMITED dimension + + allocate( stat( ncf%nvar ) ) + + l_error = .false. + + + select case (core_rknd) + case ( selected_real_kind( p=5 ) ) + netcdf_precision = NF90_FLOAT + case ( selected_real_kind( p=12 ) ) + netcdf_precision = NF90_DOUBLE + case default + netcdf_precision = NF90_DOUBLE + end select + + do i = 1, ncf%nvar, 1 +! stat(i) = nf90_def_var( ncf%iounit, trim( ncf%var(i)%name ), & +! NF90_FLOAT, (/ncf%TimeDimId, ncf%AltDimId, & +! ncf%LatDimId, ncf%LongDimId/), ncf%var(i)%indx ) + stat(i) = nf90_def_var( ncf%iounit, trim( ncf%var(i)%name ), & + netcdf_precision, var_dim(:), ncf%var(i)%indx ) + if ( stat(i) /= NF90_NOERR ) then + write(fstderr,*) "Error defining variable ", & + ncf%var(i)%name //": ", trim( nf90_strerror( stat(i) ) ) + l_error = .true. + end if + + stat(i) = nf90_put_att( ncf%iounit, ncf%var(i)%indx, & + "valid_range", var_range(1:2) ) + if ( stat(i) /= NF90_NOERR ) then + write(fstderr,*) "Error defining valid range", & + trim( nf90_strerror( stat(i) ) ) + l_error = .true. + end if + + stat(i) = nf90_put_att( ncf%iounit, ncf%var(i)%indx, "long_name", & + trim( ncf%var(i)%description ) ) + if ( stat(i) /= NF90_NOERR ) then + write(fstderr,*) "Error in description", & + trim( nf90_strerror( stat(i) ) ) + l_error = .true. + end if + + stat(i) = nf90_put_att( ncf%iounit, ncf%var(i)%indx, "units", & + trim( ncf%var(i)%units ) ) + if ( stat(i) /= NF90_NOERR ) then + write(fstderr,*) "Error in units", & + trim( nf90_strerror( stat(i) ) ) + l_error = .true. + end if + end do + + if ( l_error ) stop "Error in netCDF file definition." + + deallocate( stat ) + + if ( l_output_file_run_date ) then + allocate( stat(3) ) + else + allocate( stat(2) ) + end if + + ! Define global attributes of the file, for reproducing the results and + ! determining how a run was configured + stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "Conventions", "COARDS" ) + stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "model", "CLUBB" ) + + if ( l_output_file_run_date ) then + + ! Enabling l_output_file_run_date allows the date and time that the + ! netCDF output file is created to be included in the netCDF output file. + ! Disabling l_output_file_run_date means that this information will not + ! be included in the netCDF output file. The advantage of disabling this + ! output is that it allows for a check for binary differences between two + ! netCDF output files. + + ! Figure out when the model is producing this file + call date_and_time( current_date, current_time ) + + stat(3) = nf90_put_att(ncf%iounit, NF90_GLOBAL, "created_on", & + current_date(1:4)//'-'//current_date(5:6)//'-'// & + current_date(7:8)//' '// & + current_time(1:2)//':'//current_time(3:4) ) + + end if ! l_output_file_run_date + + if ( any( stat /= NF90_NOERR ) ) then + write(fstderr,*) "Error writing model information" + do i = 1, size( stat ), 1 + write(fstderr,*) trim( nf90_strerror( stat(i) ) ) + end do + stop + end if + + ! Write the model flags to the file + deallocate( stat ) + allocate( stat(8) ) ! # of model flags + + stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_pos_def", lchar( l_pos_def ) ) + stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_hole_fill", lchar( l_hole_fill ) ) + stat(3) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_clip_semi_implicit", & + lchar( l_clip_semi_implicit ) ) + stat(4) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_standard_term_ta", & + lchar( l_standard_term_ta ) ) + stat(5) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_single_C2_Skw", & + lchar( l_single_C2_Skw ) ) + stat(6) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_gamma_Skw", lchar( l_gamma_Skw ) ) + stat(7) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_uv_nudge", lchar( l_uv_nudge ) ) + stat(8) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "l_tke_aniso", lchar( l_tke_aniso ) ) + + if ( any( stat /= NF90_NOERR ) ) then + write(fstderr,*) "Error writing model flags" + do i = 1, size( stat ), 1 + write(fstderr,*) i, trim( nf90_strerror( stat(i) ) ) + end do + stop + end if + + ! Write model parameter values to the file + deallocate( stat ) + allocate( stat(nparams) ) + + stat(1) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "T0", T0 ) + stat(2) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "ts_nudge", ts_nudge ) + stat(3) = nf90_put_att( ncf%iounit, NF90_GLOBAL, "sclr_tol", sclr_tol ) + + call get_parameters( params ) + + do i = 1, nparams, 1 + stat(i) = nf90_put_att( ncf%iounit, NF90_GLOBAL, params_list(i), params(i) ) + end do + + if ( any( stat /= NF90_NOERR ) ) then + write(fstderr,*) "Error writing parameters" + do i = 1, nparams, 1 + write(fstderr,*) i, trim( nf90_strerror( stat(i) ) ) + end do + stop + end if + + stat(1) = nf90_enddef( ncf%iounit ) ! end definitions + if ( stat(1) /= NF90_NOERR ) then + write(fstderr,*) "Error finalizing definitions", & + trim( nf90_strerror( stat(1) ) ) + stop + end if + + deallocate( stat ) + + return + end subroutine first_write + +!------------------------------------------------------------------------------- + subroutine write_grid( ncf ) + +! Description: +! Writes inforation about latitude, longitude and the grid +! References: +! None +!------------------------------------------------------------------------------- + + use netcdf, only: & + NF90_NOERR, & ! Variable(s) + nf90_put_var, & ! Procedure(s) + nf90_strerror + use stat_file_module, only: & + stat_file ! Type + use constants_clubb, only: & + fstderr ! Variable + + implicit none + + ! Input Variable(s) + type (stat_file), intent(inout) :: ncf + + integer :: stat + + ! ---- Begin Code ---- + + stat = nf90_put_var( ncid=ncf%iounit, varid=ncf%AltVarId, & + values=ncf%z(ncf%ia:ncf%iz) ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error entering grid: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_put_var( ncid=ncf%iounit, varid=ncf%LongVarId, & + values=ncf%rlon ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error entering longitude: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + stat = nf90_put_var( ncid=ncf%iounit, varid=ncf%LatVarId, & + values=ncf%rlat ) + if ( stat /= NF90_NOERR ) then + write(fstderr,*) "Error entering latitude: ", & + trim( nf90_strerror( stat ) ) + stop + end if + + return + end subroutine write_grid + +!------------------------------------------------------------------------------- + + subroutine format_date & + ( day_in, month_in, year_in, time_in, date ) + +! Description: +! Put the model date in a format that udunits and NetCDF can easily +! handle. GrADSnc is dumb and apparently cannot handle time +! intervals < 1 minute. + +! Notes: +! Adapted from the original GrADS version written by Chris Golaz. +! Uses Fortran `internal' files to write the string output. +!------------------------------------------------------------------------------- + + use calendar, only: & + compute_current_date ! Procedure(s) + + use clubb_precision, only: & + time_precision ! Variable(s) + + implicit none + + ! External + intrinsic :: floor, int, mod, nint + + ! Input Variables + integer, intent(in) :: & + day_in, & ! Day of Month at Model Start [dd] + month_in, & ! Month of Year at Model Start [mm] + year_in ! Year at Model Start [yyyy] + + real(kind=time_precision), intent(in) :: time_in ! Start time [s] + + ! Output Variables + character(len=35), intent(out) :: date + + integer:: & + iday, imonth, iyear ! Integer for day, month and year. + + real(kind=time_precision) :: st_time ! Start time [s] + + call compute_current_date( day_in, month_in, & + year_in, & + time_in, & + iday, imonth, & + iyear, & + st_time ) + + if ( .not. l_grads_netcdf_boost_ts ) then + date = "seconds since YYYY-MM-DD HH:MM:00.0" + else + date = "minutes since YYYY-MM-DD HH:MM:00.0" + end if + write(date(15:18),'(i4.4)') iyear + write(date(20:21),'(i2.2)') imonth + write(date(23:24),'(i2.2)') iday + write(date(26:27),'(i2.2)') floor( st_time / 3600._time_precision ) + write(date(29:30),'(i2.2)') int( mod( nint( st_time ),3600 ) / 60 ) + + if ( .not. l_grads_netcdf_boost_ts ) then + write(date(32:33),'(i2.2)') nint(((real(mod( nint( st_time ),3600),kind=time_precision) / & + 60._time_precision) - (real(int(mod( nint( st_time ),3600 ) / 60 ), & + kind=time_precision) ) )*60._time_precision) + end if + + return + end subroutine format_date + +!=============================================================================== + character function lchar( l_input ) +! Description: +! Cast a logical to a character data type. +! +! References: +! None +!------------------------------------------------------------------------------- + + implicit none + + ! Input Variable + logical, intent(in) :: l_input + + ! ---- Begin Code ---- + + if ( l_input ) then + lchar = 'T' + else + lchar = 'F' + end if + + return + end function lchar + +#endif /*NETCDF*/ +end module output_netcdf diff --git a/src/physics/clubb/parameter_indices.F90 b/src/physics/clubb/parameter_indices.F90 new file mode 100644 index 0000000000..61e3a64022 --- /dev/null +++ b/src/physics/clubb/parameter_indices.F90 @@ -0,0 +1,120 @@ +!------------------------------------------------------------------------------- +! $Id: parameter_indices.F90 7361 2014-11-04 21:51:02Z bmg2@uwm.edu $ +!=============================================================================== +module parameter_indices + +! Description: +! Since f90/95 lacks enumeration, we're stuck numbering each +! parameter by hand like this. + +! Adding new parameters is relatively simple. First, the +! parameter should be added in the common block of the parameters +! module so it can be used in other parts of the code. Each +! variable needs a unique number in this module, and nparams must +! be incremented for the new variable. Next, the params_list +! variable in module parameters should have new variable added to +! it. The subroutines pack_parameters and uppack_parameters will +! need to have the variable added to their list, but the order +! doesn't actually matter, since the i variables in here determine +! where in the params vector the number is placed. +! Finally, the namelists clubb_params_nl and initspread will need to +! have the parameter added to them. +!------------------------------------------------------------------------------- + + implicit none + + private ! Default Scope + + integer, parameter, public :: & + nparams = 71 ! Total tunable parameters + +!*************************************************************** +! ***** IMPORTANT ***** +! If you change the order of these parameters, you will need to +! change the order of params_list as well or the tuner will +! break! +! ***** IMPORTANT ***** +!*************************************************************** + + integer, parameter, public :: & + iC1 = 1, & + iC1b = 2, & + iC1c = 3, & + iC2 = 4, & + iC2b = 5, & + iC2c = 6, & + iC2rt = 7, & + iC2thl = 8, & + iC2rtthl = 9, & + iC4 = 10, & + iC5 = 11, & + iC6rt = 12, & + iC6rtb = 13, & + iC6rtc = 14, & + iC6thl = 15, & + iC6thlb = 16, & + iC6thlc = 17, & + iC7 = 18, & + iC7b = 19, & + iC7c = 20, & + iC8 = 21, & + iC8b = 22, & + iC10 = 23, & + iC11 = 24, & + iC11b = 25, & + iC11c = 26, & + iC12 = 27, & + iC13 = 28, & + iC14 = 29, & + iC15 = 30 + + integer, parameter, public :: & + iC6rt_Lscale0 = 31, & + iC6thl_Lscale0 = 32, & + iC7_Lscale0 = 33, & + iwpxp_L_thresh = 34 + + integer, parameter, public :: & + ic_K = 35, & + ic_K1 = 36, & + inu1 = 37, & + ic_K2 = 38, & + inu2 = 39, & + ic_K6 = 40, & + inu6 = 41, & + ic_K8 = 42, & + inu8 = 43, & + ic_K9 = 44, & + inu9 = 45, & + inu10 = 46, & + ic_K_hm = 47, & + ic_K_hmb = 48, & + iK_hm_min_coef = 49, & + inu_hm = 50 + + integer, parameter, public :: & + igamma_coef = 51, & + igamma_coefb = 52, & + igamma_coefc = 53, & + imu = 54, & + ibeta = 55, & + ilmin_coef = 56, & + iomicron = 57, & + izeta_vrnce_rat = 58, & + iupsilon_precip_frac_rat = 59, & + ilambda0_stability_coef = 60, & + imult_coef = 61, & + itaumin = 62, & + itaumax = 63, & + iLscale_mu_coef = 64, & + iLscale_pert_coef = 65, & + ialpha_corr = 66, & + iSkw_denom_coef = 67, & + ic_K10 = 68, & + ic_K10h = 69, & + ithlp2_rad_coef = 70, & + ithlp2_rad_cloud_frac_thresh = 71 + + +end module parameter_indices +!----------------------------------------------------------------------- diff --git a/src/physics/clubb/parameters_model.F90 b/src/physics/clubb/parameters_model.F90 new file mode 100644 index 0000000000..0c261eb8cc --- /dev/null +++ b/src/physics/clubb/parameters_model.F90 @@ -0,0 +1,153 @@ +!------------------------------------------------------------------------------- +! $Id: parameters_model.F90 7226 2014-08-19 15:52:41Z betlej@uwm.edu $ +!=============================================================================== +module parameters_model + +! Description: +! Contains model parameters that are determined at run time rather than +! compile time. +! +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + private ! Default scope + + integer, parameter :: & + sp = selected_real_kind(6) ! 32-bit floating point number + + ! Maximum magnitude of PDF parameter 'mixt_frac'. + real( kind = core_rknd ), public :: mixt_frac_max_mag + +!$omp threadprivate(mixt_frac_max_mag) + + ! Model parameters and constraints setup in the namelists + real( kind = core_rknd ), public :: & + T0 = 300._core_rknd, & ! Reference temperature (usually 300) [K] + ts_nudge = 0._core_rknd ! Timescale of u/v nudging [s] + +#ifdef GFDL + real( kind = core_rknd ), public :: & ! h1g, 2010-06-15 + cloud_frac_min ! minimum cloud fraction for droplet # +!$omp threadprivate( cloud_frac_min ) +#endif + + +!$omp threadprivate(T0, ts_nudge) + + real( kind = core_rknd), public :: & + rtm_min = epsilon( rtm_min ), & ! Value below which rtm will be nudged [kg/kg] + rtm_nudge_max_altitude = 10000._core_rknd ! Highest altitude at which to nudge rtm [m] +!$omp threadprivate( rtm_min, rtm_nudge_max_altitude ) + + integer, public :: & + sclr_dim = 0, & ! Number of passive scalars + edsclr_dim = 0, & ! Number of eddy-diff. passive scalars + hydromet_dim = 0 ! Number of hydrometeor species + +!$omp threadprivate(sclr_dim, edsclr_dim, hydromet_dim) + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + sclr_tol ! Threshold(s) on the passive scalars [units vary] + +!$omp threadprivate(sclr_tol) + + real( kind = sp ), public :: PosInf + +!$omp threadprivate(PosInf) + + public :: setup_parameters_model + + contains + +!------------------------------------------------------------------------------- + subroutine setup_parameters_model & + ( T0_in, ts_nudge_in, & + hydromet_dim_in, & + sclr_dim_in, sclr_tol_in, edsclr_dim_in & +#ifdef GFDL + , cloud_frac_min_in & ! hlg, 2010-6-15 +#endif + + ) + +! Description: +! Sets parameters to their initial values +! +! References: +! None +!------------------------------------------------------------------------------- + use constants_clubb, only: Skw_max_mag, Skw_max_mag_sqd + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: sqrt, allocated, transfer + + ! Constants + integer(kind=4), parameter :: nanbits = 2139095040 + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + T0_in, & ! Ref. temperature [K] + ts_nudge_in ! Timescale for u/v nudging [s] + +#ifdef GFDL + real( kind = core_rknd ), intent(in) :: cloud_frac_min_in ! h1g, 2010-06-15 +#endif + + + integer, intent(in) :: & + hydromet_dim_in, & ! Number of hydrometeor species + sclr_dim_in, & ! Number of passive scalars + edsclr_dim_in ! Number of eddy-diff. passive scalars + + real( kind = core_rknd ), intent(in), dimension(sclr_dim_in) :: & + sclr_tol_in ! Threshold on passive scalars + + ! --- Begin Code --- + + ! Formula from subroutine pdf_closure, where sigma_sqd_w = 0.4 and Skw = + ! Skw_max_mag in this formula. Note that this is constant, but can't appear + ! with a Fortran parameter attribute, so we define it here. + mixt_frac_max_mag = 1.0_core_rknd & + - ( 0.5_core_rknd * ( 1.0_core_rknd - Skw_max_mag / & + sqrt( 4.0_core_rknd * ( 1.0_core_rknd - 0.4_core_rknd )**3 & + + Skw_max_mag_sqd ) ) ) ! Known magic number + + T0 = T0_in + ts_nudge = ts_nudge_in + + hydromet_dim = hydromet_dim_in + sclr_dim = sclr_dim_in + edsclr_dim = edsclr_dim_in + + ! In a tuning run, this array has the potential to be allocated already + if ( .not. allocated( sclr_tol ) ) then + allocate( sclr_tol(1:sclr_dim) ) + else + deallocate( sclr_tol ) + allocate( sclr_tol(1:sclr_dim) ) + end if + + sclr_tol(1:sclr_dim) = sclr_tol_in(1:sclr_dim) + + PosInf = transfer( nanbits, PosInf ) + +#ifdef GFDL + cloud_frac_min = cloud_frac_min_in ! h1g, 2010-06-15 +#endif + + return + end subroutine setup_parameters_model +!------------------------------------------------------------------------------- + +end module parameters_model diff --git a/src/physics/clubb/parameters_tunable.F90 b/src/physics/clubb/parameters_tunable.F90 new file mode 100644 index 0000000000..c107beb8f2 --- /dev/null +++ b/src/physics/clubb/parameters_tunable.F90 @@ -0,0 +1,1430 @@ +!----------------------------------------------------------------------- +! $Id: parameters_tunable.F90 7416 2014-12-04 20:16:51Z schemena@uwm.edu $ +!=============================================================================== +module parameters_tunable + + ! Description: + ! This module contains tunable model parameters. The purpose of the module is to make it + ! easier for the clubb_tuner code to use the params vector without "knowing" any information + ! about the individual parameters contained in the vector itself. It makes it easier to add + ! new parameters to be tuned for, but does not make the CLUBB_core code itself any simpler. + ! The parameters within the vector do not need to be the same variables used in the rest of + ! CLUBB_core (see for e.g. nu1_vert_res_dep or lmin_coef). + ! The parameters in the params vector only need to be those parameters for which we're not + ! sure the correct value and we'd like to tune for. + ! + ! References: + ! None + ! + ! Notes: + ! To make it easier to verify of code correctness, please keep the omp threadprivate + ! directives just after the variable declaration. All parameters in this + ! module should be declared threadprivate because of the CLUBB tuner. + !----------------------------------------------------------------------- + + use parameter_indices, only: nparams ! Variable(s) + + use grid_class, only: gr ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Default to private + private + + public :: setup_parameters, read_parameters, read_param_spread, & + get_parameters, adj_low_res_nu, cleanup_nu + + ! NOTE: In CLUBB standalone, as well as some host models, the hardcoded + ! default values of some or all of the parameters below have no effect, + ! as the values are simply read in using a namelist or set in host model + ! specific code. + + ! Model constant parameters + real( kind = core_rknd ), public :: & + C1 = 1.000000_core_rknd, & ! Low Skewness in C1 Skw. Function [-] + C1b = 1.000000_core_rknd, & ! High Skewness in C1 Skw. Function [-] + C1c = 1.000000_core_rknd, & ! Degree of Slope of C1 Skw. Function [-] + C2 = 1.300000_core_rknd, & ! Low Skewness in C2 Skw. Function [-] + C2rt = 1.000000_core_rknd, & ! C2 coef. for the rtp2_dp1 term [-] + C2thl = 1.000000_core_rknd, & ! C2 coef. for the thlp2_dp1 term [-] + C2rtthl = 2.000000_core_rknd, & ! C2 coef. for the rtpthlp_dp1 term [-] + C2b = 1.300000_core_rknd, & ! High Skewness in C2 Skw. Function [-] + C2c = 5.000000_core_rknd, & ! Degree of Slope of C2 Skw. Function [-] + C4 = 5.200000_core_rknd, & ! Used only when l_tke_aniso is true [-] + C5 = 0.300000_core_rknd, & ! Coef. in pressure terms: w'^2 eqn [-] + C6rt = 4.000000_core_rknd, & ! Low Skewness in C6rt Skw. Function [-] + C6rtb = 6.000000_core_rknd, & ! High Skewness in C6rt Skw. Function [-] + C6rtc = 1.000000_core_rknd, & ! Degree of Slope of C6rt Skw. Fnct. [-] + C6thl = 4.000000_core_rknd, & ! Low Skewness in C6thl Skw. Function [-] + C6thlb = 6.000000_core_rknd, & ! High Skewness in C6thl Skw. Fnct. [-] + C6thlc = 1.000000_core_rknd, & ! Degree of Slope of C6thl Skw. Fnct. [-] + C7 = 0.500000_core_rknd, & ! Low Skewness in C7 Skw. Function [-] + C7b = 0.800000_core_rknd, & ! High Skewness in C7 Skw. Function [-] + C7c = 0.500000_core_rknd, & ! Degree of Slope of C7 Skw. Function [-] + C8 = 3.000000_core_rknd, & ! Coef. #1 in C8 Skewness Equation [-] + C8b = 0.000000_core_rknd, & ! Coef. #2 in C8 Skewness Equation [-] + C10 = 3.300000_core_rknd, & ! Currently Not Used in the Model [-] + C11 = 0.80000_core_rknd, & ! Low Skewness in C11 Skw. Function [-] + C11b = 0.350000_core_rknd, & ! High Skewness in C11 Skw. Function [-] + C11c = 0.500000_core_rknd, & ! Degree of Slope of C11 Skw. Fnct. [-] + C12 = 1.000000_core_rknd, & ! Constant in w'^3 Crank-Nich. diff. [-] + C13 = 0.100000_core_rknd, & ! Not currently used in model [-] + C14 = 1.000000_core_rknd, & ! Constant for u'^2 and v'^2 terms [-] + C15 = 0.4_core_rknd ! Coefficient for the wp3_bp2 term [-] +!$omp threadprivate(C1, C1b, C1c, C2, C2b, C2c, & +!$omp C2rt, C2thl, C2rtthl, C4, C5, C6rt, C6rtb, C6rtc, & +!$omp C6thl, C6thlb, C6thlc, & +!$omp C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, C12, & +!$omp C13, C14, C15) + + real( kind = core_rknd ), public :: & + C6rt_Lscale0 = 14.0_core_rknd, & ! Damp C6rt as a fnct. of Lscale [-] + C6thl_Lscale0 = 14.0_core_rknd, & ! Damp C6thl as a fnct. of Lscale [-] + C7_Lscale0 = 0.8500000_core_rknd, & ! Damp C7 as a fnct. of Lscale [-] + wpxp_L_thresh = 60.0_core_rknd ! Lscale threshold: damp C6 & C7 [m] +!$omp threadprivate(C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh) + + ! Note: DD 1987 is Duynkerke & Driedonks (1987). + real( kind = core_rknd ), public :: & + c_K = 0.200000_core_rknd, & ! Constant C_mu^(1/4) in DD 1987 [m^2/s] + c_K1 = 0.750000_core_rknd, & ! Coef. of Eddy Diffusion: wp2 [m^2/s] + c_K2 = 0.125000_core_rknd, & ! Coef. of Eddy Diffusion: xp2 [m^2/s] + c_K6 = 0.375000_core_rknd, & ! Coef. of Eddy Diffusion: wpxp [m^2/s] + c_K8 = 1.250000_core_rknd, & ! Coef. of Eddy Diffusion: wp3 [m^2/s] + c_K9 = 0.250000_core_rknd, & ! Coef. of Eddy Diff.: up2/vp2 [m^2/s] + c_K_hm = 0.750000_core_rknd, & ! Coef. of Eddy Diffusion: hmm [m^2/s] + c_K_hmb = 0.10000_core_rknd, & ! Coef. of Non-Local Factor, Eddy Diffusion: hmm [m^2/s] + K_hm_min_coef = 0.10000_core_rknd,& ! Min. of Non-Local Factor, Eddy Diffusion: hmm [m^2/s] + gamma_coef = 0.320000_core_rknd, & ! Low Skw.: gamma coef. Skw. Fnct. [-] + gamma_coefb = 0.320000_core_rknd, & ! High Skw.: gamma coef. Skw. Fnct. [-] + gamma_coefc = 5.000000_core_rknd, & ! Deg. Slope: gamma coef. Skw. Fnct. [-] + mu = 1.000E-3_core_rknd, & ! Fract entrain rate per unit alt [1/m] + mult_coef = 0.500000_core_rknd, & ! Coef. applied to log(avg dz/thresh)[-] + taumin = 90.00000_core_rknd, & ! Min. allow. value: time-scale tau [s] + taumax = 3600.000_core_rknd, & ! Max. allow. value: time-scale tau [s] + lmin = 20.00000_core_rknd ! Min. value for the length scale [m] +!$omp threadprivate(c_K, c_K1, c_K2, c_K6, & +!$omp c_K8, c_K9, c_K_hm, c_K_hmb, K_hm_min_coef, gamma_coef, gamma_coefb, gamma_coefc, & +!$omp mu, mult_coef, taumin, taumax, lmin) + + real( kind = core_rknd ), public :: & + Lscale_mu_coef = 2.0_core_rknd, & ! Coef perturb mu: av calc Lscale [-] + Lscale_pert_coef = 0.1_core_rknd ! Coef pert thlm/rtm: av calc Lscale [-] +!$omp threadprivate(Lscale_mu_coef, Lscale_pert_coef) + + real( kind = core_rknd ), public :: & + alpha_corr = 0.15_core_rknd ! Coef. for the corr. diagnosis algorithm [-] + +!$omp threadprivate(alpha_corr) + + real( kind = core_rknd ), private :: & + nu1 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wp2 [m^2/s] + nu2 = 5.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: xp2 [m^2/s] + nu6 = 5.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wpxp [m^2/s] + nu8 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: wp3 [m^2/s] + nu9 = 20.00000_core_rknd, & ! Bg. Coef. Eddy Diffusion: up2/vp2 [m^2/s] + nu10 = 0.000000_core_rknd, & ! Bg. Coef. Eddy Diffusion: edsclrm [m^2/s] + nu_hm = 1.500000_core_rknd ! Bg. Coef. Eddy Diffusion: hmm [m^2/s] +!$omp threadprivate(nu1, nu2, nu6, nu8, nu9, nu10, nu_hm) + + + real( kind = core_rknd ), public, allocatable, dimension(:) :: & + nu1_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wp2 [m^2/s] + nu2_vert_res_dep, & ! Background Coef. of Eddy Diffusion: xp2 [m^2/s] + nu6_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wpxp [m^2/s] + nu8_vert_res_dep, & ! Background Coef. of Eddy Diffusion: wp3 [m^2/s] + nu9_vert_res_dep, & ! Background Coef. of Eddy Diffusion: up2/vp2 [m^2/s] + nu10_vert_res_dep, & ! Background Coef. of Eddy Diffusion: edsclrm [m^2/s] + nu_hm_vert_res_dep ! Background Coef. of Eddy Diffusion: hydromet [m^2/s] + +!$omp threadprivate(nu1_vert_res_dep, nu2_vert_res_dep, nu6_vert_res_dep, & +!$omp nu8_vert_res_dep, nu9_vert_res_dep, nu10_vert_res_dep, nu_hm_vert_res_dep) + + ! Vince Larson added a constant to set plume widths for theta_l and rt + ! beta should vary between 0 and 3. + + real( kind = core_rknd ), public :: & + beta = 2.400000_core_rknd ! Beta coefficient [-] + +!$omp threadprivate(beta) + + real( kind = core_rknd ), private :: & + lmin_coef = 0.500000_core_rknd ! Coefficient of lmin [-] + +!$omp threadprivate(lmin_coef) + + ! Brian Griffin added a parameter for hydrometeors, omicron, to increase the + ! standard deviation of each component and decrease the spread between the + ! component means as the value of omicron inreases. Valid value are + ! 0 < omicron <= 1. + ! A second parameter for hydrometeors, zeta, increases the standard deviation + ! of component 1 at the expense of the standard deviation of component 2 when + ! the value of zeta > 0 (and increasingly so as zeta increases). Valid values + ! are zeta > -1. + real( kind = core_rknd ), public :: & + omicron = 0.8_core_rknd, & ! Hydromet width/spread-of-means param [-] + zeta_vrnce_rat = 0.0_core_rknd ! Ratio sigma^2/mu^2 comp. 1 / comp. 2 [-] + +!$omp threadprivate( omicron, zeta_vrnce_rat ) + + real( kind = core_rknd ), public :: & + ! ratio mixt_frac*precip_frac_1/precip_frac (precip_frac_calc_type=2) [-] + upsilon_precip_frac_rat = 0.9_core_rknd, & + ! Intensity of stability correction applied to C1 and C6 [-] + lambda0_stability_coef = 0.03_core_rknd + +!$omp threadprivate( upsilon_precip_frac_rat, lambda0_stability_coef) + + ! Factor to decrease sensitivity in the denominator of Skw calculation + real( kind = core_rknd ), public :: & + Skw_denom_coef = 4.0_core_rknd + +!$omp threadprivate( Skw_denom_coef ) + + ! Momentum coefficient of Kh_zm + real( kind = core_rknd ), public :: & + c_K10 = 1.0_core_rknd + +!$omp threadprivate( c_K10 ) + + ! Thermodynamic coefficient of Kh_zm + real( kind = core_rknd ), public :: & + c_K10h = 1.0_core_rknd + +!$omp threadprivate( c_K10h ) + + real( kind = core_rknd ), public :: & + thlp2_rad_coef = 1.0_core_rknd, & ! Coefficient of thlp2_rad [-] + thlp2_rad_cloud_frac_thresh = 0.1_core_rknd ! Minimum cloud fraction for computation + ! of thlp2_rad [-] + +!$omp threadprivate( thlp2_rad_coef, thlp2_rad_cloud_frac_thresh ) + + ! used in adj_low_res_nu. If .true., avg_deltaz = deltaz +#ifdef GFDL + logical, public :: l_prescribed_avg_deltaz = .true. +#else + logical, public :: l_prescribed_avg_deltaz = .false. +#endif + +!$omp threadprivate(l_prescribed_avg_deltaz) + + ! Since we lack a devious way to do this just once, this namelist + ! must be changed as well when a new parameter is added. + namelist /clubb_params_nl/ & + C1, C1b, C1c, C2, C2b, C2c, & + C2rt, C2thl, C2rtthl, C4, C5, & + C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, & + C12, C13, C14, C15, C6rt_Lscale0, C6thl_Lscale0, & + C7_Lscale0, wpxp_L_thresh, c_K, c_K1, nu1, c_K2, nu2, & + c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, beta, gamma_coef, gamma_coefb, gamma_coefc, lmin_coef, & + omicron, zeta_vrnce_rat, upsilon_precip_frac_rat, & + lambda0_stability_coef, mult_coef, taumin, taumax, mu, Lscale_mu_coef, & + Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh + + ! These are referenced together often enough that it made sense to + ! make a list of them. Note that lmin_coef is the input parameter, + ! while the actual lmin model constant is computed from this. + !*************************************************************** + ! ***** IMPORTANT ***** + ! If you change the order of the parameters in the parameter_indices, + ! you will need to change the order of this list as well or the + ! tuner will break! + ! ***** IMPORTANT ***** + !*************************************************************** + character(len=27), dimension(nparams), parameter, public :: & + params_list = & + (/"C1 ", "C1b ", & + "C1c ", "C2 ", & + "C2b ", "C2c ", & + "C2rt ", "C2thl ", & + "C2rtthl ", "C4 ", & + "C5 ", "C6rt ", & + "C6rtb ", "C6rtc ", & + "C6thl ", "C6thlb ", & + "C6thlc ", "C7 ", & + "C7b ", "C7c ", & + "C8 ", "C8b ", & + "C10 ", "C11 ", & + "C11b ", "C11c ", & + "C12 ", "C13 ", & + "C14 ", "C15 ", & + "C6rt_Lscale0 ", "C6thl_Lscale0 ", & + "C7_Lscale0 ", "wpxp_L_thresh ", & + "c_K ", "c_K1 ", & + "nu1 ", "c_K2 ", & + "nu2 ", "c_K6 ", & + "nu6 ", "c_K8 ", & + "nu8 ", "c_K9 ", & + "nu9 ", "nu10 ", & + "c_K_hm ", "c_K_hmb ", & + "K_hm_min_coef ", "nu_hm ", & + "gamma_coef ", "gamma_coefb ", & + "gamma_coefc ", "mu ", & + "beta ", "lmin_coef ", & + "omicron ", "zeta_vrnce_rat ", & + "upsilon_precip_frac_rat ", "lambda0_stability_coef ", & + "mult_coef ", "taumin ", & + "taumax ", "Lscale_mu_coef ", & + "Lscale_pert_coef ", "alpha_corr ", & + "Skw_denom_coef ", "c_K10 ", & + "c_K10h ", "thlp2_rad_coef ", & + "thlp2_rad_cloud_frac_thresh" /) + + real( kind = core_rknd ), parameter, private :: & + init_value = -999._core_rknd ! Initial value for the parameters, used to detect missing values + + contains + + !============================================================================= + subroutine setup_parameters & + ( deltaz, params, nzmax, & + grid_type, momentum_heights, thermodynamic_heights, & + err_code ) + + ! Description: + ! Subroutine to setup model parameters + + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Variable(s) + + use error_code, only: & + clubb_var_out_of_bounds, & ! Variable(s) + clubb_no_error + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + + ! Constant Parameters + real( kind = core_rknd ), parameter :: & + lmin_deltaz = 40.0_core_rknd ! Fixed value for minimum value for the length scale. + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + real( kind = core_rknd ), intent(in), dimension(nparams) :: & + params ! Tuneable model parameters [-] + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on its own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Output Variables + integer, intent(out) :: & + err_code ! Error condition + + !-------------------- Begin code -------------------- + + call unpack_parameters( params, & + C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ) + + + ! It was decided after some experimentation, that the best + ! way to produce grid independent results is to set lmin to be + ! some fixed value. -dschanen 21 May 2007 + !lmin = lmin_coef * deltaz ! Old + lmin = lmin_coef * lmin_deltaz ! New fixed value + + ! ### Adjust Constant Diffusivity Coefficients Based On Grid Spacing ### + call adj_low_res_nu & + ( nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + + ! Sanity check + ! Initialize err_code to clubb_no_error. Only overwrite it if a variable + ! out-of-bounds error is found. + err_code = clubb_no_error + + if ( beta < 0.0_core_rknd .or. beta > 3.0_core_rknd ) then + + ! Constraints on beta + write(fstderr,*) "beta = ", beta + write(fstderr,*) "beta cannot be < 0 or > 3" + err_code = clubb_var_out_of_bounds + + endif ! beta < 0 or beta > 3 + + if ( omicron <= 0.0_core_rknd .or. omicron > 1.0_core_rknd ) then + + ! Constraints on omicron + write(fstderr,*) "omicron = ", omicron + write(fstderr,*) "omicron cannot be <= 0 or > 1" + err_code = clubb_var_out_of_bounds + + endif ! omicron <= 0 or omicron > 1 + + if ( zeta_vrnce_rat <= -1.0_core_rknd ) then + + ! Constraints on zeta_vrnce_rat + write(fstderr,*) "zeta_vrnce_rat = ", zeta_vrnce_rat + write(fstderr,*) "zeta_vrnce_rat cannot be <= -1" + err_code = clubb_var_out_of_bounds + + endif ! zeta_vrnce_rat <= -1 + + if ( upsilon_precip_frac_rat < 0.0_core_rknd & + .or. upsilon_precip_frac_rat > 1.0_core_rknd ) then + + ! Constraints on upsilon_precip_frac_rat + write(fstderr,*) "upsilon_precip_frac_rat = ", upsilon_precip_frac_rat + write(fstderr,*) "upsilon_precip_frac_rat cannot be < 0 or > 1" + err_code = clubb_var_out_of_bounds + + endif ! upsilon_precip_frac_rat < 0 or upsilon_precip_frac_rat > 1 + + if ( mu < 0.0_core_rknd ) then + + ! Constraints on entrainment rate, mu. + write(fstderr,*) "mu = ", mu + write(fstderr,*) "mu cannot be < 0" + err_code = clubb_var_out_of_bounds + + endif ! mu < 0.0 + + if ( lmin < 4.0_core_rknd ) then + + ! Constraints on mixing length + write(fstderr,*) "lmin = ", lmin + write(fstderr,*) "lmin is < 4.0_core_rknd" + err_code = clubb_var_out_of_bounds + + endif ! lmin < 4.0 + +! write(*,nml=clubb_params_nl) ! %% debug + + + return + + end subroutine setup_parameters + + !============================================================================= + subroutine adj_low_res_nu & + ( nzmax, grid_type, deltaz, & ! Intent(in) + momentum_heights, thermodynamic_heights ) ! Intent(in) + + ! Description: + ! Adjust the values of background eddy diffusivity based on + ! vertical grid spacing. + ! This code was made into a public subroutine so that it may be + ! called multiple times per model run in scenarios where grid + ! altitudes, and hence average grid spacing, change through space + ! and/or time. This occurs, for example, when CLUBB is + ! implemented in WRF. --ldgrant Jul 2010 + !---------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant Parameters + + ! Flag for adjusting the values of the constant background eddy diffusivity + ! coefficients based on the average vertical grid spacing. If this flag is + ! turned off, the values of the various nu coefficients will remain as they + ! are declared in the tunable_parameters.in file. + logical, parameter :: l_adj_low_res_nu = .true. + + ! The size of the average vertical grid spacing that serves as a threshold + ! for when to increase the size of the background eddy diffusivity + ! coefficients (nus) by a certain factor above what the background + ! coefficients are specified to be in tunable_parameters.in. At any average + ! grid spacing at or below this value, the values of the background + ! diffusivities remain the same. However, at any average vertical grid + ! spacing above this value, the values of the background eddy diffusivities + ! are increased. Traditionally, the threshold grid spacing has been set to + ! 40.0 meters. This is only relevant if l_adj_low_res_nu is turned on. + real( kind = core_rknd ), parameter :: & + grid_spacing_thresh = 40.0_core_rknd ! grid spacing threshold [m] + + ! Input Variables + + ! Grid definition + integer, intent(in) :: nzmax ! Vertical grid levels [#] + + ! If CLUBB is running on it's own, this option determines + ! if it is using: + ! 1) an evenly-spaced grid, + ! 2) a stretched (unevenly-spaced) grid entered on the + ! thermodynamic grid levels (with momentum levels set + ! halfway between thermodynamic levels), or + ! 3) a stretched (unevenly-spaced) grid entered on the + ! momentum grid levels (with thermodynamic levels set + ! halfway between momentum levels). + integer, intent(in) :: grid_type + + real( kind = core_rknd ), intent(in) :: & + deltaz ! Change per height level [m] + + ! If the CLUBB parameterization is implemented in a host model, + ! it needs to use the host model's momentum level altitudes + ! and thermodynamic level altitudes. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on thermodynamic levels (grid_type = 2), + ! it needs to use the thermodynamic level altitudes as input. + ! If the CLUBB model is running by itself, but is using a + ! stretched grid entered on momentum levels (grid_type = 3), + ! it needs to use the momentum level altitudes as input. + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + momentum_heights, & ! Momentum level altitudes (input) [m] + thermodynamic_heights ! Thermodynamic level altitudes (input) [m] + + ! Local Variables + real( kind = core_rknd ) :: avg_deltaz ! Average grid box height [m] + + ! The factor by which to multiply the coefficients of background eddy + ! diffusivity if the grid spacing threshold is exceeded and l_adj_low_res_nu + ! is turned on. + real( kind = core_rknd ),dimension(gr%nz) :: & + mult_factor_zt, & ! Uses gr%dzt for nu values on zt levels + mult_factor_zm ! Uses gr%dzm for nu values on zm levels + + ! Flag to enable nu values that are a function of grid spacing + logical, parameter :: l_nu_grid_dependent = .false. + + integer :: k ! Loop variable + + !--------------- Begin code ------------------------- + + if ( .not. allocated( nu1_vert_res_dep ) ) then + allocate( nu1_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu2_vert_res_dep ) ) then + allocate( nu2_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu6_vert_res_dep ) ) then + allocate( nu6_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu8_vert_res_dep ) ) then + allocate( nu8_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu9_vert_res_dep ) ) then + allocate( nu9_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu10_vert_res_dep ) ) then + allocate( nu10_vert_res_dep(1:gr%nz) ) + end if + if ( .not. allocated( nu_hm_vert_res_dep ) ) then + allocate( nu_hm_vert_res_dep(1:gr%nz) ) + end if + + ! Flag for adjusting the values of the constant diffusivity coefficients + ! based on the grid spacing. If this flag is turned off, the values of the + ! various nu coefficients will remain as they are declared in the + ! parameters.in file. + if ( l_adj_low_res_nu ) then + + ! ### Adjust Constant Diffusivity Coefficients Based On Grid Spacing ### + + ! All of the background coefficients of eddy diffusivity, as well as the + ! constant coefficient for 4th-order hyper-diffusion, must be adjusted + ! based on the size of the grid spacing. For a case that uses an + ! evenly-spaced grid, the adjustment is based on the constant grid + ! spacing deltaz. For a case that uses a stretched grid, the adjustment + ! is based on avg_deltaz, which is the average grid spacing over the + ! vertical domain. + + if ( l_prescribed_avg_deltaz ) then + + avg_deltaz = deltaz + + else if ( grid_type == 3 ) then + + ! CLUBB is implemented in a host model, or is using grid_type = 3 + + ! Find the average deltaz over the grid based on momentum level + ! inputs. + + avg_deltaz & + = ( momentum_heights(nzmax) - momentum_heights(1) ) & + / real( nzmax - 1, kind = core_rknd ) + + else if ( grid_type == 1 ) then + + ! Evenly-spaced grid. + + avg_deltaz = deltaz + + else if ( grid_type == 2 ) then + + ! Stretched (unevenly-spaced) grid: stretched thermodynamic level + ! input. + + ! Find the average deltaz over the stretched grid based on + ! thermodynamic level inputs. + + avg_deltaz & + = ( thermodynamic_heights(nzmax) - thermodynamic_heights(1) ) & + / real( nzmax - 1, kind = core_rknd ) + else + ! Eric Raut added to remove compiler warning. (Obviously, this value is not used) + avg_deltaz = 0.0_core_rknd + write(fstderr,*) "Invalid grid_type:", grid_type + stop "Fatal error" + + end if ! grid_type + + ! The nu's are chosen for deltaz <= 40 m. Looks like they must + ! be adjusted for larger grid spacings (Vince Larson) + if( .not. l_nu_grid_dependent ) then + ! Use a constant mult_factor so nu does not depend on grid spacing + if( avg_deltaz > grid_spacing_thresh ) then + mult_factor_zt = 1.0_core_rknd + mult_coef * log( avg_deltaz / grid_spacing_thresh ) + mult_factor_zm = mult_factor_zt + else + mult_factor_zt = 1.0_core_rknd + mult_factor_zm = 1.0_core_rknd + end if + else ! l_nu_grid_dependent = .true. + ! mult_factor will vary to create nu values that vary with grid spacing + do k = 1, gr%nz + if( gr%dzm(k) > grid_spacing_thresh ) then + mult_factor_zm(k) = 1.0_core_rknd + mult_coef * log( gr%dzm(k) / grid_spacing_thresh ) + else + mult_factor_zm(k) = 1.0_core_rknd + end if + + if( gr%dzt(k) > grid_spacing_thresh ) then + mult_factor_zt(k) = 1.0_core_rknd + mult_coef * log( gr%dzt(k) / grid_spacing_thresh ) + else + mult_factor_zt(k) = 1.0_core_rknd + end if + end do + end if ! l_nu_grid_dependent + + !mult_factor = 1.0_core_rknd + mult_coef * log( avg_deltaz / grid_spacing_thresh ) + nu1_vert_res_dep = nu1 * mult_factor_zm + nu2_vert_res_dep = nu2 * mult_factor_zm + nu6_vert_res_dep = nu6 * mult_factor_zm + nu8_vert_res_dep = nu8 * mult_factor_zt + nu9_vert_res_dep = nu9 * mult_factor_zm + nu10_vert_res_dep = nu10 * mult_factor_zt !We're unsure of the grid + nu_hm_vert_res_dep = nu_hm * mult_factor_zt + + else ! nu values are not adjusted + + nu1_vert_res_dep = nu1 + nu2_vert_res_dep = nu2 + nu6_vert_res_dep = nu6 + nu8_vert_res_dep = nu8 + nu9_vert_res_dep = nu9 + nu10_vert_res_dep = nu10 + nu_hm_vert_res_dep = nu_hm + + end if ! l_adj_low_res_nu + + return + end subroutine adj_low_res_nu + + !============================================================================= + subroutine read_parameters( iunit, filename, params ) + + ! Description: + ! Read a namelist containing the model parameters + + ! References: + ! None + !----------------------------------------------------------------------- + use constants_clubb, only: fstderr ! Constant + + implicit none + + ! Input variables + integer, intent(in) :: iunit + + character(len=*), intent(in) :: filename + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(nparams) :: params + + ! Local variables + integer :: i + + logical :: l_error + + ! ---- Begin Code ---- + + ! If the filename is empty, assume we're using a `working' set of + ! parameters that are set statically here (handy for host models). + ! Read the namelist + if ( filename /= "" ) then + ! Read the namelist + open(unit=iunit, file=filename, status='old', action='read') + + read(unit=iunit, nml=clubb_params_nl) + + close(unit=iunit) + + end if + + ! Put the variables in the output array + call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) + + l_error = .false. + + do i = 1, nparams + if ( params(i) == init_value ) then + write(fstderr,*) "Tuning parameter "//trim( params_list(i) )// & + " was missing from "//trim( filename ) + l_error = .true. + end if + end do + + if ( l_error ) stop "Fatal error." + + return + + end subroutine read_parameters + + !============================================================================= + subroutine read_param_spread & + ( iunit, filename, nindex, param_spread, ndim ) + + ! Description: + ! Read a namelist containing the amount to vary model parameters. + ! Used by the downhill simplex / simulated annealing algorithm. + + ! References: + ! None + !----------------------------------------------------------------------- + use constants_clubb, only: fstderr ! Constant + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input variables + integer, intent(in) :: iunit + + character(len=*), intent(in) :: filename + + ! Output variables + + ! An array of array indices (i.e. which elements of the array `params' + ! are contained within the simplex and the spread variable) + integer, intent(out), dimension(nparams) :: nindex + + real( kind = core_rknd ), intent(out), dimension(nparams) :: & + param_spread ! Amount to vary the parameter in the initial simplex + + integer, intent(out) :: & + ndim ! Number of variables, e.g. rcm, to be tuned. Dimension of the init simplex + + + ! Local variables + integer :: i + + logical :: l_error + + ! Amount to change each parameter for the initial simplex + ! This MUST be changed to match the clubb_params_nl namelist if parameters are added! + namelist /initspread/ & + C1, C1b, C1c, C2, C2b, C2c, & + C2rt, C2thl, C2rtthl, C4, C5, & + C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, C11, C11b, C11c, & + C12, C13, C14, C15, C6rt_Lscale0, C6thl_Lscale0, & + C7_Lscale0, wpxp_L_thresh, c_K, c_K1, nu1, c_K2, nu2, & + c_K6, nu6, c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, beta, gamma_coef, gamma_coefb, gamma_coefc, & + lmin_coef, omicron, zeta_vrnce_rat, upsilon_precip_frac_rat, & + lambda0_stability_coef, mult_coef, taumin, taumax, mu, & + Lscale_mu_coef, Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, c_K10h, & + thlp2_rad_coef, thlp2_rad_cloud_frac_thresh + + ! Initialize values to -999. + call init_parameters_999( ) + + ! Read the namelist + open(unit=iunit, file=filename, status='old', action='read') + + read(unit=iunit, nml=initspread) + + close(unit=iunit) + + ! Put the variables in the output array + call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, param_spread ) + + l_error = .false. + + do i = 1, nparams + if ( param_spread(i) == init_value ) then + write(fstderr,*) "A spread parameter "//trim( params_list(i) )// & + " was missing from "//trim( filename ) + l_error = .true. + end if + end do + + if ( l_error ) stop "Fatal error." + + ! Initialize to zero + nindex(1:nparams) = 0 + ndim = 0 + + ! Determine how many variables are being changed + do i = 1, nparams, 1 + + if ( param_spread(i) /= 0.0_core_rknd ) then + ndim = ndim + 1 ! Increase the total + nindex(ndim) = i ! Set the next array index + endif + + enddo + + return + + end subroutine read_param_spread + + !============================================================================= + subroutine pack_parameters & + ( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) + + ! Description: + ! Takes the list of scalar variables and puts them into a 1D vector. + ! It is here for the purpose of keeping the code generalized + ! when new variables are added. + + ! References: + ! None + !----------------------------------------------------------------------- + + use parameter_indices, only: & + iC1, & ! Variable(s) + iC1b, & + iC1c, & + iC2, & + iC2b, & + iC2c, & + iC2rt, & + iC2thl, & + iC2rtthl, & + iC4, & + iC5, & + iC6rt, & + iC6rtb, & + iC6rtc, & + iC6thl, & + iC6thlb, & + iC6thlc, & + iC7, & + iC7b, & + iC7c, & + iC8, & + iC8b, & + iC10, & + iC11, & + iC11b, & + iC11c, & + iC12, & + iC13, & + iC14, & + iC15 + + use parameter_indices, only: & + iC6rt_Lscale0, & + iC6thl_Lscale0, & + iC7_Lscale0, & + iwpxp_L_thresh + + use parameter_indices, only: & + ic_K, & + ic_K1, & + inu1, & + ic_K2, & + inu2, & + ic_K6, & + inu6, & + ic_K8, & + inu8, & + ic_K9, & + inu9, & + inu10, & + ic_K_hm, & + ic_K_hmb, & + iK_hm_min_coef, & + inu_hm, & + igamma_coef, & + igamma_coefb, & + igamma_coefc, & + imu, & + ibeta, & + ilmin_coef, & + iomicron, & + izeta_vrnce_rat, & + iupsilon_precip_frac_rat, & + ilambda0_stability_coef, & + imult_coef, & + itaumin, & + itaumax, & + iLscale_mu_coef, & + iLscale_pert_coef, & + ialpha_corr, & + iSkw_denom_coef, & + ic_K10, & + ic_K10h, & + ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh, & + nparams + + implicit none + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, c_K8, nu8, & + c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, nu_hm, gamma_coef, & + gamma_coefb, gamma_coefc, mu, beta, lmin_coef, & + omicron, zeta_vrnce_rat, upsilon_precip_frac_rat, & + lambda0_stability_coef, mult_coef, taumin, taumax, Lscale_mu_coef, & + Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh + + ! Output variables + real( kind = core_rknd ), intent(out), dimension(nparams) :: params + + params(iC1) = C1 + params(iC1b) = C1b + params(iC1c) = C1c + params(iC2) = C2 + params(iC2b) = C2b + params(iC2c) = C2c + params(iC2rt) = C2rt + params(iC2thl) = C2thl + params(iC2rtthl) = C2rtthl + params(iC4) = C4 + params(iC5) = C5 + params(iC6rt) = C6rt + params(iC6rtb) = C6rtb + params(iC6rtc) = C6rtc + params(iC6thl) = C6thl + params(iC6thlb) = C6thlb + params(iC6thlc) = C6thlc + params(iC7) = C7 + params(iC7b) = C7b + params(iC7c) = C7c + params(iC8) = C8 + params(iC8b) = C8b + params(iC10) = C10 + params(iC11) = C11 + params(iC11b) = C11b + params(iC11c) = C11c + params(iC12) = C12 + params(iC13) = C13 + params(iC14) = C14 + params(iC15) = C15 + + params(iC6rt_Lscale0) = C6rt_Lscale0 + params(iC6thl_Lscale0) = C6thl_Lscale0 + params(iC7_Lscale0) = C7_Lscale0 + params(iwpxp_L_thresh) = wpxp_L_thresh + + params(ic_K) = c_K + params(ic_K1) = c_K1 + params(inu1) = nu1 + params(ic_K2) = c_K2 + params(inu2) = nu2 + params(ic_K6) = c_K6 + params(inu6) = nu6 + params(ic_K8) = c_K8 + params(inu8) = nu8 + params(ic_K9) = c_K9 + params(inu9) = nu9 + params(inu10) = nu10 + params(ic_K_hm) = c_K_hm + params(ic_K_hmb) = c_K_hmb + params(iK_hm_min_coef) = K_hm_min_coef + params(inu_hm) = nu_hm + + params(igamma_coef) = gamma_coef + params(igamma_coefb) = gamma_coefb + params(igamma_coefc) = gamma_coefc + + params(imu) = mu + + params(ibeta) = beta + + params(ilmin_coef) = lmin_coef + + params(iomicron) = omicron + params(izeta_vrnce_rat) = zeta_vrnce_rat + + params(iupsilon_precip_frac_rat) = upsilon_precip_frac_rat + params(ilambda0_stability_coef) = lambda0_stability_coef + params(imult_coef) = mult_coef + + params(itaumin) = taumin + params(itaumax) = taumax + + params(iLscale_mu_coef) = Lscale_mu_coef + params(iLscale_pert_coef) = Lscale_pert_coef + params(ialpha_corr) = alpha_corr + params(iSkw_denom_coef) = Skw_denom_coef + params(ic_K10) = c_K10 + params(ic_K10h) = c_K10h + params(ithlp2_rad_coef) = thlp2_rad_coef + params(ithlp2_rad_cloud_frac_thresh) = thlp2_rad_cloud_frac_thresh + + return + end subroutine pack_parameters + + !============================================================================= + subroutine unpack_parameters & + ( params, & + C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh ) + + ! Description: + ! Takes the 1D vector and returns the list of scalar variables. + ! Here for the purposes of keeping the code generalized + ! when new variables are added. + + ! References: + ! None + !----------------------------------------------------------------------- + + use parameter_indices, only: & + iC1, & ! Variable(s) + iC1b, & + iC1c, & + iC2, & + iC2b, & + iC2c, & + iC2rt, & + iC2thl, & + iC2rtthl, & + iC4, & + iC5, & + iC6rt, & + iC6rtb, & + iC6rtc, & + iC6thl, & + iC6thlb, & + iC6thlc, & + iC7, & + iC7b, & + iC7c, & + iC8, & + iC8b, & + iC10, & + iC11, & + iC11b, & + iC11c, & + iC12, & + iC13, & + iC14, & + iC15 + + use parameter_indices, only: & + iC6rt_Lscale0, & + iC6thl_Lscale0, & + iC7_Lscale0, & + iwpxp_L_thresh + + use parameter_indices, only: & + ic_K, & + ic_K1, & + inu1, & + ic_K2, & + inu2, & + ic_K6, & + inu6, & + ic_K8, & + inu8, & + ic_K9, & + inu9, & + inu10, & + ic_K_hm, & + ic_K_hmb, & + iK_hm_min_coef, & + inu_hm, & + igamma_coef, & + igamma_coefb, & + igamma_coefc, & + imu, & + ibeta, & + ilmin_coef, & + iomicron, & + izeta_vrnce_rat, & + iupsilon_precip_frac_rat, & + ilambda0_stability_coef, & + imult_coef, & + itaumin, & + itaumax, & + iLscale_mu_coef, & + iLscale_pert_coef, & + ialpha_corr, & + iSkw_denom_coef, & + ic_K10, & + ic_K10h, & + ithlp2_rad_coef, & + ithlp2_rad_cloud_frac_thresh, & + nparams + + implicit none + + ! Input variables + real( kind = core_rknd ), intent(in), dimension(nparams) :: params + + ! Output variables + real( kind = core_rknd ), intent(out) :: & + C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, nu_hm, & + gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, upsilon_precip_frac_rat, & + lambda0_stability_coef, mult_coef, taumin, & + taumax, Lscale_mu_coef, Lscale_pert_coef, alpha_corr, Skw_denom_coef, c_K10, & + c_K10h, thlp2_rad_coef, thlp2_rad_cloud_frac_thresh + + C1 = params(iC1) + C1b = params(iC1b) + C1c = params(iC1c) + C2 = params(iC2) + C2b = params(iC2b) + C2c = params(iC2c) + C2rt = params(iC2rt) + C2thl = params(iC2thl) + C2rtthl = params(iC2rtthl) + C4 = params(iC4) + C5 = params(iC5) + C6rt = params(iC6rt) + C6rtb = params(iC6rtb) + C6rtc = params(iC6rtc) + C6thl = params(iC6thl) + C6thlb = params(iC6thlb) + C6thlc = params(iC6thlc) + C7 = params(iC7) + C7b = params(iC7b) + C7c = params(iC7c) + C8 = params(iC8) + C8b = params(iC8b) + C10 = params(iC10) + C11 = params(iC11) + C11b = params(iC11b) + C11c = params(iC11c) + C12 = params(iC12) + C13 = params(iC13) + C14 = params(iC14) + C15 = params(iC15) + + C6rt_Lscale0 = params(iC6rt_Lscale0) + C6thl_Lscale0 = params(iC6thl_Lscale0) + C7_Lscale0 = params(iC7_Lscale0) + wpxp_L_thresh = params(iwpxp_L_thresh) + + c_K = params(ic_K) + c_K1 = params(ic_K1) + nu1 = params(inu1) + c_K2 = params(ic_K2) + nu2 = params(inu2) + c_K6 = params(ic_K6) + nu6 = params(inu6) + c_K8 = params(ic_K8) + nu8 = params(inu8) + c_K9 = params(ic_K9) + nu9 = params(inu9) + nu10 = params(inu10) + c_K_hm = params(ic_K_hm) + c_K_hmb = params(ic_K_hmb) + K_hm_min_coef = params(iK_hm_min_coef) + nu_hm = params(inu_hm) + + gamma_coef = params(igamma_coef) + gamma_coefb = params(igamma_coefb) + gamma_coefc = params(igamma_coefc) + + mu = params(imu) + + beta = params(ibeta) + + lmin_coef = params(ilmin_coef) + + omicron = params(iomicron) + zeta_vrnce_rat = params(izeta_vrnce_rat) + + upsilon_precip_frac_rat = params(iupsilon_precip_frac_rat) + lambda0_stability_coef = params(ilambda0_stability_coef) + mult_coef = params(imult_coef) + + taumin = params(itaumin) + taumax = params(itaumax) + + Lscale_mu_coef = params(iLscale_mu_coef) + Lscale_pert_coef = params(iLscale_pert_coef) + alpha_corr = params(ialpha_corr) + Skw_denom_coef = params(iSkw_denom_coef) + c_K10 = params(ic_K10) + c_K10h = params(ic_K10h) + + thlp2_rad_coef = params(ithlp2_rad_coef) + thlp2_rad_cloud_frac_thresh = params(ithlp2_rad_cloud_frac_thresh) + + return + end subroutine unpack_parameters + + !============================================================================= + subroutine get_parameters( params ) + + ! Description: + ! Return an array of all tunable parameters + + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(out), dimension(nparams) :: params + + call pack_parameters( C1, C1b, C1c, C2, C2b, C2c, C2rt, C2thl, C2rtthl, & + C4, C5, C6rt, C6rtb, C6rtc, C6thl, C6thlb, C6thlc, & + C7, C7b, C7c, C8, C8b, C10, & + C11, C11b, C11c, C12, C13, C14, C15, & + C6rt_Lscale0, C6thl_Lscale0, C7_Lscale0, wpxp_L_thresh, & + c_K, c_K1, nu1, c_K2, nu2, c_K6, nu6, & + c_K8, nu8, c_K9, nu9, nu10, c_K_hm, c_K_hmb, K_hm_min_coef, & + nu_hm, gamma_coef, gamma_coefb, gamma_coefc, & + mu, beta, lmin_coef, omicron, zeta_vrnce_rat, & + upsilon_precip_frac_rat, lambda0_stability_coef, & + mult_coef, taumin, taumax, Lscale_mu_coef, Lscale_pert_coef, & + alpha_corr, Skw_denom_coef, c_K10, c_K10h, thlp2_rad_coef, & + thlp2_rad_cloud_frac_thresh, params ) + + return + + end subroutine get_parameters + + !============================================================================= + subroutine init_parameters_999( ) + + ! Description: + ! Set all tunable parameters to NaN + + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + ! --- Begin Code --- + + C1 = init_value + C1b = init_value + C1c = init_value + C2rt = init_value + C2thl = init_value + C2rtthl = init_value + C2 = init_value + C2b = init_value + C2c = init_value + C4 = init_value + C5 = init_value + C6rt = init_value + C6rtb = init_value + C6rtc = init_value + C6thl = init_value + C6thlb = init_value + C6thlc = init_value + C7 = init_value + C7b = init_value + C7c = init_value + C8 = init_value + C8b = init_value + C10 = init_value + C11 = init_value + C11b = init_value + C11c = init_value + C12 = init_value + C13 = init_value + C14 = init_value + C15 = init_value + C6rt_Lscale0 = init_value + C6thl_Lscale0 = init_value + C7_Lscale0 = init_value + wpxp_L_thresh = init_value + c_K = init_value + c_K1 = init_value + nu1 = init_value + c_K2 = init_value + nu2 = init_value + c_K6 = init_value + nu6 = init_value + c_K8 = init_value + nu8 = init_value + c_K9 = init_value + nu9 = init_value + nu10 = init_value + c_K_hm = init_value + c_K_hmb = init_value + K_hm_min_coef = init_value + nu_hm = init_value + beta = init_value + gamma_coef = init_value + gamma_coefb = init_value + gamma_coefc = init_value + mult_coef = init_value + taumin = init_value + taumax = init_value + lmin_coef = init_value + omicron = init_value + zeta_vrnce_rat = init_value + upsilon_precip_frac_rat = init_value + lambda0_stability_coef = init_value + mu = init_value + Lscale_mu_coef = init_value + Lscale_pert_coef = init_value + alpha_corr = init_value + Skw_denom_coef = init_value + c_K10 = init_value + c_K10h = init_value + thlp2_rad_coef = init_value + thlp2_rad_cloud_frac_thresh = init_value + + return + + end subroutine init_parameters_999 + + !============================================================================= + subroutine cleanup_nu( ) + + ! Description: + ! De-allocates memory used for the nu arrays + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant + + implicit none + + ! Local Variable(s) + integer :: ierr + + ! ----- Begin Code ----- + + deallocate( nu1_vert_res_dep, nu2_vert_res_dep, nu6_vert_res_dep, & + nu8_vert_res_dep, nu9_vert_res_dep, nu10_vert_res_dep, & + nu_hm_vert_res_dep, stat = ierr ) + + if ( ierr /= 0 ) then + write(fstderr,*) "Deallocation of vertically depedent nu arrays failed." + end if + + return + + end subroutine cleanup_nu + +!=============================================================================== + +end module parameters_tunable diff --git a/src/physics/clubb/pdf_closure_module.F90 b/src/physics/clubb/pdf_closure_module.F90 new file mode 100644 index 0000000000..f8f085d7be --- /dev/null +++ b/src/physics/clubb/pdf_closure_module.F90 @@ -0,0 +1,2501 @@ +!--------------------------------------------------------------------------- +! $Id: pdf_closure_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module pdf_closure_module + + implicit none + + public :: pdf_closure, calc_vert_avg_cf_component + + private ! Set Default Scope + + contains +!------------------------------------------------------------------------ + + !####################################################################### + !####################################################################### + ! If you change the argument list of pdf_closure you also have to + ! change the calls to this function in the host models CAM, WRF, SAM + ! and GFDL. + !####################################################################### + !####################################################################### + subroutine pdf_closure( hydromet_dim, p_in_Pa, exner, thv_ds, wm, & + wp2, wp3, sigma_sqd_w, & + Skw, Skthl, Skrt, rtm, rtp2, & + wprtp, thlm, thlp2, & + wpthlp, rtpthlp, sclrm, & + wpsclrp, sclrp2, sclrprtp, & + sclrpthlp, level, & +#ifdef GFDL + RH_crit, do_liquid_only_in_clubb, & ! h1g, 2010-06-15 +#endif + wphydrometp, wp2hmp, & + rtphmp, thlphmp, & + wp4, wprtp2, wp2rtp, & + wpthlp2, wp2thlp, wprtpthlp, & + cloud_frac, ice_supersat_frac, & + rcm, wpthvp, wp2thvp, rtpthvp, & + thlpthvp, wprcp, wp2rcp, rtprcp, & + thlprcp, rcp2, pdf_params, & + err_code, & + wpsclrprtp, wpsclrp2, sclrpthvp, & + wpsclrpthlp, sclrprcp, wp2sclrp, & + rc_coef ) + + + ! Description: + ! Subroutine that computes pdf parameters analytically. + ! + ! Based of the original formulation, but with some tweaks + ! to remove some of the less realistic assumptions and + ! improve transport terms. + + ! Corrected version that should remove inconsistency + + ! References: + ! Eqn. 29, 30, 31, 32 & 33 on p. 3547 of + ! ``A PDF-Based Model for Boundary Layer Clouds. Part I: + ! Method and Model Description'' Golaz, et al. (2002) + ! JAS, Vol. 59, pp. 3540--3551. + !---------------------------------------------------------------------- + + use constants_clubb, only: & ! Constants + two, & ! 2 + one, & ! 1 + one_half, & ! 1/2 + zero, & ! 0 + Cp, & ! Dry air specific heat at constant p [J/kg/K] + Lv, & ! Latent heat of vaporization [J/kg] + Rd, & ! Dry air gas constant [J/kg/K] + ep, & ! Rd / Rv; ep = 0.622 [-] + ep1, & ! (1.0-ep)/ep; ep1 = 0.61 [-] + ep2, & ! 1.0/ep; ep2 = 1.61 [-] + w_tol_sqd, & ! Tolerance for w'^2 [m^2/s^2] + rt_tol, & ! Tolerance for r_t [kg/kg] + thl_tol, & ! Tolerance for th_l [K] + T_freeze_K, & ! Freezing point of water [K] + fstderr, & + zero_threshold, & + chi_tol, & + eps, & + w_tol + + + use parameters_model, only: & + sclr_tol, & ! Array of passive scalar tolerances [units vary] + sclr_dim, & ! Number of passive scalar variables + mixt_frac_max_mag ! Maximum values for PDF parameter 'mixt_frac' + + use parameters_tunable, only: & + beta, & ! Variable(s) + Skw_denom_coef + + use pdf_parameter_module, only: & + pdf_parameter ! type + + use array_index, only: & + l_mix_rat_hm ! Variable(s) + + use anl_erf, only: & + erf ! Procedure(s) + ! The error function + + use numerical_check, only: & + pdf_closure_check ! Procedure(s) + + use saturation, only: & + sat_mixrat_liq, & ! Procedure(s) + sat_mixrat_ice + + use error_code, only: & + clubb_no_error ! Constant(s) + + use error_code, only: & + clubb_at_least_debug_level, & ! Procedure(s) + fatal_error + + use stats_variables, only: & + iwp4, & ! Variables + ircp2, & + iwprtp2, & + iwprtpthlp, & + iwpthlp2 + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only:& + l_use_ADG2, & + l_use_3D_closure + + implicit none + + intrinsic :: sqrt, exp, min, max, abs, present + + ! Input Variables + integer, intent(in) :: & + hydromet_dim ! Number of hydrometeor species [#] + + real( kind = core_rknd ), intent(in) :: & + p_in_Pa, & ! Pressure [Pa] + exner, & ! Exner function [-] + thv_ds, & ! Dry, base-state theta_v (ref. th_l here) [K] + wm, & ! mean w-wind component (vertical velocity) [m/s] + wp2, & ! w'^2 [m^2/s^2] + wp3, & ! w'^3 [m^3/s^3] + Skw, & ! Skewness of w [-] + Skthl, & ! Skewness of thl [-] + Skrt, & ! Skewness of rt [-] + rtm, & ! Mean total water mixing ratio [kg/kg] + rtp2, & ! r_t'^2 [(kg/kg)^2] + wprtp, & ! w'r_t' [(kg/kg)(m/s)] + thlm, & ! Mean liquid water potential temperature [K] + thlp2, & ! th_l'^2 [K^2] + wpthlp, & ! w'th_l' [K(m/s)] + rtpthlp ! r_t'th_l' [K(kg/kg)] + + real( kind = core_rknd ), dimension(sclr_dim), intent(in) :: & + sclrm, & ! Mean passive scalar [units vary] + wpsclrp, & ! w' sclr' [units vary] + sclrp2, & ! sclr'^2 [units vary] + sclrprtp, & ! sclr' r_t' [units vary] + sclrpthlp ! sclr' th_l' [units vary] + +#ifdef GFDL + ! critial relative humidity for nucleation + real( kind = core_rknd ), dimension( min(1,sclr_dim), 2 ), intent(in) :: & ! h1g, 2010-06-15 + RH_crit ! critical relative humidity for droplet and ice nucleation +! ---> h1g, 2012-06-14 + logical, intent(in) :: do_liquid_only_in_clubb +! <--- h1g, 2012-06-14 +#endif + + integer, intent(in) :: & + level ! Thermodynamic level for which calculations are taking place. + + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + wphydrometp, & ! Covariance of w and a hydrometeor [(m/s) ] + wp2hmp, & ! Third-order moment: < w'^2 hm' > [(m/s)^2 ] + rtphmp, & ! Covariance of rt and a hydrometeor [(kg/kg) ] + thlphmp ! Covariance of thl and a hydrometeor [K ] + + real( kind = core_rknd ), intent(inout) :: & + ! If l_use_ADG2, this gets overwritten. Therefore, intent(inout). + ! otherwise it should be intent(in) + sigma_sqd_w ! Width of individual w plumes [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + wp4, & ! w'^4 [m^4/s^4] + wprtp2, & ! w' r_t' [(m kg)/(s kg)] + wp2rtp, & ! w'^2 r_t' [(m^2 kg)/(s^2 kg)] + wpthlp2, & ! w' th_l'^2 [(m K^2)/s] + wp2thlp, & ! w'^2 th_l' [(m^2 K)/s^2] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fracion [-] + rcm, & ! Mean liquid water [kg/kg] + wpthvp, & ! Buoyancy flux [(K m)/s] + wp2thvp, & ! w'^2 th_v' [(m^2 K)/s^2] + rtpthvp, & ! r_t' th_v' [(kg K)/kg] + thlpthvp, & ! th_l' th_v' [K^2] + wprcp, & ! w' r_c' [(m kg)/(s kg)] + wp2rcp, & ! w'^2 r_c' [(m^2 kg)/(s^2 kg)] + rtprcp, & ! r_t' r_c' [(kg^2)/(kg^2)] + thlprcp, & ! th_l' r_c' [(K kg)/kg] + rcp2, & ! r_c'^2 [(kg^2)/(kg^2)] + wprtpthlp ! w' r_t' th_l' [(m kg K)/(s kg)] + + type(pdf_parameter), intent(out) :: & + pdf_params ! pdf paramters [units vary] + + integer, intent(out) :: & + err_code ! Are the outputs usable numbers? + + ! Output (passive scalar variables) + + real( kind = core_rknd ), intent(out), dimension(sclr_dim) :: & + sclrpthvp, & + sclrprcp, & + wpsclrp2, & + wpsclrprtp, & + wpsclrpthlp, & + wp2sclrp + + ! Local Variables + + real( kind = core_rknd ) :: & + w_1_n, w_2_n, & + thl_1_n, thl_2_n, & + rt_1_n, rt_2_n + + ! Variables that are stored in derived data type pdf_params. + real( kind = core_rknd ) :: & + w_1, & ! Mean of w (1st PDF component) [m/s] + w_2, & ! Mean of w (2nd PDF component) [m/s] + varnce_w_1, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2, & ! Variance of w (2nd PDF component) [m^2/s^2] + rt_1, & ! Mean of r_t (1st PDF component) [kg/kg] + rt_2, & ! Mean of r_t (2nd PDF component) [kg/kg] + varnce_rt_1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] + varnce_rt_2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] + thl_1, & ! Mean of th_l (1st PDF component) [K] + thl_2, & ! Mean of th_l (2nd PDF component) [K] + varnce_thl_1, & ! Variance of th_l (1st PDF component) [K^2] + varnce_thl_2, & ! Variance of th_l (2nd PDF component) [K^2] + rrtthl, & ! Correlation of r_t and th_l (both components) [-] + alpha_thl, & ! Factor relating to normalized variance for th_l [-] + alpha_rt, & ! Factor relating to normalized variance for r_t [-] + crt_1, & ! Coef. on r_t in s/t eqns. (1st PDF comp.) [-] + crt_2, & ! Coef. on r_t in s/t eqns. (2nd PDF comp.) [-] + cthl_1, & ! Coef. on th_l in s/t eqns. (1st PDF comp.) [(kg/kg)/K] + cthl_2 ! Coef. on th_l in s/t eqns. (2nd PDF comp.) [(kg/kg)/K] + + real( kind = core_rknd ) :: & + chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + stdev_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + stdev_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + stdev_eta_1, & ! Standard dev. of eta (old t) (1st PDF comp.) [kg/kg] + stdev_eta_2, & ! Standard dev. of eta (old t) (2nd PDF comp.) [kg/kg] + covar_chi_eta_1, & ! Covariance of chi and eta (1st PDF comp.) [kg^2/kg^2] + covar_chi_eta_2, & ! Covariance of chi and eta (2nd PDF comp.) [kg^2/kg^2] + corr_chi_eta_1, & ! Correlation of chi and eta (1st PDF component) [-] + corr_chi_eta_2, & ! Correlation of chi and eta (2nd PDF component) [-] + rsatl_1, & ! Mean of r_sl (1st PDF component) [kg/kg] + rsatl_2, & ! Mean of r_sl (2nd PDF component) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] + + real( kind = core_rknd ) :: & ! If l_use_ADG2 == .true., or l_use_3D_closure + sigma_sqd_w_1, & ! + sigma_sqd_w_2, & ! + sigma_sqd_thl_1, & ! + sigma_sqd_thl_2, & ! + sigma_sqd_rt_1, & ! + sigma_sqd_rt_2 + + ! Note: alpha coefficients = 0.5 * ( 1 - correlations^2 ). + ! These are used to calculate the scalar widths + ! varnce_thl_1, varnce_thl_2, varnce_rt_1, and varnce_rt_2 as in Eq. (34) + ! of Larson and Golaz (2005) + + ! Passive scalar local variables + + real( kind = core_rknd ), dimension(sclr_dim) :: & + sclr1, sclr2, & + varnce_sclr1, varnce_sclr2, & + alpha_sclr, & + rsclrthl, rsclrrt +! sclr1_n, sclr2_n, + + logical :: & + l_scalar_calc, & ! True if sclr_dim > 0 + l_calc_ice_supersat_frac ! True if we should calculate ice_supersat_frac + + ! Quantities needed to predict higher order moments + real( kind = core_rknd ) :: & + tl1, tl2, & + beta1, beta2 + + real( kind = core_rknd ) :: sqrt_wp2 + + ! Thermodynamic quantity + + real( kind = core_rknd ), intent(out) :: rc_coef + + real( kind = core_rknd ) :: & + wp2rxp, & ! Sum total < w'^2 r_x' > for all hm species x [(m/s)^2(kg/kg)] + wprxp, & ! Sum total < w'r_x' > for all hm species x [(m/s)(kg/kg)] + thlprxp, & ! Sum total < th_l'r_x' > for all hm species x [K(kg/kg)] + rtprxp ! Sum total < r_t'r_x' > for all hm species x [(kg/kg)^2] + + ! variables for a generalization of Chris Golaz' closure + ! varies width of plumes in theta_l, rt + real( kind = core_rknd ) :: width_factor_1, width_factor_2 + + ! variables for the ADG2 and 3D-Luhar closure + real( kind = core_rknd ) :: big_m_w, small_m_w, & + big_m_thl, small_m_thl, & + big_m_rt, small_m_rt + + ! variables for computing ice cloud fraction + real( kind = core_rknd) :: & + ice_supersat_frac_1, & ! Ice supersaturation fraction (1st PDF comp.) [-] + ice_supersat_frac_2, & ! Ice supersaturation fraction (2nd PDF comp.) [-] + rt_at_ice_sat1, rt_at_ice_sat2, & + chi_at_ice_sat1, chi_at_ice_sat2, rc_1_ice, rc_2_ice + + ! To test pdf parameters + real( kind = core_rknd ) :: & + wm_clubb_pdf, & + rtm_clubb_pdf, & + thlm_clubb_pdf, & + wp2_clubb_pdf, & + rtp2_clubb_pdf, & + thlp2_clubb_pdf, & + wp3_clubb_pdf, & + rtp3_clubb_pdf, & + thlp3_clubb_pdf, & + Skw_clubb_pdf, & + Skrt_clubb_pdf, & + Skthl_clubb_pdf + + real( kind = core_rknd ), parameter :: & + chi_at_liq_sat = 0.0_core_rknd ! Always zero + + logical, parameter :: & + l_liq_ice_loading_test = .false. ! Temp. flag liq./ice water loading test + + integer :: i, hm_idx ! Indices + +#ifdef GFDL + real ( kind = core_rknd ), parameter :: t1_combined = 273.16, & + t2_combined = 268.16, & + t3_combined = 238.16 +#endif + +!------------------------ Code Begins ---------------------------------- + + ! Check whether the passive scalars are present. + + if ( sclr_dim > 0 ) then + l_scalar_calc = .true. + else + l_scalar_calc = .false. + end if + + err_code = clubb_no_error ! Initialize to the value for no errors + + ! If there is no variance in vertical velocity, then treat rt and theta-l as + ! constant, as well. Otherwise width parameters (e.g. varnce_w_1, + ! varnce_w_2, etc.) are non-zero. + if ( (wp2 <= w_tol_sqd) .and. (.not. l_use_3D_closure) ) then + + mixt_frac = one_half + w_1 = wm + w_2 = wm + varnce_w_1 = 0._core_rknd + varnce_w_2 = 0._core_rknd + rt_1 = rtm + rt_2 = rtm + alpha_rt = one_half + varnce_rt_1 = 0._core_rknd + varnce_rt_2 = 0._core_rknd + thl_1 = thlm + thl_2 = thlm + alpha_thl = one_half + varnce_thl_1 = 0._core_rknd + varnce_thl_2 = 0._core_rknd + rrtthl = 0._core_rknd + + if ( l_scalar_calc ) then + do i = 1, sclr_dim, 1 + sclr1(i) = sclrm(i) + sclr2(i) = sclrm(i) + varnce_sclr1(i) = 0.0_core_rknd + varnce_sclr2(i) = 0.0_core_rknd + alpha_sclr(i) = one_half + rsclrrt(i) = 0.0_core_rknd + rsclrthl(i) = 0.0_core_rknd + end do ! 1..sclr_dim + end if + + else ! Width (standard deviation) parameters are non-zero + + ! To avoid recomputing + sqrt_wp2 = sqrt( wp2 ) + + if( (.not. l_use_ADG2) .and. (.not. l_use_3D_closure) ) then ! use ADG1 + call ADG1_w_closure(Skw, wm, wp2, sigma_sqd_w, sqrt_wp2, mixt_frac_max_mag,& + mixt_frac, varnce_w_1, varnce_w_2, w_1_n, w_2_n, w_1, w_2 ) + + elseif( l_use_ADG2 ) then ! use ADG2 + + ! Reproduce ADG2_w_closure using separate functions + call calc_Luhar_params( Skw, Skw, & ! intent(in) + mixt_frac, big_m_w, small_m_w ) ! intent(out) + + call close_Luhar_pdf( wm, wp2, mixt_frac, & ! intent(in) + small_m_w, Skw, Skw, & ! intent(in) + sigma_sqd_w_1, sigma_sqd_w_2, & ! intent(out) + varnce_w_1, varnce_w_2, & ! intent(out) + w_1_n, w_2_n, w_1, w_2 ) ! intent(out) + + ! Overwrite sigma_sqd_w for consistency with ADG1 + sigma_sqd_w = min( one / ( one + small_m_w**2 ), 0.99_core_rknd ) + + endif ! l_use_ADG2 + + if( .not. l_use_3D_closure ) then ! proceed as usual + ! The normalized variance for thl, rt, and sclr for "plume" 1 is: + ! + ! { 1 - [1/(1-sigma_sqd_w)]*[ (w'x')^2 / (w'^2 * x'^2) ] / mixt_frac } + ! * { (1/3)*beta + mixt_frac*( 1 - (2/3)*beta ) }; + ! + ! where "x" stands for thl, rt, or sclr; "mixt_frac" is the weight of Gaussian + ! "plume" 1, and 0 <= beta <= 3. + ! + ! The factor { (1/3)*beta + mixt_frac*( 1 - (2/3)*beta ) } does not depend on + ! which varable "x" stands for. The factor is multiplied by 2 and defined + ! as width_factor_1. + ! + ! The factor { 1 - [1/(1-sigma_sqd_w)]*[ (w'x')^2 / (w'^2 * x'^2) ] / mixt_frac } + ! depends on which variable "x" stands for. It is multiplied by one_half and + ! defined as alpha_x, where "x" stands for thl, rt, or sclr. + + ! Vince Larson added a dimensionless factor so that the + ! width of plumes in theta_l, rt can vary. + ! beta is a constant defined in module parameters_tunable + ! Set 0= abs(Skthl)) .and. ( abs(Skw) >= abs(Skrt) ) ) then + + ! w has the greatest magnitude of skewness. + + ! Solve for the w PDF + call calc_Luhar_params( Skw, Skw, & ! intent(in) + mixt_frac, big_m_w, small_m_w ) ! intent(out) + + call close_Luhar_pdf( wm, wp2, mixt_frac, & ! intent(in) + small_m_w, Skw, Skw, & ! intent(in) + sigma_sqd_w_1, sigma_sqd_w_2, & ! intent(out) + varnce_w_1, varnce_w_2, & ! intent(out) + w_1_n, w_2_n, w_1, w_2 ) ! intent(out) + + ! Solve for the thl PDF + call backsolve_Luhar_params( Skw, Skthl, & ! intent(in) + big_m_w, mixt_frac, & ! intent(in) + big_m_thl, small_m_thl ) ! intent(out) + + call close_Luhar_pdf( thlm, thlp2, mixt_frac, &! intent(in) + small_m_thl, Skthl, Skw, &! intent(in) + sigma_sqd_thl_1, sigma_sqd_thl_2, &! intent(out) + varnce_thl_1, varnce_thl_2, &! intent(out) + thl_1_n, thl_2_n, thl_1, thl_2 ) ! intent(out) + + ! Solve for the rt PDF + call backsolve_Luhar_params( Skw, Skrt, & ! intent(in) + big_m_w, mixt_frac, & ! intent(in) + big_m_rt, small_m_rt ) ! intent(out) + + call close_Luhar_pdf( rtm, rtp2, mixt_frac, & ! intent(in) + small_m_rt, Skrt, Skw, & ! intent(in) + sigma_sqd_rt_1, sigma_sqd_rt_2, & ! intent(out) + varnce_rt_1, varnce_rt_2, & ! intent(out) + rt_1_n, rt_2_n, rt_1, rt_2 ) ! intent(out) + + elseif ( ( abs(Skthl) > abs(Skw) ) & + .and. ( abs(Skthl) >= abs(Skrt) ) ) then + + ! theta-l has the greatest magnitude of skewness. + + ! Solve for the thl PDF + call calc_Luhar_params( Skthl, Skw, & !intent(in) + mixt_frac, big_m_thl, small_m_thl )!intent(out) + + ! Solve for the thl PDF + call close_Luhar_pdf( thlm, thlp2, mixt_frac, &! intent(in) + small_m_thl, Skthl, Skw, &! intent(in) + sigma_sqd_thl_1, sigma_sqd_thl_2, &! intent(out) + varnce_thl_1, varnce_thl_2, &! intent(out) + thl_1_n, thl_2_n, thl_1, thl_2 ) ! intent(out) + + ! Solve for the w PDF + call backsolve_Luhar_params( Skthl, Skw, & ! intent(in) + big_m_thl, mixt_frac, & ! intent(in) + big_m_w, small_m_w ) ! intent(out) + + call close_Luhar_pdf( wm, wp2, mixt_frac, & ! intent(in) + small_m_w, Skw, Skw, & ! intent(in) + sigma_sqd_w_1, sigma_sqd_w_2, & ! intent(out) + varnce_w_1, varnce_w_2, & ! intent(out) + w_1_n, w_2_n, w_1, w_2 ) ! intent(out) + + ! Solve for the rt PDF + call backsolve_Luhar_params( Skthl, Skrt, & ! intent(in) + big_m_thl, mixt_frac, & ! intent(in) + big_m_rt, small_m_rt ) ! intent(out) + + call close_Luhar_pdf( rtm, rtp2, mixt_frac, & ! intent(in) + small_m_rt, Skrt, Skw, & ! intent(in) + sigma_sqd_rt_1, sigma_sqd_rt_2, & ! intent(out) + varnce_rt_1, varnce_rt_2, & ! intent(out) + rt_1_n, rt_2_n, rt_1, rt_2 ) ! intent(out) + + else + + ! rt has the greatest magnitude of skewness. + + ! Solve for the rt PDF + call calc_Luhar_params( Skrt, Skw, & ! intent(in) + mixt_frac, big_m_rt, small_m_rt ) ! intent(out) + + ! Solve for the rt PDF + call close_Luhar_pdf( rtm, rtp2, mixt_frac, & ! intent(in) + small_m_rt, Skrt, Skw, & ! intent(in) + sigma_sqd_rt_1, sigma_sqd_rt_2, & ! intent(out) + varnce_rt_1, varnce_rt_2, & ! intent(out) + rt_1_n, rt_2_n, rt_1, rt_2 ) ! intent(out) + + ! Solve for the w PDF + call backsolve_Luhar_params( Skrt, Skw, & ! intent(in) + big_m_rt, mixt_frac, & ! intent(in) + big_m_w, small_m_w ) ! intent(out) + + call close_Luhar_pdf( wm, wp2, mixt_frac, & ! intent(in) + small_m_w, Skw, Skw, & ! intent(in) + sigma_sqd_w_1, sigma_sqd_w_2, & ! intent(out) + varnce_w_1, varnce_w_2, & ! intent(out) + w_1_n, w_2_n, w_1, w_2 ) ! intent(out) + + ! Solve for the thl PDF + call backsolve_Luhar_params( Skrt, Skthl, & ! intent(in) + big_m_rt, mixt_frac, & ! intent(in) + big_m_thl, small_m_thl ) ! intent(out) + + call close_Luhar_pdf( thlm, thlp2, mixt_frac, &! intent(in) + small_m_thl, Skthl, Skw, &! intent(in) + sigma_sqd_thl_1, sigma_sqd_thl_2, &! intent(out) + varnce_thl_1, varnce_thl_2, &! intent(out) + thl_1_n, thl_2_n, thl_1, thl_2 ) ! intent(out) + + endif + + ! CLUBB still uses ADG1 elsewhere in the code. This makes things a + ! little more consistent. + sigma_sqd_w = min( one / ( one + small_m_w**2 ), 0.99_core_rknd ) + + ! Set to default values when using the 3D_Luhar closure + alpha_thl = one_half + alpha_rt = one_half + + endif ! if( .not. l_use_3D_closure ) + + ! Compute pdf parameters for passive scalars + if ( l_scalar_calc ) then + do i = 1, sclr_dim + if ( sclrp2(i) <= sclr_tol(i)**2 ) then + ! Set plume sclr for plume 1,2 to the mean + sclr1(i)= sclrm(i) + sclr2(i)= sclrm(i) + ! Set the variance to zero + varnce_sclr1(i) = 0.0_core_rknd + varnce_sclr2(i) = 0.0_core_rknd + + alpha_sclr(i) = one_half + else +! sclr1_n(i) = - ( wpsclrp(i) / (sqrt( wp2 ) & +! * sqrt( sclrp2(i) )) )/w_2_n +! sclr2_n(i) = - ( wpsclrp(i) / (sqrt( wp2 ) & +! * sqrt( sclrp2(i) )) )/w_1_n + + sclr1(i) = sclrm(i) & + - ( wpsclrp(i) / sqrt_wp2 ) / w_2_n + sclr2(i) = sclrm(i) & + - ( wpsclrp(i) / sqrt_wp2 ) / w_1_n + + alpha_sclr(i) = one_half * ( one - wpsclrp(i)*wpsclrp(i) & + / ((one-sigma_sqd_w)*wp2*sclrp2(i)) ) + + alpha_sclr(i) = max( min( alpha_sclr(i), one ), zero_threshold ) + + ! Vince Larson multiplied original expressions by width_factor_1,2 + ! to generalize scalar skewnesses. 05 Nov 03 + varnce_sclr1(i) = ( alpha_sclr(i) / mixt_frac * sclrp2(i) ) * width_factor_1 + varnce_sclr2(i) = ( alpha_sclr(i) / (one-mixt_frac) * & + sclrp2(i) ) * width_factor_2 + end if ! sclrp2(i) <= sclr_tol(i)**2 + end do ! i=1, sclr_dim + end if ! l_scalar_calc + + ! We include sub-plume correlation with coeff rrtthl. + + if ( varnce_rt_1*varnce_thl_1 > 0._core_rknd .and. & + varnce_rt_2*varnce_thl_2 > 0._core_rknd ) then + rrtthl = ( rtpthlp - mixt_frac * ( rt_1-rtm ) * ( thl_1-thlm ) & + - (one-mixt_frac) * ( rt_2-rtm ) * ( thl_2-thlm ) ) & + / ( mixt_frac*sqrt( varnce_rt_1*varnce_thl_1 ) & + + (one-mixt_frac)*sqrt( varnce_rt_2*varnce_thl_2 ) ) + if ( rrtthl < -one ) then + rrtthl = -one + end if + if ( rrtthl > one ) then + rrtthl = one + end if + else + rrtthl = 0.0_core_rknd + end if ! varnce_rt_1*varnce_thl_1 > 0 .and. varnce_rt_2*varnce_thl_2 > 0 + + ! Sub-plume correlation, rsclrthl, of passive scalar and theta_l. + if ( l_scalar_calc ) then + do i=1, sclr_dim + if ( varnce_sclr1(i)*varnce_thl_1 > 0._core_rknd .and. & + varnce_sclr2(i)*varnce_thl_2 > 0._core_rknd ) then + rsclrthl(i) = ( sclrpthlp(i) & + - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( thl_1-thlm ) & + - (one-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( thl_2-thlm ) ) & + / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_thl_1 ) & + + (one-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_thl_2 ) ) + if ( rsclrthl(i) < -one ) then + rsclrthl(i) = -one + end if + if ( rsclrthl(i) > one ) then + rsclrthl(i) = one + end if + else + rsclrthl(i) = 0.0_core_rknd + end if + + ! Sub-plume correlation, rsclrrt, of passive scalar and total water. + + if ( varnce_sclr1(i)*varnce_rt_1 > 0._core_rknd .and. & + varnce_sclr2(i)*varnce_rt_2 > 0._core_rknd ) then + rsclrrt(i) = ( sclrprtp(i) - mixt_frac * ( sclr1(i)-sclrm(i) ) * ( rt_1-rtm )& + - (one-mixt_frac) * ( sclr2(i)-sclrm(i) ) * ( rt_2-rtm ) ) & + / ( mixt_frac*sqrt( varnce_sclr1(i)*varnce_rt_1 ) & + + (one-mixt_frac)*sqrt( varnce_sclr2(i)*varnce_rt_2 ) ) + if ( rsclrrt(i) < -one ) then + rsclrrt(i) = -one + end if + if ( rsclrrt(i) > one ) then + rsclrrt(i) = one + end if + else + rsclrrt(i) = 0.0_core_rknd + end if + end do ! i=1, sclr_dim + end if ! l_scalar_calc + + end if ! Widths non-zero + + ! Compute higher order moments (these are interactive) + wp2rtp = mixt_frac * ( (w_1-wm)**2+varnce_w_1 ) * ( rt_1-rtm ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( rt_2-rtm ) + + wp2thlp = mixt_frac * ( (w_1-wm)**2+varnce_w_1 ) * ( thl_1-thlm ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( thl_2-thlm ) + + ! Compute higher order moments (these are non-interactive diagnostics) + if ( iwp4 > 0 ) then + wp4 = mixt_frac * ( 3._core_rknd*varnce_w_1**2 + & + 6._core_rknd*((w_1-wm)**2)*varnce_w_1 + (w_1-wm)**4 ) & + + (one-mixt_frac) * ( 3._core_rknd*varnce_w_2**2 + & + 6._core_rknd*((w_2-wm)**2)*varnce_w_2 + (w_2-wm)**4 ) + end if + + if ( iwprtp2 > 0 ) then + wprtp2 = mixt_frac * ( w_1-wm )*( (rt_1-rtm)**2 + varnce_rt_1 ) & + + (one-mixt_frac) * ( w_2-wm )*( (rt_2-rtm)**2 + varnce_rt_2) + end if + + if ( iwpthlp2 > 0 ) then + wpthlp2 = mixt_frac * ( w_1-wm )*( (thl_1-thlm)**2 + varnce_thl_1 ) & + + (one-mixt_frac) * ( w_2-wm )*( (thl_2-thlm)**2+varnce_thl_2 ) + end if + + if ( iwprtpthlp > 0 ) then + wprtpthlp = mixt_frac * ( w_1-wm )*( (rt_1-rtm)*(thl_1-thlm) & + + rrtthl*sqrt( varnce_rt_1*varnce_thl_1 ) ) & + + ( one-mixt_frac ) * ( w_2-wm )*( (rt_2-rtm)*(thl_2-thlm) & + + rrtthl*sqrt( varnce_rt_2*varnce_thl_2 ) ) + end if + + + ! Scalar Addition to higher order moments + if ( l_scalar_calc ) then + do i=1, sclr_dim + + wp2sclrp(i) = mixt_frac * ( (w_1-wm)**2+varnce_w_1 )*( sclr1(i)-sclrm(i) ) & + + (one-mixt_frac) * ( (w_2-wm)**2+varnce_w_2 ) * ( sclr2(i)-sclrm(i) ) + + wpsclrp2(i) = mixt_frac * ( w_1-wm ) * ( (sclr1(i)-sclrm(i))**2 + varnce_sclr1(i) ) & + + (one-mixt_frac) * ( w_2-wm ) * & + ( (sclr2(i)-sclrm(i))**2 + varnce_sclr2(i) ) + + wpsclrprtp(i) = mixt_frac * ( w_1-wm ) * ( ( rt_1-rtm )*( sclr1(i)-sclrm(i) ) & + + rsclrrt(i)*sqrt( varnce_rt_1*varnce_sclr1(i) ) ) & + + ( one-mixt_frac )*( w_2-wm ) * & + ( ( rt_2-rtm )*( sclr2(i)-sclrm(i) ) + rsclrrt(i)*sqrt( varnce_rt_2*varnce_sclr2(i) ) ) + + wpsclrpthlp(i) = mixt_frac * ( w_1-wm ) * ( ( sclr1(i)-sclrm(i) )*( thl_1-thlm ) & + + rsclrthl(i)*sqrt( varnce_sclr1(i)*varnce_thl_1 ) ) & + + ( one-mixt_frac ) * ( w_2-wm ) * & + ( ( sclr2(i)-sclrm(i) )*( thl_2-thlm ) & + + rsclrthl(i)*sqrt( varnce_sclr2(i)*varnce_thl_2 ) ) + + end do ! i=1, sclr_dim + end if ! l_scalar_calc + + ! Compute higher order moments that include theta_v. + + ! First compute some preliminary quantities. + ! "1" denotes first Gaussian; "2" denotes 2nd Gaussian + ! liq water temp (Sommeria & Deardorff 1977 (SD), eqn. 3) + + tl1 = thl_1*exner + tl2 = thl_2*exner + +#ifdef GFDL + if( sclr_dim > 0 .and. (.not. do_liquid_only_in_clubb) ) then ! h1g, 2010-06-16 begin mod + + if( tl1 > t1_combined ) then + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + elseif( tl1 > t2_combined ) then + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) * (tl1 - t2_combined)/(t1_combined - t2_combined) & + + sat_mixrat_ice( p_in_Pa, tl1 ) * (t1_combined - tl1)/(t1_combined - t2_combined) + elseif( tl1 > t3_combined ) then + rsatl_1 = sat_mixrat_ice( p_in_Pa, tl1 ) & + + sat_mixrat_ice( p_in_Pa, tl1 ) * (RH_crit(1, 1) -one ) & + * ( t2_combined -tl1)/(t2_combined - t3_combined) + else + rsatl_1 = sat_mixrat_ice( p_in_Pa, tl1 ) * RH_crit(1, 1) + endif + + if( tl2 > t1_combined ) then + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) + elseif( tl2 > t2_combined ) then + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) * (tl2 - t2_combined)/(t1_combined - t2_combined) & + + sat_mixrat_ice( p_in_Pa, tl2 ) * (t1_combined - tl2)/(t1_combined - t2_combined) + elseif( tl2 > t3_combined ) then + rsatl_2 = sat_mixrat_ice( p_in_Pa, tl2 ) & + + sat_mixrat_ice( p_in_Pa, tl2 )* (RH_crit(1, 2) -one) & + * ( t2_combined -tl2)/(t2_combined - t3_combined) + else + rsatl_2 = sat_mixrat_ice( p_in_Pa, tl2 ) * RH_crit(1, 2) + endif + + else !sclr_dim <= 0 or do_liquid_only_in_clubb = .T. + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) + + endif !sclr_dim > 0 +#else + rsatl_1 = sat_mixrat_liq( p_in_Pa, tl1 ) + rsatl_2 = sat_mixrat_liq( p_in_Pa, tl2 ) ! h1g, 2010-06-16 end mod +#endif + + ! SD's beta (eqn. 8) + beta1 = ep * ( Lv/(Rd*tl1) ) * ( Lv/(Cp*tl1) ) + beta2 = ep * ( Lv/(Rd*tl2) ) * ( Lv/(Cp*tl2) ) + + ! s from Lewellen and Yoh 1993 (LY) eqn. 1 + chi_1 = ( rt_1 - rsatl_1 ) / ( one + beta1 * rsatl_1 ) + chi_2 = ( rt_2 - rsatl_2 ) / ( one + beta2 * rsatl_2 ) + + ! Coefficients for s' + ! For each normal distribution in the sum of two normal distributions, + ! s' = crt * rt' + cthl * thl'; + ! therefore, x's' = crt * x'rt' + cthl * x'thl'. + ! Larson et al. May, 2001. + + crt_1 = one/( one + beta1*rsatl_1) + crt_2 = one/( one + beta2*rsatl_2) + + cthl_1 = ( (one + beta1 * rt_1) / ( one + beta1*rsatl_1)**2 ) & + * ( Cp/Lv ) * beta1 * rsatl_1 * exner + cthl_2 = ( (one + beta2 * rt_2) / ( one + beta2*rsatl_2 )**2 ) & + * ( Cp/Lv ) * beta2 * rsatl_2 * exner + + ! Standard deviation of chi for each component. + ! Include subplume correlation of qt, thl + ! Because of round-off error, + ! stdev_chi_1 (and probably stdev_chi_2) can become negative when rrtthl=1 + ! One could also write this as a squared term + ! plus a postive correction; this might be a neater format + stdev_chi_1 = sqrt( max( crt_1**2 * varnce_rt_1 & + - two * rrtthl * crt_1 * cthl_1 & + * sqrt( varnce_rt_1 * varnce_thl_1 ) & + + cthl_1**2 * varnce_thl_1, & + zero_threshold ) ) + + stdev_chi_2 = sqrt( max( crt_2**2 * varnce_rt_2 & + - two * rrtthl * crt_2 * cthl_2 & + * sqrt( varnce_rt_2 * varnce_thl_2 ) & + + cthl_2**2 * varnce_thl_2, & + zero_threshold ) ) + + ! We need to introduce a threshold value for the variance of chi + if ( stdev_chi_1 <= chi_tol ) then + ! Treat chi as a delta function in this component. + stdev_chi_1 = zero + end if + + if ( stdev_chi_2 <= chi_tol ) then + ! Treat chi as a delta function in this component. + stdev_chi_2 = zero + end if + + ! Standard deviation of eta for each component. + stdev_eta_1 = sqrt( max( crt_1**2 * varnce_rt_1 & + + two * rrtthl * crt_1 * cthl_1 & + * sqrt( varnce_rt_1 * varnce_thl_1 ) & + + cthl_1**2 * varnce_thl_1, & + zero_threshold ) ) + + stdev_eta_2 = sqrt( max( crt_2**2 * varnce_rt_2 & + + two * rrtthl * crt_2 * cthl_2 & + * sqrt( varnce_rt_2 * varnce_thl_2 ) & + + cthl_2**2 * varnce_thl_2, & + zero_threshold ) ) + + ! Covariance of chi and eta for each component. + covar_chi_eta_1 = crt_1**2 * varnce_rt_1 - cthl_1**2 * varnce_thl_1 + + covar_chi_eta_2 = crt_2**2 * varnce_rt_2 - cthl_2**2 * varnce_thl_2 + + ! Correlation of chi and eta for each component. + if ( stdev_chi_1 * stdev_eta_1 > zero ) then + corr_chi_eta_1 = covar_chi_eta_1 / ( stdev_chi_1 * stdev_eta_1 ) + else + corr_chi_eta_1 = zero + endif + + if ( stdev_chi_2 * stdev_eta_2 > zero ) then + corr_chi_eta_2 = covar_chi_eta_2 / ( stdev_chi_2 * stdev_eta_2 ) + else + corr_chi_eta_2 = zero + endif + + ! Determine whether to compute ice_supersat_frac. We do not compute + ! ice_supersat_frac for GFDL (unless do_liquid_only_in_clubb is true), + ! because liquid and ice are both fed into rtm, ruining the calculation. +#ifdef GFDL + if (do_liquid_only_in_clubb) then + l_calc_ice_supersat_frac = .true. + else + l_calc_ice_supersat_frac = .false. + end if +#else + l_calc_ice_supersat_frac = .true. +#endif + + ! Calculate cloud_frac_1 and rc_1 + call calc_cloud_frac_component(chi_1, stdev_chi_1, chi_at_liq_sat, cloud_frac_1, rc_1) + + ! Calculate cloud_frac_2 and rc_2 + call calc_cloud_frac_component(chi_2, stdev_chi_2, chi_at_liq_sat, cloud_frac_2, rc_2) + + if ( l_calc_ice_supersat_frac ) then + ! We must compute chi_at_ice_sat1 and chi_at_ice_sat2 + if (tl1 <= T_freeze_K) then + rt_at_ice_sat1 = sat_mixrat_ice( p_in_Pa, tl1 ) + chi_at_ice_sat1 = ( rt_at_ice_sat1 - rsatl_1 ) / ( one + beta1 * rsatl_1 ) + else + ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac + ! is not defined, so we use chi_at_liq_sat + chi_at_ice_sat1 = chi_at_liq_sat + end if + + if (tl2 <= T_freeze_K) then + rt_at_ice_sat2 = sat_mixrat_ice( p_in_Pa, tl2 ) + chi_at_ice_sat2 = ( rt_at_ice_sat2 - rsatl_2 ) / ( one + beta2 * rsatl_2 ) + else + ! If the temperature is warmer than freezing (> 0C) then ice_supersat_frac + ! is not defined, so we use chi_at_liq_sat + chi_at_ice_sat2 = chi_at_liq_sat + end if + + ! Calculate ice supersaturation fraction in the 1st PDF component. + call calc_cloud_frac_component( chi_1, stdev_chi_1, chi_at_ice_sat1, & + ice_supersat_frac_1, rc_1_ice ) + + ! Calculate ice supersaturation fraction in the 2nd PDF component. + call calc_cloud_frac_component( chi_2, stdev_chi_2, chi_at_ice_sat2, & + ice_supersat_frac_2, rc_2_ice ) + end if + + ! Compute moments that depend on theta_v + ! + ! The moments that depend on th_v' are calculated based on an approximated + ! and linearized form of the theta_v equation: + ! + ! theta_v = theta_l + { (R_v/R_d) - 1 } * thv_ds * r_t + ! + [ {L_v/(C_p*exner)} - (R_v/R_d) * thv_ds ] * r_c; + ! + ! and therefore: + ! + ! th_v' = th_l' + { (R_v/R_d) - 1 } * thv_ds * r_t' + ! + [ {L_v/(C_p*exner)} - (R_v/R_d) * thv_ds ] * r_c'; + ! + ! where thv_ds is used as a reference value to approximate theta_l. + + rc_coef = Lv / (exner*Cp) - ep2 * thv_ds + + wp2rxp = zero + wprxp = zero + thlprxp = zero + rtprxp = zero + if ( l_liq_ice_loading_test ) then + do hm_idx = 1, hydromet_dim, 1 + if ( l_mix_rat_hm(hm_idx) ) then + wp2rxp = wp2rxp + wp2hmp(hm_idx) + wprxp = wprxp + wphydrometp(hm_idx) + thlprxp = thlprxp + thlphmp(hm_idx) + rtprxp = rtprxp + rtphmp(hm_idx) + endif + enddo ! hm_idx = 1, hydromet_dim, 1 + endif ! l_liq_ice_loading_test + + wp2rcp = mixt_frac * ((w_1-wm)**2 + varnce_w_1)*rc_1 & + + (one-mixt_frac) * ((w_2-wm)**2 + varnce_w_2)*rc_2 & + - wp2 * (mixt_frac*rc_1+(one-mixt_frac)*rc_2) + + wp2thvp = wp2thlp + ep1*thv_ds*wp2rtp + rc_coef*wp2rcp - thv_ds * wp2rxp + + wprcp = mixt_frac * (w_1-wm)*rc_1 + (one-mixt_frac) * (w_2-wm)*rc_2 + + wpthvp = wpthlp + ep1*thv_ds*wprtp + rc_coef*wprcp - thv_ds * wprxp + + ! Account for subplume correlation in qt-thl + thlprcp = mixt_frac * ( (thl_1-thlm)*rc_1 - (cthl_1*varnce_thl_1)*cloud_frac_1 ) & + + (one-mixt_frac) * ( (thl_2-thlm)*rc_2 - (cthl_2*varnce_thl_2)*cloud_frac_2 ) & + + mixt_frac*rrtthl*crt_1*sqrt( varnce_rt_1*varnce_thl_1 )*cloud_frac_1 & + + (one-mixt_frac)*rrtthl*crt_2*sqrt( varnce_rt_2*varnce_thl_2 )*cloud_frac_2 + thlpthvp = thlp2 + ep1*thv_ds*rtpthlp + rc_coef*thlprcp - thv_ds * thlprxp + + ! Account for subplume correlation in qt-thl + rtprcp = mixt_frac * ( (rt_1-rtm)*rc_1 + (crt_1*varnce_rt_1)*cloud_frac_1 ) & + + (one-mixt_frac) * ( (rt_2-rtm)*rc_2 + (crt_2*varnce_rt_2)*cloud_frac_2 ) & + - mixt_frac*rrtthl*cthl_1*sqrt( varnce_rt_1*varnce_thl_1 )*cloud_frac_1 & + - (one-mixt_frac)*rrtthl*cthl_2*sqrt( varnce_rt_2*varnce_thl_2 )*cloud_frac_2 + + rtpthvp = rtpthlp + ep1*thv_ds*rtp2 + rc_coef*rtprcp - thv_ds * rtprxp + + ! Account for subplume correlation of scalar, theta_v. + ! See Eqs. A13, A8 from Larson et al. (2002) ``Small-scale...'' + ! where the ``scalar'' in this paper is w. + if ( l_scalar_calc ) then + do i=1, sclr_dim + sclrprcp(i) & + = mixt_frac * ( ( sclr1(i)-sclrm(i) ) * rc_1 ) & + + (one-mixt_frac) * ( ( sclr2(i)-sclrm(i) ) * rc_2 ) & + + mixt_frac*rsclrrt(i) * crt_1 & + * sqrt( varnce_sclr1(i) * varnce_rt_1 ) * cloud_frac_1 & + + (one-mixt_frac) * rsclrrt(i) * crt_2 & + * sqrt( varnce_sclr2(i) * varnce_rt_2 ) * cloud_frac_2 & + - mixt_frac * rsclrthl(i) * cthl_1 & + * sqrt( varnce_sclr1(i) * varnce_thl_1 ) * cloud_frac_1 & + - (one-mixt_frac) * rsclrthl(i) * cthl_2 & + * sqrt( varnce_sclr2(i) * varnce_thl_2 ) * cloud_frac_2 + + sclrpthvp(i) = sclrpthlp(i) + ep1*thv_ds*sclrprtp(i) + rc_coef*sclrprcp(i) + end do ! i=1, sclr_dim + end if ! l_scalar_calc + + ! Compute mean cloud fraction and cloud water + cloud_frac = calc_cloud_frac(cloud_frac_1, cloud_frac_2, mixt_frac) + rcm = mixt_frac * rc_1 + (one-mixt_frac) * rc_2 + + rcm = max( zero_threshold, rcm ) + + if (l_calc_ice_supersat_frac) then + ! Compute ice cloud fraction, ice_supersat_frac + ice_supersat_frac = calc_cloud_frac( ice_supersat_frac_1, & + ice_supersat_frac_2, mixt_frac ) + else + ! ice_supersat_frac will be garbage if computed as above + ice_supersat_frac = 0.0_core_rknd + if (clubb_at_least_debug_level( 1 )) then + write(fstderr,*) "Warning: ice_supersat_frac has garbage values if & + & do_liquid_only_in_clubb = .false." + end if + end if + ! Compute variance of liquid water mixing ratio. + ! This is not needed for closure. Statistical Analysis only. + +#ifndef CLUBB_CAM + ! if CLUBB is used in CAM we want this variable computed no matter what + if ( ircp2 > 0 ) then +#endif + + rcp2 = mixt_frac * ( chi_1*rc_1 + cloud_frac_1*stdev_chi_1**2 ) & + + ( one-mixt_frac ) * ( chi_2*rc_2 + cloud_frac_2*stdev_chi_2**2 ) - rcm**2 + rcp2 = max( zero_threshold, rcp2 ) + +#ifndef CLUBB_CAM + ! if CLUBB is used in CAM we want this variable computed no matter what + end if +#endif + + + ! Save PDF parameters + pdf_params%w_1 = w_1 + pdf_params%w_2 = w_2 + pdf_params%varnce_w_1 = varnce_w_1 + pdf_params%varnce_w_2 = varnce_w_2 + pdf_params%rt_1 = rt_1 + pdf_params%rt_2 = rt_2 + pdf_params%varnce_rt_1 = varnce_rt_1 + pdf_params%varnce_rt_2 = varnce_rt_2 + pdf_params%thl_1 = thl_1 + pdf_params%thl_2 = thl_2 + pdf_params%varnce_thl_1 = varnce_thl_1 + pdf_params%varnce_thl_2 = varnce_thl_2 + pdf_params%rrtthl = rrtthl + pdf_params%alpha_thl = alpha_thl + pdf_params%alpha_rt = alpha_rt + pdf_params%crt_1 = crt_1 + pdf_params%crt_2 = crt_2 + pdf_params%cthl_1 = cthl_1 + pdf_params%cthl_2 = cthl_2 + pdf_params%chi_1 = chi_1 + pdf_params%chi_2 = chi_2 + pdf_params%stdev_chi_1 = stdev_chi_1 + pdf_params%stdev_chi_2 = stdev_chi_2 + pdf_params%stdev_eta_1 = stdev_eta_1 + pdf_params%stdev_eta_2 = stdev_eta_2 + pdf_params%covar_chi_eta_1 = covar_chi_eta_1 + pdf_params%covar_chi_eta_2 = covar_chi_eta_2 + pdf_params%corr_chi_eta_1 = corr_chi_eta_1 + pdf_params%corr_chi_eta_2 = corr_chi_eta_2 + pdf_params%rsatl_1 = rsatl_1 + pdf_params%rsatl_2 = rsatl_2 + pdf_params%rc_1 = rc_1 + pdf_params%rc_2 = rc_2 + pdf_params%cloud_frac_1 = cloud_frac_1 + pdf_params%cloud_frac_2 = cloud_frac_2 + pdf_params%mixt_frac = mixt_frac + + pdf_params%ice_supersat_frac_1 = ice_supersat_frac_1 + pdf_params%ice_supersat_frac_2 = ice_supersat_frac_2 + + if ( clubb_at_least_debug_level( 2 ) ) then + + call pdf_closure_check & + ( wp4, wprtp2, wp2rtp, wpthlp2, & + wp2thlp, cloud_frac, rcm, wpthvp, wp2thvp, & + rtpthvp, thlpthvp, wprcp, wp2rcp, & + rtprcp, thlprcp, rcp2, wprtpthlp, & + crt_1, crt_2, cthl_1, cthl_2, pdf_params, & + sclrpthvp, sclrprcp, wpsclrp2, & + wpsclrprtp, wpsclrpthlp, wp2sclrp, & + err_code ) + + ! Error Reporting + ! Joshua Fasching February 2008 + + if ( fatal_error( err_code ) ) then + + write(fstderr,*) "Error in pdf_closure_new" + + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "p_in_Pa = ", p_in_Pa + write(fstderr,*) "exner = ", exner + write(fstderr,*) "thv_ds = ", thv_ds + write(fstderr,*) "wm = ", wm + write(fstderr,*) "wp2 = ", wp2 + write(fstderr,*) "wp3 = ", wp3 + write(fstderr,*) "sigma_sqd_w = ", sigma_sqd_w + write(fstderr,*) "rtm = ", rtm + write(fstderr,*) "rtp2 = ", rtp2 + write(fstderr,*) "wprtp = ", wprtp + write(fstderr,*) "thlm = ", thlm + write(fstderr,*) "thlp2 = ", thlp2 + write(fstderr,*) "wpthlp = ", wpthlp + write(fstderr,*) "rtpthlp = ", rtpthlp + + if ( sclr_dim > 0 ) then + write(fstderr,*) "sclrm = ", sclrm + write(fstderr,*) "wpsclrp = ", wpsclrp + write(fstderr,*) "sclrp2 = ", sclrp2 + write(fstderr,*) "sclrprtp = ", sclrprtp + write(fstderr,*) "sclrpthlp = ", sclrpthlp + end if + + write(fstderr,*) "level = ", level + + write(fstderr,*) "Intent(out)" + + write(fstderr,*) "wp4 = ", wp4 + write(fstderr,*) "wprtp2 = ", wprtp2 + write(fstderr,*) "wp2rtp = ", wp2rtp + write(fstderr,*) "wpthlp2 = ", wpthlp2 + write(fstderr,*) "cloud_frac = ", cloud_frac + write(fstderr,*) "ice_supersat_frac = ", ice_supersat_frac + write(fstderr,*) "rcm = ", rcm + write(fstderr,*) "wpthvp = ", wpthvp + write(fstderr,*) "wp2thvp = ", wp2thvp + write(fstderr,*) "rtpthvp = ", rtpthvp + write(fstderr,*) "thlpthvp = ", thlpthvp + write(fstderr,*) "wprcp = ", wprcp + write(fstderr,*) "wp2rcp = ", wp2rcp + write(fstderr,*) "rtprcp = ", rtprcp + write(fstderr,*) "thlprcp = ", thlprcp + write(fstderr,*) "rcp2 = ", rcp2 + write(fstderr,*) "wprtpthlp = ", wprtpthlp + write(fstderr,*) "pdf_params%w_1 = ", pdf_params%w_1 + write(fstderr,*) "pdf_params%w_2 = ", pdf_params%w_2 + write(fstderr,*) "pdf_params%varnce_w_1 = ", pdf_params%varnce_w_1 + write(fstderr,*) "pdf_params%varnce_w_2 = ", pdf_params%varnce_w_2 + write(fstderr,*) "pdf_params%rt_1 = ", pdf_params%rt_1 + write(fstderr,*) "pdf_params%rt_2 = ", pdf_params%rt_2 + write(fstderr,*) "pdf_params%varnce_rt_1 = ", pdf_params%varnce_rt_1 + write(fstderr,*) "pdf_params%varnce_rt_2 = ", pdf_params%varnce_rt_2 + write(fstderr,*) "pdf_params%thl_1 = ", pdf_params%thl_1 + write(fstderr,*) "pdf_params%thl_2 = ", pdf_params%thl_2 + write(fstderr,*) "pdf_params%varnce_thl_1 = ", pdf_params%varnce_thl_1 + write(fstderr,*) "pdf_params%varnce_thl_2 = ", pdf_params%varnce_thl_2 + write(fstderr,*) "pdf_params%rrtthl = ", pdf_params%rrtthl + write(fstderr,*) "pdf_params%alpha_thl = ", pdf_params%alpha_thl + write(fstderr,*) "pdf_params%alpha_rt = ", pdf_params%alpha_rt + write(fstderr,*) "pdf_params%crt_1 = ", pdf_params%crt_1 + write(fstderr,*) "pdf_params%crt_2 = ", pdf_params%crt_2 + write(fstderr,*) "pdf_params%cthl_1 = ", pdf_params%cthl_1 + write(fstderr,*) "pdf_params%cthl_2 = ", pdf_params%cthl_2 + write(fstderr,*) "pdf_params%chi_1 = ", pdf_params%chi_1 + write(fstderr,*) "pdf_params%chi_2 = ", pdf_params%chi_2 + write(fstderr,*) "pdf_params%stdev_chi_1 = ", pdf_params%stdev_chi_1 + write(fstderr,*) "pdf_params%stdev_chi_2 = ", pdf_params%stdev_chi_2 + write(fstderr,*) "pdf_params%stdev_eta_1 = ", pdf_params%stdev_eta_1 + write(fstderr,*) "pdf_params%stdev_eta_2 = ", pdf_params%stdev_eta_2 + write(fstderr,*) "pdf_params%covar_chi_eta_1 = ", & + pdf_params%covar_chi_eta_1 + write(fstderr,*) "pdf_params%covar_chi_eta_2 = ", & + pdf_params%covar_chi_eta_2 + write(fstderr,*) "pdf_params%corr_chi_eta_1 = ", & + pdf_params%corr_chi_eta_1 + write(fstderr,*) "pdf_params%corr_chi_eta_2 = ", & + pdf_params%corr_chi_eta_2 + write(fstderr,*) "pdf_params%rsatl_1 = ", pdf_params%rsatl_1 + write(fstderr,*) "pdf_params%rsatl_2 = ", pdf_params%rsatl_2 + write(fstderr,*) "pdf_params%rc_1 = ", pdf_params%rc_1 + write(fstderr,*) "pdf_params%rc_2 = ", pdf_params%rc_2 + write(fstderr,*) "pdf_params%cloud_frac_1 = ", pdf_params%cloud_frac_1 + write(fstderr,*) "pdf_params%cloud_frac_2 = ", pdf_params%cloud_frac_2 + write(fstderr,*) "pdf_params%mixt_frac = ", pdf_params%mixt_frac + write(fstderr,*) "pdf_params%ice_supersat_frac_1 = ", & + pdf_params%ice_supersat_frac_1 + write(fstderr,*) "pdf_params%ice_supersat_frac_2 = ", & + pdf_params%ice_supersat_frac_2 + + if ( sclr_dim > 0 )then + write(fstderr,*) "sclrpthvp = ", sclrpthvp + write(fstderr,*) "sclrprcp = ", sclrprcp + write(fstderr,*) "wpsclrp2 = ", wpsclrp2 + write(fstderr,*) "wpsclrprtp = ", wpsclrprtp + write(fstderr,*) "wpsclrpthlp = ", wpsclrpthlp + write(fstderr,*) "wp2sclrp = ", wp2sclrp + end if + + end if ! Fatal error + + ! Error check pdf parameters and moments to ensure consistency + if(l_use_3D_closure) then + + ! Means + wm_clubb_pdf = mixt_frac * w_1 + ( one - mixt_frac ) * w_2 + + if( abs( (wm_clubb_pdf - wm) / max(wm,eps) ) > .05_core_rknd ) then + write(fstderr,*) "wm error at thlm = ", thlm, ( (wm_clubb_pdf - wm) / max(wm,eps) ) + endif + + rtm_clubb_pdf = mixt_frac * rt_1 + ( one - mixt_frac ) * rt_2 + + if( abs( (rtm_clubb_pdf - rtm) / max(rtm,eps) ) > .05_core_rknd ) then + write(fstderr,*) "rtm error at thlm = ", thlm, ( (rtm_clubb_pdf - rtm) / max(rtm,eps) ) + endif + + thlm_clubb_pdf = mixt_frac * thl_1 + ( one - mixt_frac ) * thl_2 + + if( abs( (thlm_clubb_pdf - thlm) / thlm ) > .05_core_rknd ) then + write(fstderr,*) "thlm error at thlm = ", thlm, ( (thlm_clubb_pdf - thlm) / thlm ) + endif + + ! Variances + if(wp2 > w_tol**2) then + + wp2_clubb_pdf & + = mixt_frac * ( ( w_1 - wm )**2 + varnce_w_1 ) & + + ( one - mixt_frac ) * ( ( w_2 - wm )**2 + varnce_w_2 ) + + if( ( abs( (wp2_clubb_pdf - wp2) / wp2 ) > .05_core_rknd ) ) then + write(fstderr,*) "wp2 error at thlm = ", thlm, ( (wp2_clubb_pdf - wp2) / wp2 ) + endif + + endif + + if(rtp2 > rt_tol**2) then + + rtp2_clubb_pdf & + = mixt_frac * ( ( rt_1 - rtm )**2 + varnce_rt_1 ) & + + ( one - mixt_frac ) * ( ( rt_2 - rtm )**2 + varnce_rt_2 ) + + if( abs( (rtp2_clubb_pdf - rtp2) / rtp2 ) > .05_core_rknd ) then + write(fstderr,*) "rtp2 error at thlm = ", thlm, & + "Error = ", ( (rtp2_clubb_pdf - rtp2) / rtp2 ) + endif + + endif + + if(thlp2 > thl_tol**2) then + + thlp2_clubb_pdf & + = mixt_frac * ( ( thl_1 - thlm )**2 + varnce_thl_1 ) & + + ( one - mixt_frac ) * ( ( thl_2 - thlm )**2 + varnce_thl_2 ) + + if( abs( (thlp2_clubb_pdf - thlp2) / thlp2 ) > .05_core_rknd ) then + write(fstderr,*) "thlp2 error at thlm = ", thlm, & + "Error = ", ( (thlp2_clubb_pdf - thlp2) / thlp2 ) + endif + + endif + + ! Third order moments + wp3_clubb_pdf & + = mixt_frac * ( w_1 - wm ) & + * ( ( w_1 - wm )**2 + 3.0_core_rknd*varnce_w_1 ) & + + ( one - mixt_frac ) * ( w_2 - wm ) & + * ( ( w_2 - wm )**2 + 3.0_core_rknd*varnce_w_2 ) + + rtp3_clubb_pdf & + = mixt_frac * ( rt_1 - rtm ) & + * ( ( rt_1 - rtm )**2 + 3.0_core_rknd*varnce_rt_1 ) & + + ( one - mixt_frac ) * ( rt_2 - rtm ) & + * ( ( rt_2 - rtm )**2 + 3.0_core_rknd*varnce_rt_2 ) + + thlp3_clubb_pdf & + = mixt_frac * ( thl_1 - thlm ) & + * ( ( thl_1 - thlm )**2 + 3.0_core_rknd*varnce_thl_1 ) & + + ( one - mixt_frac ) * ( thl_2 - thlm ) & + * ( ( thl_2 - thlm )**2 + 3.0_core_rknd*varnce_thl_2 ) + + ! Skewness + Skw_clubb_pdf = wp3_clubb_pdf / & + ( wp2_clubb_pdf + Skw_denom_coef * w_tol**2 )**1.5_core_rknd + + if(Skw > .05_core_rknd) then + if( abs( (Skw_clubb_pdf - Skw) / Skw ) > .25_core_rknd ) then + write(fstderr,*) "Skw error at thlm = ", thlm, & + "Error = ",( (Skw_clubb_pdf - Skw) / Skw ), Skw_clubb_pdf, Skw + endif + endif + + Skrt_clubb_pdf = rtp3_clubb_pdf / & + ( rtp2_clubb_pdf + Skw_denom_coef * rt_tol**2 )**1.5_core_rknd + + if(Skrt > .05_core_rknd) then + if( abs( (Skrt_clubb_pdf - Skrt) / Skrt ) > .25_core_rknd ) then + write(fstderr,*) "Skrt error at thlm = ", thlm, & + "Error = ", ( (Skrt_clubb_pdf - Skrt) / Skrt ), Skrt_clubb_pdf, Skrt + endif + endif + + Skthl_clubb_pdf = thlp3_clubb_pdf / & + ( thlp2_clubb_pdf + Skw_denom_coef * thl_tol**2 )**1.5_core_rknd + + if(Skthl > .05_core_rknd) then + if( abs( (Skthl_clubb_pdf - Skthl) / Skthl ) > .25_core_rknd ) then + write(fstderr,*) "Skthl error at thlm = ", thlm, & + "Error = ", ( (Skthl_clubb_pdf - Skthl) / Skthl ), Skthl_clubb_pdf, Skthl + endif + endif + + end if !l_use_3D_closure + + end if ! clubb_at_least_debug_level + + return + end subroutine pdf_closure + + !============================================================================= + elemental subroutine calc_cloud_frac_component( mean_chi_i, stdev_chi_i, & + chi_at_sat, & + cloud_frac_i, rc_i ) + + ! Description: + ! Calculates the PDF component cloud water mixing ratio, rc_i, and cloud + ! fraction, cloud_frac_i, for the ith PDF component. + ! + ! The equation for cloud water mixing ratio, rc, at any point is: + ! + ! rc = chi * H(chi); + ! + ! and the equation for cloud fraction at a point, fc, is: + ! + ! fc = H(chi); + ! + ! where where extended liquid water mixing ratio, chi, is equal to cloud + ! water mixing ratio, rc, when positive. When the atmosphere is saturated + ! at this point, cloud water is found, and rc = chi, while fc = 1. + ! Otherwise, clear air is found at this point, and rc = fc = 0. + ! + ! The mean of rc and fc is calculated by integrating over the PDF, such + ! that: + ! + ! = INT(-inf:inf) chi * H(chi) * P(chi) dchi; and + ! + ! cloud_frac = = INT(-inf:inf) H(chi) * P(chi) dchi. + ! + ! This can be rewritten as: + ! + ! = INT(0:inf) chi * P(chi) dchi; and + ! + ! cloud_frac = = INT(0:inf) P(chi) dchi; + ! + ! and further rewritten as: + ! + ! = SUM(i=1,N) mixt_frac_i INT(0:inf) chi * P_i(chi) dchi; and + ! + ! cloud_frac = SUM(i=1,N) mixt_frac_i INT(0:inf) P_i(chi) dchi; + ! + ! where N is the number of PDF components. The equation for mean rc in the + ! ith PDF component is: + ! + ! rc_i = INT(0:inf) chi * P_i(chi) dchi; + ! + ! and the equation for cloud fraction in the ith PDF component is: + ! + ! cloud_frac_i = INT(0:inf) P_i(chi) dchi. + ! + ! The component values are related to the overall values by: + ! + ! = SUM(i=1,N) mixt_frac_i * rc_i; and + ! + ! cloud_frac = SUM(i=1,N) mixt_frac_i * cloud_frac_i. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + chi_tol, & ! Tolerance for pdf parameter chi [kg/kg] + sqrt_2pi, & ! sqrt(2*pi) + sqrt_2, & ! sqrt(2) + one, & ! 1 + one_half, & ! 1/2 + zero ! 0 + + use anl_erf, only: & + erf ! Procedure(s) -- The error function + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mean_chi_i, & ! Mean of chi (old s) (ith PDF component) [kg/kg] + stdev_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + chi_at_sat ! Value of chi at saturation (0--liquid; neg.--ice) [kg/kg] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + cloud_frac_i, & ! Cloud fraction (ith PDF component) [-] + rc_i ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + + ! Local Variables + real( kind = core_rknd) :: zeta_i + + !----- Begin Code ----- + if ( stdev_chi_i > chi_tol ) then + + ! The value of chi varies in the ith PDF component. + + zeta_i = ( mean_chi_i - chi_at_sat ) / stdev_chi_i + + cloud_frac_i = one_half * ( one + erf( zeta_i / sqrt_2 ) ) + + rc_i = ( mean_chi_i - chi_at_sat ) * cloud_frac_i & + + stdev_chi_i * exp( - one_half * zeta_i**2 ) / ( sqrt_2pi ) + + else ! stdev_chi_i <= chi_tol + + ! The value of chi does not vary in the ith PDF component. + if ( ( mean_chi_i - chi_at_sat ) < zero ) then + ! All clear air in the ith PDF component. + cloud_frac_i = zero + rc_i = zero + else ! mean_chi_i >= 0 + ! All cloud in the ith PDF component. + cloud_frac_i = one + rc_i = mean_chi_i - chi_at_sat + endif ! mean_chi_i < 0 + + endif ! stdev_chi_i > chi_tol + + + return + + end subroutine calc_cloud_frac_component + + !============================================================================= + function calc_cloud_frac( cloud_frac_1, cloud_frac_2, mixt_frac ) + + ! Description: + ! Given the the two pdf components of a cloud fraction, and the weight + ! of the first component, this fuction calculates the cloud fraction, + ! cloud_frac + ! + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & ! Constant(s) + one, & ! 1 + fstderr, & ! Standard error output + zero_threshold ! A physical quantity equal to zero + + use clubb_precision, only: & + core_rknd ! Precision + + use error_code, only: & + clubb_at_least_debug_level ! Function to check whether clubb is in + ! at least the specified debug level + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + cloud_frac_1, & ! First PDF component of cloud_frac + cloud_frac_2, & ! Second PDF component of cloud_frac + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) + + ! Output Variables + real( kind = core_rknd) :: & + calc_cloud_frac ! Cloud fraction + + ! Local Variables + real( kind = core_rknd) :: & + cloud_frac ! Cloud fraction (used as a holding variable for + ! output) + + !----------------------------------------------------------------------- + !----- Begin Code ----- + cloud_frac = mixt_frac * cloud_frac_1 + (one-mixt_frac) * cloud_frac_2 + + ! Note: Brian added the following lines to ensure that there + ! are never any negative liquid water values (or any negative + ! cloud fraction values, for that matter). According to + ! Vince Larson, the analytic formula should not produce any + ! negative results, but such computer-induced errors such as + ! round-off error may produce such a value. This has been + ! corrected because Brian found a small negative value of + ! rcm in the first timestep of the FIRE case. + + cloud_frac = max( zero_threshold, cloud_frac ) + if ( clubb_at_least_debug_level( 2 ) ) then + if ( cloud_frac > one ) then + write(fstderr,*) "Cloud fraction > 1" + end if + end if + cloud_frac = min( one, cloud_frac ) + + calc_cloud_frac = cloud_frac + return + + end function calc_cloud_frac + + !============================================================================= + subroutine calc_vert_avg_cf_component & + ( nz, k, z_vals, chi, stdev_chi, chi_at_sat, & + cloud_frac_i, rc_i ) + ! Description: + ! This subroutine is similar to calc_cloud_frac_component, but + ! resolves cloud_frac and rc at an arbitrary number of vertical levels + ! in the vicinity of the desired level. This may give a better + ! parameterization of sub-grid atmospheric conditions. + ! + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + intrinsic :: sum + + ! Local Constants + integer, parameter :: & + n_points = 9 ! Number of vertical levels to use in averaging + ! (arbitrary, but must be odd) + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of vertical levels [count] + k ! Level at which cloud_frac is to be computed [count] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + chi, & ! Value of chi (old s) [kg/kg] + stdev_chi, & ! Standard deviation of chi [kg/kg] + chi_at_sat ! Value of chi at saturation with respect to ice [kg/kg] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + cloud_frac_i, & ! Vertically averaged cloud fraction [-] + rc_i ! Vertically averaged cloud water mixing ratio [kg/kg] + + ! Local Variables + real( kind = core_rknd ), dimension(n_points) :: & + chi_ref, & ! chi (old s) evaluated on refined grid [kg/kg] + stdev_chi_ref, & ! stdev_chi evaluated on refined grid [kg/kg] + cloud_frac_ref, & ! cloud_frac evaluated on refined grid [-] + rc_ref ! r_c evaluated on refined grid [kg/kg] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + chi_ref = interp_var_array( n_points, nz, k, z_vals, chi ) + stdev_chi_ref = interp_var_array( n_points, nz, k, z_vals, stdev_chi ) + ! We could optionally compute chi_at_sat in an analogous manner. For now, + ! use chi_at_sat(k) as an approximation. + + ! Compute cloud_frac and r_c at each refined grid level + call calc_cloud_frac_component( chi_ref(:), stdev_chi_ref(:), chi_at_sat(k), & ! Intent(in) + cloud_frac_ref(:), rc_ref(:) ) ! Intent(out) + + cloud_frac_i = sum( cloud_frac_ref(:) ) / real( n_points, kind=core_rknd ) + rc_i = sum( rc_ref(:) ) / real( n_points, kind=core_rknd ) + + return + end subroutine calc_vert_avg_cf_component + + !============================================================================= + elemental subroutine ADG1_w_closure(Skw, wm, wp2, sigma_sqd_w, sqrt_wp2, mixt_frac_max_mag,& + mixt_frac, varnce_w_1, varnce_w_2, w_1_n, w_2_n, & + w_1, w_2 ) + ! Description: + ! The Analytic Double Gaussian 1 closure is used by default in CLUBB. It + ! assumes the widths of both w Gaussians to be the same. + ! + ! References: + ! Golaz, J-C., V. E. Larson, and W. R. Cotton, 2002a: A PDF-based model for + ! boundary layer clouds. Part I: Method and model description. J. Atmos. + ! Sci., 59, 3540–3551. + ! + ! Vincent E. Larson and Jean-Christophe Golaz, 2005: Using Probability + ! Density Functions to Derive Consistent Closure Relationships among + ! Higher-Order Moments. Mon. Wea. Rev., 133, 1023–1042. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & + one_half + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Skw, & ! Skewness of w [-] + wm, & ! Mean w [m / s] + wp2, & ! w'^2 [m^2/s^2] + sigma_sqd_w, & ! Widths of each w Gaussian [-] + sqrt_wp2, & ! w' [m/s^1] + mixt_frac_max_mag ! [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + mixt_frac, & ! Mixture fraction [-] + varnce_w_1, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2, & ! Variance of w (2nd PDF component) [m^2/s^2] + w_1_n, & ! Normalized Mean of w (1st PDF component) [-] + w_2_n, & ! Normalized Mean of w (2nd PDF component) [-] + w_1, & ! Mean of w (1st PDF component) [m/s] + w_2 ! Mean of w (2nd PDF component) [m/s] + + !----------------------------------------------------------------------- + !----- Begin Code ----- + + ! The variable "mixt_frac" is the weight of the 1st PDF component. The + ! weight of the 2nd PDF component is "1-mixt_frac". If there isn't any + ! skewness of w (Sk_w = 0 because w'^3 = 0), mixt_frac = 0.5, and both + ! PDF components are equally weighted. If there is positive skewness of + ! w (Sk_w > 0 because w'^3 > 0), 0 < mixt_frac < 0.5, and the 2nd PDF + ! component has greater weight than does the 1st PDF component. If there + ! is negative skewness of w (Sk_w < 0 because w'^3 < 0), + ! 0.5 < mixt_frac < 1, and the 1st PDF component has greater weight than + ! does the 2nd PDF component. + if ( abs( Skw ) <= 1e-5_core_rknd ) then + mixt_frac = one_half + else + mixt_frac = one_half * ( one - Skw/ & + sqrt( 4.0_core_rknd*( one - sigma_sqd_w )**3 + Skw**2 ) ) + endif + + ! Clip mixt_frac, 1-mixt_frac, to avoid dividing by zero + ! Formula for mixt_frac_max_mag = + ! 1 - ( 1/2 * ( 1 - Skw_max/sqrt( 4*( 1 - sigma_sqd_w )^3 + Skw_max^2 ) ) ) + ! Where sigma_sqd_w is fixed at 0.4. + mixt_frac = min( max( mixt_frac, one-mixt_frac_max_mag ), mixt_frac_max_mag ) + + ! The normalized mean of w for Gaussian "plume" 1 is w_1_n. It's value + ! will always be greater than 0. As an example, a value of 1.0 would + ! indicate that the actual mean of w for Gaussian "plume" 1 is found + ! 1.0 standard deviation above the overall mean for w. + w_1_n = sqrt( ( (one-mixt_frac)/mixt_frac )*(one-sigma_sqd_w) ) + ! The normalized mean of w for Gaussian "plume" 2 is w_2_n. It's value + ! will always be less than 0. As an example, a value of -0.5 would + ! indicate that the actual mean of w for Gaussian "plume" 2 is found + ! 0.5 standard deviations below the overall mean for w. + w_2_n = -sqrt( ( mixt_frac/(one-mixt_frac) )*(one-sigma_sqd_w) ) + ! The mean of w for Gaussian "plume" 1 is w_1. + w_1 = wm + sqrt_wp2*w_1_n + ! The mean of w for Gaussian "plume" 2 is w_2. + w_2 = wm + sqrt_wp2*w_2_n + + ! The variance of w for Gaussian "plume" 1 for varnce_w_1. + varnce_w_1 = sigma_sqd_w*wp2 + ! The variance of w for Gaussian "plume" 2 for varnce_w_2. + ! The variance in both Gaussian "plumes" is defined to be the same. + varnce_w_2 = sigma_sqd_w*wp2 + + end subroutine ADG1_w_closure + + !============================================================================= + elemental subroutine calc_Luhar_params( Skx, Skw, & + mixt_frac, big_m, small_m ) + + ! Description: + ! For the Luhar closure, this subroutine takes Skx (and Skw) as input and + ! outputs the mixture fraction, big_m, and small_m. This code was written + ! using the equations and nomenclature of Larson et al. (2002) Appendix + ! section e. + ! + ! The relationship between skewness of x (Skx), mixture fraction (a), and + ! Luhar's small m (m) is given by: + ! + ! Skx^2 = ( m^2 * ( m^2 + 3 )^2 / ( m^2 + 1 )^3 ) + ! * ( 1 - 2*a )^2 / ( a * ( 1 - a ) ). + ! + ! Luhar's large M (M) is used to more easily express the factor involving + ! the m's: + ! + ! M = ( m^2 + 1 )^3 / ( m^2 * ( m^2 + 3 )^2 ). + ! + ! The equation involving skewness of x becomes: + ! + ! Skx^2 = ( 1 / M ) * ( 1 - 2*a )^2 / ( a * ( 1 - a ) ); + ! + ! or: + ! + ! M * Skx^2 = ( 1 - 2*a )^2 / ( a * ( 1 - a ) ). + ! + ! This equation can be rewritten as: + ! + ! ( a * ( 1 - a ) ) * M * Skx^2 = ( 1 - 2*a )^2; + ! + ! as well as: + ! + ! ( a - a^2 ) * M * Skx^2 = 1 - 4*a + 4*a^2; + ! + ! and eventually as: + ! + ! ( 4 + M * Skx^2 ) * a^2 - ( 4 + M * Skx^2 ) * a + 1 = 0. + ! + ! Solving the quadratic equation for a: + ! + ! a = (1/2) * ( 1 +- Skx * sqrt( 1 / ( 4/M + Skx^2 ) ) ). + ! + ! Since by definition, mu_w_1 >= mu_w_2, a < 0.5 when Skw > 0, the equation + ! for mixture fraction is: + ! + ! a = (1/2) * ( 1 - Skx * sqrt( 1 / ( 4/M + Skx^2 ) ) ). + ! + ! For 3-D Luhar, the variable (w, rt, or theta-l) with the greatest + ! magnitude of skewness is used to calculate mixture fraction. Since it is + ! desirable to still have a < 0.5 when Skw > 0 and a > 0.5 when Skw < 0, the + ! sign function is used. The value of Skx is replaced by: + ! + ! Skx|_adj = sign(Skw) * sign(Skx) * Skx; + ! + ! where + ! + ! sign(Skx) = | 1 when x >= 0 + ! | -1 when x < 0. + ! + ! Since Skx|_adj^2 = ( sign(Skw) * sign(Skx) * Skx )^2 + ! = ( sign(Skw) * sign(Skx) )^2 * Skx^2 = Skx^2, the equation for mixture + ! fraction is: + ! + ! a = (1/2) + ! * ( 1 - sign(Skw) * sign(Skx) * Skx * sqrt( 1 / ( 4/M + Skx^2 ) ) ). + ! + ! When using the ADG2 closure or when using the 3-D Luhar closure when the + ! variable with the greatest magnitude of skewness is w, Skw = Skx and + ! sign(Skw) * sign(Skx) is always equal to 1, reducing the equation to its + ! previous form. + + ! References: + ! Vincent E. Larson, Jean-Christophe Golaz, and William R. Cotton, 2002: + ! Small-Scale and Mesoscale Variability in Cloudy Boundary Layers: Joint + ! Probability Density Functions. J. Atmos. Sci., 59, 3519–3539. + ! + !----------------------------------------------------------------------- + + use constants_clubb, only: & + four, & ! Constant(s) + three, & + one, & + two_thirds, & + one_half, & + one_third, & + zero + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Skx, & ! Skewness of x ( / ^(3/2) ) [-] + Skw ! Skewness of w ( / ^(3/2) ) [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + mixt_frac, & ! Mixture fraction [-] + big_m, & ! Luhar's M [-] + small_m ! Luhar's m [-] + + ! Local Variables + real( kind = core_rknd ) :: & + small_m_sqd, & ! Luhar's m^2 [-] + sign_Skw, & ! Sign( Skw ); 1 when Skw >= 0 or -1 when Skw < 0 [-] + sign_Skx ! Sign( Skx ); 1 when Skx >= 0 or -1 when Skx < 0 [-] + + + ! Calculate Luhar's m (small m). + ! If Skx is very small, then small_m will tend to zero which risks + ! divide-by-zero. To ameliorate this problem, we enforce abs( x_1_n ) and + ! abs( x_2_n ) > 0.05. + ! Note: Luhar's small_m (m) is the only tunable parameter in the Luhar + ! closure, so this equation can be changed. However, the value of m + ! should go toward 0 as Skx goes toward 0 so that the double Gaussian + ! reduces to a single Gaussian when the distribution is unskewed. + small_m = max( two_thirds * abs( Skx )**one_third, 0.05_core_rknd ) + + ! Calculate m^2. + small_m_sqd = small_m**2 + + ! Calculate Luhar's M (big M). + big_m = ( one + small_m_sqd )**3 & + / ( ( three + small_m_sqd )**2 * small_m_sqd ) + + ! Calculate sign( Skw ). + if ( Skw >= zero ) then + sign_Skw = one + else ! Skw < 0 + sign_Skw = -one + endif ! Skw >= 0 + + ! Calculate sign( Skx ). + if ( Skx >= zero ) then + sign_Skx = one + else ! Skx < 0 + sign_Skx = -one + endif ! Skx >= 0 + + ! Calculate mixture fraction. + mixt_frac = one_half & + * ( one - sign_Skw * sign_Skx * Skx & + * sqrt( one / ( ( four / big_m ) + Skx**2 ) ) ) + + + return + + end subroutine calc_Luhar_params + + !============================================================================= + elemental subroutine close_Luhar_pdf( xm, xp2, mixt_frac, & + small_m, Skx, Skw, & + sigma_sqd_x_1, sigma_sqd_x_2, & + varnce_x_1, varnce_x_2, & + x_1_n, x_2_n, x_1, x_2 ) + + ! Description: + ! For the Luhar closure, this subroutine takes Skx, xm, xp2, and mixt_frac, + ! big_m, and small_m (calculated in calc_Luhar_params) as input and outputs + ! the PDF component means and variances of a variable x in the joint-PDF + ! according to Luhar et al. (1996). This code was written using the + ! equations and nomenclature of Larson et al. (2002) Appendix section e. + + ! References: + ! Vincent E. Larson, Jean-Christophe Golaz, and William R. Cotton, 2002: + ! Small-Scale and Mesoscale Variability in Cloudy Boundary Layers: Joint + ! Probability Density Functions. J. Atmos. Sci., 59, 3519–3539. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + one_half, & + zero, & + eps + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + xm, & ! Mean (overall) of x, [(x units)] + xp2, & ! Variance (overall) of x, [(x units)^2] + mixt_frac, & ! Mixture fraction [-] + small_m, & ! Luhar's small m [-] + Skx, & ! Skewness of x ( / ^(3/2) ) [-] + Skw ! Skewness of w ( / ^(3/2) ) [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + sigma_sqd_x_1, & ! Normalized width parameter of x (1st PDF component) [-] + sigma_sqd_x_2, & ! Normalized width parameter of x (1st PDF component) [-] + varnce_x_1, & ! Variance of x (1st PDF component) [(x units)^2] + varnce_x_2, & ! Variance of x (2nd PDF component) [(x units)^2] + x_1_n, & ! Normalized mean of x (1st PDF component) [-] + x_2_n, & ! Normalized mean of x (2nd PDF component) [-] + x_1, & ! Mean of x (1st PDF component) [(x units)] + x_2 ! Mean of x (2nd PDF component) [(x units)] + + ! Local Variables + real( kind = core_rknd) :: & + sqrt_xp2, & ! Square root of the variance of x [(x units)] + sign_Skw, & ! Sign( Skw ); 1 when Skw >= 0 or -1 when Skw < 0 [-] + sign_Skx ! Sign( Skx ); 1 when Skx >= 0 or -1 when Skx < 0 [-] + + + ! Calculate sign( Skw ). + if ( Skw >= zero ) then + sign_Skw = one + else ! Skw < 0 + sign_Skw = -one + endif ! Skw >= 0 + + ! Calculate sign( Skx ). + if ( Skx >= zero ) then + sign_Skx = one + else ! Skx < 0 + sign_Skx = -one + endif ! Skx >= 0 + + ! Calculate the square root of the overall variance of x. + sqrt_xp2 = sqrt( xp2 ) + + ! Normalized width parameter of x in the 1st PDF component. + sigma_sqd_x_1 = ( one - mixt_frac ) / ( mixt_frac * ( one + small_m**2 ) ) + + ! The variance of x in the 1st PDF component. + varnce_x_1 = sigma_sqd_x_1 * xp2 + + ! Normalized width parameter of x in the 2nd PDF component. + sigma_sqd_x_2 = mixt_frac / ( ( one - mixt_frac ) * ( one + small_m**2 ) ) + + ! The variance of x in the 2nd PDF component. + varnce_x_2 = sigma_sqd_x_2 * xp2 + + ! Normalized mean of x in the 1st PDF component. + x_1_n = sign_Skw * sign_Skx * small_m * sqrt( sigma_sqd_x_1 ) + + ! Normalized mean of x in the 2nd PDF component. + x_2_n = -sign_Skw * sign_Skx * small_m * sqrt( sigma_sqd_x_2 ) + + ! The mean of x in the 1st PDF component. + x_1 = xm + sqrt_xp2 * x_1_n + + ! The mean of x in the 2nd PDF component. + x_2 = xm + sqrt_xp2 * x_2_n + + + return + + end subroutine close_Luhar_pdf + + !============================================================================= + elemental subroutine backsolve_Luhar_params( Sk_max, Skx, & + big_m_max, mixt_frac, & + big_m_x, small_m_x ) + + ! Description: + ! This subroutine calculates Luhar's big_m and small_m for the variate 'x' + ! consistent with the mixture fraction of the variate with the largest + ! skewness. + ! + ! The relationship between skewness of x (Skx), mixture fraction (a), and + ! Luhar's small m (m) is given by: + ! + ! Skx^2 = ( m^2 * ( m^2 + 3 )^2 / ( m^2 + 1 )^3 ) + ! * ( 1 - 2*a )^2 / ( a * ( 1 - a ) ). + ! + ! Moving the factor involving mixture fraction to the right-hand side: + ! + ! ( ( a * ( 1 - a ) ) / ( 1 - 2*a )^2 ) * Skx^2 + ! = m^2 * ( m^2 + 3 )^2 / ( m^2 + 1 )^3. + ! + ! This can be rewritten as: + ! + ! ( ( a * ( 1 - a ) ) / ( 1 - 2*a )^2 ) * Skx^2 + ! = ( m^6 + 6*m^4 + 9*m^2 ) / ( m^6 + 3*m^4 + 3*m^2 + 1 ). + ! + ! Setting alpha = ( ( a * ( 1 - a ) ) / ( 1 - 2*a )^2 ) * Skx^2, the + ! equation can be rewritten as: + ! + ! ( m^6 + 3*m^4 + 3*m^2 + 1 ) * alpha = m^6 + 6*m^4 + 9*m^2. + ! + ! This can be rearranged and rewritten as: + ! + ! ( alpha - 1 ) * m^6 + ( 3 * alpha - 6 ) * m^4 + ! + ( 3 * alpha - 9 ) * m^2 + alpha = 0. + ! + ! This can be rewritten again as: + ! + ! ( alpha - 1 ) * (m^2)^3 + ( 3 * alpha - 6 ) * (m^2)^2 + ! + ( 3 * alpha - 9 ) * (m^2) + alpha = 0. + ! + ! The goal is to solve for m^2, and then take the square root of m^2 to + ! solve for m. This can be accomplished by using the cubic formula (with + ! the l_use_cubic_backsolve option), or else by a quadratic approximation. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + three, & + two, & + one, & + one_half, & + zero, & + eps, & + fstderr + + use clubb_precision, only: & + core_rknd ! Precision + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + Sk_max, & ! Maximum skewness + Skx, & ! Skewness of the variate solving small_m and big_m for + big_m_max, & ! Luhar's big_m of the variate with maximum skewness + mixt_frac ! Mixture fraction [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + big_m_x, & ! Luhar's big_m for the variate being solved for + small_m_x ! Luhar's small_m for the variate being solved for + + ! Local Variables + real( kind = core_rknd ) :: & + alpha, & ! 1 / big_m_x + a, & ! For readability, quadratic equation + b, & + c, & + alpha_upr, & + alpha_low, & + discrim + + ! Flag to backsolve for m^2 using cubic formula + logical, parameter :: & + l_use_cubic_backsolve = .true. + + + if ( l_use_cubic_backsolve ) then + + if ( abs( mixt_frac - one_half ) < 0.001_core_rknd ) then + + ! When mixture fraction = 0.5 (based on the variable with the largest + ! magnitude of skewness), all variables must have a skewness of 0. + ! Set m to the minimum threshold of 0.05. + small_m_x = 0.05_core_rknd + + ! Calculate the corresponding value of big_m_x. + big_m_x = ( one + small_m_x**2 )**3 & + / ( ( three + small_m_x**2 )**2 * small_m_x**2 ) + + elseif ( Skx == zero ) then + + ! Mixture fraction /= 0.5 because the variable with the largest + ! magnitude of skewness has a skewness /= 0. However, variable x has + ! a skewness of 0. In order to reproduce the correct skewness for + ! variable x, set m to 0 (regardless of minimum thresholds used in + ! other parts of the code). + small_m_x = zero + + ! The value of big_m_x should be inf. Set it to huge. This is not + ! used in any calculation, anyway. + big_m_x = huge( big_m_x ) + + else ! mixt_frac /= 0.5 and Skx /= 0 + + ! Backsolve for m, given mixt_frac and Skx. + + ! alpha = 1/M is given by: + ! [ mixt_frac * ( 1 - mixt_frac ) / ( 1 - 2 * mixt_frac )^2 ] * Skx^2. + alpha = ( mixt_frac * ( one - mixt_frac ) & + / ( one - two * mixt_frac )**2 ) * Skx**2 + + ! Calculate big_m_x. + big_m_x = one / alpha + + ! Solve the cubic equation for m^2: + ! ( alpha - 1 ) * (m^2)^3 + ( 3 * alpha - 6 ) * (m^2)^2 + ! + ( 3 * alpha - 9 ) * (m^2) + alpha = 0. + ! The largest root is preferred. + small_m_x & + = sqrt( max( max_cubic_root( alpha - one, three * alpha - 6.0_core_rknd, & + three * alpha - 9.0_core_rknd, alpha ), & + 0.05_core_rknd**2 ) ) + + endif + + else ! original formualation + + alpha = ( Skx**2 / (max(Sk_max**2, eps) * big_m_max) ) ! 1 / big_m_x + + ! This limit keeps the discriminant >= 0 + alpha_upr = 2.0_core_rknd*sqrt( 13.0_core_rknd ) - 5.0_core_rknd + + alpha_low = eps + + ! For this approximation, alpha must be less than 2*sqrt(13) - 5 to get a real ans. + alpha = min(alpha, alpha_upr) + + ! For testing, eliminate possibility of divide by zero + alpha = max(alpha,alpha_low) + + ! Use a piece-wise approximation + if(alpha < 1.0_core_rknd) then + a = max(3.0_core_rknd * alpha - 6.0_core_rknd, eps) ! Prevent divide by zero + b = 3.0_core_rknd * alpha - 9.0_core_rknd + c = alpha + + discrim = b**2 - 4.0_core_rknd * a * c + small_m_x = sqrt( (-b - sqrt(discrim)) / (2.0_core_rknd * a) ) + else + ! For this approximation, alpha must be less than 2*sqrt(13) - 5 to get a real ans. + alpha = min(alpha, 2.0_core_rknd) + + a = max(6.0_core_rknd * alpha - 9.0_core_rknd, eps) ! Prevent divide by zero + b = -6.0_core_rknd + c = 2.0_core_rknd * alpha - 1.0_core_rknd + + discrim = b**2 - 4.0_core_rknd * a * c + small_m_x = sqrt( (-b - sqrt(discrim)) / (2.0_core_rknd * a) ) + endif + + ! Clip consistently with subroutine calc_Luhar_params + small_m_x = max( 5e-2_core_rknd, small_m_x) + + big_m_x = 1.0_core_rknd / alpha + + endif ! l_use_cubic_backsolve + + + end subroutine backsolve_Luhar_params + + !============================================================================= + function interp_var_array( n_points, nz, k, z_vals, var ) + + ! Description: + ! Interpolates a variable to an array of values about a given level + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + integer, intent(in) :: & + n_points, & ! Number of points to interpolate to (must be odd and >= 3) + nz, & ! Total number of vertical levels + k ! Center of interpolation array + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + var ! Variable values on grid [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(n_points) :: & + interp_var_array ! Interpolated values of variable [units vary] + + ! Local Variables + real( kind = core_rknd ) :: & + dz ! Distance between vertical levels + + real( kind = core_rknd ) :: & + z_val ! Height at some sub-grid level + + integer :: & + i, & ! Loop iterator + + subgrid_lev_count ! Number of refined grid points located between + ! two defined grid levels + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Place a point at each of k-1, k, and k+1. + interp_var_array(1) = var_value_integer_height( nz, k-1, z_vals, var ) + interp_var_array((n_points+1)/2) = var_value_integer_height( nz, k, z_vals, var ) + interp_var_array(n_points) = var_value_integer_height( nz, k+1, z_vals, var ) + + subgrid_lev_count = (n_points - 3) / 2 + + ! Lower half + if ( k == 1 ) then + dz = (z_vals(2) - z_vals(1)) / real( subgrid_lev_count+1, kind=core_rknd ) + else + dz = (z_vals(k) - z_vals(k-1)) / real( subgrid_lev_count+1, kind=core_rknd ) + end if + do i=1, subgrid_lev_count + z_val = z_vals(k) - real( i, kind=core_rknd ) * dz + interp_var_array(1+i) & + = var_subgrid_interp( nz, k, z_vals, var, z_val, l_below=.true. ) + end do + + ! Upper half + if ( k == nz ) then + dz = ( z_vals(nz) - z_vals(nz-1) ) / real( subgrid_lev_count+1, kind=core_rknd ) + else + dz = ( z_vals(k+1) - z_vals(k) ) / real( subgrid_lev_count+1, kind=core_rknd ) + end if + do i=1, (n_points-3)/2 + z_val = z_vals(k) + real( i, kind=core_rknd ) * dz + interp_var_array((n_points+1)/2+i) & + = var_subgrid_interp( nz, k, z_vals, var, z_val, l_below=.false. ) + end do + + return + end function interp_var_array + + !============================================================================= + function var_value_integer_height( nz, k, z_vals, var_grid_value ) result( var_value ) + + ! Description + ! Returns the value of a variable at an integer height between 0 and + ! nz+1 inclusive, using extrapolation when k==0 or k==nz+1 + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use interpolation, only: & + mono_cubic_interp ! Procedure + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Total number of vertical levels + k ! Level to resolve variable value + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each vertical level [m] + var_grid_value ! Value of variable at each grid level [units vary] + + ! Output Variables + real( kind = core_rknd ) :: & + var_value ! Value of variable at height level [units vary] + + ! Local Variables + integer :: km1, k00, kp1, kp2 + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + if ( k >= 1 .and. k <= nz ) then + ! This is the simple case. No extrapolation necessary. + var_value = var_grid_value(k) + else if ( k == 0 ) then + ! Extrapolate below the lower boundary + km1 = nz + k00 = 1 + kp1 = 2 + kp2 = 3 + var_value = mono_cubic_interp( z_vals(1)-(z_vals(2)-z_vals(1)), & + km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var_grid_value(km1), var_grid_value(k00), & + var_grid_value(kp1), var_grid_value(kp2) ) + else if ( k == nz+1 ) then + ! Extrapolate above the upper boundary + km1 = nz + k00 = nz-1 + kp1 = nz + kp2 = nz + var_value = mono_cubic_interp( z_vals(nz)+(z_vals(nz)-z_vals(nz-1)), & + km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var_grid_value(km1), var_grid_value(k00), & + var_grid_value(kp1), var_grid_value(kp2) ) + else + ! Invalid height requested + var_value = -999._core_rknd + end if ! k > 1 .and. k < nz + return + end function var_value_integer_height + + !============================================================================= + function var_subgrid_interp( nz, k, z_vals, var, z_interp, l_below ) result( var_value ) + + ! Description + ! Interpolates (or extrapolates) a variable to a value between grid + ! levels + + ! References + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use interpolation, only: & + mono_cubic_interp ! Procedure + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of vertical levels + k ! Grid level near interpolation target + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + z_vals, & ! Height at each grid level [m] + var ! Variable values at grid levels [units vary] + + real( kind = core_rknd ), intent(in) :: & + z_interp ! Interpolation target height [m] + + logical, intent(in) :: & + l_below ! True if z_interp < z_vals(k), false otherwise + + ! Output Variable + real( kind = core_rknd ) :: & + var_value ! Interpolated value of variable [units vary] + + ! Local Variables + integer :: km1, k00, kp1, kp2 ! Parameters for call to mono_cubic_interp + !---------------------------------------------------------------------- + + !----- Begin Code ----- + if ( l_below ) then + + if ( k == 1 ) then ! Extrapolation + km1 = nz + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == 2 ) then + km1 = 1 + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == nz ) then + km1 = nz-2 + k00 = nz-1 + kp1 = nz + kp2 = nz + else + km1 = k-2 + k00 = k-1 + kp1 = k + kp2 = k+1 + end if ! k == 1 + + else ! .not. l_below + + if ( k == 1 ) then + km1 = 1 + k00 = 1 + kp1 = 2 + kp2 = 3 + else if ( k == nz-1 ) then + km1 = nz-2 + k00 = nz-1 + kp1 = nz + kp2 = nz + else if ( k == nz ) then ! Extrapolation + km1 = nz + k00 = nz-1 + kp1 = nz + kp2 = nz + else + km1 = k-1 + k00 = k + kp1 = k+1 + kp2 = k+2 + end if ! k == 1 + + end if ! l_below + + ! Now perform the interpolation + var_value = mono_cubic_interp( z_interp, km1, k00, kp1, kp2, & + z_vals(km1), z_vals(k00), z_vals(kp1), z_vals(kp2), & + var(km1), var(k00), var(kp1), var(kp2) ) + + return + + end function var_subgrid_interp + + !============================================================================= + pure function max_cubic_root( a_coef, b_coef, c_coef, d_coef ) & + result( max_root ) + + ! Description: + ! Calculates the largest root that results from solving a cubic equation of + ! the form a*x^3 + b*x^2 + c*x + d = 0. + ! + ! This is done to backsolve for m^2 for the 3-D Luhar closure, given the + ! values of mixt_frac and Skx. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant(s) + + use calc_roots, only: & + cubic_solve, & ! Procedure(s) + quadratic_solve + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + a_coef, & ! Coefficient a (of x^3) in a*x^3 + b*x^2 + c^x + d = 0 [-] + b_coef, & ! Coefficient b (of x^2) in a*x^3 + b*x^2 + c^x + d = 0 [-] + c_coef, & ! Coefficient c (of x) in a*x^3 + b*x^2 + c^x + d = 0 [-] + d_coef ! Coefficient d in a*x^3 + b*x^2 + c^x + d = 0 [-] + + ! Return Variable + real( kind = core_rknd ) :: & + max_root ! Maximum root that solves the cubic equation [-] + + ! Local Variables + complex( kind = core_rknd ), dimension(3) :: & + cubic_roots ! Roots of x that satisfy a*x^3 + b*x^2 + c*x + d = 0 [-] + + complex( kind = core_rknd ), dimension(2) :: & + quadratic_roots ! Roots of x that satisfy b*x^2 + c*x + d = 0 [-] + + real( kind = core_rknd ) :: & + a_coef_thresh, & ! Minimum threshold of |a| to use cubic solver [-] + b_coef_thresh ! Minimum threshold of |b| to use quadratic solver [-] + + + ! Calculate a minimum threshold for |a| to call this a cubic equation. + a_coef_thresh = 0.001_core_rknd & + * max( abs(b_coef), abs(c_coef), abs(d_coef) ) + + ! Calculate a minimum threshold for |b| to call this a quadratic equation. + ! This only matters when |a| <= a_coef_thresh. + b_coef_thresh = 0.001_core_rknd * max( abs(c_coef), abs(d_coef) ) + + if ( abs( a_coef ) > a_coef_thresh ) then + + ! The equation is a cubic equation. + cubic_roots = cubic_solve( a_coef, b_coef, c_coef, d_coef ) + + if ( aimag( cubic_roots(2) ) == zero & + .and. aimag( cubic_roots(3) ) == zero ) then + + ! Find the maximum root of the three roots. + max_root = max( real( cubic_roots(1), kind = core_rknd ), & + real( cubic_roots(2), kind = core_rknd ), & + real( cubic_roots(3), kind = core_rknd ) ) + + else ! cubic_roots(2) and cubic_roots(3) are complex. + + max_root = real( cubic_roots(1), kind = core_rknd ) + + endif + + elseif ( abs( b_coef ) > b_coef_thresh ) then + + ! The equation is a quadratic equation, since a = 0, but b /= 0. + ! This should very rarely occur for 3-D Luhar. When it does, the result + ! will always be two real-valued roots. + quadratic_roots = quadratic_solve( b_coef, c_coef, d_coef ) + + ! Find the maximum root of the two roots. + max_root = max( real( quadratic_roots(1), kind = core_rknd ), & + real( quadratic_roots(2), kind = core_rknd ) ) + + else ! |a| = 0 and |b| = 0 + + ! The equation is a linear equation. + ! This won't happen for 3-D Luhar. + max_root = - d_coef / c_coef + + endif ! |a| > 0 + + + return + + end function max_cubic_root + +!=============================================================================== + +end module pdf_closure_module diff --git a/src/physics/clubb/pdf_parameter_module.F90 b/src/physics/clubb/pdf_parameter_module.F90 new file mode 100644 index 0000000000..85b9d3d086 --- /dev/null +++ b/src/physics/clubb/pdf_parameter_module.F90 @@ -0,0 +1,305 @@ +!----------------------------------------------------------------------- +! $Id: pdf_parameter_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module pdf_parameter_module +! Description: +! This module defines the derived type pdf_parameter. +! References: +! None +!------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd + + implicit none + + private ! Default scope + + public :: pdf_parameter + + type pdf_parameter + + real( kind = core_rknd ) :: & + w_1, & ! Mean of w (1st PDF component) [m/s] + w_2, & ! Mean of w (2nd PDF component) [m/s] + varnce_w_1, & ! Variance of w (1st PDF component) [m^2/s^2] + varnce_w_2, & ! Variance of w (2nd PDF component) [m^2/s^2] + rt_1, & ! Mean of r_t (1st PDF component) [kg/kg] + rt_2, & ! Mean of r_t (2nd PDF component) [kg/kg] + varnce_rt_1, & ! Variance of r_t (1st PDF component) [kg^2/kg^2] + varnce_rt_2, & ! Variance of r_t (2nd PDF component) [kg^2/kg^2] + thl_1, & ! Mean of th_l (1st PDF component) [K] + thl_2, & ! Mean of th_l (2nd PDF component) [K] + varnce_thl_1, & ! Variance of th_l (1st PDF component) [K^2] + varnce_thl_2, & ! Variance of th_l (2nd PDF component) [K^2] + rrtthl, & ! Correlation of r_t and th_l (both components) [-] + alpha_thl, & ! Factor relating to normalized variance for th_l [-] + alpha_rt, & ! Factor relating to normalized variance for r_t [-] + crt_1, & ! r_t coef. in chi/eta eqns. (1st PDF comp.) [-] + crt_2, & ! r_t coef. in chi/eta eqns. (2nd PDF comp.) [-] + cthl_1, & ! th_l coef.: chi/eta eqns. (1st PDF comp.) [(kg/kg)/K] + cthl_2, & ! th_l coef.: chi/eta eqns. (2nd PDF comp.) [(kg/kg)/K] + chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + stdev_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + stdev_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + stdev_eta_1, & ! Standard dev. of eta (old t) (1st PDF comp.) [kg/kg] + stdev_eta_2, & ! Standard dev. of eta (old t) (2nd PDF comp.) [kg/kg] + covar_chi_eta_1, & ! Covariance of chi and eta (1st PDF comp.) [kg^2/kg^2] + covar_chi_eta_2, & ! Covariance of chi and eta (2nd PDF comp.) [kg^2/kg^2] + corr_chi_eta_1, & ! Correlation of chi and eta (1st PDF component) [-] + corr_chi_eta_2, & ! Correlation of chi and eta (2nd PDF component) [-] + rsatl_1, & ! Saturation mixing ratio r_sat(mu_Tl_1,p) [kg/kg] + rsatl_2, & ! Saturation mixing ratio r_sat(mu_Tl_2,p) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Weight of 1st PDF component (Sk_w dependent) [-] + + real( kind = core_rknd ) :: & + ice_supersat_frac_1, & ! Ice supersaturation fraction (1st PDF comp.) [-] + ice_supersat_frac_2 ! Ice supersaturation fraction (2nd PDF comp.) [-] + + end type pdf_parameter + +#ifdef CLUBB_CAM /* Code for storing pdf_parameter structs in pbuf as array */ + + public :: pack_pdf_params, unpack_pdf_params + + integer, public, parameter :: num_pdf_params = 38 + + !------- + contains + !------- + + subroutine pack_pdf_params(pdf_params, nz, r_param_array) + implicit none + ! Input a pdf_parameter array with nz instances of pdf_parameter + integer, intent(in) :: nz ! Num Vert Model Levs + type (pdf_parameter), dimension(nz), intent(in) :: pdf_params + + ! Output a two dimensional real array with all values + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(out) :: & + r_param_array + + ! Local Loop vars + integer :: k, p + + do k = 1,nz + do p = 1,num_pdf_params + + r_param_array(k,p) = get_param_at_ind(pdf_params(k), p) + + end do ! p + end do ! k + + end subroutine pack_pdf_params + + subroutine unpack_pdf_params(r_param_array, nz, pdf_params) + implicit none + ! Input a two dimensional real array with pdf values + integer, intent(in) :: nz ! Num Vert Model Levs + real (kind = core_rknd), dimension(nz,num_pdf_params), intent(in) :: & + r_param_array + + ! Output a pdf_parameter array with nz instances of pdf_parameter + type (pdf_parameter), dimension(nz), intent(out) :: pdf_params + + ! Local Loop vars + integer :: k, p + ! temp var + real (kind = core_rknd) :: value + + do k = 1,nz + do p = 1,num_pdf_params + + value = r_param_array(k,p) + call set_param_at_ind(pdf_params(k), p, value) + + end do ! p + end do ! k + + end subroutine unpack_pdf_params + + real( kind = core_rknd ) function get_param_at_ind(pp_struct, ind) + implicit none + type (pdf_parameter), intent(in) :: pp_struct + integer, intent(in) :: ind + + SELECT CASE (ind) + CASE (1) + get_param_at_ind = pp_struct%w_1 + CASE (2) + get_param_at_ind = pp_struct%w_2 + CASE (3) + get_param_at_ind = pp_struct%varnce_w_1 + CASE (4) + get_param_at_ind = pp_struct%varnce_w_2 + CASE (5) + get_param_at_ind = pp_struct%rt_1 + CASE (6) + get_param_at_ind = pp_struct%rt_2 + CASE (7) + get_param_at_ind = pp_struct%varnce_rt_1 + CASE (8) + get_param_at_ind = pp_struct%varnce_rt_2 + CASE (9) + get_param_at_ind = pp_struct%thl_1 + CASE (10) + get_param_at_ind = pp_struct%thl_2 + CASE (11) + get_param_at_ind = pp_struct%varnce_thl_1 + CASE (12) + get_param_at_ind = pp_struct%varnce_thl_2 + CASE (13) + get_param_at_ind = pp_struct%rrtthl + CASE (14) + get_param_at_ind = pp_struct%alpha_thl + CASE (15) + get_param_at_ind = pp_struct%alpha_rt + CASE (16) + get_param_at_ind = pp_struct%crt_1 + CASE (17) + get_param_at_ind = pp_struct%crt_2 + CASE (18) + get_param_at_ind = pp_struct%cthl_1 + CASE (19) + get_param_at_ind = pp_struct%cthl_2 + CASE (20) + get_param_at_ind = pp_struct%chi_1 + CASE (21) + get_param_at_ind = pp_struct%chi_2 + CASE (22) + get_param_at_ind = pp_struct%stdev_chi_1 + CASE (23) + get_param_at_ind = pp_struct%stdev_chi_2 + CASE (24) + get_param_at_ind = pp_struct%stdev_eta_1 + CASE (25) + get_param_at_ind = pp_struct%stdev_eta_2 + CASE (26) + get_param_at_ind = pp_struct%covar_chi_eta_1 + CASE (27) + get_param_at_ind = pp_struct%covar_chi_eta_2 + CASE (28) + get_param_at_ind = pp_struct%corr_chi_eta_1 + CASE (29) + get_param_at_ind = pp_struct%corr_chi_eta_2 + CASE (30) + get_param_at_ind = pp_struct%rsatl_1 + CASE (31) + get_param_at_ind = pp_struct%rsatl_2 + CASE (32) + get_param_at_ind = pp_struct%rc_1 + CASE (33) + get_param_at_ind = pp_struct%rc_2 + CASE (34) + get_param_at_ind = pp_struct%cloud_frac_1 + CASE (35) + get_param_at_ind = pp_struct%cloud_frac_2 + CASE (36) + get_param_at_ind = pp_struct%mixt_frac + CASE (37) + get_param_at_ind = pp_struct%ice_supersat_frac_1 + CASE (38) + get_param_at_ind = pp_struct%ice_supersat_frac_2 + CASE DEFAULT + stop "Invalid index in get_param_at_ind" + END SELECT + + RETURN + end function get_param_at_ind + + subroutine set_param_at_ind(pp_struct, ind, val) + implicit none + type (pdf_parameter), intent(inout) :: pp_struct + integer, intent(in) :: ind + real (kind = core_rknd), intent(in) :: val + + SELECT CASE (ind) + CASE (1) + pp_struct%w_1 = val + CASE (2) + pp_struct%w_2 = val + CASE (3) + pp_struct%varnce_w_1 = val + CASE (4) + pp_struct%varnce_w_2 = val + CASE (5) + pp_struct%rt_1 = val + CASE (6) + pp_struct%rt_2 = val + CASE (7) + pp_struct%varnce_rt_1 = val + CASE (8) + pp_struct%varnce_rt_2 = val + CASE (9) + pp_struct%thl_1 = val + CASE (10) + pp_struct%thl_2 = val + CASE (11) + pp_struct%varnce_thl_1 = val + CASE (12) + pp_struct%varnce_thl_2 = val + CASE (13) + pp_struct%rrtthl = val + CASE (14) + pp_struct%alpha_thl = val + CASE (15) + pp_struct%alpha_rt = val + CASE (16) + pp_struct%crt_1 = val + CASE (17) + pp_struct%crt_2 = val + CASE (18) + pp_struct%cthl_1 = val + CASE (19) + pp_struct%cthl_2 = val + CASE (20) + pp_struct%chi_1 = val + CASE (21) + pp_struct%chi_2 = val + CASE (22) + pp_struct%stdev_chi_1 = val + CASE (23) + pp_struct%stdev_chi_2 = val + CASE (24) + pp_struct%stdev_eta_1 = val + CASE (25) + pp_struct%stdev_eta_2 = val + CASE (26) + pp_struct%covar_chi_eta_1 = val + CASE (27) + pp_struct%covar_chi_eta_2 = val + CASE (28) + pp_struct%corr_chi_eta_1 = val + CASE (29) + pp_struct%corr_chi_eta_2 = val + CASE (30) + pp_struct%rsatl_1 = val + CASE (31) + pp_struct%rsatl_2 = val + CASE (32) + pp_struct%rc_1 = val + CASE (33) + pp_struct%rc_2 = val + CASE (34) + pp_struct%cloud_frac_1 = val + CASE (35) + pp_struct%cloud_frac_2 = val + CASE (36) + pp_struct%mixt_frac = val + CASE (37) + pp_struct%ice_supersat_frac_1 = val + CASE (38) + pp_struct%ice_supersat_frac_2 = val + CASE DEFAULT + ! do nothing ! + END SELECT + + end subroutine set_param_at_ind + +#endif + +end module pdf_parameter_module diff --git a/src/physics/clubb/pdf_utilities.F90 b/src/physics/clubb/pdf_utilities.F90 new file mode 100644 index 0000000000..7429e58b9e --- /dev/null +++ b/src/physics/clubb/pdf_utilities.F90 @@ -0,0 +1,1085 @@ +!------------------------------------------------------------------------- +! $Id: pdf_utilities.F90 7370 2014-11-07 20:59:58Z bmg2@uwm.edu $ +!=============================================================================== +module pdf_utilities + + implicit none + + private ! Set default scope to private + + public :: mean_L2N, & + mean_L2N_dp, & + stdev_L2N, & + stdev_L2N_dp, & + corr_NL2NN, & + corr_NL2NN_dp, & + corr_NN2NL, & + corr_LL2NN, & + corr_LL2NN_dp, & + corr_NN2LL, & + compute_mean_binormal, & + compute_variance_binormal, & + calc_corr_chi_x, & + calc_corr_rt_x, & + calc_corr_thl_x, & + calc_xp2 + + contains + + !============================================================================= + pure function mean_L2N( mu_x, sigma2_on_mu2 ) & + result( mu_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the mean of + ! ln x (mu_x_n) for the ith component of the PDF, given the mean of x (mu_x) + ! and the variance of x (sigma_sqd_x) for the ith component of the PDF. The + ! value ln x is distributed normally when x is distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x, & ! Mean of x (ith PDF component) [-] + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + mu_x_n ! Mean of ln x (ith PDF component) [-] + + + ! Find the mean of ln x for the ith component of the PDF. + mu_x_n = log( mu_x / sqrt( one + sigma2_on_mu2 ) ) + + + return + + end function mean_L2N + + !============================================================================= + pure function mean_L2N_dp( mu_x, sigma2_on_mu2 ) & + result( mu_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the mean of + ! ln x (mu_x_n) for the ith component of the PDF, given the mean of x (mu_x) + ! and the variance of x (sigma_sqd_x) for the ith component of the PDF. The + ! value ln x is distributed normally when x is distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + mu_x, & ! Mean of x (ith PDF component) [-] + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + mu_x_n ! Mean of ln x (ith PDF component) [-] + + + ! Find the mean of ln x for the ith component of the PDF. + mu_x_n = log( mu_x / sqrt( one_dp + sigma2_on_mu2 ) ) + + + return + + end function mean_L2N_dp + + !============================================================================= + pure function stdev_L2N( sigma2_on_mu2 ) & + result( sigma_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the standard + ! deviation of ln x (sigma_x_n) for the ith component of the PDF, given the + ! mean of x (mu_x) and the variance of x (sigma_sqd_x) for the ith component + ! of the PDF. The value ln x is distributed normally when x is distributed + ! lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + sigma_x_n ! Standard deviation of ln x (ith PDF component) [-] + + + ! Find the standard deviation of ln x for the ith component of the PDF. + sigma_x_n = sqrt( log( one + sigma2_on_mu2 ) ) + + + return + + end function stdev_L2N + + !============================================================================= + pure function stdev_L2N_dp( sigma2_on_mu2 ) & + result( sigma_x_n ) + + ! Description: + ! For a lognormally-distributed variable x, this function finds the standard + ! deviation of ln x (sigma_x_n) for the ith component of the PDF, given the + ! mean of x (mu_x) and the variance of x (sigma_sqd_x) for the ith component + ! of the PDF. The value ln x is distributed normally when x is distributed + ! lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- App. B. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp ! Constant(s) + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + sigma2_on_mu2 ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + sigma_x_n ! Standard deviation of ln x (ith PDF component) [-] + + + ! Find the standard deviation of ln x for the ith component of the PDF. + sigma_x_n = sqrt( log( one_dp + sigma2_on_mu2 ) ) + + + return + + end function stdev_L2N_dp + + !============================================================================= + pure function corr_NL2NN( corr_x_y, sigma_y_n, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For a normally-distributed variable x and a lognormally-distributed + ! variable y, this function finds the correlation of x and ln y (corr_x_y_n) + ! for the ith component of the PDF, given the correlation of x and y + ! (corr_x_y) and the standard deviation of ln y (sigma_y_n) for the ith + ! component of the PDF. The value ln y is distributed normally when y is + ! distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. B-1. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y_n ! Correlation of x and ln y (ith PDF component) [-] + + + ! Find the correlation of x and ln y for the ith component of the PDF. + ! When sigma_y = 0 and mu_y > 0, y_sigma2_on_mu2 = 0. This results in + ! sigma_y_n = 0. The resulting corr_x_y_n is undefined. However, the + ! divide-by-zero problem needs to be addressed in the code. + if ( sigma_y_n > zero ) then + corr_x_y_n = corr_x_y * sqrt( y_sigma2_on_mu2 ) / sigma_y_n + else ! sigma_y_n = 0 + ! The value of sqrt( y_sigma2_on_mu2 ) / sigma_y_n can be rewritten as: + ! sqrt( y_sigma2_on_mu2 ) / sqrt( ln( 1 + y_sigma2_on_mu2 ) ). + ! This can be further rewritten as: + ! sqrt( y_sigma2_on_mu2 / ln( 1 + y_sigma2_on_mu2 ) ), + ! which has a limit of 1 as y_sigma2_on_mu2 approaches 0 from the right. + ! When sigma_y_n = 0, the value of corr_x_y_n is undefined, so set it + ! to corr_x_y. + corr_x_y_n = corr_x_y + endif ! sigma_y_n > 0 + + ! Clip the magnitude of the correlation of x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y and + ! the standard deviation (ith PDF component) of ln y are inconsistent, + ! resulting in an unrealizable value for corr_x_y_n. + if ( corr_x_y_n > max_mag_correlation ) then + corr_x_y_n = max_mag_correlation + elseif ( corr_x_y_n < -max_mag_correlation ) then + corr_x_y_n = -max_mag_correlation + endif + + + return + + end function corr_NL2NN + + !============================================================================= + pure function corr_NL2NN_dp( corr_x_y, sigma_y_n, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For a normally-distributed variable x and a lognormally-distributed + ! variable y, this function finds the correlation of x and ln y (corr_x_y_n) + ! for the ith component of the PDF, given the correlation of x and y + ! (corr_x_y) and the standard deviation of ln y (sigma_y_n) for the ith + ! component of the PDF. The value ln y is distributed normally when y is + ! distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. B-1. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation, & ! Constant(s) + zero_dp + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = dp ) :: & + corr_x_y_n ! Correlation of x and ln y (ith PDF component) [-] + + + ! Find the correlation of x and ln y for the ith component of the PDF. + ! When sigma_y = 0 and mu_y > 0, y_sigma2_on_mu2 = 0. This results in + ! sigma_y_n = 0. The resulting corr_x_y_n is undefined. However, the + ! divide-by-zero problem needs to be addressed in the code. + if ( sigma_y_n > zero_dp ) then + corr_x_y_n = corr_x_y * sqrt( y_sigma2_on_mu2 ) / sigma_y_n + else ! sigma_y_n = 0 + ! The value of sqrt( y_sigma2_on_mu2 ) / sigma_y_n can be rewritten as: + ! sqrt( y_sigma2_on_mu2 ) / sqrt( ln( 1 + y_sigma2_on_mu2 ) ). + ! This can be further rewritten as: + ! sqrt( y_sigma2_on_mu2 / ln( 1 + y_sigma2_on_mu2 ) ), + ! which has a limit of 1 as y_sigma2_on_mu2 approaches 0 from the right. + ! When sigma_y_n = 0, the value of corr_x_y_n is undefined, so set it + ! to corr_x_y. + corr_x_y_n = corr_x_y + endif ! sigma_y_n > 0 + + ! Clip the magnitude of the correlation of x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y and + ! the standard deviation (ith PDF component) of ln y are inconsistent, + ! resulting in an unrealizable value for corr_x_y_n. + if ( corr_x_y_n > real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = real( max_mag_correlation, kind = dp ) + elseif ( corr_x_y_n < -real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = -real( max_mag_correlation, kind = dp ) + endif + + + return + + end function corr_NL2NN_dp + + !============================================================================= + pure function corr_NN2NL( corr_x_y_n, sigma_y_n, y_sigma2_on_mu2 ) & + result( corr_x_y ) + + ! Description: + ! For a normally-distributed variable x and a lognormally-distributed + ! variable y, this function finds the correlation of x and y (corr_x_y) for + ! the ith component of the PDF, given the correlation of x and ln y + ! (corr_x_y_n) and the standard deviation of ln y (sigma_y_n) for the ith + ! component of the PDF. The value ln y is distributed normally when y is + ! distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. B-1. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + max_mag_correlation, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y_n, & ! Correlation of x and ln y (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y ! Correlation of x and y (ith PDF component) [-] + + + ! Find the correlation of x and y for the ith component of the PDF. + ! When sigma_y = 0 and mu_y > 0, y_sigma2_on_mu2 = 0. This results in + ! sigma_y_n = 0. The resulting corr_x_y and corr_x_y_n are undefined. + ! However, the divide-by-zero problem needs to be addressed in the code. + if ( sigma_y_n > zero ) then + corr_x_y = corr_x_y_n * sigma_y_n / sqrt( y_sigma2_on_mu2 ) + else ! sigma_y_n = 0 + ! The value of sigma_y_n / sqrt( y_sigma2_on_mu2 ) can be rewritten as: + ! sqrt( ln( 1 + y_sigma2_on_mu2 ) ) / sqrt( y_sigma2_on_mu2 ). + ! This can be further rewritten as: + ! sqrt( ln( 1 + y_sigma2_on_mu2 ) / y_sigma2_on_mu2 ), + ! which has a limit of 1 as y_sigma2_on_mu2 approaches 0 from the right. + ! When sigma_y_n = 0, the value of corr_x_y is undefined, so set it + ! to corr_x_y_n. + corr_x_y = corr_x_y_n + endif ! sigma_y_n > 0 + + ! Clip the magnitude of the correlation of x and y in the ith PDF component, + ! just in case the correlation (ith PDF component) of x and ln y and the + ! standard deviation (ith PDF component) of ln y are inconsistent, resulting + ! in an unrealizable value for corr_x_y. + if ( corr_x_y > max_mag_correlation ) then + corr_x_y = max_mag_correlation + elseif ( corr_x_y < -max_mag_correlation ) then + corr_x_y = -max_mag_correlation + endif + + + return + + end function corr_NN2NL + + !============================================================================= + pure function corr_LL2NN( corr_x_y, sigma_x_n, sigma_y_n, & + x_sigma2_on_mu2, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For lognormally-distributed variables x and y, this function finds the + ! correlation of ln x and ln y (corr_x_y_n) for the ith component of the + ! PDF, given the correlation of x and y (corr_x_y), the standard deviation + ! of ln x (sigma_x_n), and the standard deviation of ln y (sigma_y_n) for + ! the ith component of the PDF. The value of ln x (or ln y) is distributed + ! normally when x (or y) is distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. C-3. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_x_n, & ! Standard deviation of ln x (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + x_sigma2_on_mu2, & ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y_n ! Correlation of ln x and ln y (ith PDF component) [-] + + ! Local Variable + real( kind = core_rknd ) :: & + log_arg ! Input into the ln function [-] + + + ! Find the correlation of ln x and ln y for the ith component of the PDF. + ! When sigma_x = 0 and mu_x > 0, x_sigma2_on_mu2 = 0. This results in + ! sigma_x_n = 0. The resulting corr_x_y_n is undefined. The same holds + ! true when sigma_y = 0 and mu_y > 0. However, the divide-by-zero problem + ! needs to be addressed in the code. + if ( sigma_x_n > zero .and. sigma_y_n > zero ) then +! corr_x_y_n = log( one + corr_x_y * sqrt( exp( sigma_x_n**2 ) - one ) & +! * sqrt( exp( sigma_y_n**2 ) - one ) ) & +! / ( sigma_x_n * sigma_y_n ) + log_arg = one + corr_x_y * sqrt( x_sigma2_on_mu2 * y_sigma2_on_mu2 ) + corr_x_y_n = log( log_arg ) / ( sigma_x_n * sigma_y_n ) + else ! sigma_x_n = 0 or sigma_y_n = 0 + ! The value of corr_x_y_n is undefined, so set it to corr_x_y. + corr_x_y_n = corr_x_y + endif ! sigma_x_n > 0 and sigma_y_n > 0 + + ! Clip the magnitude of the correlation of ln x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y, + ! the standard deviation (ith PDF component) of ln x, and the standard + ! deviation (ith PDF component) of ln y are inconsistent, resulting in an + ! unrealizable value for corr_x_y_n. + if ( corr_x_y_n > max_mag_correlation ) then + corr_x_y_n = max_mag_correlation + elseif ( corr_x_y_n < -max_mag_correlation ) then + corr_x_y_n = -max_mag_correlation + endif + + + return + + end function corr_LL2NN + + !============================================================================= + pure function corr_LL2NN_dp( corr_x_y, sigma_x_n, sigma_y_n, & + x_sigma2_on_mu2, y_sigma2_on_mu2 ) & + result( corr_x_y_n ) + + ! Description: + ! For lognormally-distributed variables x and y, this function finds the + ! correlation of ln x and ln y (corr_x_y_n) for the ith component of the + ! PDF, given the correlation of x and y (corr_x_y), the standard deviation + ! of ln x (sigma_x_n), and the standard deviation of ln y (sigma_y_n) for + ! the ith component of the PDF. The value of ln x (or ln y) is distributed + ! normally when x (or y) is distributed lognormally. + ! This function uses double precision variables. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. C-3. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one_dp, & ! Constant(s) + zero_dp, & + max_mag_correlation + + use clubb_precision, only: & + dp ! double precision + + implicit none + + ! Input Variables + real( kind = dp ), intent(in) :: & + corr_x_y, & ! Correlation of x and y (ith PDF component) [-] + sigma_x_n, & ! Standard deviation of ln x (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + x_sigma2_on_mu2, & ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + + ! Return Variable + real( kind = dp ) :: & + corr_x_y_n ! Correlation of ln x and ln y (ith PDF component) [-] + + + ! Find the correlation of ln x and ln y for the ith component of the PDF. + ! When sigma_x = 0 and mu_x > 0, x_sigma2_on_mu2 = 0. This results in + ! sigma_x_n = 0. The resulting corr_x_y_n is undefined. The same holds + ! true when sigma_y = 0 and mu_y > 0. However, the divide-by-zero problem + ! needs to be addressed in the code. + if ( sigma_x_n > zero_dp .and. sigma_y_n > zero_dp ) then + corr_x_y_n & + = log( one_dp + corr_x_y * sqrt( x_sigma2_on_mu2 * y_sigma2_on_mu2 ) ) & + / ( sigma_x_n * sigma_y_n ) + else ! sigma_x_n = 0 or sigma_y_n = 0 + ! The value of corr_x_y_n is undefined, so set it to corr_x_y. + corr_x_y_n = corr_x_y + endif ! sigma_x_n > 0 and sigma_y_n > 0 + + ! Clip the magnitude of the correlation of ln x and ln y in the ith PDF + ! component, just in case the correlation (ith PDF component) of x and y, + ! the standard deviation (ith PDF component) of ln x, and the standard + ! deviation (ith PDF component) of ln y are inconsistent, resulting in an + ! unrealizable value for corr_x_y_n. + if ( corr_x_y_n > real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = real( max_mag_correlation, kind = dp ) + elseif ( corr_x_y_n < -real( max_mag_correlation, kind = dp ) ) then + corr_x_y_n = -real( max_mag_correlation, kind = dp ) + endif + + + return + + end function corr_LL2NN_dp + + !============================================================================= + pure function corr_NN2LL( corr_x_y_n, sigma_x_n, sigma_y_n, & + x_sigma2_on_mu2, y_sigma2_on_mu2 ) & + result( corr_x_y ) + + ! Description: + ! For lognormally-distributed variables x and y, this function finds the + ! correlation of x and y (corr_x_y) for the ith component of the PDF, given + ! the correlation of ln x and ln y (corr_x_y_n), the standard deviation of + ! ln x (sigma_x_n), and the standard deviation of ln y (sigma_y_n) for + ! the ith component of the PDF. The value of ln x (or ln y) is distributed + ! normally when x (or y) is distributed lognormally. + + ! References: + ! Garvey, P. R., 2000: Probability methods for cost uncertainty analysis. + ! Marcel Dekker, 401 pp. + ! -- Eq. C-3. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_x_y_n, & ! Correlation of ln x and ln y (ith PDF component) [-] + sigma_x_n, & ! Standard deviation of ln x (ith PDF component) [-] + sigma_y_n, & ! Standard deviation of ln y (ith PDF component) [-] + x_sigma2_on_mu2, & ! Ratio: sigma_x^2 / mu_x^2 (ith PDF component) [-] + y_sigma2_on_mu2 ! Ratio: sigma_y^2 / mu_y^2 (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_y ! Correlation of x and y (ith PDF component) [-] + + + ! Find the correlation of x and y for the ith component of the PDF. + ! When sigma_x = 0 and mu_x > 0, x_sigma2_on_mu2 = 0. This results in + ! sigma_x_n = 0. The resulting corr_x_y and corr_x_y_n are undefined. The + ! same holds true when sigma_y = 0 and mu_y > 0. However, the + ! divide-by-zero problem needs to be addressed in the code. + if ( sigma_x_n > zero .and. sigma_y_n > zero ) then +! corr_x_y = ( exp( sigma_x_n * sigma_y_n * corr_x_y_n ) - one ) & +! / ( sqrt( exp( sigma_x_n**2 ) - one ) & +! * sqrt( exp( sigma_y_n**2 ) - one ) ) + corr_x_y = ( exp( sigma_x_n * sigma_y_n * corr_x_y_n ) - one ) & + / sqrt( x_sigma2_on_mu2 * y_sigma2_on_mu2 ) + else ! sigma_x_n = 0 or sigma_y_n = 0 + ! The value of corr_x_y is undefined, so set it to corr_x_y_n. + corr_x_y = corr_x_y_n + endif ! sigma_x_n > 0 and sigma_y_n > 0 + + ! Clip the magnitude of the correlation of x and y in the ith PDF component, + ! just in case the correlation (ith PDF component) of ln x and ln y, the + ! standard deviation (ith PDF component) of ln x, and the standard deviation + ! (ith PDF component) of ln y are inconsistent, resulting in an unrealizable + ! value for corr_x_y. + if ( corr_x_y > max_mag_correlation ) then + corr_x_y = max_mag_correlation + elseif ( corr_x_y < -max_mag_correlation ) then + corr_x_y = -max_mag_correlation + endif + + + return + + end function corr_NN2LL + + !============================================================================= + elemental function compute_mean_binormal( mu_x_1, mu_x_2, mixt_frac ) & + result( xm ) + + ! Description: + ! Computes the overall grid-box mean of a binormal distribution from the + ! mean of each component + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use constants_clubb, only: & + one ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x_1, & ! First PDF component mean of 'x' [?] + mu_x_2, & ! Second PDF component mean of 'x' [?] + mixt_frac ! Weight of the first PDF component [-] + + ! Output Variables + real( kind = core_rknd ) :: & + xm ! Mean of 'x' (overall) [?] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + xm = mixt_frac * mu_x_1 + ( one - mixt_frac ) * mu_x_2 + + + return + + end function compute_mean_binormal + + !============================================================================= + elemental function compute_variance_binormal( xm, mu_x_1, mu_x_2, & + stdev_x_1, stdev_x_2, & + mixt_frac ) & + result( xp2 ) + + ! Description: + ! Computes the overall grid-box variance of a binormal distribution from the + ! variance of each component. + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use constants_clubb, only: & + one ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + xm, & ! Overall mean of 'x' [?] + mu_x_1, & ! First PDF component mean of 'x' [?] + mu_x_2, & ! Second PDF component mean of 'x' [?] + stdev_x_1, & ! Standard deviation of 'x' in the first PDF component [?] + stdev_x_2, & ! Standard deviation of 'x' in the second PDF component [?] + mixt_frac ! Weight of the first PDF component [-] + + ! Output Variables + real( kind = core_rknd ) :: & + xp2 ! Variance of 'x' (overall) [?^2] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + xp2 = mixt_frac * ( ( mu_x_1 - xm )**2 + stdev_x_1**2 ) & + + ( one - mixt_frac ) * ( ( mu_x_2 - xm )**2 + stdev_x_2**2 ) + + + return + + end function compute_variance_binormal + + !============================================================================= + pure function calc_corr_chi_x( crt_i, cthl_i, sigma_rt_i, sigma_thl_i, & + sigma_chi_i, corr_rt_x_i, corr_thl_x_i ) & + result( corr_chi_x_i ) + + ! Description: + ! This function calculates the correlation of extended liquid water mixing + ! ratio, chi (old s), and a generic variable x, within the ith component of + ! the PDF. The variable chi can be split into mean and turbulent + ! components, such that: + ! + ! chi = + chi'; + ! + ! where < > denotes a mean field an ' denotes a turbulent component. + ! + ! The linearized equation for chi' is given in Larson et al. (2001), where + ! within the ith component of the PDF: + ! + ! chi_(i)' = Coef_rt(i) * r_t(i)' - Coef_thl(i) * th_l(i)'. + ! + ! The equation for chi' can be multiplied by x'. The equation becomes: + ! + ! chi'x'_(i) = Coef_rt(i) * r_t'x'_(i) - Coef_thl(i) * th_l'x'_(i). + ! + ! Averaging both sides, the covariance is given by the equation: + ! + ! = Coef_rt(i) * - Coef_thl(i) * . + ! + ! This equation can be rewritten as: + ! + ! sigma_chi(i) * sigma_x(i) * corr_chi_x(i) + ! = Coef_rt(i) * sigma_rt(i) * sigma_x(i) * corr_rt_x(i) + ! - Coef_thl(i) * sigma_thl(i) * sigma_x(i) * corr_thl_x(i). + ! + ! This equation can be solved for corr_chi_x(i): + ! + ! corr_chi_x(i) + ! = Coef_rt(i) * ( sigma_rt(i) / sigma_chi(i) ) * corr_rt_x(i) + ! - Coef_thl(i) * ( sigma_thl(i) / sigma_chi(i) ) * corr_thl_x(i). + ! + ! The correlation of chi and x within the ith component of the PDF is + ! calculated. + + ! References: + ! Larson, V. E., R. Wood, P. R. Field, J.-C. Golaz, T. H. Vonder Haar, + ! W. R. Cotton, 2001: Systematic Biases in the Microphysics and + ! Thermodynamics of Numerical Models That Ignore Subgrid-Scale + ! Variability. J. Atmos. Sci., 58, 1117--1128. + ! -- Eq. 13 and 14. + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero, & ! Constant(s) + chi_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + crt_i, & ! Coefficient of r_t for chi (old s) (ith PDF comp.) [-] + cthl_i, & ! Coefficient of th_l for chi (ith PDF comp.) [(kg/kg)/K] + sigma_rt_i, & ! Standard deviation of r_t (ith PDF component) [kg/kg] + sigma_thl_i, & ! Standard deviation of th_l (ith PDF component) [K] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + corr_rt_x_i, & ! Correlation of r_t and x (ith PDF component) [-] + corr_thl_x_i ! Correlation of th_l and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_chi_x_i ! Correlation of chi and x (ith PDF component) [-] + + + ! Calculate the correlation of chi and x in the ith PDF component. + if ( sigma_chi_i > chi_tol ) then + + corr_chi_x_i = crt_i * ( sigma_rt_i / sigma_chi_i ) * corr_rt_x_i & + - cthl_i * ( sigma_thl_i / sigma_chi_i ) * corr_thl_x_i + + else ! sigma_chi_i = 0 + + ! The standard deviation of chi in the ith PDF component is 0. This + ! means that chi is constant within the ith PDF component, and the ith + ! PDF component covariance of chi and x is also 0. The correlation of + ! chi and x is undefined in the ith PDF component, so a value of 0 will + ! be used. + corr_chi_x_i = zero + + endif + + ! Clip the magnitude of the correlation of chi and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_chi_x_i. + if ( corr_chi_x_i > max_mag_correlation ) then + corr_chi_x_i = max_mag_correlation + elseif ( corr_chi_x_i < -max_mag_correlation ) then + corr_chi_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_chi_x + + !============================================================================= + pure function calc_corr_rt_x( crt_i, sigma_rt_i, sigma_chi_i, & + sigma_eta_i, corr_chi_x_i, corr_eta_x_i ) & + result( corr_rt_x_i ) + + ! Description: + ! This function calculates the correlation of rt and x based on the + ! correlation of chi and x and the correlation of eta and x. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + zero, & + rt_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + crt_i, & ! Coef. of r_t in chi/eta eqns. (ith PDF component) [-] + sigma_rt_i, & ! Standard deviation of r_t (ith PDF component) [kg/kg] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + sigma_eta_i, & ! Standard deviation of eta (ith PDF component) [kg/kg] + corr_chi_x_i, & ! Correlation of chi and x (ith PDF component) [-] + corr_eta_x_i ! Correlation of eta and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_rt_x_i ! Correlation of rt and x (ith PDF component) [-] + + + ! Calculate the correlation of rt and x in the ith PDF component. + if ( sigma_rt_i > rt_tol ) then + + corr_rt_x_i = ( sigma_eta_i * corr_eta_x_i & + + sigma_chi_i * corr_chi_x_i ) & + / ( two * crt_i * sigma_rt_i ) + + else ! sigma_rt_i = 0 + + ! The standard deviation of rt in the ith PDF component is 0. This means + ! that rt is constant within the ith PDF component, and the ith PDF + ! component covariance of rt and x is also 0. The correlation of rt and + ! x is undefined in the ith PDF component, so a value of 0 will be used. + corr_rt_x_i = zero + + endif + + ! Clip the magnitude of the correlation of rt and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_rt_x_i. + if ( corr_rt_x_i > max_mag_correlation ) then + corr_rt_x_i = max_mag_correlation + elseif ( corr_rt_x_i < -max_mag_correlation ) then + corr_rt_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_rt_x + + !============================================================================= + pure function calc_corr_thl_x( cthl_i, sigma_thl_i, sigma_chi_i, & + sigma_eta_i, corr_chi_x_i, corr_eta_x_i ) & + result( corr_thl_x_i ) + + ! Description: + ! This function calculates the correlation of thl and x based on the + ! correlation of chi and x and the correlation of eta and x. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + zero, & + thl_tol, & + max_mag_correlation + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + cthl_i, & ! Coef. of thl: chi/eta eqns. (ith PDF comp.) [(kg/kg)/K] + sigma_thl_i, & ! Standard deviation of thl (ith PDF component) [K] + sigma_chi_i, & ! Standard deviation of chi (ith PDF component) [kg/kg] + sigma_eta_i, & ! Standard deviation of eta (ith PDF component) [kg/kg] + corr_chi_x_i, & ! Correlation of chi and x (ith PDF component) [-] + corr_eta_x_i ! Correlation of eta and x (ith PDF component) [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_thl_x_i ! Correlation of thl and x (ith PDF component) [-] + + + ! Calculate the correlation of thl and x in the ith PDF component. + if ( sigma_thl_i > thl_tol ) then + + corr_thl_x_i = ( sigma_eta_i * corr_eta_x_i & + - sigma_chi_i * corr_chi_x_i ) & + / ( two * cthl_i * sigma_thl_i ) + + else ! sigma_thl_i = 0 + + ! The standard deviation of thl in the ith PDF component is 0. This + ! means that thl is constant within the ith PDF component, and the ith + ! PDF component covariance of thl and x is also 0. The correlation of + ! thl and x is undefined in the ith PDF component, so a value of 0 will + ! be used. + corr_thl_x_i = zero + + endif + + ! Clip the magnitude of the correlation of thl and x in the ith PDF + ! component, just in case the correlations and standard deviations used in + ! calculating it are inconsistent, resulting in an unrealizable value for + ! corr_thl_x_i. + if ( corr_thl_x_i > max_mag_correlation ) then + corr_thl_x_i = max_mag_correlation + elseif ( corr_thl_x_i < -max_mag_correlation ) then + corr_thl_x_i = -max_mag_correlation + endif + + + return + + end function calc_corr_thl_x + + !============================================================================= + pure function calc_xp2( mu_x_1, mu_x_2, & + mu_x_1_n, mu_x_2_n, & + sigma_x_1, sigma_x_2, & + sigma_x_1_n, sigma_x_2_n, & + mixt_frac, x_frac_1, x_frac_2, & + x_mean ) & + result( xp2 ) + + ! Description: + ! Calculates the overall variance of x, , where the distribution of x + ! is a combination of a lognormal distribution and/or 0 in each PDF + ! component. The fraction of each component where x is lognormally + ! distributed (amd greater than 0) is x_frac_i (x_frac_1 and x_frac_2 for + ! PDF components 1 and 2, respectively). The fraction of each component + ! where x has a value of 0 is ( 1 - x_frac_i ). This function should be + ! called to calculate the total variance for x when is not provided + ! by a predictive (or other) equation. + ! + ! This function is used to calculate the overall variance for rain water + ! mixing ratio, , and the overall variance for rain drop + ! concentration, . The ratio of variance to mean-value-squared is + ! specified for the in-precip values of r_r and N_r within each PDF + ! component, allowing for the calculation of sigma_rr_i and sigma_Nr_i, + ! as well as sigma_rr_i_n and sigma_Nr_i_n. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + two, & ! Constant(s) + one, & + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + mu_x_1, & ! Mean of x (1st PDF comp.) in x_frac [-] + mu_x_2, & ! Mean of x (2nd PDF comp.) in x_frac [-] + mu_x_1_n, & ! Mean of ln x (1st PDF comp.) in x_frac [-] + mu_x_2_n, & ! Mean of ln x (2nd PDF comp.) in x_frac [-] + sigma_x_1, & ! Standard deviation of x (1st PDF comp.) in x_frac [-] + sigma_x_2, & ! Standard deviation of x (2nd PDF comp.) in x_frac [-] + sigma_x_1_n, & ! Standard deviation of ln x (1st PDF comp.) in x_frac [-] + sigma_x_2_n, & ! Standard deviation of ln x (2nd PDF comp.) in x_frac [-] + mixt_frac, & ! Mixture fraction [-] + x_frac_1, & ! Fraction: x distributed lognormally (1st PDF comp.) [-] + x_frac_2, & ! Fraction: x distributed lognormally (2nd PDF comp.) [-] + x_mean ! Overall mean value of x [-] + + ! Return Variable + real( kind = core_rknd ) :: & + xp2 ! Overall variance of x [-] + + + ! Calculate overall variance of x, . + if ( sigma_x_1 == zero .and. sigma_x_2 == zero ) then + + ! The value of x is constant within both PDF components. + xp2 = ( mixt_frac * x_frac_1 * mu_x_1**2 & + + ( one - mixt_frac ) * x_frac_2 * mu_x_2**2 & + ) & + - x_mean**2 + + + elseif ( sigma_x_1 == zero ) then + + ! The value of x is constant within the 1st PDF component. + xp2 = ( mixt_frac * x_frac_1 * mu_x_1**2 & + + ( one - mixt_frac ) * x_frac_2 & + * exp( two * mu_x_2_n + two * sigma_x_2_n**2 ) & + ) & + - x_mean**2 + + + elseif ( sigma_x_2 == zero ) then + + ! The value of x is constant within the 2nd PDF component. + xp2 = ( mixt_frac * x_frac_1 & + * exp( two * mu_x_1_n + two * sigma_x_1_n**2 ) & + + ( one - mixt_frac ) * x_frac_2 * mu_x_2**2 & + ) & + - x_mean**2 + + + else ! sigma_x_1 and sigma_x_2 > 0 + + ! The value of x varies within both PDF component. + xp2 = ( mixt_frac * x_frac_1 & + * exp( two * mu_x_1_n + two * sigma_x_1_n**2 ) & + + ( one - mixt_frac ) * x_frac_2 & + * exp( two * mu_x_2_n + two * sigma_x_2_n**2 ) & + ) & + - x_mean**2 + + + endif + + + ! As a check, prevent negative values for hydrometeor variances due to + ! numerical loss of precision error. + if ( xp2 < zero ) then + xp2 = zero + endif + + + return + + end function calc_xp2 + +!=============================================================================== + +end module pdf_utilities diff --git a/src/physics/clubb/pos_definite_module.F90 b/src/physics/clubb/pos_definite_module.F90 new file mode 100644 index 0000000000..e0bffd4bce --- /dev/null +++ b/src/physics/clubb/pos_definite_module.F90 @@ -0,0 +1,221 @@ +!------------------------------------------------------------------------- +!$Id: pos_definite_module.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== +module pos_definite_module + + implicit none + + public :: pos_definite_adj + + private ! Default Scope + + contains +!----------------------------------------------------------------------- + subroutine pos_definite_adj & + ( dt, field_grid, field_np1, & + flux_np1, field_n, field_pd, flux_pd ) +! Description: +! Applies a flux conservative positive definite scheme to a variable + +! There are two possible grids: +! (1) flux on zm field on zt +! then +! flux_zt(k) = ( flux_zm(k) + flux_zm(k-1) ) / 2 + +! CLUBB grid Smolarkiewicz grid +! m +-- flux zm(k) --+ flux k + 1/2 +! t +-- field zt(k) --+ field, fout k +! m +-- flux zm(k-1) --+ flux k - 1/2 +! t +-- field zt(k-1) --+ + +! (1) flux on zt field on zm +! then +! flux_zm(k) = ( flux_zt(k) + flux_zt(k+1) ) / 2 + +! CLUBB grid Smolarkiewicz grid +! m +-- field (k+1) --+ +! t +-- flux (k+1) --+ flux k + 1/2 +! m +-- field (k) --+ field, fout k +! t +-- flux (k) --+ flux k - 1/2 + + +! References: +! ``A Positive Definite Advection Scheme Obtained by +! Nonlinear Renormalization of the Advective Fluxes'' Smolarkiewicz (1989) +! Monthly Weather Review, Vol. 117, pp. 2626--2632 +!----------------------------------------------------------------------- + + use grid_class, only: & + gr, & ! Variable(s) + ddzt, & ! Function + ddzm ! Function + + use constants_clubb, only : & + eps, & ! Variable(s) + zero_threshold + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use error_code, only: & + clubb_at_least_debug_level + + implicit none + + ! External + intrinsic :: eoshift, kind, any, min, max + + ! Input variables + real( kind = core_rknd ), intent(in) :: & + dt ! Timestep [s] + + character(len=2), intent(in) :: & + field_grid ! The grid of the field, either zt or zm + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + field_n ! The field (e.g. rtm) at n, prior to n+1 + + real( kind = core_rknd ), dimension(gr%nz), intent(out) :: & + flux_pd, & ! Budget of the change in the flux term due to the scheme + field_pd ! Budget of the change in the mean term due to the scheme + + ! Output Variables + + real( kind = core_rknd ), intent(inout), dimension(gr%nz) :: & + field_np1, & ! Field at n+1 (e.g. rtm in [kg/kg]) + flux_np1 ! Flux applied to field + + ! Local Variables + integer :: & + kabove, & ! # of vertical levels the flux higher point resides + kbelow ! # of vertical levels the flux lower point resides + + integer :: & + k, kmhalf, kp1, kphalf ! Loop indices + + real( kind = core_rknd ), dimension(gr%nz) :: & + flux_plus, flux_minus, & ! [F_i+1/2]^+ [F_i+1/2]^- in Smolarkiewicz + fout, & ! (A4) F_i{}^OUT, or the sum flux_plus+flux_minus + flux_lim, & ! Correction applied to flux at n+1 + field_nonlim ! Temporary variable for calculation + + real( kind = core_rknd ), dimension(gr%nz) :: & + dz_over_dt ! Conversion factor [m/s] + + +!----------------------------------------------------------------------- + + ! If all the values are positive or the values at the previous + ! timestep were negative, then just return + if ( .not. any( field_np1 < 0._core_rknd ) .or. any( field_n < 0._core_rknd ) ) then + flux_pd = 0._core_rknd + field_pd = 0._core_rknd + return + end if + + if ( field_grid == "zm" ) then + kabove = 0 + kbelow = 1 + else if ( field_grid == "zt" ) then + kabove = 1 + kbelow = 0 + else + ! This is only necessary to avoid a compiler warning in g95 + kabove = -1 + kbelow = -1 + ! Joshua Fasching June 2008 + + stop "Error in pos_def_adj" + end if + + if ( clubb_at_least_debug_level( 1 ) ) then + print *, "Correcting flux" + end if + + do k = 1, gr%nz, 1 + + ! Def. of F+ and F- from eqn 2 Smolarkowicz + flux_plus(k) = max( zero_threshold, flux_np1(k) ) ! defined on flux levels + flux_minus(k) = -min( zero_threshold, flux_np1(k) ) ! defined on flux levels + + if ( field_grid == "zm" ) then + dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzm(k) ) / dt + + else if ( field_grid == "zt" ) then + dz_over_dt(k) = ( 1._core_rknd/gr%invrs_dzt(k) ) / dt + + end if + + end do + + do k = 1, gr%nz, 1 + ! If the scalar variable is on the kth t-level, then + ! Smolarkowicz's k+1/2 flux level is the kth m-level in CLUBB. + + ! If the scalar variable is on the kth m-level, then + ! Smolarkowicz's k+1/2 flux level is the k+1 t-level in CLUBB. + + kphalf = min( k+kabove, gr%nz ) ! k+1/2 flux level + kmhalf = max( k-kbelow, 1 ) ! k-1/2 flux level + + ! Eqn A4 from Smolarkowicz + ! We place a limiter of eps to prevent a divide by zero, and + ! after this calculation fout is on the scalar level, and + ! fout is the total outward flux for the scalar level k. + + fout(k) = max( flux_plus(kphalf) + flux_minus(kmhalf), eps ) + + end do + + + do k = 1, gr%nz, 1 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FIXME: + ! We haven't tested this for negative values at the gr%nz level + ! -dschanen 13 June 2008 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + kphalf = min( k+kabove, gr%nz ) ! k+1/2 flux level + kp1 = min( k+1, gr%nz ) ! k+1 scalar level + + ! Eqn 10 from Smolarkowicz (1989) + + flux_lim(kphalf) & + = max( min( flux_np1(kphalf), & + ( flux_plus(kphalf)/fout(k) ) * field_n(k) & + * dz_over_dt(k) & + ), & + -( ( flux_minus(kphalf)/fout(kp1) ) * field_n(kp1) & + * dz_over_dt(k) ) & + ) + end do + + ! Boundary conditions + flux_lim(1) = flux_np1(1) + flux_lim(gr%nz) = flux_np1(gr%nz) + + flux_pd = ( flux_lim - flux_np1 ) / dt + + field_nonlim = field_np1 + + ! Apply change to field at n+1 + if ( field_grid == "zt" ) then + + field_np1 = -dt * ddzm( flux_lim - flux_np1 ) + field_np1 + + else if ( field_grid == "zm" ) then + + field_np1 = -dt * ddzt( flux_lim - flux_np1 ) + field_np1 + + end if + + ! Determine the total time tendency in field due to this calculation + ! (for diagnostic purposes) + field_pd = ( field_np1 - field_nonlim ) / dt + + ! Replace the non-limited flux with the limited flux + flux_np1 = flux_lim + + return + end subroutine pos_definite_adj + +end module pos_definite_module diff --git a/src/physics/clubb/precipitation_fraction.F90 b/src/physics/clubb/precipitation_fraction.F90 new file mode 100644 index 0000000000..75e5814aa4 --- /dev/null +++ b/src/physics/clubb/precipitation_fraction.F90 @@ -0,0 +1,1221 @@ +!------------------------------------------------------------------------- +! $Id: precipitation_fraction.F90 77826 2016-04-07 23:05:53Z cacraig@ucar.edu $ +!=============================================================================== +module precipitation_fraction + + ! Description: + ! Sets overall precipitation fraction as well as the precipitation fraction + ! in each PDF component. + + implicit none + + private + + public :: precip_fraction + + private :: component_precip_frac_weighted, & + component_precip_frac_specify, & + precip_frac_assert_check + + integer, parameter, public :: & + precip_frac_calc_type = 2 ! Option used to calculate component precip_frac + + contains + + !============================================================================= + subroutine precip_fraction( nz, hydromet, cloud_frac, cloud_frac_1, & + cloud_frac_2, ice_supersat_frac, & + ice_supersat_frac_1, ice_supersat_frac_2, & + mixt_frac, l_stats_samp, & + precip_frac, precip_frac_1, precip_frac_2, & + precip_frac_tol ) + + ! Description: + ! Determines (overall) precipitation fraction over the horizontal domain, as + ! well as the precipitation fraction within each PDF component, at every + ! vertical grid level. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + cloud_frac_min, & + fstderr + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + l_mix_rat_hm, & ! Variable(s) + l_frozen_hm, & + hydromet_tol + + use error_code, only : & + clubb_at_least_debug_level ! Procedure(s) + + use stats_variables, only: & + stats_sfc, & ! Variable(s) + iprecip_frac_tol + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet ! Mean of hydrometeor, hm (overall) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + cloud_frac, & ! Cloud fraction (overall) [-] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + ice_supersat_frac, & ! Ice supersaturation fraction (overall) [-] + ice_supersat_frac_1, & ! Ice supersaturation fraction (1st PDF comp.) [-] + ice_supersat_frac_2, & ! Ice supersaturation fraction (2nd PDF comp.) [-] + mixt_frac ! Mixture fraction [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), intent(out) :: & + precip_frac_tol ! Minimum precip. frac. when hydromet. are present [-] + + ! Local Variables + + ! "Maximum allowable" hydrometeor mixing ratio in-precip component mean. + real( kind = core_rknd ), parameter :: & + max_hm_ip_comp_mean = 0.0025_core_rknd ! [kg/kg] + + real( kind = core_rknd ), parameter :: & + precip_frac_tol_coef = 0.1_core_rknd ! Coefficient for precip_frac_tol + + integer :: & + k, ivar ! Loop indices + + + ! Initialize the precipitation fraction variables (precip_frac, + ! precip_frac_1, and precip_frac_2) to 0. + precip_frac = zero + precip_frac_1 = zero + precip_frac_2 = zero + + ! Set the minimum allowable precipitation fraction when hydrometeors are + ! found at a grid level. + if ( any( l_frozen_hm ) ) then + ! Ice microphysics included. + precip_frac_tol & + = max( precip_frac_tol_coef & + * max( maxval( cloud_frac ), maxval( ice_supersat_frac ) ), & + cloud_frac_min ) + else + ! Warm microphysics. + precip_frac_tol = max( precip_frac_tol_coef * maxval( cloud_frac ), & + cloud_frac_min ) + endif + + !!! Find overall precipitation fraction. + do k = nz, 1, -1 + + ! The precipitation fraction is the greatest cloud fraction at or above a + ! vertical level. + if ( k < nz ) then + if ( any( l_frozen_hm ) ) then + ! Ice microphysics included. + precip_frac(k) = max( precip_frac(k+1), cloud_frac(k), & + ice_supersat_frac(k) ) + else + ! Warm microphysics. + precip_frac(k) = max( precip_frac(k+1), cloud_frac(k) ) + endif + else ! k = nz + if ( any( l_frozen_hm ) ) then + ! Ice microphysics included. + precip_frac(k) = max( cloud_frac(k), ice_supersat_frac(k) ) + else + ! Warm microphysics. + precip_frac(k) = cloud_frac(k) + endif + endif + + enddo ! Overall precipitation fraction loop: k = nz, 1, -1 + + !!! Special checks for overall precipitation fraction + do k = 1, nz, 1 + + if ( any( hydromet(k,:) >= hydromet_tol(:) ) & + .and. precip_frac(k) < precip_frac_tol ) then + + ! In a scenario where we find any hydrometeor at this grid level, but + ! no cloud at or above this grid level, set precipitation fraction to + ! a minimum threshold value. + precip_frac(k) = precip_frac_tol + + elseif ( all( hydromet(k,:) < hydromet_tol(:) ) ) then + + ! The means (overall) of every precipitating hydrometeor are all less + ! than their respective tolerance amounts. They are all considered to + ! have values of 0. There are not any hydrometeor species found at + ! this grid level. There is also no cloud at or above this grid + ! level, so set precipitation fraction to 0. + precip_frac(k) = zero + + endif + + enddo ! Special checks for overall precipitation fraction loop: k = 1, nz, 1 + + + !!! Find precipitation fraction within each PDF component. + ! + ! The overall precipitation fraction, f_p, is given by the equation: + ! + ! f_p = a * f_p(1) + ( 1 - a ) * f_p(2); + ! + ! where "a" is the mixture fraction (weight of PDF component 1), f_p(1) is + ! the precipitation fraction within PDF component 1, and f_p(2) is the + ! precipitation fraction within PDF component 2. Overall precipitation + ! fraction is found according the method above, and mixture fraction is + ! already determined, leaving f_p(1) and f_p(2) to be solved for. The + ! values for f_p(1) and f_p(2) must satisfy the above equation. + if ( precip_frac_calc_type == 1 ) then + + ! Calculatate precip_frac_1 and precip_frac_2 based on the greatest + ! weighted cloud_frac_1 at or above a grid level. + call component_precip_frac_weighted( nz, hydromet, precip_frac, & + cloud_frac_1, cloud_frac_2, & + ice_supersat_frac_1, & + ice_supersat_frac_2, mixt_frac, & + precip_frac_tol, & + precip_frac_1, precip_frac_2 ) + + elseif ( precip_frac_calc_type == 2 ) then + + ! Specified method. + call component_precip_frac_specify( nz, hydromet, precip_frac, & + mixt_frac, precip_frac_tol, & + precip_frac_1, precip_frac_2 ) + + else ! Invalid option selected. + + write(fstderr,*) "Invalid option to calculate precip_frac_1 " & + // "and precip_frac_2." + stop + + endif ! precip_frac_calc_type + + + ! Increase Precipiation Fraction under special conditions. + ! + ! There are scenarios that sometimes occur that require precipitation + ! fraction to be boosted. Precipitation fraction is calculated from cloud + ! fraction and ice supersaturation fraction. For numerical reasons, CLUBB's + ! PDF may become entirely subsaturated with respect to liquid and ice, + ! resulting in both a cloud fraction of 0 and an ice supersaturation + ! fraction of 0. When this happens, precipitation fraction drops to 0 when + ! there aren't any hydrometeors present at that grid level, or to + ! precip_frac_tol when there is at least one hydrometeor present at that + ! grid level. However, sometimes there are large values of hydrometeors + ! found at that grid level. When this occurs, the PDF component in-precip + ! mean of a hydrometeor can become ridiculously large. This is because the + ! ith PDF component in-precip mean of a hydrometeor, mu_hm_i, is given by + ! the equation: + ! + ! mu_hm_i = hm_i / precip_frac_i; + ! + ! where hm_i is the overall ith PDF component mean of the hydrometeor, and + ! precip_frac_i is the ith PDF component precipitation fraction. When + ! precip_frac_i has a value of precip_frac_tol and hm_i is large, mu_hm_i + ! can be huge. This can cause enormous microphysical process rates and + ! result in numerical instability. It is also very inaccurate. + ! + ! In order to limit this problem, the ith PDF component precipitation + ! fraction is increased in order to decrease mu_hm_i. First, an "upper + ! limit" is set for mu_hm_i when the hydrometeor is a mixing ratio. This is + ! called max_hm_ip_comp_mean. At every vertical level and for every + ! hydrometeor mixing ratio, a check is made to try to prevent mu_hm_i from + ! exceeding the "upper limit". The check is: + ! + ! hm_i / precip_frac_i ( which = mu_hm_i ) > max_hm_ip_comp_mean, + ! + ! which can be rewritten: + ! + ! hm_i > precip_frac_i * max_hm_ip_comp_mean. + ! + ! Since hm_i has not been calculated yet, the assumption for this check is + ! that all of the hydrometeor is found in one PDF component, which is the + ! worst-case scenario in violating this limit. The check becomes: + ! + ! / ( mixt_frac * precip_frac_1 ) > max_hm_ip_comp_mean; + ! in PDF comp. 1; and + ! / ( ( 1 - mixt_frac ) * precip_frac_2 ) > max_hm_ip_comp_mean; + ! in PDF comp. 2. + ! + ! These limits can be rewritten as: + ! + ! > mixt_frac * precip_frac_1 * max_hm_ip_comp_mean; + ! in PDF comp. 1; and + ! > ( 1 - mixt_frac ) * precip_frac_2 * max_hm_ip_comp_mean; + ! in PDF comp. 2. + ! + ! When component precipitation fraction is found to be in excess of the + ! limit, precip_frac_i is increased to: + ! + ! / ( mixt_frac * max_hm_ip_comp_mean ); + ! when the limit is exceeded in PDF comp. 1; and + ! / ( ( 1 - mixt_frac ) * max_hm_ip_comp_mean ); + ! when the limit is exceeded in PDF comp. 2. + ! + ! Of course, precip_frac_i is not allowed to exceed 1, so when + ! / mixt_frac (or / ( 1 - mixt_frac )) is already greater than + ! max_hm_ip_comp_mean, mu_hm_i will also have to be greater than + ! max_hm_ip_comp_mean. However, the value of mu_hm_i is still reduced when + ! compared to what it would have been using precip_frac_tol. In the event + ! that multiple hydrometeor mixing ratios violate the check, the code is set + ! up so that precip_frac_i is increased based on the highest hm_i. + do k = 1, nz, 1 + + do ivar = 1, hydromet_dim, 1 + + if ( l_mix_rat_hm(ivar) ) then + + ! The hydrometeor is a mixing ratio. + + if ( hydromet(k,ivar) >= hydromet_tol(ivar) .and. & + hydromet(k,ivar) > mixt_frac(k) * precip_frac_1(k) & + * max_hm_ip_comp_mean ) then + + ! Increase precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = min( hydromet(k,ivar) & + / ( mixt_frac(k) * max_hm_ip_comp_mean ), one ) + + ! The value of precip_frac_1 must be at least precip_frac_tol + ! when precipitation is found in the 1st PDF component. + precip_frac_1(k) = max( precip_frac_1(k), precip_frac_tol ) + + endif ! /(mixt_frac*precip_frac_1) > max_hm_ip_comp_mean + + if ( hydromet(k,ivar) >= hydromet_tol(ivar) .and. & + hydromet(k,ivar) > ( one - mixt_frac(k) ) * precip_frac_2(k) & + * max_hm_ip_comp_mean ) then + + ! Increase precipitation fraction in the 2nd PDF component. + precip_frac_2(k) & + = min( hydromet(k,ivar) & + / ( ( one - mixt_frac(k) ) * max_hm_ip_comp_mean ), one ) + + ! The value of precip_frac_2 must be at least precip_frac_tol + ! when precipitation is found in the 2nd PDF component. + precip_frac_2(k) = max( precip_frac_2(k), precip_frac_tol ) + + endif ! /((1-mixt_frac)*precip_frac_2) > max_hm_ip_comp_mean + + endif ! l_mix_rat_hm(ivar) + + enddo ! ivar = 1, hydromet_dim, 1 + + enddo ! k = 1, nz, 1 + + ! Recalculate overall precipitation fraction for consistency. + precip_frac = mixt_frac * precip_frac_1 & + + ( one - mixt_frac ) * precip_frac_2 + + ! Double check that precip_frac_tol <= precip_frac <= 1 when hydrometeors + ! are found at a grid level. + ! PLEASE DO NOT ALTER precip_frac, precip_frac_1, or precip_frac_2 anymore + ! after this point in the code. + do k = 1, nz, 1 + if ( any( hydromet(k,:) >= hydromet_tol(:) ) ) then + precip_frac(k) = min( max( precip_frac(k), precip_frac_tol ), one ) + endif ! any( hydromet(k,:) >= hydromet_tol(:) ) + enddo ! k = 1, nz, 1 + + + ! Statistics + if ( l_stats_samp ) then + if ( iprecip_frac_tol > 0 ) then + call stat_update_var_pt( iprecip_frac_tol, 1, precip_frac_tol, & + stats_sfc ) + endif ! iprecip_frac_tol + endif ! l_stats_samp + + + ! Assertion check for precip_frac, precip_frac_1, and precip_frac_2. + if ( clubb_at_least_debug_level( 2 ) ) then + call precip_frac_assert_check( nz, hydromet, mixt_frac, precip_frac, & + precip_frac_1, precip_frac_2, & + precip_frac_tol ) + endif + + + return + + end subroutine precip_fraction + + !============================================================================= + subroutine component_precip_frac_weighted( nz, hydromet, precip_frac, & + cloud_frac_1, cloud_frac_2, & + ice_supersat_frac_1, & + ice_supersat_frac_2, mixt_frac, & + precip_frac_tol, & + precip_frac_1, precip_frac_2 ) + + ! Description: + ! Set precipitation fraction in each component of the PDF. The weighted 1st + ! PDF component precipitation fraction (weighted_pfrac_1) at a grid level is + ! calculated by the greatest value of mixt_frac * cloud_frac_1 at or above + ! the relevant grid level. Likewise, the weighted 2nd PDF component + ! precipitation fraction (weighted_pfrac_2) at a grid level is calculated by + ! the greatest value of ( 1 - mixt_frac ) * cloud_frac_2 at or above the + ! relevant grid level. + ! + ! The fraction weighted_pfrac_1 / ( weighted_pfrac_1 + weighted_pfrac_2 ) is + ! the weighted_pfrac_1 fraction. Multiplying this fraction by overall + ! precipitation fraction and then dividing by mixt_frac produces the 1st PDF + ! component precipitation fraction (precip_frac_1). Then, calculate the 2nd + ! PDF component precipitation fraction (precip_frac_2) accordingly. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + l_frozen_hm, & ! Variable(s) + hydromet_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet ! Mean of hydrometeor, hm (overall) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + ice_supersat_frac_1, & ! Ice supersaturation fraction (1st PDF comp.) [-] + ice_supersat_frac_2, & ! Ice supersaturation fraction (2nd PDF comp.) [-] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + precip_frac_tol ! Minimum precip. frac. when hydromet. are present [-] + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + ! Local Variables + real( kind = core_rknd ), dimension(nz) :: & + weighted_pfrac_1, & ! Product of mixt_frac and cloud_frac_1 [-] + weighted_pfrac_2 ! Product of ( 1 - mixt_frac ) and cloud_frac_2 [-] + + integer :: k ! Loop index + + + !!! Find precipitation fraction within PDF component 1. + ! The method used to find overall precipitation fraction will also be to + ! find precipitation fraction within PDF component 1 and PDF component 2. + ! In order to do so, it is assumed (poorly) that PDF component 1 overlaps + ! PDF component 1 and that PDF component 2 overlaps PDF component 2 at every + ! vertical level in the vertical profile. + do k = nz, 1, -1 + + ! The weighted precipitation fraction in PDF component 1 is the greatest + ! value of the product of mixture fraction (mixt_frac) and 1st PDF + ! component cloud fraction at or above a vertical level. Likewise, the + ! weighted precipitation fraction in PDF component 2 is the greatest + ! value of the product of ( 1 - mixt_frac ) and 2nd PDF component cloud + ! fraction at or above a vertical level. + if ( k < nz ) then + + if ( any( l_frozen_hm ) ) then + + ! Ice microphysics included. + + ! Weighted precipitation fraction in PDF component 1. + weighted_pfrac_1(k) & + = max( weighted_pfrac_1(k+1), & + mixt_frac(k) * cloud_frac_1(k), & + mixt_frac(k) * ice_supersat_frac_1(k) ) + + ! Weighted precipitation fraction in PDF component 2. + weighted_pfrac_2(k) & + = max( weighted_pfrac_2(k+1), & + ( one - mixt_frac(k) ) * cloud_frac_2(k), & + ( one - mixt_frac(k) ) * ice_supersat_frac_2(k) ) + + else + + ! Warm microphysics. + + ! Weighted precipitation fraction in PDF component 1. + weighted_pfrac_1(k) & + = max( weighted_pfrac_1(k+1), & + mixt_frac(k) * cloud_frac_1(k) ) + + ! Weighted precipitation fraction in PDF component 2. + weighted_pfrac_2(k) & + = max( weighted_pfrac_2(k+1), & + ( one - mixt_frac(k) ) * cloud_frac_2(k) ) + + endif + + else ! k = nz + + if ( any( l_frozen_hm ) ) then + + ! Ice microphysics included. + + ! Weighted precipitation fraction in PDF component 1. + weighted_pfrac_1(k) & + = max( mixt_frac(k) * cloud_frac_1(k), & + mixt_frac(k) * ice_supersat_frac_1(k) ) + + ! Weighted precipitation fraction in PDF component 2. + weighted_pfrac_2(k) & + = max( ( one - mixt_frac(k) ) * cloud_frac_2(k), & + ( one - mixt_frac(k) ) * ice_supersat_frac_2(k) ) + + else + + ! Warm microphysics. + + ! Weighted precipitation fraction in PDF component 1. + weighted_pfrac_1(k) = mixt_frac(k) * cloud_frac_1(k) + + ! Weighted precipitation fraction in PDF component 2. + weighted_pfrac_2(k) = ( one - mixt_frac(k) ) * cloud_frac_2(k) + + endif + + endif + + enddo ! Weighted precipitation fraction (1st PDF comp.) loop: k = nz, 1, -1 + + ! Calculate precip_frac_1 and special cases for precip_frac_1. + do k = 1, nz, 1 + + ! Calculate precipitation fraction in the 1st PDF component. + if ( weighted_pfrac_1(k) + weighted_pfrac_2(k) > zero ) then + + ! Adjust weighted 1st PDF component precipitation fraction by + ! multiplying it by a factor. That factor is overall precipitation + ! fraction divided by the sum of the weighted 1st PDF component + ! precipitation fraction and the weighted 2nd PDF component + ! precipitation fraction. The 1st PDF component precipitation + ! fraction is then found by dividing the adjusted weighted 1st PDF + ! component precipitation fraction by mixture fraction. + precip_frac_1(k) & + = weighted_pfrac_1(k) & + * ( precip_frac(k) & + / ( weighted_pfrac_1(k) + weighted_pfrac_2(k) ) ) & + / mixt_frac(k) + else + + ! Usually, the sum of the weighted 1st PDF component precipitation + ! fraction and the 2nd PDF component precipitation fraction go to 0 + ! when overall precipitation fraction goes to 0. Since 1st PDF + ! component weighted precipitation fraction is 0, 1st PDF component + ! precipitation fraction also 0. + precip_frac_1(k) = zero + + endif + + ! Special cases for precip_frac_1. + if ( any( hydromet(k,:) >= hydromet_tol(:) ) & + .and. precip_frac_1(k) & + > min( one, precip_frac(k) / mixt_frac(k) ) ) then + + ! Using the above method, it is possible for precip_frac_1 to be + ! greater than 1. For example, the mixture fraction at level k+1 is + ! 0.10 and the cloud_frac_1 at level k+1 is 1, resulting in a + ! weighted_pfrac_1 of 0.10. This product is greater than the product + ! of mixt_frac and cloud_frac_1 at level k. The mixture fraction at + ! level k is 0.05, resulting in a precip_frac_1 of 2. The value of + ! precip_frac_1 is limited at 1. The leftover precipitation fraction + ! (a result of the decreasing weight of PDF component 1 between the + ! levels) is applied to PDF component 2. + ! Additionally, when weighted_pfrac_1 at level k is greater than + ! overall precipitation fraction at level k, the resulting calculation + ! of precip_frac_2 at level k will be negative. + precip_frac_1(k) = min( one, precip_frac(k) / mixt_frac(k) ) + + elseif ( any( hydromet(k,:) >= hydromet_tol(:) ) & + .and. precip_frac_1(k) > zero & + .and. precip_frac_1(k) < precip_frac_tol ) then + + ! In a scenario where we find precipitation in the 1st PDF component + ! (it is allowed to have a value of 0 when all precipitation is found + ! in the 2nd PDF component) but it is tiny (less than tolerance + ! level), boost 1st PDF component precipitation fraction to tolerance + ! level. + precip_frac_1(k) = precip_frac_tol + + elseif ( all( hydromet(k,:) < hydromet_tol(:) ) ) then + + ! The means (overall) of every precipitating hydrometeor are all less + ! than their respective tolerance amounts. They are all considered to + ! have values of 0. There are not any hydrometeor species found at + ! this grid level. There is also no cloud at or above this grid + ! level, so set 1st component precipitation fraction to 0. + precip_frac_1(k) = zero + + endif + + enddo ! Precipitation fraction (1st PDF component) loop: k = 1, nz, 1 + + + !!! Find precipitation fraction within PDF component 2. + ! The equation for precipitation fraction within PDF component 2 is: + ! + ! f_p(2) = ( f_p - a * f_p(1) ) / ( 1 - a ); + ! + ! given the overall precipitation fraction, f_p (calculated above), the + ! precipitation fraction within PDF component 1, f_p(1) (calculated above), + ! and mixture fraction, a. Any leftover precipitation fraction from + ! precip_frac_1 will be included in this calculation of precip_frac_2. + do k = 1, nz, 1 + + if ( any( hydromet(k,:) >= hydromet_tol(:) ) ) then + + ! Calculate precipitation fraction in the 2nd PDF component. + precip_frac_2(k) & + = max( ( precip_frac(k) - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ), & + zero ) + + ! Special cases for precip_frac_2. + if ( precip_frac_2(k) > one ) then + + ! Again, it is possible for precip_frac_2 to be greater than 1. + ! For example, the mixture fraction at level k+1 is 0.10 and the + ! cloud_frac_1 at level k+1 is 1, resulting in a weighted_pfrac_1 + ! of 0.10. This product is greater than the product of mixt_frac + ! and cloud_frac_1 at level k. Additionally, precip_frac (overall) + ! is 1 for level k. The mixture fraction at level k is 0.5, + ! resulting in a precip_frac_1 of 0.2. Using the above equation, + ! precip_frac_2 is calculated to be 1.8. The value of + ! precip_frac_2 is limited at 1. The leftover precipitation + ! fraction (as a result of the increasing weight of component 1 + ! between the levels) is applied to PDF component 1. + precip_frac_2(k) = one + + ! Recalculate precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = ( precip_frac(k) - ( one - mixt_frac(k) ) ) / mixt_frac(k) + + ! Double check precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + if ( precip_frac(k) == one ) then + precip_frac_2(k) = one + else + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + endif + elseif ( precip_frac_1(k) > zero & + .and. precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + else + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + endif + endif + + elseif ( precip_frac_2(k) > zero & + .and. precip_frac_2(k) < precip_frac_tol ) then + + ! In a scenario where we find precipitation in the 2nd PDF + ! component (it is allowed to have a value of 0 when all + ! precipitation is found in the 1st PDF component) but it is tiny + ! (less than tolerance level), boost 2nd PDF component + ! precipitation fraction to tolerance level. + precip_frac_2(k) = precip_frac_tol + + ! Recalculate precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = ( precip_frac(k) - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + + ! Double check precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + if ( precip_frac(k) == one ) then + precip_frac_2(k) = one + else + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + endif + elseif ( precip_frac_1(k) > zero & + .and. precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + else + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + endif + endif + + endif ! Special cases for precip_frac_2 + + else ! all( hydromet(k,:) < hydromet_tol(:) ) + + ! The means (overall) of every precipitating hydrometeor are all less + ! than their respective tolerance amounts. They are all considered to + ! have values of 0. There are not any hydrometeor species found at + ! this grid level. There is also no cloud at or above this grid + ! level, so set 2nd component precipitation fraction to 0. + precip_frac_2(k) = zero + + endif ! any( hydromet(k,:) > hydromet_tol(:) ) + + enddo ! Precipitation fraction (2nd PDF component) loop: k = 1, nz, 1 + + + return + + end subroutine component_precip_frac_weighted + + !============================================================================= + subroutine component_precip_frac_specify( nz, hydromet, precip_frac, & + mixt_frac, precip_frac_tol, & + precip_frac_1, precip_frac_2 ) + + ! Description: + ! Calculates the precipitation fraction in each PDF component. + ! + ! The equation for precipitation fraction is: + ! + ! f_p = mixt_frac * f_p(1) + ( 1 - mixt_frac ) * f_p(2); + ! + ! where f_p is overall precipitation fraction, f_p(1) is precipitation + ! fraction in the 1st PDF component, f_p(2) is precipitation fraction in the + ! 2nd PDF component, and mixt_frac is the mixture fraction. Using this + ! method, a new specified parameter is introduced, upsilon, where: + ! + ! upsilon = mixt_frac * f_p(1) / f_p; and where 0 <= upsilon <= 1. + ! + ! In other words, upsilon is the ratio of mixt_frac * f_p(1) to f_p. Since + ! f_p and mixt_frac are calculated previously, and upsilon is specified, + ! f_p(1) can be calculated by: + ! + ! f_p(1) = upsilon * f_p / mixt_frac; + ! + ! and has an upper limit of 1. The value of f_p(2) can then be calculated + ! by: + ! + ! f_p(2) = ( f_p - mixt_frac * f_p(1) ) / ( 1 - mixt_frac ); + ! + ! and also has an upper limit of 1. When upsilon = 1, all of the + ! precipitation is found in the 1st PDF component (as long as + ! f_p <= mixt_frac, otherwise it would cause f_p(1) to be greater than 1). + ! When upsilon = 0, all of the precipitation is found in the 2nd PDF + ! component (as long as f_p <= 1 - mixt_frac, otherwise it would cause + ! f_p(2) to be greater than 1). When upsilon is between 0 and 1, + ! precipitation is split between the two PDF components accordingly. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use parameters_tunable, only: & + upsilon_precip_frac_rat ! Variable(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use array_index, only: & + hydromet_tol ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet ! Mean of hydrometeor, hm (overall) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), intent(in) :: & + precip_frac_tol ! Minimum precip. frac. when hydromet. are present [-] + + ! Output Variables + real( kind = core_rknd ), dimension(nz), intent(out) :: & + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + integer :: k ! Loop index. + + + ! Loop over all vertical levels. + do k = 1, nz, 1 + + if ( any( hydromet(k,:) >= hydromet_tol(:) ) ) then + + ! There are hydrometeors found at this grid level. + if ( upsilon_precip_frac_rat == one ) then + + if ( precip_frac(k) <= mixt_frac(k) ) then + + ! All the precipitation is found in the 1st PDF component. + precip_frac_1(k) = precip_frac(k) / mixt_frac(k) + precip_frac_2(k) = zero + + else ! precip_frac(k) > mixt_frac(k) + + ! Some precipitation is found in the 2nd PDF component. + precip_frac_1(k) = one + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + + if ( precip_frac_2(k) > one & + .and. precip_frac(k) == one ) then + + ! Set precip_frac_2 = 1. + precip_frac_2(k) = one + + elseif ( precip_frac_2(k) < precip_frac_tol ) then + + ! Since precipitation is found in the 2nd PDF component, it + ! must have a value of at least precip_frac_tol. + precip_frac_2(k) = precip_frac_tol + + ! Recalculate precip_frac_1 + precip_frac_1(k) & + = ( precip_frac(k) & + - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + + ! Double check precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + if ( precip_frac(k) == one ) then + precip_frac_2(k) = one + else + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + endif + elseif ( precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + else + precip_frac_2(k) & + = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + endif + endif + + endif ! precip_frac_2(k) < precip_frac_tol + + endif ! precip_frac(k) <= mixt_frac(k) + + + elseif ( upsilon_precip_frac_rat == zero ) then + + if ( precip_frac(k) <= ( one - mixt_frac(k) ) ) then + + ! All the precipitation is found in the 2nd PDF component. + precip_frac_1(k) = zero + precip_frac_2(k) = precip_frac(k) / ( one - mixt_frac(k) ) + + else ! precip_frac(k) > ( 1 - mixt_frac(k) ) + + ! Some precipitation is found in the 1st PDF component. + precip_frac_1(k) = ( precip_frac(k) - ( one - mixt_frac(k) ) ) & + / mixt_frac(k) + precip_frac_2(k) = one + + if ( precip_frac_1(k) > one & + .and. precip_frac(k) == one ) then + + ! Set precip_frac_1 = 1. + precip_frac_1(k) = one + + elseif ( precip_frac_1(k) < precip_frac_tol ) then + + ! Since precipitation is found in the 1st PDF component, it + ! must have a value of at least precip_frac_tol. + precip_frac_1(k) = precip_frac_tol + + ! Recalculate precip_frac_2 + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + + ! Double check precip_frac_2 + if ( precip_frac_2(k) > one ) then + precip_frac_2(k) = one + if ( precip_frac(k) == one ) then + precip_frac_1(k) = one + else + precip_frac_1(k) & + = ( precip_frac(k) - ( one - mixt_frac(k) ) ) & + / mixt_frac(k) + endif + elseif ( precip_frac_2(k) < precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + else + precip_frac_1(k) & + = ( precip_frac(k) & + - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + endif + endif + + endif ! precip_frac_1(k) < precip_frac_tol + + endif ! precip_frac(k) <= ( 1 - mixt_frac(k) ) + + + else ! 0 < upsilon_precip_frac_rat < 1 + + ! Precipitation is found in both PDF components. Each component + ! must have a precipitation fraction that is at least + ! precip_frac_tol and that does not exceed 1. + + ! Calculate precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = upsilon_precip_frac_rat * precip_frac(k) / mixt_frac(k) + + ! Special cases for precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + elseif ( precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + endif + + ! Calculate precipitation fraction in the 2nd PDF component. + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + + ! Special case for precip_frac_2 + if ( precip_frac_2(k) > one ) then + + ! Set precip_frac_2 to 1. + precip_frac_2(k) = one + + ! Recalculate precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = ( precip_frac(k) - ( one - mixt_frac(k) ) ) / mixt_frac(k) + + ! Double check precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + if ( precip_frac(k) == one ) then + precip_frac_2(k) = one + else + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + endif + elseif ( precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + else + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + endif + endif + + elseif ( precip_frac_2(k) < precip_frac_tol ) then + + ! Set precip_frac_2 to precip_frac_tol. + precip_frac_2(k) = precip_frac_tol + + ! Recalculate precipitation fraction in the 1st PDF component. + precip_frac_1(k) & + = ( precip_frac(k) & + - ( one - mixt_frac(k) ) * precip_frac_2(k) ) & + / mixt_frac(k) + + ! Double check precip_frac_1 + if ( precip_frac_1(k) > one ) then + precip_frac_1(k) = one + if ( precip_frac(k) == one ) then + precip_frac_2(k) = one + else + precip_frac_2(k) = ( precip_frac(k) - mixt_frac(k) ) & + / ( one - mixt_frac(k) ) + endif + elseif ( precip_frac_1(k) < precip_frac_tol ) then + precip_frac_1(k) = precip_frac_tol + if ( precip_frac(k) == precip_frac_tol ) then + precip_frac_2(k) = precip_frac_tol + else + precip_frac_2(k) = ( precip_frac(k) & + - mixt_frac(k) * precip_frac_1(k) ) & + / ( one - mixt_frac(k) ) + endif + endif + + endif ! Special cases for precip_frac_2 + + endif ! upsilon_precip_frac_rat + + + else ! all( hydromet(k,:) < hydromet_tol(:) ) + + ! There aren't any hydrometeors found at the grid level. + precip_frac_1(k) = zero + precip_frac_2(k) = zero + + + endif ! any( hydromet(k,:) >= hydromet_tol(:) ) + + enddo ! k = 1, nz, 1 + + + return + + end subroutine component_precip_frac_specify + + !============================================================================= + subroutine precip_frac_assert_check( nz, hydromet, mixt_frac, precip_frac, & + precip_frac_1, precip_frac_2, & + precip_frac_tol ) + + ! Description: + ! Assertion check for the precipitation fraction code. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + fstderr + + use array_index, only: & + hydromet_tol ! Variable(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz ! Number of model vertical grid levels + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet ! Mean of hydrometeor, hm (overall) [units vary] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + mixt_frac, & ! Mixture fraction [-] + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + precip_frac_tol ! Minimum precip. frac. when hydromet. are present [-] + + ! Local Variables + integer :: k ! Loop index + + + ! Loop over all vertical levels. + do k = 1, nz, 1 + + if ( any( hydromet(k,:) >= hydromet_tol(:) ) ) then + + ! Overall precipitation fraction cannot be less than precip_frac_tol + ! when a hydrometeor is present at a grid level. + if ( precip_frac(k) < precip_frac_tol ) then + write(fstderr,*) "precip_frac < precip_frac_tol when " & + // "a hydrometeor is present" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac = ", precip_frac(k), & + "precip_frac_tol = ", precip_frac_tol + stop + endif + + ! Overall precipitation fraction cannot exceed 1. + if ( precip_frac(k) > one ) then + write(fstderr,*) "precip_frac > 1" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac = ", precip_frac(k) + stop + endif + + ! Precipitation fraction in the 1st PDF component is allowed to be 0 + ! when all the precipitation is found in the 2nd PDF component. + ! Otherwise, it cannot be less than precip_frac_tol when a hydrometeor + ! is present at a grid level. In other words, it cannot have a value + ! that is greater than 0 but less than precip_frac_tol + if ( precip_frac_1(k) > zero & + .and. precip_frac_1(k) < precip_frac_tol ) then + write(fstderr,*) "0 < precip_frac_1 < precip_frac_tol" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_1 = ", precip_frac_1(k), & + "precip_frac_tol = ", precip_frac_tol + stop + endif + + ! Precipitation fraction in the 1st PDF component cannot exceed 1. + if ( precip_frac_1(k) > one ) then + write(fstderr,*) "precip_frac_1 > 1" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_1 = ", precip_frac_1(k) + stop + endif + + ! Precipiation fraction in the 1st PDF component cannot be negative. + if ( precip_frac_1(k) < zero ) then + write(fstderr,*) "precip_frac_1 < 0" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_1 = ", precip_frac_1(k) + stop + endif + + ! Precipitation fraction in the 2nd PDF component is allowed to be 0 + ! when all the precipitation is found in the 1st PDF component. + ! Otherwise, it cannot be less than precip_frac_tol when a hydrometeor + ! is present at a grid level. In other words, it cannot have a value + ! that is greater than 0 but less than precip_frac_tol + if ( precip_frac_2(k) > zero & + .and. precip_frac_2(k) < precip_frac_tol ) then + write(fstderr,*) "0 < precip_frac_2 < precip_frac_tol" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_2 = ", precip_frac_2(k), & + "precip_frac_tol = ", precip_frac_tol + stop + endif + + ! Precipitation fraction in the 2nd PDF component cannot exceed 1. + if ( precip_frac_2(k) > one ) then + write(fstderr,*) "precip_frac_2 > 1" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_2 = ", precip_frac_2(k) + stop + endif + + ! Precipiation fraction in the 2nd PDF component cannot be negative. + if ( precip_frac_2(k) < zero ) then + write(fstderr,*) "precip_frac_2 < 0" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_2 = ", precip_frac_2(k) + stop + endif + + else ! all( hydromet(k,:) < hydromet_tol(:) ) + + ! Overall precipitation fraction must be 0 when no hydrometeors are + ! found at a grid level. + if ( precip_frac(k) /= zero ) then + write(fstderr,*) "precip_frac /= 0 when no hydrometeors are found" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac = ", precip_frac(k) + stop + endif + + ! Precipitation fraction in the 1st PDF component must be 0 when no + ! hydrometeors are found at a grid level. + if ( precip_frac_1(k) /= zero ) then + write(fstderr,*) "precip_frac_1 /= 0 when no hydrometeors " & + // "are found" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_1 = ", precip_frac_1(k) + stop + endif + + ! Precipitation fraction in the 2nd PDF component must be 0 when no + ! hydrometeors are found at a grid level. + if ( precip_frac_2(k) /= zero ) then + write(fstderr,*) "precip_frac_2 /= 0 when no hydrometeors " & + // "are found" + write(fstderr,*) "level = ", k + write(fstderr,*) "precip_frac_2 = ", precip_frac_2(k) + stop + endif + + endif ! any( hydromet(k,:) >= hydromet_tol(:) ) + + ! The precipitation fraction equation is: + ! + ! precip_frac + ! = mixt_frac * precip_frac_1 + ( 1 - mixt_frac ) * precip_frac_2; + ! + ! which means that: + ! + ! precip_frac + ! - ( mixt_frac * precip_frac_1 + ( 1 - mixt_frac ) * precip_frac_2 ) + ! = 0. + ! + ! Check that this is true with numerical round off. + if ( ( precip_frac(k) & + - ( mixt_frac(k) * precip_frac_1(k) & + + ( one - mixt_frac(k) ) * precip_frac_2(k) ) ) & + > ( epsilon( precip_frac(k) ) * precip_frac(k) ) ) then + write(fstderr,*) "mixt_frac * precip_frac_1 " & + // "+ ( 1 - mixt_frac ) * precip_frac_2 " & + // "/= precip_frac within numerical roundoff" + write(fstderr,*) "level = ", k + write(fstderr,*) "mixt_frac * precip_frac_1 " & + // "+ ( 1 - mixt_frac ) * precip_frac_2 = ", & + mixt_frac(k) * precip_frac_1(k) & + + ( one - mixt_frac(k) ) * precip_frac_2(k) + write(fstderr,*) "precip_frac = ", precip_frac(k) + stop + endif + + enddo ! k = 1, nz, 1 + + + return + + end subroutine precip_frac_assert_check + +!=============================================================================== + +end module precipitation_fraction diff --git a/src/physics/clubb/recl.inc b/src/physics/clubb/recl.inc new file mode 100644 index 0000000000..c5eb02a57c --- /dev/null +++ b/src/physics/clubb/recl.inc @@ -0,0 +1,26 @@ +!------------------------------------------------------------------------------- +! $Id: recl.inc 6938 2014-06-09 21:29:40Z bmg2@uwm.edu $ +! Description: +! Preprocessing rules for determining how large an unformatted +! data record is when using Fortran write. This does not affect +! netCDF output at all. + +! Notes: +! New directives will need to be added to port CLUBB GrADS output +! to new compilers that do not use byte size record lengths. + +! Early Alpha processors lacked the ability to work with anything +! smaller than a 32 bit word, so DEC Fortran and its successors +! (Compaq Visual Fortran, newer Intel Fortran, etc.) all use 4 +! byte records. Note that specifying byterecl on Alpha still +! results in a performance hit, even on newer chips. +!------------------------------------------------------------------------------- +#if defined GFDL /* F_RECL should be 4 for the GFDL SCM-CLUBB */ +# define F_RECL 4 +#elif defined __INTEL_COMPILER && __INTEL_COMPILER >= 800 /* Versions of Intel fortran > 8.0 */ +# define F_RECL 1 +#elif defined(__alpha) /* Assume 4 byte word on Alpha processors */ +# define F_RECL 1 +#else +# define F_RECL 4 /* Most compilers and computers */ +#endif diff --git a/src/physics/clubb/saturation.F90 b/src/physics/clubb/saturation.F90 new file mode 100644 index 0000000000..39ad6a5331 --- /dev/null +++ b/src/physics/clubb/saturation.F90 @@ -0,0 +1,813 @@ +!------------------------------------------------------------------------- +!$Id: saturation.F90 8470 2017-10-04 14:50:30Z vlarson@uwm.edu $ +!=============================================================================== +module saturation + +! Description: +! Contains functions that compute saturation with respect +! to liquid or ice. +!----------------------------------------------------------------------- + +#ifdef GFDL + use model_flags, only: & ! h1g, 2010-06-18 + I_sat_sphum +#endif + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Change default so all items private + + public :: sat_mixrat_liq, sat_mixrat_liq_lookup, sat_mixrat_ice, rcm_sat_adj, & + sat_vapor_press_liq + + private :: sat_vapor_press_liq_flatau, sat_vapor_press_liq_bolton + private :: sat_vapor_press_ice_flatau, sat_vapor_press_ice_bolton + + ! Lookup table of values for saturation + real( kind = core_rknd ), private, dimension(188:343) :: & + svp_liq_lookup_table + + data svp_liq_lookup_table(188:343) / & + 0.049560547_core_rknd, 0.059753418_core_rknd, 0.070129395_core_rknd, 0.083618164_core_rknd, & + 0.09814453_core_rknd, 0.11444092_core_rknd, 0.13446045_core_rknd, 0.15686035_core_rknd, & + 0.18218994_core_rknd, 0.21240234_core_rknd, 0.24725342_core_rknd, 0.28668213_core_rknd, & + 0.33184814_core_rknd, 0.3826294_core_rknd, 0.4416504_core_rknd, 0.50775146_core_rknd, & + 0.58343506_core_rknd, 0.6694946_core_rknd, 0.7668457_core_rknd, 0.87750244_core_rknd, & + 1.0023804_core_rknd, 1.1434937_core_rknd, 1.3028564_core_rknd, 1.482544_core_rknd, & + 1.6847534_core_rknd, 1.9118042_core_rknd, 2.1671143_core_rknd, 2.4535522_core_rknd, & + 2.774231_core_rknd, 3.1330566_core_rknd, 3.5343628_core_rknd, 3.9819336_core_rknd, & + 4.480713_core_rknd, 5.036072_core_rknd, 5.6540527_core_rknd, 6.340088_core_rknd, & + 7.1015015_core_rknd, 7.9450684_core_rknd, 8.8793335_core_rknd, 9.91217_core_rknd, & + 11.053528_core_rknd, 12.313049_core_rknd, 13.70166_core_rknd, 15.231018_core_rknd, & + 16.91394_core_rknd, 18.764038_core_rknd, 20.795898_core_rknd, 23.025574_core_rknd, & + 25.470093_core_rknd, 28.147766_core_rknd, 31.078003_core_rknd, 34.282043_core_rknd, & + 37.782593_core_rknd, 41.60382_core_rknd, 45.771606_core_rknd, 50.31366_core_rknd, & + 55.259644_core_rknd, 60.641174_core_rknd, 66.492004_core_rknd, 72.84802_core_rknd, & + 79.74756_core_rknd, 87.23126_core_rknd, 95.34259_core_rknd, 104.12747_core_rknd, & + 113.634796_core_rknd, 123.91641_core_rknd, 135.02725_core_rknd, 147.02563_core_rknd, & + 159.97308_core_rknd, 173.93488_core_rknd, 188.97995_core_rknd, 205.18109_core_rknd, & + 222.61517_core_rknd, 241.36334_core_rknd, 261.51108_core_rknd, 283.14853_core_rknd, & + 306.37054_core_rknd, 331.27698_core_rknd, 357.97278_core_rknd, 386.56842_core_rknd, & + 417.17978_core_rknd, 449.9286_core_rknd, 484.94254_core_rknd, 522.3556_core_rknd, & + 562.30804_core_rknd, 604.947_core_rknd, 650.42645_core_rknd, 698.9074_core_rknd, & + 750.55835_core_rknd, 805.55554_core_rknd, 864.0828_core_rknd, 926.3325_core_rknd, & + 992.5052_core_rknd, 1062.8102_core_rknd, 1137.4657_core_rknd, 1216.6995_core_rknd, & + 1300.7483_core_rknd, 1389.8594_core_rknd, 1484.2896_core_rknd, 1584.3064_core_rknd, & + 1690.1881_core_rknd, 1802.224_core_rknd, 1920.7146_core_rknd, 2045.9724_core_rknd, & + 2178.3218_core_rknd, 2318.099_core_rknd, 2465.654_core_rknd, 2621.3489_core_rknd, & + 2785.5596_core_rknd, 2958.6758_core_rknd, 3141.101_core_rknd, 3333.2534_core_rknd, & + 3535.5657_core_rknd, 3748.4863_core_rknd, 3972.4792_core_rknd, 4208.024_core_rknd, & + 4455.616_core_rknd, 4715.7686_core_rknd, 4989.0127_core_rknd, 5275.8945_core_rknd, & + 5576.9795_core_rknd, 5892.8535_core_rknd, 6224.116_core_rknd, 6571.3926_core_rknd, & + 6935.3213_core_rknd, 7316.5674_core_rknd, 7715.8105_core_rknd, 8133.755_core_rknd, & + 8571.125_core_rknd, 9028.667_core_rknd, 9507.15_core_rknd, 10007.367_core_rknd, & + 10530.132_core_rknd, 11076.282_core_rknd, 11646.683_core_rknd, 12242.221_core_rknd, & + 12863.808_core_rknd, 13512.384_core_rknd, 14188.913_core_rknd, 14894.385_core_rknd, & + 15629.823_core_rknd, 16396.268_core_rknd, 17194.799_core_rknd, 18026.516_core_rknd, & + 18892.55_core_rknd, 19794.07_core_rknd, 20732.262_core_rknd, 21708.352_core_rknd, & + 22723.592_core_rknd, 23779.273_core_rknd, 24876.709_core_rknd, 26017.258_core_rknd, & + 27202.3_core_rknd, 28433.256_core_rknd, 29711.578_core_rknd, 31038.766_core_rknd / + +!$omp threadprivate( svp_liq_lookup_table ) + + contains + +!------------------------------------------------------------------------- + elemental real( kind = core_rknd ) function sat_mixrat_liq( p_in_Pa, T_in_K ) + +! Description: +! Used to compute the saturation mixing ratio of liquid water. + +! References: +! Formula from Emanuel 1994, 4.4.14 +!------------------------------------------------------------------------- + + use constants_clubb, only: & + ep ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + p_in_Pa, & ! Pressure [Pa] + T_in_K ! Temperature [K] + + ! Local Variables + real( kind = core_rknd ) :: esatv + + ! --- Begin Code --- + + ! Calculate the SVP for water vapor. + esatv = sat_vapor_press_liq( T_in_K ) + + ! If esatv exceeds the air pressure, then assume esatv~=0.5*pressure + ! and set rsat = ep = 0.622 + if ( p_in_Pa-esatv < 1.0_core_rknd ) then + sat_mixrat_liq = ep + else + +#ifdef GFDL + + ! GFDL uses specific humidity + ! Formula for Saturation Specific Humidity + if ( I_sat_sphum ) then ! h1g, 2010-06-18 begin mod + sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - (1.0_core_rknd-ep) * esatv ) ) + else + sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - esatv ) ) + endif ! h1g, 2010-06-18 end mod +#else + ! Formula for Saturation Mixing Ratio: + ! + ! rs = (epsilon) * [ esat / ( p - esat ) ]; + ! where epsilon = R_d / R_v + sat_mixrat_liq = ep * ( esatv / ( p_in_Pa - esatv ) ) +#endif + + end if + + return + end function sat_mixrat_liq + +!------------------------------------------------------------------------- + elemental real( kind = core_rknd ) function sat_mixrat_liq_lookup( p_in_Pa, T_in_K ) + +! Description: +! Used to compute the saturation mixing ratio of liquid water. +! This function utilizes sat_vapor_press_liq_lookup; the SVP is found +! using a lookup table rather than calculating it using various +! approximations. + +! References: +! Formula from Emanuel 1994, 4.4.14 +!------------------------------------------------------------------------- + + use constants_clubb, only: & + ep ! Variable + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + p_in_Pa, & ! Pressure [Pa] + T_in_K ! Temperature [K] + + ! Local Variables + real( kind = core_rknd ) :: esatv + + ! --- Begin Code --- + + ! Calculate the SVP for water vapor using a lookup table. + esatv = sat_vapor_press_liq_lookup( T_in_K ) + + ! If esatv exceeds the air pressure, then assume esatv~=0.5*pressure + ! and set rsat = ep = 0.622 + if ( p_in_Pa-esatv < 1.0_core_rknd ) then + sat_mixrat_liq_lookup = ep + else + +#ifdef GFDL + + ! GFDL uses specific humidity + ! Formula for Saturation Specific Humidity + if( I_sat_sphum ) then ! h1g, 2010-06-18 begin mod + sat_mixrat_liq_lookup = ep * ( esatv / ( p_in_Pa - (1.0_core_rknd-ep) * esatv ) ) + else + sat_mixrat_liq_lookup = ep * ( esatv / ( p_in_Pa - esatv ) ) + endif ! h1g, 2010-06-18 end mod +#else + ! Formula for Saturation Mixing Ratio: + ! + ! rs = (epsilon) * [ esat / ( p - esat ) ]; + ! where epsilon = R_d / R_v + sat_mixrat_liq_lookup = ep * ( esatv / ( p_in_Pa - esatv ) ) +#endif + + end if + + return + end function sat_mixrat_liq_lookup + +!----------------------------------------------------------------- + elemental function sat_vapor_press_liq( T_in_K ) result ( esat ) + +! Description: +! Computes SVP for water vapor. Calls one of the other functions +! that calculate an approximation to SVP. + +! References: +! None + + use model_flags, only: & + saturation_formula, & ! Variable + saturation_bolton, & + saturation_gfdl, & + saturation_flatau + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esat ! Saturation Vapor Pressure over Water [Pa] + + ! Undefined approximation + esat = -99999.999_core_rknd + + ! Saturation Vapor Pressure, esat, can be found to be approximated + ! in many different ways. + select case ( saturation_formula ) + case ( saturation_bolton ) + ! Using the Bolton 1980 approximations for SVP over vapor + esat = sat_vapor_press_liq_bolton( T_in_K ) + + case ( saturation_flatau ) + ! Using the Flatau, et al. polynomial approximation for SVP over vapor + esat = sat_vapor_press_liq_flatau( T_in_K ) + +! ---> h1g + case ( saturation_gfdl ) + ! Using GFDL polynomial approximation for SVP with respect to liquid + esat = sat_vapor_press_liq_gfdl( T_in_K ) +! <--- h1g + + ! Add new cases after this + + end select + + return + + end function sat_vapor_press_liq + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_liq_lookup( T_in_K ) result ( esat ) + +! Description: +! Computes SVP for water vapor, using a lookup table. +! +! The lookup table was constructed using the Flatau approximation. + +! References: +! ``Polynomial Fits to Saturation Vapor Pressure'' Falatau, Walko, +! and Cotton. (1992) Journal of Applied Meteorology, Vol. 31, +! pp. 1507--1513 +!------------------------------------------------------------------------ + + implicit none + + ! External + intrinsic :: max, min, int, anint + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esat ! Saturation vapor pressure over water [Pa] + + ! Local Variables + integer :: T_in_K_int + + ! ---- Begin Code ---- + + T_in_K_int = int( anint( T_in_K ) ) + + ! Since this approximation is only good out to -85 degrees Celsius we + ! truncate the result here + T_in_K_int = min( max( T_in_K_int, 188 ), 343 ) + + ! Use the lookup table to determine the saturation vapor pressure. + esat = svp_liq_lookup_table( T_in_K_int ) + + return + end function sat_vapor_press_liq_lookup + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_liq_flatau( T_in_K ) result ( esat ) + +! Description: +! Computes SVP for water vapor. + +! References: +! ``Polynomial Fits to Saturation Vapor Pressure'' Falatau, Walko, +! and Cotton. (1992) Journal of Applied Meteorology, Vol. 31, +! pp. 1507--1513 +!------------------------------------------------------------------------ + + use constants_clubb, only: T_freeze_K + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Constant parameters + + ! Relative error norm expansion (-50 to 50 deg_C) from + ! Table 3 of pp. 1510 of Flatau et al. 1992 (Water Vapor) + ! (The 100 coefficient converts from mb to Pa) +! real, dimension(7), parameter :: a = & +! 100.* (/ 6.11176750, 0.443986062, 0.143053301E-01, & +! 0.265027242E-03, 0.302246994E-05, 0.203886313E-07, & +! 0.638780966E-10 /) + + ! Relative error norm expansion (-85 to 70 deg_C) from + ! Table 4 of pp. 1511 of Flatau et al. + real( kind = core_rknd ), dimension(9), parameter :: a = & + 100._core_rknd * & + (/ 6.11583699_core_rknd, 0.444606896_core_rknd, 0.143177157E-01_core_rknd, & + 0.264224321E-03_core_rknd, 0.299291081E-05_core_rknd, 0.203154182E-07_core_rknd, & + 0.702620698E-10_core_rknd, 0.379534310E-13_core_rknd,-0.321582393E-15_core_rknd /) + + real( kind = core_rknd ), parameter :: min_T_in_C = -85._core_rknd ! [deg_C] + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esat ! Saturation vapor pressure over water [Pa] + + ! Local Variables + real( kind = core_rknd ) :: T_in_C +! integer :: i ! Loop index + + ! ---- Begin Code ---- + + ! Determine deg K - 273.15 + T_in_C = T_in_K - T_freeze_K + + ! Since this approximation is only good out to -85 degrees Celsius we + ! truncate the result here (Flatau, et al. 1992) + T_in_C = max( T_in_C, min_T_in_C ) + + ! Polynomial approx. (Flatau, et al. 1992) + + ! This is the generalized formula but is not computationally efficient. + ! Based on Wexler's expressions(2.1)-(2.4) (See Flatau et al. p 1508) + ! e_{sat} = a_1 + a_2 ( T - T_0 ) + ... + a_{n+1} ( T - T_0 )^n + +! esat = a(1) + +! do i = 2, size( a ) , 1 +! esat = esat + a(i) * ( T_in_C )**(i-1) +! end do + + ! The 8th order polynomial fit. When running deep + ! convective cases I noticed that absolute temperature often dips below + ! -50 deg_C at higher altitudes, where the 6th order approximation is + ! not accurate. -dschanen 20 Nov 2008 + esat = a(1) + T_in_C*( a(2) + T_in_C*( a(3) + T_in_C*( a(4) + T_in_C & + *( a(5) + T_in_C*( a(6) + T_in_C*( a(7) + T_in_C*( a(8) + T_in_C*( a(9) ) ) ) ) ) ) ) ) + + return + end function sat_vapor_press_liq_flatau + + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_liq_bolton( T_in_K ) result ( esat ) +! Description: +! Computes SVP for water vapor. +! References: +! Bolton 1980 +!------------------------------------------------------------------------ + + use constants_clubb, only: T_freeze_K + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: exp + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esat ! Saturation vapor pressure over water [Pa] + + ! (Bolton 1980) approx. + ! Generally this more computationally expensive than the Flatau polnomial expansion + esat = 611.2_core_rknd * exp( (17.67_core_rknd*(T_in_K-T_freeze_K)) / & + (T_in_K-29.65_core_rknd) ) ! Known magic number + + return + end function sat_vapor_press_liq_bolton + + +! ---> h1g, 2010-06-16 +!------------------------------------------------------------------------ + elemental function sat_vapor_press_liq_gfdl( T_in_K ) result ( esat ) +! Description: +! copy from "GFDL polysvp.F90" +! Compute saturation vapor pressure with respect to liquid by using +! function from Goff and Gratch (1946) + +! Polysvp returned in units of pa. +! T_in_K is input in units of K. +!------------------------------------------------------------------------ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Absolute temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esat ! Saturation vapor pressure over water [Pa] + + ! Local Variables + real( kind = core_rknd ), parameter :: & + min_T_in_K = 203.15_core_rknd ! Lowest temperature at which Goff-Gratch is valid [K] + + real( kind = core_rknd ) :: & + T_in_K_clipped ! Absolute temperature with minimum threshold applied [K] + + ! Since the Goff-Gratch approximation is valid only down to -70 degrees Celsius, + ! we threshold the temperature. This will yield a minimal saturation at + ! cold temperatures. + T_in_K_clipped = max( min_T_in_K, T_in_K ) + + ! Goff Gratch equation, uncertain below -70 C + + esat = 10._core_rknd**(-7.90298_core_rknd*(373.16_core_rknd/T_in_K_clipped-1._core_rknd)+ & + 5.02808_core_rknd*log10(373.16_core_rknd/T_in_K_clipped)- & + 1.3816e-7_core_rknd*(10._core_rknd**(11.344_core_rknd & + *(1._core_rknd-T_in_K_clipped/373.16_core_rknd))-1._core_rknd)+ & + 8.1328e-3_core_rknd*(10._core_rknd**(-3.49149_core_rknd & + *(373.16_core_rknd/T_in_K_clipped-1._core_rknd))-1._core_rknd)+ & + log10(1013.246_core_rknd))*100._core_rknd ! Known magic number + + return + end function sat_vapor_press_liq_gfdl +! <--- h1g, 2010-06-16 + +!------------------------------------------------------------------------ + elemental real( kind = core_rknd ) function sat_mixrat_ice( p_in_Pa, T_in_K ) + +! Description: +! Used to compute the saturation mixing ratio of ice. + +! References: +! Formula from Emanuel 1994, 4.4.15 +!------------------------------------------------------------------------- + + use constants_clubb, only: & + ep ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: trim + + ! Input Variables + + real( kind = core_rknd ), intent(in) :: & + p_in_Pa, & ! Pressure [Pa] + T_in_K ! Temperature [K] + + ! Local Variables + + real( kind = core_rknd ) :: esat_ice + + ! --- Begin Code --- + + ! Determine the SVP for the given temperature + esat_ice = sat_vapor_press_ice( T_in_K ) + + ! If esat_ice exceeds the air pressure, then assume esat_ice~=0.5*pressure + ! and set rsat = ep = 0.622 + if ( p_in_Pa-esat_ice < 1.0_core_rknd ) then + sat_mixrat_ice = ep + else + +#ifdef GFDL + ! GFDL uses specific humidity + ! Formula for Saturation Specific Humidity + if( I_sat_sphum ) then ! h1g, 2010-06-18 begin mod + sat_mixrat_ice = ep * ( esat_ice / ( p_in_Pa - (1.0_core_rknd-ep) * esat_ice ) ) + else + sat_mixrat_ice = ep * ( esat_ice / ( p_in_Pa - esat_ice ) ) + endif ! h1g, 2010-06-18 end mod +#else + ! Formula for Saturation Mixing Ratio: + ! + ! rs = (epsilon) * [ esat / ( p - esat ) ]; + ! where epsilon = R_d / R_v + + sat_mixrat_ice = ep * ( esat_ice / ( p_in_Pa - esat_ice ) ) +#endif + + end if + + return + end function sat_mixrat_ice + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_ice( T_in_K ) result ( esat_ice ) +! +! Description: +! Computes SVP for ice, using one of the various approximations. +! +! References: +! None +!------------------------------------------------------------------------ + + use model_flags, only: & + saturation_formula, & ! Variable(s) + saturation_bolton, & + saturation_gfdl, & + saturation_flatau + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable + real( kind = core_rknd ), intent(in) :: & + T_in_K ! Temperature [K] + + ! Output Variable + real( kind = core_rknd ) :: esat_ice ! Saturation Vapor Pressure over Ice [Pa] + + ! Undefined approximation + esat_ice = -99999.999_core_rknd + + select case ( saturation_formula ) + case ( saturation_bolton ) + ! Using the Bolton 1980 approximations for SVP over ice + esat_ice = sat_vapor_press_ice_bolton( T_in_K ) + + case ( saturation_flatau ) + ! Using the Flatau, et al. polynomial approximation for SVP over ice + esat_ice = sat_vapor_press_ice_flatau( T_in_K ) + +! ---> h1g, 2010-06-16 + case ( saturation_gfdl ) + ! Using GFDL polynomial approximation for SVP with respect to ice + esat_ice = sat_vapor_press_ice_gfdl( T_in_K ) +! <--- h1g, 2010-06-16 + + ! Add new cases after this + + end select + + return + + end function sat_vapor_press_ice + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_ice_flatau( T_in_K ) result ( esati ) +! +! Description: +! Computes SVP for ice. +! +! References: +! ``Polynomial Fits to Saturation Vapor Pressure'' Falatau, Walko, +! and Cotton. (1992) Journal of Applied Meteorology, Vol. 31, +! pp. 1507--1513 +!------------------------------------------------------------------------ + use constants_clubb, only: T_freeze_K + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: max + + ! Relative error norm expansion (-90 to 0 deg_C) from + ! Table 4 of pp. 1511 of Flatau et al. 1992 (Ice) + real( kind = core_rknd ), dimension(9), parameter :: a = & + 100._core_rknd * (/ 6.09868993_core_rknd, 0.499320233_core_rknd, 0.184672631E-01_core_rknd, & + 0.402737184E-03_core_rknd, 0.565392987E-05_core_rknd, 0.521693933E-07_core_rknd, & + 0.307839583E-09_core_rknd, 0.105785160E-11_core_rknd, 0.161444444E-14_core_rknd /) + + real( kind = core_rknd ), parameter :: min_T_in_C = -90._core_rknd ! [deg_C] + + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [deg_K] + + ! Output Variables + real( kind = core_rknd ) :: esati ! Saturation vapor pressure over ice [Pa] + + ! Local Variables + real( kind = core_rknd ) :: T_in_C ! Temperature [deg_C] +! integer :: i + + ! ---- Begin Code ---- + + ! Determine deg K - 273.15 + T_in_C = T_in_K - T_freeze_K + + ! Since this approximation is only good out to -90 degrees Celsius we + ! truncate the result here (Flatau, et al. 1992) + T_in_C = max( T_in_C, min_T_in_C ) + + ! Polynomial approx. (Flatau, et al. 1992) +! esati = a(1) + +! do i = 2, size( a ), 1 +! esati = esati + a(i) * ( T_in_C )**(i-1) +! end do + + esati = a(1) + T_in_C*( a(2) + T_in_C*( a(3) + T_in_C*( a(4) + T_in_C & + *( a(5) + T_in_C*( a(6) + T_in_C*( a(7) + T_in_C*( a(8) + T_in_C*( a(9) ) ) ) ) ) ) ) ) + + return + + end function sat_vapor_press_ice_flatau + +!------------------------------------------------------------------------ + elemental function sat_vapor_press_ice_bolton( T_in_K ) result ( esati ) +! +! Description: +! Computes SVP for ice. +! +! References: +! Bolton 1980 +!------------------------------------------------------------------------ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: exp, log + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esati ! Saturation vapor pressure over ice [Pa] + + ! Exponential approx. + esati = 100.0_core_rknd * exp( 23.33086_core_rknd - & + (6111.72784_core_rknd/T_in_K) + (0.15215_core_rknd*log( T_in_K )) ) + + return + + end function sat_vapor_press_ice_bolton + + +! ---> h1g, 2010-06-16 +!------------------------------------------------------------------------ + elemental function sat_vapor_press_ice_gfdl( T_in_K ) result ( esati ) +! Description: +! copy from "GFDL polysvp.F90" +! Compute saturation vapor pressure with respect to liquid by using +! function from Goff and Gratch (1946) +! +! Polysvp returned in units of pa. +! T_in_K is input in units of K. +!------------------------------------------------------------------------ + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: T_in_K ! Absolute temperature [K] + + ! Output Variables + real( kind = core_rknd ) :: esati ! Saturation vapor pressure over ice [Pa] + + ! Local Variables + real( kind = core_rknd ), parameter :: & + min_T_in_K = 173.15_core_rknd ! Lowest temperature at which Goff-Gratch is valid [K] + + real( kind = core_rknd ) :: & + T_in_K_clipped ! Absolute temperature with minimum threshold applied [K] + + ! Since the Goff-Gratch ice approximation is valid only down to -100 degrees Celsius, + ! we threshold the temperature. This will yield a minimal saturation at + ! cold temperatures. + T_in_K_clipped = max( min_T_in_K, T_in_K ) + + ! Goff Gratch equation (good down to -100 C) + + esati = 10._core_rknd**(-9.09718_core_rknd* & + (273.16_core_rknd/T_in_K_clipped-1._core_rknd)-3.56654_core_rknd* & + log10(273.16_core_rknd/T_in_K_clipped)+0.876793_core_rknd* & + (1._core_rknd-T_in_K_clipped/273.16_core_rknd)+ & + log10(6.1071_core_rknd))*100._core_rknd ! Known magic number + + return + + end function sat_vapor_press_ice_gfdl +! <--- h1g, 2010-06-16 + +!------------------------------------------------------------------------- + function rcm_sat_adj( thlm, rtm, p_in_Pa, exner ) result ( rcm ) + + ! Description: + ! + ! This function uses an iterative method to find the value of rcm + ! from an initial profile that has saturation at some point. + ! + ! References: + ! None + !------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use constants_clubb, only: & + Cp, & ! Variable(s) + Lv, & + zero_threshold + + implicit none + + ! Local Constant(s) + real( kind = core_rknd ), parameter :: & + tolerance = 0.001_core_rknd ! Tolerance on theta calculation [K] + + integer, parameter :: & + itermax = 1000000 ! Maximum interations + + ! External + intrinsic :: max, abs + + ! Input Variable(s) + real( kind = core_rknd ), intent(in) :: & + thlm, & ! Liquid Water Potential Temperature [K] + rtm, & ! Total Water Mixing Ratio [kg/kg] + p_in_Pa, & ! Pressure [Pa] + exner ! Exner function [-] + + ! Output Variable(s) + real( kind = core_rknd ) :: rcm ! Cloud water mixing ratio [kg/kg] + + ! Local Variable(s) + real( kind = core_rknd ) :: & + theta, answer, too_low, too_high ! [K] + + integer :: iteration + + ! ----- Begin Code ----- + + ! Default initialization + theta = thlm + too_high = 0.0_core_rknd + too_low = 0.0_core_rknd + + do iteration = 1, itermax, 1 + + answer = & + theta - (Lv/(Cp*exner)) & + *(MAX( rtm - sat_mixrat_liq(p_in_Pa,theta*exner), zero_threshold )) + + if ( ABS(answer - thlm) <= tolerance ) then + exit + else if ( answer - thlm > tolerance ) then + too_high = theta + else if ( thlm - answer > tolerance ) THEN + too_low = theta + end if + + ! For the first timestep, be sure to set a "too_high" + ! that is "way too high." + if ( iteration == 1 ) then + too_high = theta + 20.0_core_rknd + end if + + theta = (too_low + too_high)/2.0_core_rknd + + end do ! 1..itermax + + if ( iteration == itermax ) then + ! Magic Eric Raut added to remove compiler warning (clearly this value is not used) + rcm = 0.0_core_rknd + + stop "Error in rcm_sat_adj: could not determine rcm" + else + rcm = MAX( rtm - sat_mixrat_liq( p_in_Pa, theta*exner), zero_threshold ) + return + end if + + end function rcm_sat_adj + +end module saturation diff --git a/src/physics/clubb/setup_clubb_pdf_params.F90 b/src/physics/clubb/setup_clubb_pdf_params.F90 new file mode 100644 index 0000000000..c77401c74a --- /dev/null +++ b/src/physics/clubb/setup_clubb_pdf_params.F90 @@ -0,0 +1,4039 @@ +!------------------------------------------------------------------------- +! $Id: setup_clubb_pdf_params.F90 7379 2014-11-11 05:32:53Z bmg2@uwm.edu $ +!=============================================================================== +module setup_clubb_pdf_params + + implicit none + + private + + public :: setup_pdf_parameters, & + compute_mean_stdev, & + calc_comp_mu_sigma_hm, & + norm_transform_mean_stdev, & + comp_corr_norm, & + denorm_transform_corr + + private :: calc_mu_sigma_two_comps, & + component_corr_w_x, & + component_corr_chi_eta, & + component_corr_w_hm_n_ip, & + component_corr_x_hm_n_ip, & + component_corr_hmx_hmy_n_ip, & + component_corr_eta_hm_n_ip, & + calc_corr_w_hm_n, & + pdf_param_hm_stats, & + pdf_param_ln_hm_stats, & + pack_pdf_params, & + compute_rtp2_from_chi + + ! Prescribed parameters are set to in-cloud or outside-cloud (below-cloud) + ! values based on whether or not cloud water mixing ratio has a value of at + ! least rc_tol. However, this does not take into account the amount of + ! cloudiness in a component, just whether or not there is any cloud in the + ! component. The option l_interp_prescribed_params allows for an interpolated + ! value between the in-cloud and below-cloud parameter value based on the + ! component cloud fraction. + logical, parameter, private :: & + l_interp_prescribed_params = .false. + + contains + + !============================================================================= + subroutine setup_pdf_parameters( nz, d_variables, dt, & ! Intent(in) + Nc_in_cloud, rcm, cloud_frac, & ! Intent(in) + ice_supersat_frac, hydromet, wphydrometp, & ! Intent(in) + corr_array_n_cloud, corr_array_n_below, & ! Intent(in) + pdf_params, l_stats_samp, & ! Intent(in) + hydrometp2, & ! Intent(inout) + mu_x_1_n, mu_x_2_n, & ! Intent(out) + sigma_x_1_n, sigma_x_2_n, & ! Intent(out) + corr_array_1_n, corr_array_2_n, & ! Intent(out) + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Intent(out) + hydromet_pdf_params ) ! Intent(out) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use grid_class, only: & + gr, & ! Variable(s) + zm2zt, & ! Procedure(s) + zt2zm + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + rc_tol, & + Ncn_tol, & + cloud_frac_min, & + fstderr, & + zero_threshold + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) + + use hydromet_pdf_parameter_module, only: & + hydromet_pdf_parameter, & ! Type + init_hydromet_pdf_params ! Procedure + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use model_flags, only: & + l_use_precip_frac, & ! Flag(s) + l_calc_w_corr + + use array_index, only: & + hydromet_list, & ! Variable(s) + hydromet_tol + + use model_flags, only: & + l_const_Nc_in_cloud ! Flag(s) + + use precipitation_fraction, only: & + precip_fraction + + use Nc_Ncn_eqns, only: & + Nc_in_cloud_to_Ncnm ! Procedure(s) + + use advance_windm_edsclrm_module, only: & + xpwp_fnc + + use variables_diagnostic_module, only: & + Kh_zm + + use parameters_tunable, only: & + c_K_hm + + use pdf_utilities, only: & + calc_xp2, & ! Procedure(s) + compute_mean_binormal, & + compute_variance_binormal, & + stdev_L2N, & + corr_NN2NL + + use clip_explicit, only: & + clip_covar_level, & ! Procedure(s) + clip_wphydrometp ! Variables(s) + + use clubb_precision, only: & + core_rknd, & ! Variable(s) + dp + + use matrix_operations, only: & + Cholesky_factor, & ! Procedure(s) + mirror_lower_triangular_matrix + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use stats_variables, only: & + iprecip_frac, & ! Variable(s) + iprecip_frac_1, & + iprecip_frac_2, & + iNcnm, & + ihmp2_zt, & + irtp2_from_chi, & + stats_zt, & + stats_zm + + use model_flags, only: & + l_diagnose_correlations ! Variable(s) + + use diagnose_correlations_module, only: & + diagnose_correlations, & ! Procedure(s) + calc_cholesky_corr_mtx_approx + + use corr_varnce_module, only: & + assert_corr_symmetric, & ! Procedure(s) + iiPDF_Ncn, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + hmp2_ip_on_hmm2_ip, & + Ncnp2_on_Ncnm2 + + use error_code, only : & + clubb_at_least_debug_level ! Procedure(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + nz, & ! Number of model vertical grid levels + d_variables ! Number of variables in the correlation array + + real( kind = core_rknd ), intent(in) :: & + dt ! Model timestep [s] + + real( kind = core_rknd ), dimension(nz), intent(in) :: & + Nc_in_cloud, & ! Mean (in-cloud) cloud droplet conc. [num/kg] + rcm, & ! Mean cloud water mixing ratio, < r_c > [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac ! Ice supersaturation fraction [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(in) :: & + hydromet, & ! Mean of hydrometeor, hm (overall) (t-levs.) [units] + wphydrometp ! Covariance < w'h_m' > (momentum levels) [(m/s)units] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_n_cloud, & ! Prescribed normal space corr. array in cloud [-] + corr_array_n_below ! Prescribed normal space corr. array below cl. [-] + + type(pdf_parameter), dimension(nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + logical, intent(in) :: & + l_stats_samp ! Flag to sample statistics + + ! Input/Output Variables + real( kind = core_rknd ), dimension(nz,hydromet_dim), intent(inout) :: & + hydrometp2 ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, nz), intent(out) :: & + mu_x_1_n, & ! Mean array (normal space): PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normal space): PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normal space) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normal space) of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables,d_variables,nz), & + intent(out) :: & + corr_cholesky_mtx_1, & ! Transposed corr. cholesky matrix, 1st comp. [-] + corr_cholesky_mtx_2 ! Transposed corr. cholesky matrix, 2nd comp. [-] + + type(hydromet_pdf_parameter), dimension(nz), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + ! Local Variables + + real( kind = core_rknd ), dimension(d_variables,d_variables) :: & + corr_mtx_approx_1, & ! Approximated corr. matrix (C = LL'), 1st comp. [-] + corr_mtx_approx_2 ! Approximated corr. matrix (C = LL'), 2nd comp. [-] + + real( kind = core_rknd ), dimension(nz) :: & + mu_w_1, & ! Mean of w (1st PDF component) [m/s] + mu_w_2, & ! Mean of w (2nd PDF component) [m/s] + mu_chi_1, & ! Mean of chi (old s) (1st PDF component) [kg/kg] + mu_chi_2, & ! Mean of chi (old s) (2nd PDF component) [kg/kg] + sigma_w_1, & ! Standard deviation of w (1st PDF component) [m/s] + sigma_w_2, & ! Standard deviation of w (2nd PDF component) [m/s] + sigma_chi_1, & ! Standard deviation of chi (1st PDF component) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF component) [kg/kg] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + mixt_frac ! Mixture fraction [-] + + real( kind = core_rknd ), dimension(nz) :: & + ice_supersat_frac_1, & ! Ice supersaturation fraction (1st PDF comp.) [-] + ice_supersat_frac_2 ! Ice supersaturation fraction (2nd PDF comp.) [-] + + real( kind = core_rknd ), dimension(nz) :: & + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + real( kind = core_rknd ), dimension(nz) :: & + wpchip_zm, & ! Covariance of chi and w (momentum levels) [(m/s)(kg/kg)] + wpNcnp_zm, & ! Covariance of N_cn and w (momentum levs.) [(m/s)(num/kg)] + wpchip_zt, & ! Covariance of chi and w on t-levs [(m/s)(kg/kg)] + wpNcnp_zt ! Covariance of N_cn and w on t-levs [(m/s)(num/kg)] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + hm_1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + hydrometp2_zt, & ! Variance of a hydrometeor (overall); t-lev [units^2] + wphydrometp_zt ! Covariance of w and hm interp. to t-levs. [(m/s)units] + + real( kind = core_rknd ), dimension(nz) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), dimension(d_variables,d_variables) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), dimension(d_variables) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables) :: & + corr_array_scaling + + real( kind = core_rknd ), dimension(d_variables) :: & + sigma2_on_mu2_ip_1, & ! Ratio array sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Ratio array sigma_hm_2^2/mu_hm_2^2 [-] + + real( kind = core_rknd ) :: & + const_Ncnp2_on_Ncnm2, & ! Prescribed ratio of to ^2 [-] + const_corr_chi_Ncn, & ! Prescribed correlation of chi (old s) & Ncn [-] + precip_frac_tol ! Min. precip. frac. when hydromet. present [-] + + real( kind = core_rknd ), dimension(nz,hydromet_dim) :: & + wphydrometp_chnge ! Change in wphydrometp_zt: covar. clip. [(m/s)units] + + real( kind = core_rknd ), dimension(nz) :: & + wm_zt, & ! Mean vertical velocity, , on thermo. levels [m/s] + wp2_zt ! Variance of w, (interp. to t-levs.) [m^2/s^2] + + real( kind = core_rknd ), dimension(nz) :: & + rtp2_zt_from_chi + + logical :: l_corr_array_scaling + + ! Flags used for covariance clipping of . + logical, parameter :: & + l_first_clip_ts = .true., & ! First instance of clipping in a timestep. + l_last_clip_ts = .true. ! Last instance of clipping in a timestep. + + character(len=10) :: & + hydromet_name ! Name of a hydrometeor + + integer :: k, i ! Loop indices + + ! ---- Begin Code ---- + + ! Assertion check + ! Check that all hydrometeors are positive otherwise exit the program + if ( clubb_at_least_debug_level( 2 ) ) then + do i = 1, hydromet_dim + if ( any( hydromet(:,i) < zero_threshold ) ) then + hydromet_name = hydromet_list(i) + do k = 1, nz + if ( hydromet(k,i) < zero_threshold ) then + + ! Write error message + write(fstderr,*) trim( hydromet_name )//" = ", & + hydromet(k,i), " < ", zero_threshold, & + " at beginning of setup_pdf_parameters" & + //" at k = ", k + + ! Exit program + stop "Exiting..." + + endif ! hydromet(k,i) < 0 + enddo ! k = 1, nz + endif ! hydromet(:,i) < 0 + enddo ! i = 1, hydromet_dim + + endif !clubb_at_least_debug_level( 2 ) + + ! Setup some of the PDF parameters + mu_w_1 = pdf_params%w_1 + mu_w_2 = pdf_params%w_2 + mu_chi_1 = pdf_params%chi_1 + mu_chi_2 = pdf_params%chi_2 + sigma_w_1 = sqrt( pdf_params%varnce_w_1 ) + sigma_w_2 = sqrt( pdf_params%varnce_w_2 ) + sigma_chi_1 = pdf_params%stdev_chi_1 + sigma_chi_2 = pdf_params%stdev_chi_2 + rc_1 = pdf_params%rc_1 + rc_2 = pdf_params%rc_2 + cloud_frac_1 = pdf_params%cloud_frac_1 + cloud_frac_2 = pdf_params%cloud_frac_2 + mixt_frac = pdf_params%mixt_frac + + ice_supersat_frac_1 = pdf_params%ice_supersat_frac_1 + ice_supersat_frac_2 = pdf_params%ice_supersat_frac_2 + + ! Recalculate wm_zt and wp2_zt. Mean vertical velocity may not be easy to + ! pass into this subroutine from a host model, and wp2_zt needs to have a + ! value consistent with the value it had when the PDF parameters involving w + ! were originally set in subroutine pdf_closure. The variable wp2 has since + ! been advanced, resulting a new wp2_zt. However, the value of wp2 here + ! needs to be consistent with wp2 at the time the PDF parameters were + ! calculated. + do k = 1, nz, 1 + + ! Calculate the overall mean of vertical velocity, w, on thermodynamic + ! levels. + wm_zt(k) = compute_mean_binormal( mu_w_1(k), mu_w_2(k), mixt_frac(k) ) + + ! Calculate the overall variance of vertical velocity on thermodynamic + ! levels. + wp2_zt(k) = compute_variance_binormal( wm_zt(k), mu_w_1(k), mu_w_2(k), & + sigma_w_1(k), sigma_w_2(k), & + mixt_frac(k) ) + + enddo + + ! Note on hydrometeor PDF shape: + ! To use a single lognormal over the entire grid level, turn off the + ! l_use_precip_frac flag and set omicron to 1 and zeta_vrnce_rat to 0 in + ! tunable_parameters.in. + ! To use a single delta-lognormal (single lognormal in-precip.), enable the + ! l_use_precip_frac flag and set omicron to 1 and zeta_vrnce_rat to 0 in + ! tunable_parameters.in. + ! Otherwise, with l_use_precip_frac enabled and omicron and zeta_vrnce_rat + ! values that are not 1 and 0, respectively, the PDF shape is a double + ! delta-lognormal (two independent lognormals in-precip.). + + ! Calculate precipitation fraction. + if ( l_use_precip_frac ) then + + call precip_fraction( nz, hydromet, cloud_frac, cloud_frac_1, & ! In + cloud_frac_2, ice_supersat_frac, & ! In + ice_supersat_frac_1, ice_supersat_frac_2, & ! In + mixt_frac, l_stats_samp, & ! In + precip_frac, precip_frac_1, precip_frac_2, & ! Out + precip_frac_tol ) ! Out + + else + + precip_frac = one + precip_frac_1 = one + precip_frac_2 = one + precip_frac_tol = cloud_frac_min + + endif + + ! Calculate from Nc_in_cloud, whether Nc_in_cloud is predicted or + ! based on a prescribed value, and whether the value is constant or varying + ! over the grid level. + if ( .not. l_const_Nc_in_cloud ) then + ! Ncn varies at each vertical level. + const_Ncnp2_on_Ncnm2 = Ncnp2_on_Ncnm2 + else ! l_const_Nc_in_cloud + ! Ncn is constant at each vertical level. + const_Ncnp2_on_Ncnm2 = zero + endif + + const_corr_chi_Ncn = corr_NN2NL( corr_array_n_cloud(iiPDF_Ncn, iiPDF_chi), & + stdev_L2N( const_Ncnp2_on_Ncnm2 ), & + const_Ncnp2_on_Ncnm2 ) + + do k = 2, nz + + Ncnm(k) & + = Nc_in_cloud_to_Ncnm( mu_chi_1(k), mu_chi_2(k), sigma_chi_1(k), & + sigma_chi_2(k), mixt_frac(k), Nc_in_cloud(k), & + cloud_frac_1(k), cloud_frac_2(k), & + const_Ncnp2_on_Ncnm2, const_corr_chi_Ncn ) + + enddo ! k = 2, nz + + ! Boundary Condition. + ! At thermodynamic level k = 1, which is below the model lower boundary, the + ! value of Ncnm does not matter. + Ncnm(1) = Nc_in_cloud(1) + + ! Calculate the overall variance of a precipitating hydrometeor (hm), + !. + do i = 1, hydromet_dim, 1 + + do k = 1, nz, 1 + if ( hydromet(k,i) >= hydromet_tol(i) ) then + ! There is some of the hydrometeor species found at level k. + ! Calculate the variance (overall) of the hydrometeor. + hydrometp2_zt(k,i) & + = ( ( hmp2_ip_on_hmm2_ip(i) + one ) / precip_frac(k) - one ) & + * hydromet(k,i)**2 + else + hydrometp2_zt(k,i) = zero + endif + enddo ! k = 1, nz, 1 + + ! Statistics + if ( l_stats_samp ) then + if ( ihmp2_zt(i) > 0 ) then + ! Variance (overall) of the hydrometeor, . + call stat_update_var( ihmp2_zt(i), hydrometp2_zt(:,i), stats_zt ) + endif + endif ! l_stats_samp + + ! Interpolate the covariances (overall) of w and precipitating + ! hydrometeors to thermodynamic grid levels. + wphydrometp_zt(:,i) = zm2zt( wphydrometp(:,i) ) + + ! When the mean value of a precipitating hydrometeor is below tolerance + ! value, it is considered to have a value of 0, and the precipitating + ! hydrometeor does not vary over the grid level. Any covariances + ! involving that precipitating hydrometeor also have values of 0 at that + ! grid level. + do k = 1, nz, 1 + + if ( hydromet(k,i) < hydromet_tol(i) ) then + wphydrometp_zt(k,i) = zero + endif + + ! Clip the value of covariance on thermodynamic levels. + call clip_covar_level( clip_wphydrometp, k, l_first_clip_ts, & + l_last_clip_ts, dt, wp2_zt(k), & + hydrometp2_zt(k,i), & + wphydrometp_zt(k,i), wphydrometp_chnge(k,i) ) + + enddo ! k = 1, nz, 1 + + enddo ! i = 1, hydromet_dim, 1 + + ! Calculate correlations involving w by first calculating total covariances + ! involving w (, etc.) using the down-gradient approximation. + if ( l_calc_w_corr ) then + + ! Calculate the covariances of w with the hydrometeors + do k = 1, nz + wpchip_zm(k) = pdf_params(k)%mixt_frac & + * ( one - pdf_params(k)%mixt_frac ) & + * ( pdf_params(k)%chi_1 - pdf_params(k)%chi_2 ) & + * ( pdf_params(k)%w_1 - pdf_params(k)%w_2 ) + enddo + + wpNcnp_zm(1:nz-1) = xpwp_fnc( -c_K_hm * Kh_zm(1:nz-1), Ncnm(1:nz-1), & + Ncnm(2:nz), gr%invrs_dzm(1:nz-1) ) + + ! Boundary conditions; We are assuming zero flux at the top. + wpNcnp_zm(nz) = zero + + ! Interpolate the covariances to thermodynamic grid levels. + wpchip_zt = zm2zt( wpchip_zm ) + wpNcnp_zt = zm2zt( wpNcnp_zm ) + + ! When the mean value of Ncn is below tolerance value, it is considered + ! to have a value of 0, and Ncn does not vary over the grid level. Any + ! covariance involving Ncn also has a value of 0 at that grid level. + do k = 1, nz, 1 + if ( Ncnm(k) <= Ncn_tol ) then + wpNcnp_zt(k) = zero + endif + enddo ! k = 1, nz, 1 + + endif ! l_calc_w_corr + + ! Statistics + if ( l_stats_samp ) then + + if ( iprecip_frac > 0 ) then + ! Overall precipitation fraction. + call stat_update_var( iprecip_frac, precip_frac, stats_zt ) + endif + + if ( iprecip_frac_1 > 0 ) then + ! Precipitation fraction in PDF component 1. + call stat_update_var( iprecip_frac_1, precip_frac_1, stats_zt ) + endif + + if ( iprecip_frac_2 > 0 ) then + ! Precipitation fraction in PDF component 2. + call stat_update_var( iprecip_frac_2, precip_frac_2, stats_zt ) + endif + + if ( iNcnm > 0 ) then + ! Mean simplified cloud nuclei concentration (overall). + call stat_update_var( iNcnm, Ncnm, stats_zt ) + endif + + endif + + + !!! Setup PDF parameters loop. + ! Loop over all model thermodynamic level above the model lower boundary. + ! Now also including "model lower boundary" -- Eric Raut Aug 2013 + ! Now not including "model lower boundary" -- Eric Raut Aug 2014 + do k = 2, nz, 1 + + !!! Calculate the means and standard deviations involving PDF variables + !!! -- w, chi, eta, N_cn, and any precipitating hydrometeors (hm + !!! in-precip) -- for each PDF component. + call compute_mean_stdev( hydromet(k,:), hydrometp2_zt(k,:), & ! In + Ncnm(k), mixt_frac(k), precip_frac(k), & ! In + precip_frac_1(k), precip_frac_2(k), & ! In + precip_frac_tol, & ! In + pdf_params(k), d_variables, & ! In + mu_x_1, mu_x_2, & ! Out + sigma_x_1, sigma_x_2, & ! Out + hm_1(k,:), hm_2(k,:), & ! Out + sigma2_on_mu2_ip_1, & ! Out + sigma2_on_mu2_ip_2 ) ! Out + + !!! Transform the component means and standard deviations involving + !!! precipitating hydrometeors (hm in-precip) and N_cn -- ln hm and + !!! ln N_cn -- to normal space for each PDF component. + call norm_transform_mean_stdev( hm_1(k,:), hm_2(k,:), & + Ncnm(k), d_variables, & + mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + sigma2_on_mu2_ip_1, & + sigma2_on_mu2_ip_2, & + mu_x_1_n(:,k), mu_x_2_n(:,k), & + sigma_x_1_n(:,k), sigma_x_2_n(:,k) ) + + !!! Calculate the normal space correlations. + !!! The normal space correlations are the same as the true correlations + !!! except when at least one of the variables involved is a precipitating + !!! hydrometeor or Ncn. In these cases, the normal space correlation + !!! involves the natural logarithm of the precipitating hydrometeors, + !!! ln hm (for example, ln r_r and ln N_r), and ln N_cn for each PDF + !!! component. + if ( l_diagnose_correlations ) then + + if ( rcm(k) > rc_tol ) then + + call diagnose_correlations( d_variables, corr_array_n_cloud, & ! Intent(in) + corr_array_1_n ) ! Intent(out) + + call diagnose_correlations( d_variables, corr_array_n_cloud, & ! Intent(in) + corr_array_2_n ) ! Intent(out) + + else + + call diagnose_correlations( d_variables, corr_array_n_below, & ! Intent(in) + corr_array_1_n ) ! Intent(out) + + call diagnose_correlations( d_variables, corr_array_n_below, & ! Intent(in) + corr_array_2_n ) ! Intent(out) + + endif + + else ! if .not. l_diagnose_correlations + + call comp_corr_norm( wm_zt(k), rc_1(k), rc_2(k), cloud_frac_1(k), & + cloud_frac_2(k), wpchip_zt(k), wpNcnp_zt(k), & + sqrt(wp2_zt(k)), mixt_frac(k), precip_frac_1(k),& + precip_frac_2(k), wphydrometp_zt(k,:), & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + sigma_x_1_n(:,k), sigma_x_2_n(:,k), & + corr_array_n_cloud, corr_array_n_below, & + pdf_params(k), d_variables, & + corr_array_1_n(:,:,k), corr_array_2_n(:,:,k) ) + + endif ! l_diagnose_correlations + + !!! Calculate the true correlations for each PDF component. + call denorm_transform_corr( d_variables, & + sigma_x_1_n(:,k), sigma_x_2_n(:,k), & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + corr_array_1_n(:,:,k), & + corr_array_2_n(:,:,k), & + corr_array_1, corr_array_2 ) + + !!! Statistics for standard PDF parameters involving hydrometeors. + call pdf_param_hm_stats( d_variables, k, hm_1(k,:), hm_2(k,:), & + mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + corr_array_1, corr_array_2, & + l_stats_samp ) + + !!! Statistics for normal space PDF parameters involving hydrometeors. + call pdf_param_ln_hm_stats( d_variables, k, mu_x_1_n(:,k), & + mu_x_2_n(:,k), sigma_x_1_n(:,k), & + sigma_x_2_n(:,k), corr_array_1_n(:,:,k), & + corr_array_2_n(:,:,k), l_stats_samp ) + + !!! Pack the PDF parameters + call pack_pdf_params( hm_1(k,:), hm_2(k,:), d_variables, & ! In + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & ! In + corr_array_1, corr_array_2, precip_frac(k), & ! In + precip_frac_1(k), precip_frac_2(k), & ! In + hydromet_pdf_params(k) ) ! Out + + if ( l_diagnose_correlations ) then + + call calc_cholesky_corr_mtx_approx & + ( d_variables, corr_array_1_n(:,:,k), & ! intent(in) + corr_cholesky_mtx_1(:,:,k), corr_mtx_approx_1 ) ! intent(out) + + call calc_cholesky_corr_mtx_approx & + ( d_variables, corr_array_2_n(:,:,k), & ! intent(in) + corr_cholesky_mtx_2(:,:,k), corr_mtx_approx_2 ) ! intent(out) + + corr_array_1_n(:,:,k) = corr_mtx_approx_1 + corr_array_2_n(:,:,k) = corr_mtx_approx_2 + + else + + ! Compute choleksy factorization for the correlation matrix (out of + ! cloud) + call Cholesky_factor( d_variables, corr_array_1_n(:,:,k), & ! In + corr_array_scaling, corr_cholesky_mtx_1(:,:,k), & ! Out + l_corr_array_scaling ) ! Out + + call Cholesky_factor( d_variables, corr_array_2_n(:,:,k), & ! In + corr_array_scaling, corr_cholesky_mtx_2(:,:,k), & ! Out + l_corr_array_scaling ) ! Out + endif + + ! For ease of use later in the code, we make the correlation arrays + ! symmetrical + call mirror_lower_triangular_matrix( d_variables, corr_array_1_n(:,:,k) ) + call mirror_lower_triangular_matrix( d_variables, corr_array_2_n(:,:,k) ) + + enddo ! Setup PDF parameters loop: k = 2, nz, 1 + + ! Interpolate the overall variance of a hydrometeor, , to its home on + ! momentum grid levels. + do i = 1, hydromet_dim, 1 + hydrometp2(:,i) = zt2zm( hydrometp2_zt(:,i) ) + hydrometp2(nz,i) = zero + enddo + + if ( l_stats_samp ) then + if ( irtp2_from_chi > 0 ) then + rtp2_zt_from_chi & + = compute_rtp2_from_chi( pdf_params(:), & + corr_array_1_n(iiPDF_chi,iiPDF_eta,:), & + corr_array_2_n(iiPDF_chi,iiPDF_eta,:) ) + call stat_update_var( irtp2_from_chi, zt2zm( rtp2_zt_from_chi ), & + stats_zm ) + endif + endif + + + ! Boundary conditions for the output variables at k=1. + mu_x_1_n(:,1) = zero + mu_x_2_n(:,1) = zero + sigma_x_1_n(:,1) = zero + sigma_x_2_n(:,1) = zero + corr_array_1_n(:,:,1) = zero + corr_array_2_n(:,:,1) = zero + corr_cholesky_mtx_1(:,:,1) = zero + corr_cholesky_mtx_2(:,:,1) = zero + call init_hydromet_pdf_params( hydromet_pdf_params(1) ) + + if (clubb_at_least_debug_level( 2 )) then + do k = 2, nz + call assert_corr_symmetric( corr_array_1_n(:,:,k), d_variables ) + call assert_corr_symmetric( corr_array_2_n(:,:,k), d_variables ) + enddo + endif + + + return + + end subroutine setup_pdf_parameters + + !============================================================================= + subroutine compute_mean_stdev( hydromet, hydrometp2_zt, & ! Intent(in) + Ncnm, mixt_frac, precip_frac, & ! Intent(in) + precip_frac_1, precip_frac_2, & ! Intent(in) + precip_frac_tol, & ! Intent(in) + pdf_params, d_variables, & ! Intent(in) + mu_x_1, mu_x_2, & ! Intent(out) + sigma_x_1, sigma_x_2, & ! Intent(out) + hm_1, hm_2, & ! Intent(out) + sigma_hm_1_sqd_on_mu_hm_1_sqd, & ! Intent(out) + sigma_hm_2_sqd_on_mu_hm_2_sqd ) ! Intent(out) + + ! Description: + ! Calculates the means and standard deviations (for each PDF component) of + ! chi, eta, w, Ncn, and the precipitating hydrometeors. For the + ! precipitating hydrometeors, the component means and standard deviations + ! are in-precip. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use array_index, only: & + hydromet_tol + + use model_flags, only: & + l_const_Nc_in_cloud ! Variable(s) + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) type + + use parameters_tunable, only: & + omicron, & ! Variable(s) + zeta_vrnce_rat + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn, & + hmp2_ip_on_hmm2_ip, & + Ncnp2_on_Ncnm2 + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hydromet, & ! Mean of a hydrometeor (overall) [hm units] + hydrometp2_zt ! Variance of a hydrometeor (overall) [(hm units)^2] + + real( kind = core_rknd ), intent(in) :: & + Ncnm, & ! Mean simplified cloud nuclei concentration [num/kg] + mixt_frac, & ! Mixture fraction [-] + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2, & ! Precipitation fraction (2nd PDF component) [-] + precip_frac_tol ! Minimum precip. frac. when hydromet. are present [-] + + type(pdf_parameter), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + integer, intent(in) :: & + d_variables ! Number of PDF variables + + ! Output Variables + ! Note: This code assumes to be these arrays in the same order as the + ! correlation arrays, etc., which is determined by the iiPDF indices. + ! The order should be as follows: chi, eta, w, Ncn, + ! (indices increasing from left to right). + real( kind = core_rknd ), dimension(d_variables), intent(out) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(hydromet_dim), intent(out) :: & + hm_1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), dimension(d_variables), intent(out) :: & + sigma_hm_1_sqd_on_mu_hm_1_sqd, & ! Ratio sigma_hm_1^2 / mu_hm_1^2 [-] + sigma_hm_2_sqd_on_mu_hm_2_sqd ! Ratio sigma_hm_2^2 / mu_hm_2^2 [-] + + ! Local Variables + integer :: ivar ! Loop iterator + + integer :: hm_idx ! Hydrometeor array index. + + + !!! Initialize output variables. + mu_x_1 = zero + mu_x_2 = zero + sigma_x_1 = zero + sigma_x_2 = zero + hm_1 = zero + hm_2 = zero + sigma_hm_1_sqd_on_mu_hm_1_sqd = zero + sigma_hm_2_sqd_on_mu_hm_2_sqd = zero + + + !!! Enter the PDF parameters. + + !!! Vertical velocity, w. + + ! Mean of vertical velocity, w, in PDF component 1. + mu_x_1(iiPDF_w) = pdf_params%w_1 + + ! Mean of vertical velocity, w, in PDF component 2. + mu_x_2(iiPDF_w) = pdf_params%w_2 + + ! Standard deviation of vertical velocity, w, in PDF component 1. + sigma_x_1(iiPDF_w) = sqrt( pdf_params%varnce_w_1 ) + + ! Standard deviation of vertical velocity, w, in PDF component 2. + sigma_x_2(iiPDF_w) = sqrt( pdf_params%varnce_w_2 ) + + + !!! Extended liquid water mixing ratio, chi. + + ! Mean of extended liquid water mixing ratio, chi (old s), + ! in PDF component 1. + mu_x_1(iiPDF_chi) = pdf_params%chi_1 + + ! Mean of extended liquid water mixing ratio, chi (old s), + ! in PDF component 2. + mu_x_2(iiPDF_chi) = pdf_params%chi_2 + + ! Standard deviation of extended liquid water mixing ratio, chi (old s), + ! in PDF component 1. + sigma_x_1(iiPDF_chi) = pdf_params%stdev_chi_1 + + ! Standard deviation of extended liquid water mixing ratio, chi (old s), + ! in PDF component 2. + sigma_x_2(iiPDF_chi) = pdf_params%stdev_chi_2 + + + !!! Coordinate orthogonal to chi, eta. + + ! Mean of eta (old t) in PDF component 1. + ! Set the component mean values of eta to 0. + ! The component mean values of eta are not important. They can be set to + ! anything. They cancel out in the model code. However, the best thing to + ! do is to set them to 0 and avoid any kind of numerical error. + mu_x_1(iiPDF_eta) = zero + + ! Mean of eta (old t) in PDF component 2. + ! Set the component mean values of eta to 0. + ! The component mean values of eta are not important. They can be set to + ! anything. They cancel out in the model code. However, the best thing to + ! do is to set them to 0 and avoid any kind of numerical error. + mu_x_2(iiPDF_eta) = zero + + ! Standard deviation of eta (old t) in PDF component 1. + sigma_x_1(iiPDF_eta) = pdf_params%stdev_eta_1 + + ! Standard deviation of eta (old t) in PDF component 2. + sigma_x_2(iiPDF_eta) = pdf_params%stdev_eta_2 + + + !!! Simplified cloud nuclei concentration, Ncn. + + ! Mean of simplified cloud nuclei concentration, Ncn, in PDF component 1. + mu_x_1(iiPDF_Ncn) = Ncnm + + ! Mean of simplified cloud nuclei concentration, Ncn, in PDF component 2. + mu_x_2(iiPDF_Ncn) = Ncnm + + ! Standard deviation of simplified cloud nuclei concentration, Ncn, + ! in PDF component 1. + if ( .not. l_const_Nc_in_cloud ) then + + ! Ncn varies in both PDF components. + sigma_x_1(iiPDF_Ncn) = sqrt( Ncnp2_on_Ncnm2 ) * Ncnm + + sigma_x_2(iiPDF_Ncn) = sqrt( Ncnp2_on_Ncnm2 ) * Ncnm + + ! Ncn is not an official hydrometeor. However, both the + ! sigma_hm_1_sqd_on_mu_hm_1_sqd and sigma_hm_2_sqd_on_mu_hm_2_sqd arrays + ! have size d_variables, and both sigma_Ncn_1^2/mu_Ncn_1^2 and + ! sigma_Ncn_2^2/mu_Ncn_2^2 need to be output as part of these arrays. + sigma_hm_1_sqd_on_mu_hm_1_sqd(iiPDF_Ncn) = Ncnp2_on_Ncnm2 + sigma_hm_2_sqd_on_mu_hm_2_sqd(iiPDF_Ncn) = Ncnp2_on_Ncnm2 + + else ! l_const_Nc_in_cloud + + ! Ncn is constant in both PDF components. + sigma_x_1(iiPDF_Ncn) = zero + + sigma_x_2(iiPDF_Ncn) = zero + + ! Ncn is not an official hydrometeor. However, both the + ! sigma_hm_1_sqd_on_mu_hm_1_sqd and sigma_hm_2_sqd_on_mu_hm_2_sqd arrays + ! have size d_variables, and both sigma_Ncn_1^2/mu_Ncn_1^2 and + ! sigma_Ncn_2^2/mu_Ncn_2^2 need to be output as part of these arrays. + sigma_hm_1_sqd_on_mu_hm_1_sqd(iiPDF_Ncn) = zero + sigma_hm_2_sqd_on_mu_hm_2_sqd(iiPDF_Ncn) = zero + + endif ! .not. l_const_Nc_in_cloud + + + !!! Precipitating hydrometeor species. + do ivar = iiPDF_Ncn+1, d_variables, 1 + + hm_idx = pdf2hydromet_idx(ivar) + + call calc_comp_mu_sigma_hm( hydromet(hm_idx), hydrometp2_zt(hm_idx), & + hmp2_ip_on_hmm2_ip(hm_idx), & + mixt_frac, precip_frac, & + precip_frac_1, precip_frac_2, & + hydromet_tol(hm_idx), precip_frac_tol, & + omicron, zeta_vrnce_rat, & + mu_x_1(ivar), mu_x_2(ivar), & + sigma_x_1(ivar), sigma_x_2(ivar), & + hm_1(hm_idx), hm_2(hm_idx), & + sigma_hm_1_sqd_on_mu_hm_1_sqd(ivar), & + sigma_hm_2_sqd_on_mu_hm_2_sqd(ivar) ) + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + + return + + end subroutine compute_mean_stdev + + !============================================================================= + subroutine comp_corr_norm( wm_zt, rc_1, rc_2, cloud_frac_1, & + cloud_frac_2, wpchip, wpNcnp, & + stdev_w, mixt_frac, precip_frac_1, & + precip_frac_2, wphydrometp_zt, & + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & + sigma_x_1_n, sigma_x_2_n, & + corr_array_n_cloud, corr_array_n_below, & + pdf_params, d_variables, & + corr_array_1_n, corr_array_2_n ) + + ! Description: + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + Ncn_tol, & + w_tol, & ! [m/s] + chi_tol, & ! [kg/kg] + one, & + zero + + use model_flags, only: & + l_calc_w_corr + + use diagnose_correlations_module, only: & + calc_mean, & ! Procedure(s) + calc_w_corr + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use pdf_parameter_module, only: & + pdf_parameter ! Variable(s) type + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn + + use array_index, only: & + hydromet_tol + + implicit none + + ! Input Variables + integer, intent(in) :: d_variables ! Number of variables in the corr/mean/stdev arrays + + real( kind = core_rknd ), intent(in) :: & + wm_zt, & ! Mean vertical velocity, , on thermo. levels [m/s] + rc_1, & ! Mean of r_c (1st PDF component) [kg/kg] + rc_2, & ! Mean of r_c (2nd PDF component) [kg/kg] + cloud_frac_1, & ! Cloud fraction (1st PDF component) [-] + cloud_frac_2, & ! Cloud fraction (2nd PDF component) [-] + wpchip, & ! Covariance of w and chi (old s) [(m/s)kg/kg] + wpNcnp, & ! Covariance of w and N_cn (overall) [(m/s) num/kg] + stdev_w, & ! Standard deviation of w [m/s] + mixt_frac, & ! Mixture fraction [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + wphydrometp_zt ! Covariance of w and hm interp. to t-levs. [(m/s)u.v.] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean of x array (1st PDF component) [units vary] + mu_x_2, & ! Mean of x array (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation of x array (1st PDF comp.) [un. vary] + sigma_x_2, & ! Standard deviation of x array (2nd PDF comp.) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_n_cloud, & ! Prescribed correlation array in cloud [-] + corr_array_n_below ! Prescribed correlation array below cloud [-] + + type(pdf_parameter), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(out) :: & + corr_array_1_n, & ! Corr. array (normal space) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normal space) of PDF vars. (comp. 2) [-] + + ! Local Variables + real( kind = core_rknd ), dimension(d_variables) :: & + corr_w_hm_1_n, & ! Correlation of w and ln hm (1st PDF component) ip [-] + corr_w_hm_2_n ! Correlation of w and ln hm (2nd PDF component) ip [-] + + real( kind = core_rknd ) :: & + chi_m, & ! Mean of chi (s_mellor) [kg/kg] + stdev_chi, & ! Standard deviation of chi (s_mellor) [kg/kg] + corr_w_chi, & ! Correlation of w and chi (overall) [-] + corr_w_Ncn_1_n, & ! Correlation of w and ln Ncn (1st PDF component) [-] + corr_w_Ncn_2_n ! Correlation of w and ln Ncn (2nd PDF component) [-] + + logical :: & + l_limit_corr_chi_eta ! Flag to limit the correlation of chi and eta [-] + + integer :: ivar, jvar ! Loop iterators + + ! ---- Begin Code ---- + + !!! Normal space correlations + + ! Initialize corr_w_hm_1_n and corr_w_hm_2_n arrays to 0. + corr_w_hm_1_n = zero + corr_w_hm_2_n = zero + + ! Calculate normal space correlations involving w by first calculating total + ! covariances involving w (, etc.) using the down-gradient + ! approximation. + if ( l_calc_w_corr ) then + + ! Approximate the correlation between w and chi. + chi_m & + = calc_mean( pdf_params%mixt_frac, pdf_params%chi_1, pdf_params%chi_2 ) + + stdev_chi & + = sqrt( pdf_params%mixt_frac & + * ( ( pdf_params%chi_1 - chi_m )**2 & + + pdf_params%stdev_chi_1**2 ) & + + ( one - pdf_params%mixt_frac ) & + * ( ( pdf_params%chi_2 - chi_m )**2 & + + pdf_params%stdev_chi_2**2 ) & + ) + + corr_w_chi & + = calc_w_corr( wpchip, stdev_w, stdev_chi, w_tol, chi_tol ) + + ! Calculate the correlation of w and ln Ncn in each PDF component. + ! The subroutine calc_corr_w_hm_n can be used to do this as long as a + ! value of 1 is sent in for precip_frac_1 and precip_frac_2. + jvar = iiPDF_Ncn + call calc_corr_w_hm_n( wm_zt, wpNcnp, & + mu_x_1(iiPDF_w), mu_x_2(iiPDF_w), & + mu_x_1(jvar), mu_x_2(jvar), & + sigma_x_1(iiPDF_w), sigma_x_2(iiPDF_w), & + sigma_x_1(jvar), sigma_x_2(jvar), & + sigma_x_1_n(jvar), sigma_x_2_n(jvar), & + mixt_frac, one, one, & + corr_w_Ncn_1_n, corr_w_Ncn_2_n, & + Ncn_tol ) + + ! Calculate the correlation of w and the natural logarithm of the + ! hydrometeor for each PDF component and each hydrometeor type. + do jvar = iiPDF_Ncn+1, d_variables + + call calc_corr_w_hm_n( wm_zt, wphydrometp_zt(pdf2hydromet_idx(jvar)),& + mu_x_1(iiPDF_w), mu_x_2(iiPDF_w), & + mu_x_1(jvar), mu_x_2(jvar), & + sigma_x_1(iiPDF_w), sigma_x_2(iiPDF_w), & + sigma_x_1(jvar), sigma_x_2(jvar), & + sigma_x_1_n(jvar), sigma_x_2_n(jvar), & + mixt_frac, precip_frac_1, precip_frac_2, & + corr_w_hm_1_n(jvar), corr_w_hm_2_n(jvar), & + hydromet_tol(pdf2hydromet_idx(jvar)) ) + + enddo ! jvar = iiPDF_Ncn+1, d_variables + + endif + + ! In order to decompose the normal space correlation matrix, + ! we must not have a perfect correlation of chi and + ! eta. Thus, we impose a limitation. + l_limit_corr_chi_eta = .true. + + + ! Initialize the normal space correlation arrays + corr_array_1_n = zero + corr_array_2_n = zero + + !!! The corr_arrays are assumed to be lower triangular matrices + ! Set diagonal elements to 1 + do ivar=1, d_variables + corr_array_1_n(ivar, ivar) = one + corr_array_2_n(ivar, ivar) = one + end do + + + !!! This code assumes the following order in the prescribed correlation + !!! arrays (iiPDF indices): + !!! chi, eta, w, Ncn, (indices increasing from left to right) + + ! Correlation of chi (old s) and eta (old t) + corr_array_1_n(iiPDF_eta, iiPDF_chi) & + = component_corr_chi_eta( pdf_params%corr_chi_eta_1, rc_1, cloud_frac_1, & + corr_array_n_cloud(iiPDF_eta, iiPDF_chi), & + corr_array_n_below(iiPDF_eta, iiPDF_chi), & + l_limit_corr_chi_eta ) + + corr_array_2_n(iiPDF_eta, iiPDF_chi) & + = component_corr_chi_eta( pdf_params%corr_chi_eta_2, rc_2, cloud_frac_2, & + corr_array_n_cloud(iiPDF_eta, iiPDF_chi), & + corr_array_n_below(iiPDF_eta, iiPDF_chi), & + l_limit_corr_chi_eta ) + + ! Correlation of chi (old s) and w + corr_array_1_n(iiPDF_w, iiPDF_chi) & + = component_corr_w_x( corr_w_chi, rc_1, cloud_frac_1, & + corr_array_n_cloud(iiPDF_w, iiPDF_chi), & + corr_array_n_below(iiPDF_w, iiPDF_chi) ) + + corr_array_2_n(iiPDF_w, iiPDF_chi) & + = component_corr_w_x( corr_w_chi, rc_2, cloud_frac_2, & + corr_array_n_cloud(iiPDF_w, iiPDF_chi), & + corr_array_n_below(iiPDF_w, iiPDF_chi) ) + + + ! Correlation of chi (old s) and ln Ncn + corr_array_1_n(iiPDF_Ncn, iiPDF_chi) & + = component_corr_x_hm_n_ip( rc_1, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_chi), & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_chi) ) + + corr_array_2_n(iiPDF_Ncn, iiPDF_chi) & + = component_corr_x_hm_n_ip( rc_2, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_chi), & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_chi) ) + + ! Correlation of chi (old s) and the natural logarithm of the hydrometeors + ivar = iiPDF_chi + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1_n(jvar, ivar) & + = component_corr_x_hm_n_ip( rc_1, cloud_frac_1,& + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + corr_array_2_n(jvar, ivar) & + = component_corr_x_hm_n_ip( rc_2, cloud_frac_2,& + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + enddo + + ! Correlation of eta (old t) and w + corr_array_1_n(iiPDF_w, iiPDF_eta) = zero + corr_array_2_n(iiPDF_w, iiPDF_eta) = zero + + ! Correlation of eta (old t) and ln Ncn + corr_array_1_n(iiPDF_Ncn, iiPDF_eta) & + = component_corr_x_hm_n_ip( rc_1, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_eta), & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_eta) ) + + corr_array_2_n(iiPDF_Ncn, iiPDF_eta) & + = component_corr_x_hm_n_ip( rc_2, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_eta), & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_eta) ) + + ! Correlation of eta (old t) and the natural logarithm of the hydrometeors + ivar = iiPDF_eta + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1_n(jvar, ivar) & + = component_corr_eta_hm_n_ip( corr_array_1_n( iiPDF_eta, iiPDF_chi), & + corr_array_1_n( jvar, iiPDF_chi) ) + + corr_array_2_n(jvar, ivar) & + = component_corr_eta_hm_n_ip( corr_array_2_n( iiPDF_eta, iiPDF_chi), & + corr_array_2_n( jvar, iiPDF_chi) ) + enddo + + + ! Correlation of w and ln Ncn + corr_array_1_n(iiPDF_Ncn, iiPDF_w) & + = component_corr_w_hm_n_ip( corr_w_Ncn_1_n, rc_1, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_w), & + corr_array_n_below(iiPDF_Ncn, iiPDF_w) ) + + corr_array_2_n(iiPDF_Ncn, iiPDF_w) & + = component_corr_w_hm_n_ip( corr_w_Ncn_2_n, rc_2, one, & + corr_array_n_cloud(iiPDF_Ncn, iiPDF_w), & + corr_array_n_below(iiPDF_Ncn, iiPDF_w) ) + + ! Correlation of w and the natural logarithm of the hydrometeors + ivar = iiPDF_w + do jvar = iiPDF_Ncn+1, d_variables + + corr_array_1_n(jvar, ivar) & + = component_corr_w_hm_n_ip( corr_w_hm_1_n(jvar), rc_1, cloud_frac_1, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + corr_array_2_n(jvar, ivar) & + = component_corr_w_hm_n_ip( corr_w_hm_2_n(jvar), rc_2, cloud_frac_2, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + enddo + + ! Correlation of ln Ncn and the natural logarithm of the hydrometeors + ivar = iiPDF_Ncn + do jvar = iiPDF_Ncn+1, d_variables + corr_array_1_n(jvar, ivar) & + = component_corr_hmx_hmy_n_ip( rc_1, cloud_frac_1, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + corr_array_2_n(jvar, ivar) & + = component_corr_hmx_hmy_n_ip( rc_2, cloud_frac_2, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + enddo + + ! Correlation of the natural logarithm of two hydrometeors + do ivar = iiPDF_Ncn+1, d_variables-1 + do jvar = ivar+1, d_variables + + corr_array_1_n(jvar, ivar) & + = component_corr_hmx_hmy_n_ip( rc_1, cloud_frac_1, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + corr_array_2_n(jvar, ivar) & + = component_corr_hmx_hmy_n_ip( rc_2, cloud_frac_2, & + corr_array_n_cloud(jvar, ivar), & + corr_array_n_below(jvar, ivar) ) + + enddo ! jvar + enddo ! ivar + + + return + + end subroutine comp_corr_norm + + !============================================================================= + subroutine calc_comp_mu_sigma_hm( hmm, hmp2, & ! In + hmp2_ip_on_hmm2_ip, & ! In + mixt_frac, precip_frac, & ! In + precip_frac_1, precip_frac_2, & ! In + hm_tol, precip_frac_tol, & ! In + omicron, zeta_vrnce_rat, & ! In + mu_hm_1, mu_hm_2, & ! Out + sigma_hm_1, sigma_hm_2, & ! Out + hm_1, hm_2, & ! Out + sigma_hm_1_sqd_on_mu_hm_1_sqd, & ! Out + sigma_hm_2_sqd_on_mu_hm_2_sqd ) ! Out + + ! Description: + ! When precipitation is found in both PDF components (precip_frac_1 > 0 and + ! precip_frac_2 > 0), the method that solves for in-precip. mean and + ! in-precip. standard deviation in each PDF component, preserving overall + ! mean and overall variance, is used. When precipitation fraction is found + ! in one PDF component but not the other one (precip_frac_1 > 0 and + ! precip_frac_2 = 0, or precip_frac_1 = 0 and precip_frac_2 > 0), the + ! calculation of component in-precip. mean and in-precip. standard deviation + ! is simple. When precipitation is not found in either component + ! (precip_frac_1 = 0 and precip_frac_2 = 0), there isn't any precipitation + ! found overall (at that grid level). + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + hmm, & ! Hydrometeor mean (overall), [hm units] + hmp2, & ! Hydrometeor variance (overall), [hm un.^2] + hmp2_ip_on_hmm2_ip, & ! Ratio / ^2 [-] + mixt_frac, & ! Mixture fraction [-] + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2, & ! Precipitation fraction (2nd PDF component) [-] + hm_tol, & ! Tolerance value of hydrometeor [hm units] + precip_frac_tol ! Min. precip. frac. when hydromet. are present [-] + + real( kind = core_rknd ), intent(in) :: & + omicron, & ! Relative width parameter, omicron = R / Rmax [-] + zeta_vrnce_rat ! Width parameter for sigma_hm_1^2 / mu_hm_1^2 [-] + + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [hm units] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [hm units] + sigma_hm_1, & ! Standard deviation of hm (1st PDF component) ip [hm units] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF component) ip [hm units] + hm_1, & ! Mean of hm (1st PDF component) [hm units] + hm_2 ! Mean of hm (2nd PDF component) [hm units] + + real( kind = core_rknd ), intent(out) :: & + sigma_hm_1_sqd_on_mu_hm_1_sqd, & ! Ratio sigma_hm_1**2 / mu_hm_1**2 [-] + sigma_hm_2_sqd_on_mu_hm_2_sqd ! Ratio sigma_hm_2**2 / mu_hm_2**2 [-] + + + if ( hmm >= hm_tol & + .and. precip_frac_1 >= precip_frac_tol & + .and. precip_frac_2 >= precip_frac_tol ) then + + ! Precipitation is found in both PDF components. + call calc_mu_sigma_two_comps( hmm, hmp2, hmp2_ip_on_hmm2_ip, & + mixt_frac, precip_frac, precip_frac_1, & + precip_frac_2, hm_tol, & + omicron, zeta_vrnce_rat, & + mu_hm_1, mu_hm_2, sigma_hm_1, & + sigma_hm_2, hm_1, hm_2, & + sigma_hm_1_sqd_on_mu_hm_1_sqd, & + sigma_hm_2_sqd_on_mu_hm_2_sqd ) + + + elseif ( hmm >= hm_tol .and. precip_frac_1 >= precip_frac_tol ) then + + ! Precipitation is found in the 1st PDF component, but not in the 2nd + ! PDF component (precip_frac_2 = 0). + mu_hm_1 = hmm / ( mixt_frac * precip_frac_1 ) + mu_hm_2 = zero + + sigma_hm_1 = sqrt( max( ( hmp2 + hmm**2 & + - mixt_frac * precip_frac_1 * mu_hm_1**2 ) & + / ( mixt_frac * precip_frac_1 ), & + zero ) ) + sigma_hm_2 = zero + + hm_1 = mu_hm_1 * precip_frac_1 + hm_2 = zero + + sigma_hm_1_sqd_on_mu_hm_1_sqd = sigma_hm_1**2 / mu_hm_1**2 + ! The ratio sigma_hm_2^2 / mu_hm_2^2 is undefined. + sigma_hm_2_sqd_on_mu_hm_2_sqd = zero + + + elseif ( hmm >= hm_tol .and. precip_frac_2 >= precip_frac_tol ) then + + ! Precipitation is found in the 2nd PDF component, but not in the 1st + ! PDF component (precip_frac_1 = 0). + mu_hm_1 = zero + mu_hm_2 = hmm / ( ( one - mixt_frac ) * precip_frac_2 ) + + sigma_hm_1 = zero + sigma_hm_2 & + = sqrt( max( ( hmp2 + hmm**2 & + - ( one - mixt_frac ) * precip_frac_2 * mu_hm_2**2 ) & + / ( ( one - mixt_frac ) * precip_frac_2 ), & + zero ) ) + + hm_1 = zero + hm_2 = mu_hm_2 * precip_frac_2 + + ! The ratio sigma_hm_1^2 / mu_hm_1^2 is undefined. + sigma_hm_1_sqd_on_mu_hm_1_sqd = zero + sigma_hm_2_sqd_on_mu_hm_2_sqd = sigma_hm_2**2 / mu_hm_2**2 + + + else ! hm < hm_tol or ( precip_frac_1 = 0 and precip_frac_2 = 0 ). + + ! Precipitation is not found in either PDF component. + mu_hm_1 = zero + mu_hm_2 = zero + + sigma_hm_1 = zero + sigma_hm_2 = zero + + hm_1 = zero + hm_2 = zero + + ! The ratio sigma_hm_1^2 / mu_hm_1^2 is undefined. + sigma_hm_1_sqd_on_mu_hm_1_sqd = zero + ! The ratio sigma_hm_2^2 / mu_hm_2^2 is undefined. + sigma_hm_2_sqd_on_mu_hm_2_sqd = zero + + + endif ! hmm >= hm_tol and precip_frac_1 >= precip_frac_tol + ! and precip_frac_2 >= precip_frac_tol + + + return + + end subroutine calc_comp_mu_sigma_hm + + !============================================================================= + subroutine calc_mu_sigma_two_comps( hmm, hmp2, hmp2_ip_on_hmm2_ip, & + mixt_frac, precip_frac, precip_frac_1, & + precip_frac_2, hm_tol, & + omicron, zeta_vrnce_rat, & + mu_hm_1, mu_hm_2, sigma_hm_1, & + sigma_hm_2, hm_1, hm_2, & + sigma_hm_1_sqd_on_mu_hm_1_sqd, & + sigma_hm_2_sqd_on_mu_hm_2_sqd ) + + ! Description: + ! + ! OVERVIEW + ! + ! The goal is to calculate the in-precip. mean of the hydrometeor field in + ! each PDF component (mu_hm_1 and mu_hm_2) in a scenario when there is + ! precipitation found in both PDF components. The fields provided are the + ! overall mean of the hydrometeor, , the overall variance of the + ! hydrometeor, , the mixture fraction, a, the overall precipitation + ! fraction, f_p, and the precipitation fraction in each PDF component + ! (f_p_1 and f_p_2). + ! + ! The PDF equation for is: + ! + ! = a * f_p_1 * mu_hm_1 + ( 1- a ) * f_p_2 * mu_hm_2. + ! + ! Likewise, the PDF equation for is: + ! + ! = a * f_p_1 * ( mu_hm_1^2 + sigma_hm_1^2 ) + ! + ( 1 - a ) * f_p_2 * ( mu_hm_2^2 + sigma_hm_2^2 ) + ! - ^2; + ! + ! where sigma_hm_1 and sigma_hm_2 are the in-precip. standard deviations of + ! the hydrometeor field in each PDF component. This can be rewritten as: + ! + ! + ! = a * f_p_1 * ( 1 + sigma_hm_1^2 / mu_hm_1^2 ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * ( 1 + sigma_hm_2^2 / mu_hm_2^2 ) * mu_hm_2^2 + ! - ^2. + ! + ! The ratio of sigma_hm_2^2 to mu_hm_2^2 is denoted R: + ! + ! R = sigma_hm_2^2 / mu_hm_2^2. + ! + ! In order to allow sigma_hm_1^2 / mu_hm_1^2 to have a different ratio, the + ! parameter zeta is introduced, such that: + ! + ! R * ( 1 + zeta ) = sigma_hm_1^2 / mu_hm_1^2; + ! + ! where zeta > -1. When -1 < zeta < 0, the ratio sigma_hm_2^2 / mu_hm_2^2 + ! grows at the expense of sigma_hm_1^2 / mu_hm_1^2, which narrows. When + ! zeta = 0, the ratio sigma_hm_1^2 / mu_hm_1^2 is the same as + ! sigma_hm_2^2 / mu_hm_2^2. When zeta > 0, sigma_hm_1^2 / mu_hm_1^2 grows + ! at the expense of sigma_hm_2^2 / mu_hm_2^2, which narrows. The component + ! variances are written as: + ! + ! sigma_hm_1^2 = R * ( 1 + zeta ) * mu_hm_1^2; and + ! sigma_hm_2^2 = R * mu_hm_2^2, + ! + ! and the component standard deviations are simply: + ! + ! sigma_hm_1 = sqrt( R * ( 1 + zeta ) ) * mu_hm_1; and + ! sigma_hm_2 = sqrt( R ) * mu_hm_2. + ! + ! The equation for can be rewritten as: + ! + ! = a * f_p_1 * ( 1 + R * ( 1 + zeta ) ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * ( 1 + R ) * mu_hm_2^2 + ! - ^2. + ! + ! + ! HYDROMETEOR IN-PRECIP. VARIANCE: + ! THE SPREAD OF THE MEANS VS. THE STANDARD DEVIATIONS + ! + ! Part I: Minimum and Maximum Values for R + ! + ! The in-precip. variance of the hydrometeor is accounted for through a + ! combination of the variance of each PDF component and the spread between + ! the means of each PDF component. At one extreme, the standard deviation + ! of each component could be set to 0 and the in-prccip. variance could be + ! accounted for by spreading the PDF component (in-precip.) means far apart. + ! The value of R in this scenario would be its minimum possible value, which + ! is 0. At the other extreme, the means of each component could be set + ! equal to each other and the in-precip. variance could be accounted for + ! entirely by the PDF component (in-precip.) standard deviations. The value + ! of R in this scenario would be its maximum possible value, which is Rmax. + ! + ! In order to calculate the value of Rmax, use the equation set but set + ! mu_hm_1 = mu_hm_2 and R = Rmax. When this happens: + ! + ! = ( a * f_p_1 + ( 1- a ) * f_p_2 ) * mu_hm_i; + ! + ! and since f_p = a * f_p_1 + ( 1 - a ) * f_p_2: + ! + ! mu_hm_i = / f_p = ; + ! + ! where is the in-precip. mean of the hydrometeor. The equation + ! for hydrometeor variance in this scenario becomes: + ! + ! = ^2 * ( a * f_p_1 * ( 1 + Rmax * ( 1 + zeta ) ) + ! + ( 1 - a ) * f_p_2 * ( 1 + Rmax ) ) + ! - ^2. + ! + ! The general equation for the in-precip. variance of a hydrometeor, + ! , is given by: + ! + ! = ( + ^2 - f_p * ^2 ) / f_p; + ! + ! which can be rewritten as: + ! + ! + ^2 = f_p * ( + ^2 ). + ! + ! When the above equation is substituted into the modified PDF equation for + ! , Rmax is solved for and the equation is: + ! + ! Rmax = ( f_p / ( a * f_p_1 * ( 1 + zeta ) + ( 1 - a ) * f_p_2 ) ) + ! * ( / ^2 ). + ! + ! Here, in the scenario that zeta = 0, both PDF components have the same + ! mean and same variance, which reduces the in-precip. distribution to an + ! assumed single lognormal, and the above equation reduces to: + ! + ! Rmax = / ^2; + ! + ! which is what is expected in that case. + ! + ! + ! Part II: Enter omicron + ! + ! A parameter is used to prescribe the ratio of R to its maximum value, + ! Rmax. The prescribed parameter is called omicron, where: + ! + ! R = omicron * Rmax; + ! + ! where 0 <= omicron <= 1. When omicron = 0, the standard deviation of each + ! PDF component is 0, and mu_hm_1 is spread as far away from mu_hm_2 as it + ! needs to be to account for the in-precip. variance. When omicron = 1, + ! mu_hm_1 is equal to mu_hm_2, and the standard deviations of the PDF + ! components account for all of the in-precip. variance (and when zeta = 0, + ! the PDF shape is a single lognormal in-precip.). At intermediate values + ! of omicron, the means of each PDF component are somewhat spread and each + ! PDF component has some width. The modified parameters are listed below. + ! + ! The ratio of sigma_hm_2^2 to mu_hm_2^2 is: + ! + ! sigma_hm_2^2 / mu_hm_2^2 = omicron * Rmax; + ! + ! and the ratio of sigma_hm_1^2 / mu_hm_1^2 is: + ! + ! sigma_hm_1^2 / mu_hm_1^2 = omicron * Rmax * ( 1 + zeta ). + ! + ! The component variances are written as: + ! + ! sigma_hm_1^2 = omicron * Rmax * ( 1 + zeta ) * mu_hm_1^2; and + ! sigma_hm_2^2 = omicron * Rmax * mu_hm_2^2, + ! + ! and the component standard deviations are simply: + ! + ! sigma_hm_1 = sqrt( omicron * Rmax * ( 1 + zeta ) ) * mu_hm_1; and + ! sigma_hm_2 = sqrt( omicron * Rmax ) * mu_hm_2. + ! + ! The equation set becomes: + ! + ! [1] = a * f_p_1 * mu_hm_1 + ( 1- a ) * f_p_2 * mu_hm_2; and + ! + ! [2] + ! = a * f_p_1 * ( 1 + omicron * Rmax * ( 1 + zeta ) ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * ( 1 + omicron * Rmax ) * mu_hm_2^2 + ! - ^2. + ! + ! + ! SOLVING THE EQUATION SET FOR MU_HM_1 AND MU_HM_2. + ! + ! The above system of two equations can be solved for mu_hm_1 and mu_hm_2. + ! All other quantities in the equation set are known quantities. The + ! equation for is rewritten to isolate mu_hm_2: + ! + ! mu_hm_2 = ( - a * f_p_1 * mu_hm_1 ) / ( ( 1 - a ) * f_p_2 ). + ! + ! The above equation is substituted into the equation for . The + ! equation for is rewritten, resulting in: + ! + ! [ a * f_p_1 * ( 1 + omicron * Rmax * ( 1 + zeta ) ) + ! + a^2 * f_p_1^2 * ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ) ] + ! * mu_hm_1^2 + ! + [ - 2 * * a * f_p_1 * ( 1 + omicron * Rmax ) + ! / ( ( 1 - a ) * f_p_2 ) ] * mu_hm_1 + ! + [ - ( + ! + ( 1 - ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ) ) + ! * ^2 ) ] + ! = 0. + ! + ! This equation is of the form: + ! + ! A * mu_hm_1^2 + B * mu_hm_1 + C = 0; + ! + ! so the solution for mu_hm_1 is: + ! + ! mu_hm_1 = ( -B +/- sqrt( B^2 - 4*A*C ) ) / (2*A); + ! + ! where: + ! + ! A = a * f_p_1 * ( 1 + omicron * Rmax * ( 1 + zeta ) ) + ! + a^2 * f_p_1^2 * ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ); + ! + ! B = - 2 * * a * f_p_1 * ( 1 + omicron * Rmax ) + ! / ( ( 1 - a ) * f_p_2 ); + ! + ! and + ! + ! C = - ( + ! + ( 1 - ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ) ) + ! * ^2 ). + ! + ! The signs of the coefficients: + ! + ! 1) coefficient A is always positive, + ! 2) coefficient B is always negative (this means that -B is always + ! positive), and + ! 3) coefficient C can be positive, negative, or zero. + ! + ! Since ( 1 - ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ) ) * ^2 is + ! always negative and is always positive, the sign of coefficient C + ! depends on which term is greater in magnitude. + ! + ! When is greater, the sign of coefficient C is negative. This + ! means that -4*A*C is positive, which in turn means that + ! sqrt( B^2 - 4*A*C ) is greater in magnitude than -B. If the subtraction + ! option of the +/- were to be chosen, the value of mu_hm_1 would be + ! negative in this scenerio. So the natural thing to do would be to always + ! choose the addition option. However, this method requires that mu_hm_1 + ! equals mu_hm_2 when omicron = 1. When zeta >= 0, this happens when the + ! addition option is chosen, but not when the subtraction option is chosen. + ! However, when zeta < 0, this happens when the subtraction option is + ! chosen, but not when the addition option is chosen. So, the equation for + ! mu_hm_1 becomes: + ! + ! mu_hm_1 = ( -B + sqrt( B^2 - 4*A*C ) ) / (2*A); when zeta >= 0; and + ! mu_hm_1 = ( -B - sqrt( B^2 - 4*A*C ) ) / (2*A); when zeta < 0. + ! + ! Once this is set, of course: + ! + ! mu_hm_2 = ( - a * f_p_1 * mu_hm_1 ) / ( ( 1 - a ) * f_p_2 ). + ! + ! The system has been solved and the in-precip. PDF component means have + ! been found! + ! + ! + ! NOTES + ! + ! Note 1: + ! + ! The term B^2 - 4*A*C has been analyzed, and mathematically: + ! + ! B^2 - 4*A*C >= 0 + ! + ! always holds true. Additionally, the minimum value: + ! + ! B^2 - 4*A*C = 0, + ! + ! can only occur when omicron = 1 and zeta = 0 (or alternatively to + ! zeta = 0, Rmax = 0, but this only occurs when / ^2 has + ! a value of 0). + ! + ! Numerically, when omicron = 1 and zeta = 0, B^2 - 4*A*C can produce very + ! small (on the order of epsilon) negative values. This is due to numerical + ! round off error. When this happens, the erroneous small, negative value + ! of B^2 - 4*A*C is simply reset to the value it's supposed to have, which + ! is 0. + ! + ! + ! Note 2: + ! + ! As the value of / ^2 increases and as the value of + ! omicron decreases (narrowing the in-precip standard deviations and + ! increasing the spread between the in-precip means), a situtation arises + ! where the value of one of the component means will become negative. This + ! is because there is a limit to the amount of in-precip variance that can + ! be represented by this kind of distribution. In order to prevent + ! out-of-bounds values of mu_hm_1 or mu_hm_2, lower limits will be + ! declared, called mu_hm_1_min and mu_hm_2_min. The value of the + ! hydrometeor in-precip. component mean will be limited from going any + ! smaller (or negative) at this value. From there, the value of the other + ! hydrometeor in-precip. component mean is easy to calculate. Then, both + ! values will be entered into the calculation of hydrometeor variance, which + ! will be rewritten to solve for R. Then, both the hydrometeor mean and + ! hydrometeor variance will be preserved with a valid distribution. + ! + ! In this emergency scenario, the value of R is: + ! + ! R = ( + ^2 - a * f_p_1 * mu_hm_1^2 + ! - ( 1 - a ) * f_p_2 * mu_hm_2^2 ) + ! / ( a * f_p_1 * ( 1 + zeta ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * mu_hm_2^2 ). + ! + ! The minimum values of the in-precip. component means are bounded by: + ! + ! mu_hm_1_min >= hm_tol / f_p_1; and + ! mu_hm_2_min >= hm_tol / f_p_2. + ! + ! These are set this way because hm_1 ( = mu_hm_1 * f_p_1 ) and + ! hm_2 ( = mu_hm_2 * f_p_2 ) need to have values of at least hm_tol when + ! precipitation is found in both PDF components. + ! + ! However, an in-precip. component mean value of hm_tol / f_p_1 or + ! hm_tol / f_p_2 often produces a distribution where one component centers + ! around values that are too small to be a good match with data taken from + ! Large Eddy Simulations (LES). It is desirable to increase the minimum + ! threshold of mu_hm_1 and mu_hm_2. + ! + ! As the minimum threshold increases, the value of the in-precip. component + ! mean that is from the component that is not being set to the minimum + ! threshold decreases. If the minimum threshold were to be boosted as high + ! as / f_p (in most cases, / f_p >> hm_tol / f_p_i), both + ! components would have a value of / f_p. The minimum threshold should + ! not be set this high. + ! + ! Additionally, the minimum threshold for one in-precip. component mean + ! cannot be set so high as to drive the other in-precip. component mean + ! below hm_tol / f_p_i. (This doesn't come into play unless is close + ! to hm_tol.) The upper limit for the in-precip. mean values are: + ! + ! mu_hm_1|_(upper. lim.) = ( - ( 1 - a ) * f_p_2 * ( hm_tol / f_p_2 ) ) + ! / ( a * f_p_1 ); and + ! + ! mu_hm_2|_(upper. lim.) = ( - a * f_p_1 * ( hm_tol / f_p_1 ) ) + ! / ( ( 1 - a ) * f_p_2 ); + ! + ! which reduces to: + ! + ! mu_hm_1|_(upper. lim.) = ( - ( 1 - a ) * hm_tol ) / ( a * f_p_1 ); + ! and + ! mu_hm_2|_(upper. lim.) = ( - a * hm_tol ) / ( ( 1 - a ) * f_p_2 ). + ! + ! An appropriate minimum value for mu_hm_1 can be set by: + ! + ! mu_hm_1_min = | min( hm_tol / f_p_1 + ! | + mu_hm_min_coef * ( / f_p - hm_tol / f_p_1 ), + ! | ( - ( 1 - a ) * hm_tol ) / ( a * f_p_1 ) ); + ! | where / f_p > hm_tol / f_p_1; + ! | hm_tol / f_p_1; + ! | where / f_p <= hm_tol / f_p_1; + ! + ! and similarly for mu_hm_2: + ! + ! mu_hm_2_min = | min( hm_tol / f_p_2 + ! | + mu_hm_min_coef * ( / f_p - hm_tol / f_p_2 ), + ! | ( - a * hm_tol ) / ( ( 1 - a ) * f_p_2 ) ); + ! | where / f_p > hm_tol / f_p_2; + ! | hm_tol / f_p_2; + ! | where / f_p <= hm_tol / f_p_2; + ! + ! where mu_hm_min_coef is a coefficient that has a value + ! 0 <= mu_hm_min_coef < 1. When the value of mu_hm_min_coef is 0, + ! mu_hm_1_min reverts to hm_tol / f_p_1 and mu_hm_2_min reverts to + ! hm_tol / f_p_2. An appropriate value for mu_hm_min_coef should be small, + ! such as 0.01 - 0.05. + ! + ! + ! Note 3: + ! + ! When the value of zeta >= 0, the value of mu_hm_1 tends to be larger than + ! the value of mu_hm_2. Likewise when the value of zeta < 0, the value of + ! mu_hm_2 tends to be larger than the value of mu_hm_1. Since most cloud + ! water and cloud fraction tends to be found in PDF component 1, it is + ! advantageous to have the larger in-precip. component mean of the + ! hydrometeor also found in PDF component 1. The recommended value of zeta + ! is a value greater than or equal to 0. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + four, & ! Constant(s) + two, & + one, & + zero, & + fstderr + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + hmm, & ! Hydrometeor mean (overall), [hm un] + hmp2, & ! Hydrometeor variance (overall), [hm un^2] + hmp2_ip_on_hmm2_ip, & ! Ratio / ^2 [-] + mixt_frac, & ! Mixture fraction [-] + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2, & ! Precipitation fraction (2nd PDF component) [-] + hm_tol ! Tolerance value of hydrometeor [hm un] + + real( kind = core_rknd ), intent(in) :: & + omicron, & ! Relative width parameter, omicron = R / Rmax [-] + zeta_vrnce_rat ! Width parameter for sigma_hm_1^2 / mu_hm_1^2 [-] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [hm un] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [hm un] + sigma_hm_1, & ! Standard deviation of hm (1st PDF component) ip [hm un] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF component) ip [hm un] + hm_1, & ! Mean of hm (1st PDF component) [hm un] + hm_2 ! Mean of hm (2nd PDF component) [hm un] + + real( kind = core_rknd ), intent(out) :: & + sigma_hm_1_sqd_on_mu_hm_1_sqd, & ! Ratio sigma_hm_1**2 / mu_hm_1**2 [-] + sigma_hm_2_sqd_on_mu_hm_2_sqd ! Ratio sigma_hm_2**2 / mu_hm_2**2 [-] + + ! Local Variables + real( kind = core_rknd ) :: & + Rmax, & ! Maximum possible value of ratio R [-] + coef_A, & ! Coefficient A in A*mu_hm_1^2 + B*mu_hm_1 + C = 0 [-] + coef_B, & ! Coefficient B in A*mu_hm_1^2 + B*mu_hm_1 + C = 0 [hm un] + coef_C, & ! Coefficient C in A*mu_hm_1^2 + B*mu_hm_1 + C = 0 [hm un^2] + Bsqd_m_4AC ! Value B^2 - 4*A*C in quadratic eqn. for mu_hm_1 [hm un^2] + + real( kind = core_rknd ) :: & + mu_hm_1_min, & ! Minimum value of mu_hm_1 (precip. in both comps.) [hm un] + mu_hm_2_min ! Minimum value of mu_hm_2 (precip. in both comps.) [hm un] + + real( kind = core_rknd ), parameter :: & + mu_hm_min_coef = 0.01_core_rknd ! Coef. for mu_hm_1_min and mu_hm_2_min + + + ! Calculate the value of Rmax. + ! Rmax = ( f_p / ( a * f_p_1 * ( 1 + zeta ) + ( 1 - a ) * f_p_2 ) ) + ! * ( / ^2 ). + ! The parameter zeta is written in the code as zeta_vrnce_rat. + Rmax = ( precip_frac & + / ( mixt_frac * precip_frac_1 * ( one + zeta_vrnce_rat ) & + + ( one - mixt_frac ) * precip_frac_2 ) ) & + * hmp2_ip_on_hmm2_ip + + ! Calculate the value of coefficient A. + ! A = a * f_p_1 * ( 1 + omicron * Rmax * ( 1 + zeta ) ) + ! + a^2 * f_p_1^2 * ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ). + coef_A = mixt_frac * precip_frac_1 & + * ( one + omicron * Rmax * ( one + zeta_vrnce_rat ) ) & + + mixt_frac**2 * precip_frac_1**2 & + * ( one + omicron * Rmax ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) + + ! Calculate the value of coefficient B. + ! B = - 2 * * a * f_p_1 * ( 1 + omicron * Rmax ) + ! / ( ( 1 - a ) * f_p_2 ). + coef_B = -two * hmm * mixt_frac * precip_frac_1 & + * ( one + omicron * Rmax ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) + + ! Calculate the value of coefficient C. + ! C = - ( + ! + ( 1 - ( 1 + omicron * Rmax ) / ( ( 1 - a ) * f_p_2 ) ) + ! * ^2 ). + coef_C = - ( hmp2 + ( one & + - ( one + omicron * Rmax ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) & + ) * hmm**2 ) + + ! Calculate value of B^2 - 4*A*C. + Bsqd_m_4AC = coef_B**2 - four * coef_A * coef_C + + ! Mathematically, the value of B^2 - 4*A*C cannot be less than 0. + ! Numerically, this can happen when numerical round off error causes an + ! epsilon-sized negative value. When this happens, reset the value of + ! B^2 - 4*A*C to 0. + if ( Bsqd_m_4AC < zero ) then + Bsqd_m_4AC = zero + endif + + ! Calculate the mean (in-precip.) of the hydrometeor in the 1st PDF + ! component. + if ( zeta_vrnce_rat >= zero ) then + mu_hm_1 = ( -coef_B + sqrt( Bsqd_m_4AC ) ) / ( two * coef_A ) + else + mu_hm_1 = ( -coef_B - sqrt( Bsqd_m_4AC ) ) / ( two * coef_A ) + endif + + ! Calculate the mean (in-precip.) of the hydrometeor in the 2nd PDF + ! component. + mu_hm_2 = ( hmm - mixt_frac * precip_frac_1 * mu_hm_1 ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) + + ! Calculate the value of the ratio R (which is sigma_hm_2^2 / mu_hm_2^2), + ! where R = omicron * Rmax. The name of the variable used for R is + ! sigma_hm_2_sqd_on_mu_hm_2_sqd. + sigma_hm_2_sqd_on_mu_hm_2_sqd = omicron * Rmax + + ! Calculate minimum allowable values for mu_hm_1 and mu_hm_2. + if ( hmm / precip_frac > hm_tol / precip_frac_1 ) then + mu_hm_1_min & + = min( hm_tol / precip_frac_1 & + + mu_hm_min_coef * ( hmm / precip_frac & + - hm_tol / precip_frac_1 ), & + ( hmm - ( one - mixt_frac ) * hm_tol ) & + / ( mixt_frac * precip_frac_1 ) ) + else ! hmm / precip_frac <= hm_tol / precip_frac_1 + mu_hm_1_min = hm_tol / precip_frac_1 + endif + if ( hmm / precip_frac > hm_tol / precip_frac_2 ) then + mu_hm_2_min & + = min( hm_tol / precip_frac_2 & + + mu_hm_min_coef * ( hmm / precip_frac & + - hm_tol / precip_frac_2 ), & + ( hmm - mixt_frac * hm_tol ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) ) + else ! hmm / precip_frac <= hm_tol / precip_frac_2 + mu_hm_2_min = hm_tol / precip_frac_2 + endif + + ! Handle the "emergency" situation when the specified value of omicron is + ! too small for the value of / ^2, resulting in a + ! component mean that is too small (below tolerance value) or negative. + if ( mu_hm_1 < mu_hm_1_min ) then + + ! Set the value of mu_hm_1 to the threshold positive value. + mu_hm_1 = mu_hm_1_min + + ! Recalculate the mean (in-precip.) of the hydrometeor in the 2nd PDF + ! component. + mu_hm_2 = ( hmm - mixt_frac * precip_frac_1 * mu_hm_1 ) & + / ( ( one - mixt_frac ) * precip_frac_2 ) + + ! Recalculate the value of R ( sigma_hm_2^2 / mu_hm_2^2 ) in this + ! scenario. + ! R = ( + ^2 - a * f_p_1 * mu_hm_1^2 + ! - ( 1 - a ) * f_p_2 * mu_hm_2^2 ) + ! / ( a * f_p_1 * ( 1 + zeta ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * mu_hm_2^2 ). + sigma_hm_2_sqd_on_mu_hm_2_sqd & + = ( hmp2 + hmm**2 - mixt_frac * precip_frac_1 * mu_hm_1**2 & + - ( one - mixt_frac ) * precip_frac_2 * mu_hm_2**2 ) & + / ( mixt_frac * precip_frac_1 * ( one + zeta_vrnce_rat ) * mu_hm_1**2 & + + ( one - mixt_frac ) * precip_frac_2 * mu_hm_2**2 ) + + ! Mathematically, this ratio can never be less than 0. In case numerical + ! round off error produces a negative value in extreme cases, reset the + ! value of R to 0. + if ( sigma_hm_2_sqd_on_mu_hm_2_sqd < zero ) then + sigma_hm_2_sqd_on_mu_hm_2_sqd = zero + endif + + elseif ( mu_hm_2 < mu_hm_2_min ) then + + ! Set the value of mu_hm_2 to the threshold positive value. + mu_hm_2 = mu_hm_2_min + + ! Recalculate the mean (in-precip.) of the hydrometeor in the 1st PDF + ! component. + mu_hm_1 = ( hmm - ( one - mixt_frac ) * precip_frac_2 * mu_hm_2 ) & + / ( mixt_frac * precip_frac_1 ) + + ! Recalculate the value of R ( sigma_hm_2^2 / mu_hm_2^2 ) in this + ! scenario. + ! R = ( + ^2 - a * f_p_1 * mu_hm_1^2 + ! - ( 1 - a ) * f_p_2 * mu_hm_2^2 ) + ! / ( a * f_p_1 * ( 1 + zeta ) * mu_hm_1^2 + ! + ( 1 - a ) * f_p_2 * mu_hm_2^2 ). + sigma_hm_2_sqd_on_mu_hm_2_sqd & + = ( hmp2 + hmm**2 - mixt_frac * precip_frac_1 * mu_hm_1**2 & + - ( one - mixt_frac ) * precip_frac_2 * mu_hm_2**2 ) & + / ( mixt_frac * precip_frac_1 * ( one + zeta_vrnce_rat ) * mu_hm_1**2 & + + ( one - mixt_frac ) * precip_frac_2 * mu_hm_2**2 ) + + ! Mathematically, this ratio can never be less than 0. In case numerical + ! round off error produces a negative value in extreme cases, reset the + ! value of R to 0. + if ( sigma_hm_2_sqd_on_mu_hm_2_sqd < zero ) then + sigma_hm_2_sqd_on_mu_hm_2_sqd = zero + endif + + endif + + ! Calculate the standard deviation (in-precip.) of the hydrometeor in the + ! 1st PDF component. + sigma_hm_1 = sqrt( sigma_hm_2_sqd_on_mu_hm_2_sqd & + * ( one + zeta_vrnce_rat ) ) & + * mu_hm_1 + + ! Calculate the standard deviation (in-precip.) of the hydrometeor in the + ! 2nd PDF component. + sigma_hm_2 = sqrt( sigma_hm_2_sqd_on_mu_hm_2_sqd ) * mu_hm_2 + + ! Calculate the mean of the hydrometeor in the 1st PDF component. + hm_1 = max( mu_hm_1 * precip_frac_1, hm_tol ) + + ! Calculate the mean of the hydrometeor in the 1st PDF component. + hm_2 = max( mu_hm_2 * precip_frac_2, hm_tol ) + + ! Calculate the ratio of sigma_hm_1^2 / mu_hm_1^2. + sigma_hm_1_sqd_on_mu_hm_1_sqd = sigma_hm_1**2 / mu_hm_1**2 + + ! The value of R, sigma_hm_2_sqd_on_mu_hm_2_sqd, has already been + ! calculated. + + + return + + end subroutine calc_mu_sigma_two_comps + + !============================================================================= + function component_corr_w_x( corr_w_x, rc_i, cloud_frac_i, & + corr_w_x_NN_cloud, corr_w_x_NN_below ) & + result( corr_w_x_i ) + + ! Description: + ! Calculates the correlation of w and x within the ith PDF component. + ! Here, x is a variable with a normally distributed individual marginal PDF, + ! such as chi or eta. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_calc_w_corr + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_w_x, & ! Correlation of w and x (overall) [-] + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_w_x_NN_cloud, & ! Corr. of w and x (ith PDF comp.); cloudy levs [-] + corr_w_x_NN_below ! Corr. of w and x (ith PDF comp.); clear levs [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_w_x_i ! Correlation of w and x (ith PDF component) [-] + + ! Local Variables + + ! The component correlations of w and r_t and the component correlations of + ! w and theta_l are both set to be 0 within the CLUBB model code. In other + ! words, w and r_t (theta_l) have overall covariance w'r_t' (w'theta_l'), + ! but the single component covariance and correlation are defined to be 0. + ! Since the component covariances (or correlations) of w and chi (old s) and + ! of w and eta (old t) are based on the covariances (or correlations) of w + ! and r_t and of w and theta_l, the single component correlation and + ! covariance of w and chi, as well of as w and eta, are defined to be 0. + logical, parameter :: & + l_follow_CLUBB_PDF_standards = .true. + + + ! Correlation of w and x in the ith PDF component. + if ( l_follow_CLUBB_PDF_standards ) then + + ! The component correlations of w and r_t and the component correlations + ! of w and theta_l are both set to be 0 within the CLUBB model code. In + ! other words, w and r_t (theta_l) have overall covariance w'r_t' + ! (w'theta_l'), but the single component covariance and correlation are + ! defined to be 0. Since the component covariances (or correlations) + ! of w and chi (old s) and of w and eta (old t) are based on the + ! covariances (or correlations) of w and r_t and of w and theta_l, the + ! single component correlation and covariance of w and chi, as well as of + ! w and eta, are defined to be 0. + corr_w_x_i = zero + + else ! not following CLUBB PDF standards + + ! WARNING: the standards used in the generation of the two-component + ! CLUBB PDF are not being obeyed. The use of this code is + ! inconsistent with the rest of CLUBB's PDF. + if ( l_calc_w_corr ) then + corr_w_x_i = corr_w_x + else ! use prescribed parameter values + if ( l_interp_prescribed_params ) then + corr_w_x_i = cloud_frac_i * corr_w_x_NN_cloud & + + ( one - cloud_frac_i ) * corr_w_x_NN_below + else + if ( rc_i > rc_tol ) then + corr_w_x_i = corr_w_x_NN_cloud + else + corr_w_x_i = corr_w_x_NN_below + endif + endif ! l_interp_prescribed_params + endif ! l_calc_w_corr + + endif ! l_follow_CLUBB_PDF_standards + + + return + + end function component_corr_w_x + + !============================================================================= + function component_corr_chi_eta( pdf_corr_chi_eta_i, rc_i, cloud_frac_i, & + corr_chi_eta_NN_cloud, & + corr_chi_eta_NN_below, & + l_limit_corr_chi_eta ) & + result( corr_chi_eta_i ) + + ! Description: + ! Calculates the correlation of chi (old s) and eta (old t) within the + ! ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol, & + max_mag_correlation + + use model_flags, only: & + l_fix_chi_eta_correlations ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + pdf_corr_chi_eta_i, & ! Correlation of chi and eta (ith PDF component) [-] + rc_i, & ! Mean cloud water mix. rat. (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_NN_cloud, & ! Corr. of chi & eta (ith PDF comp.); cloudy [-] + corr_chi_eta_NN_below ! Corr. of chi & eta (ith PDF comp.); clear [-] + + logical, intent(in) :: & + l_limit_corr_chi_eta ! We must limit the correlation of chi and eta if + ! we are to take the Cholesky decomposition of the + ! resulting correlation matrix. This is because a + ! perfect correlation of chi and eta was found to + ! be unrealizable. + + ! Return Variable + real( kind = core_rknd ) :: & + corr_chi_eta_i ! Correlation of chi and eta (ith PDF component) [-] + + + ! Correlation of chi (old s) and eta (old t) in the ith PDF component. + + ! The PDF variables chi and eta result from a transformation of the PDF + ! involving r_t and theta_l. The correlation of chi and eta depends on the + ! correlation of r_t and theta_l, as well as the variances of r_t and + ! theta_l, and other factors. The correlation of chi and eta is subject to + ! change at every vertical level and model time step, and is calculated as + ! part of the CLUBB PDF parameters. + if ( .not. l_fix_chi_eta_correlations ) then + + ! Preferred, more accurate version. + corr_chi_eta_i = pdf_corr_chi_eta_i + + else ! fix the correlation of chi (old s) and eta (old t). + + ! WARNING: this code is inconsistent with the rest of CLUBB's PDF. This + ! code is necessary because SILHS is lazy and wussy, and only + ! wants to declare correlation arrays at the start of the model + ! run, rather than updating them throughout the model run. + if ( l_interp_prescribed_params ) then + corr_chi_eta_i = cloud_frac_i * corr_chi_eta_NN_cloud & + + ( one - cloud_frac_i ) * corr_chi_eta_NN_below + else + if ( rc_i > rc_tol ) then + corr_chi_eta_i = corr_chi_eta_NN_cloud + else + corr_chi_eta_i = corr_chi_eta_NN_below + endif + endif + + endif + + ! We cannot have a perfect correlation of chi (old s) and eta (old t) if we + ! plan to decompose this matrix and we don't want the Cholesky_factor code + ! to throw a fit. + if ( l_limit_corr_chi_eta ) then + + corr_chi_eta_i = max( min( corr_chi_eta_i, max_mag_correlation ), & + -max_mag_correlation ) + + endif + + + return + + end function component_corr_chi_eta + + !============================================================================= + function component_corr_w_hm_n_ip( corr_w_hm_i_n_in, rc_i, cloud_frac_i, & + corr_w_hm_n_NL_cloud, & + corr_w_hm_n_NL_below ) & + result( corr_w_hm_i_n ) + + ! Description: + ! Calculates the in-precip correlation of w and the natural logarithm of a + ! hydrometeor species within the ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_calc_w_corr + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_w_hm_i_n_in, & ! Correlation of w and ln hm (ith PDF comp.) ip [-] + rc_i, & ! Mean cloud water mix. ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_w_hm_n_NL_cloud, & ! Corr. of w & ln hm (ith PDF comp.) ip; cloud [-] + corr_w_hm_n_NL_below ! Corr. of w & ln hm (ith PDF comp.) ip; clear [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_w_hm_i_n ! Correlation of w and ln hm (ith PDF component) ip [-] + + + ! Correlation (in-precip) of w and the natural logarithm of the hydrometeor + ! in the ith PDF component. + if ( l_calc_w_corr ) then + corr_w_hm_i_n = corr_w_hm_i_n_in + else ! use prescribed parameter values + if ( l_interp_prescribed_params ) then + corr_w_hm_i_n = cloud_frac_i * corr_w_hm_n_NL_cloud & + + ( one - cloud_frac_i ) * corr_w_hm_n_NL_below + else + if ( rc_i > rc_tol ) then + corr_w_hm_i_n = corr_w_hm_n_NL_cloud + else + corr_w_hm_i_n = corr_w_hm_n_NL_below + endif + endif ! l_interp_prescribed_params + endif ! l_calc_w_corr + + return + + end function component_corr_w_hm_n_ip + + !============================================================================= + function component_corr_x_hm_n_ip( rc_i, cloud_frac_i, & + corr_x_hm_n_NL_cloud, & + corr_x_hm_n_NL_below ) & + result( corr_x_hm_i_n ) + + ! Description: + ! Calculates the in-precip correlation of x and a hydrometeor species + ! within the ith PDF component. Here, x is a variable with a normally + ! distributed individual marginal PDF, such as chi or eta. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_x_hm_n_NL_cloud, & ! Corr. of x and ln hm (ith PDF comp.) ip [-] + corr_x_hm_n_NL_below ! Corr. of x and ln hm (ith PDF comp.) ip [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_x_hm_i_n ! Correlation of x and ln hm (ith PDF component) ip [-] + + + ! Correlation (in-precip) of x and the hydrometeor in the ith PDF component. + if ( l_interp_prescribed_params ) then + corr_x_hm_i_n = cloud_frac_i * corr_x_hm_n_NL_cloud & + + ( one - cloud_frac_i ) * corr_x_hm_n_NL_below + else + if ( rc_i > rc_tol ) then + corr_x_hm_i_n = corr_x_hm_n_NL_cloud + else + corr_x_hm_i_n = corr_x_hm_n_NL_below + endif + endif + + + return + + end function component_corr_x_hm_n_ip + + !============================================================================= + function component_corr_hmx_hmy_n_ip( rc_i, cloud_frac_i, & + corr_hmx_hmy_n_LL_cloud, & + corr_hmx_hmy_n_LL_below ) & + result( corr_hmx_hmy_i_n ) + + ! Description: + ! Calculates the in-precip correlation of the natural logarithms of + ! hydrometeor x and hydrometeor y within the ith PDF component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + rc_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + rc_i, & ! Mean cloud water mixing ratio (ith PDF comp.) [kg/kg] + cloud_frac_i ! Cloud fraction (ith PDF component) [-] + + real( kind = core_rknd ), intent(in) :: & + corr_hmx_hmy_n_LL_cloud, & ! Corr.: ln hmx & ln hmy (ith PDF comp.) ip [-] + corr_hmx_hmy_n_LL_below ! Corr.: ln hmx & ln hmy (ith PDF comp.) ip [-] + + ! Return Variable + real( kind = core_rknd ) :: & + corr_hmx_hmy_i_n ! Corr. of ln hmx & ln hmy (ith PDF comp.) ip [-] + + + ! Correlation (in-precip) of the natural logarithms of hydrometeor x and + ! hydrometeor y in the ith PDF component. + if ( l_interp_prescribed_params ) then + corr_hmx_hmy_i_n = cloud_frac_i * corr_hmx_hmy_n_LL_cloud & + + ( one - cloud_frac_i ) * corr_hmx_hmy_n_LL_below + else + if ( rc_i > rc_tol ) then + corr_hmx_hmy_i_n = corr_hmx_hmy_n_LL_cloud + else + corr_hmx_hmy_i_n = corr_hmx_hmy_n_LL_below + endif + endif + + + return + + end function component_corr_hmx_hmy_n_ip + + !============================================================================= + pure function component_corr_eta_hm_n_ip( corr_chi_eta_i, corr_chi_hm_n_i ) & + result( corr_eta_hm_n_i ) + + ! Description: + ! Estimates the correlation of eta and the natural logarithm of a + ! hydrometeor species using the correlation of chi and eta and the + ! correlation of chi and the natural logarithm of the hydrometeor. This + ! facilities the Cholesky decomposability of the correlation array that will + ! inevitably be decomposed for SILHS purposes. Without this estimation, we + ! have found that the resulting correlation matrix cannot be decomposed. + + ! References: + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_i, & ! Component correlation of chi and eta [-] + corr_chi_hm_n_i ! Component correlation of chi and ln hm [-] + + ! Output Variables + real( kind = core_rknd ) :: & + corr_eta_hm_n_i ! Component correlation of eta and ln hm [-] + + + corr_eta_hm_n_i = corr_chi_eta_i * corr_chi_hm_n_i + + + return + + end function component_corr_eta_hm_n_ip + + !============================================================================= + subroutine norm_transform_mean_stdev( hm_1, hm_2, & + Ncnm, d_variables, & + mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + sigma2_on_mu2_ip_1, & + sigma2_on_mu2_ip_2, & + mu_x_1_n, mu_x_2_n, & + sigma_x_1_n, sigma_x_2_n ) + + ! Description: + ! Transforms the means and the standard deviations of PDF variables that + ! have assumed lognormal distributions -- which are precipitating + ! hydrometeors (in precipitation) and N_cn -- to normal space for each PDF + ! component. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + Ncn_tol, & ! Constant(s) + zero + + use pdf_utilities, only: & + mean_L2N, & ! Procedure(s) + stdev_L2N + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use corr_varnce_module, only: & + iiPDF_Ncn ! Variable(s) + + use array_index, only: & + hydromet_tol ! Variable(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use model_flags, only: & + l_const_Nc_in_cloud ! Variable + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm_1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), intent(in) :: & + Ncnm ! Mean cloud nuclei concentration, < N_cn > [num/kg] + + integer, intent(in) :: & + d_variables ! Number of variables in CLUBB's PDF + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma2_on_mu2_ip_1, & ! Prescribed ratio array: sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Prescribed ratio array: sigma_hm_2^2/mu_hm_2^2 [-] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables), intent(out) :: & + mu_x_1_n, & ! Mean array (normal space): PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normal space): PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + ! Local Variable + integer :: ivar ! Loop index + + + ! The means and standard deviations in each PDF component of w, chi (old s), + ! and eta (old t) do not need to be transformed to normal space, since w, + ! chi, and eta already follow assumed normal distributions in each PDF + ! component. The normal space means and standard deviations are the same as + ! the actual means and standard deviations. + mu_x_1_n = mu_x_1 + mu_x_2_n = mu_x_2 + sigma_x_1_n = sigma_x_1 + sigma_x_2_n = sigma_x_2 + + !!! Transform the mean and standard deviation to normal space in each PDF + !!! component for variables that have an assumed lognormal distribution, + !!! given the mean and standard deviation in each PDF component for those + !!! variables. A precipitating hydrometeor has an assumed lognormal + !!! distribution in precipitation in each PDF component. Simplified cloud + !!! nuclei concentration, N_cn, has an assumed lognormal distribution in + !!! each PDF component, and furthermore, mu_Ncn_1 = mu_Ncn_2 and + !!! sigma_Ncn_1 = sigma_Ncn_2, so N_cn has an assumed single lognormal + !!! distribution over the entire domain. + + ! Normal space mean of simplified cloud nuclei concentration, N_cn, + ! in PDF component 1. + if ( Ncnm >= Ncn_tol ) then + + mu_x_1_n(iiPDF_Ncn) = mean_L2N( mu_x_1(iiPDF_Ncn), & + sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + else + + ! Mean simplified cloud nuclei concentration in PDF component 1 is less + ! than the tolerance amount. It is considered to have a value of 0. + ! There are not any cloud nuclei or cloud at this grid level. The value + ! of mu_Ncn_1_n should be -inf. It will be set to -huge for purposes of + ! assigning it a value. + mu_x_1_n(iiPDF_Ncn) = -huge( mu_x_1(iiPDF_Ncn) ) + + endif + + ! Normal space mean of simplified cloud nuclei concentration, N_cn, + ! in PDF component 2. + if ( Ncnm >= Ncn_tol ) then + + mu_x_2_n(iiPDF_Ncn) = mean_L2N( mu_x_2(iiPDF_Ncn), & + sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + else + + ! Mean simplified cloud nuclei concentration in PDF component 1 is less + ! than the tolerance amount. It is considered to have a value of 0. + ! There are not any cloud nuclei or cloud at this grid level. The value + ! of mu_Ncn_1_n should be -inf. It will be set to -huge for purposes of + ! assigning it a value. + mu_x_2_n(iiPDF_Ncn) = -huge( mu_x_2(iiPDF_Ncn) ) + + endif + + ! Normal space standard deviation of simplified cloud nuclei concentration, + ! N_cn, in PDF components 1 and 2. + if ( l_const_Nc_in_cloud ) then + ! Ncn does not vary in the grid box. + sigma_x_1_n(iiPDF_Ncn) = zero + sigma_x_2_n(iiPDF_Ncn) = zero + else + ! Ncn (perhaps) varies in the grid box. + sigma_x_1_n(iiPDF_Ncn) = stdev_L2N( sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + sigma_x_2_n(iiPDF_Ncn) = stdev_L2N( sigma2_on_mu2_ip_2(iiPDF_Ncn) ) + end if + + ! Normal space precipitating hydrometeor means and standard deviations. + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Normal space mean of a precipitating hydrometeor, hm, in PDF + ! component 1. + if ( hm_1(pdf2hydromet_idx(ivar)) & + >= hydromet_tol(pdf2hydromet_idx(ivar)) ) then + + mu_x_1_n(ivar) = mean_L2N( mu_x_1(ivar), sigma2_on_mu2_ip_1(ivar) ) + + else + + ! The mean of a precipitating hydrometeor in PDF component 1 is less + ! than its tolerance amount. It is considered to have a value of 0. + ! There is not any of this precipitating hydrometeor in the 1st PDF + ! component at this grid level. The in-precip mean of this + ! precipitating hydrometeor (1st PDF component) is also 0. The value + ! of mu_hm_1_n should be -inf. It will be set to -huge for purposes + ! of assigning it a value. + mu_x_1_n(ivar) = -huge( mu_x_1(ivar) ) + + endif + + ! Normal space standard deviation of a precipitating hydrometeor, hm, in + ! PDF component 1. + sigma_x_1_n(ivar) = stdev_L2N( sigma2_on_mu2_ip_1(ivar) ) + + ! Normal space mean of a precipitating hydrometeor, hm, in PDF + ! component 2. + if ( hm_2(pdf2hydromet_idx(ivar)) & + >= hydromet_tol(pdf2hydromet_idx(ivar)) ) then + + mu_x_2_n(ivar) = mean_L2N( mu_x_2(ivar), sigma2_on_mu2_ip_2(ivar) ) + + else + + ! The mean of a precipitating hydrometeor in PDF component 2 is less + ! than its tolerance amount. It is considered to have a value of 0. + ! There is not any of this precipitating hydrometeor in the 2nd PDF + ! component at this grid level. The in-precip mean of this + ! precipitating hydrometeor (2nd PDF component) is also 0. The value + ! of mu_hm_2_n should be -inf. It will be set to -huge for purposes + ! of assigning it a value. + mu_x_2_n(ivar) = -huge( mu_x_2(ivar) ) + + endif + + ! Normal space standard deviation of a precipitating hydrometeor, hm, in + ! PDF component 2. + sigma_x_2_n(ivar) = stdev_L2N( sigma2_on_mu2_ip_2(ivar) ) + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + + return + + end subroutine norm_transform_mean_stdev + + !============================================================================= + subroutine denorm_transform_corr( d_variables, & + sigma_x_1_n, sigma_x_2_n, & + sigma2_on_mu2_ip_1, sigma2_on_mu2_ip_2, & + corr_array_1_n, & + corr_array_2_n, & + corr_array_1, corr_array_2 ) + + ! Description: + ! Calculates the true or "real-space" correlations between PDF variables, + ! where at least one of the variables that is part of a correlation has an + ! assumed lognormal distribution -- which are the precipitating hydrometeors + ! (in precipitation) and N_cn. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + zero ! Constant + + use pdf_utilities, only: & + corr_NN2NL, & ! Procedure(s) + corr_NN2LL + + use corr_varnce_module, only: & + iiPDF_chi, & ! Variable(s) + iiPDF_eta, & + iiPDF_w, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables ! Number of PDF variables + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + real ( kind = core_rknd ), dimension(d_variables), intent(in) :: & + sigma2_on_mu2_ip_1, & ! Ratio array sigma_hm_1^2/mu_hm_1^2 [-] + sigma2_on_mu2_ip_2 ! Ratio array sigma_hm_2^2/mu_hm_2^2 [-] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1_n, & ! Corr. array (normal space) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normal space) of PDF vars. (comp. 2) [-] + + ! Output Variables + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(out) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + ! Local Variables + integer :: ivar, jvar ! Loop indices + + + ! The correlations in each PDF component between two of w, chi (old s), and + ! eta (old t) do not need to be transformed to standard space, since w, chi, + ! and eta follow assumed normal distributions in each PDF component. The + ! normal space correlations between any two of these variables are the same + ! as the actual correlations. + corr_array_1 = corr_array_1_n + corr_array_2 = corr_array_2_n + + !!! Calculate the true correlation of variables that have an assumed normal + !!! distribution and variables that have an assumed lognormal distribution + !!! for the ith PDF component, given their normal space correlation and the + !!! normal space standard deviation of the variable with the assumed + !!! lognormal distribution. + + ! Transform the correlations between chi/eta/w and N_cn to standard space. + + ! Transform the correlation of w and N_cn to standard space in PDF + ! component 1. + corr_array_1(iiPDF_Ncn, iiPDF_w) & + = corr_NN2NL( corr_array_1_n(iiPDF_Ncn, iiPDF_w), & + sigma_x_1_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlation of w and N_cn to standard space in PDF + ! component 2. + corr_array_2(iiPDF_Ncn, iiPDF_w) & + = corr_NN2NL( corr_array_2_n(iiPDF_Ncn, iiPDF_w), & + sigma_x_2_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlation of chi (old s) and N_cn to standard space in + ! PDF component 1. + corr_array_1(iiPDF_Ncn, iiPDF_chi) & + = corr_NN2NL( corr_array_1_n(iiPDF_Ncn, iiPDF_chi), & + sigma_x_1_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlation of chi (old s) and N_cn to standard space in + ! PDF component 2. + corr_array_2(iiPDF_Ncn, iiPDF_chi) & + = corr_NN2NL( corr_array_2_n(iiPDF_Ncn, iiPDF_chi), & + sigma_x_2_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlation of eta (old t) and N_cn to standard space in + ! PDF component 1. + corr_array_1(iiPDF_Ncn, iiPDF_eta) & + = corr_NN2NL( corr_array_1_n(iiPDF_Ncn, iiPDF_eta), & + sigma_x_1_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlation of eta (old t) and N_cn to standard space in + ! PDF component 2. + corr_array_2(iiPDF_Ncn, iiPDF_eta) & + = corr_NN2NL( corr_array_2_n(iiPDF_Ncn, iiPDF_eta), & + sigma_x_2_n(iiPDF_Ncn), sigma2_on_mu2_ip_1(iiPDF_Ncn) ) + + ! Transform the correlations (in-precip) between chi/eta/w and the + ! precipitating hydrometeors to standard space. + do ivar = iiPDF_chi, iiPDF_w + do jvar = iiPDF_Ncn+1, d_variables + + ! Transform the correlation (in-precip) between w, chi, or eta and a + ! precipitating hydrometeor, hm, to standard space in PDF component 1. + corr_array_1(jvar, ivar) & + = corr_NN2NL( corr_array_1_n(jvar, ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(jvar) ) + + ! Transform the correlation (in-precip) between w, chi, or eta and a + ! precipitating hydrometeor, hm, to standard space in PDF component 2. + corr_array_2(jvar, ivar) & + = corr_NN2NL( corr_array_2_n(jvar, ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_2(jvar) ) + + enddo ! jvar = iiPDF_Ncn+1, d_variables + enddo ! ivar = iiPDF_chi, iiPDF_w + + + !!! Calculate the true correlation of two variables that both have an + !!! assumed lognormal distribution for the ith PDF component, given their + !!! normal space correlation and both of their normal space standard + !!! deviations. + + ! Transform the correlations (in-precip) between N_cn and the precipitating + ! hydrometeors to standard space. + ivar = iiPDF_Ncn + do jvar = ivar+1, d_variables + + ! Transform the correlation (in-precip) between N_cn and a precipitating + ! hydrometeor, hm, to standard space in PDF component 1. + corr_array_1(jvar, ivar) & + = corr_NN2LL( corr_array_1_n(jvar, ivar), & + sigma_x_1_n(ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(iiPDF_Ncn), sigma2_on_mu2_ip_1(jvar) ) + + ! Transform the correlation (in-precip) between N_cn and a precipitating + ! hydrometeor, hm, to standard space in PDF component 2. + corr_array_2(jvar, ivar) & + = corr_NN2LL( corr_array_2_n(jvar, ivar), & + sigma_x_2_n(ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_1(iiPDF_Ncn), sigma2_on_mu2_ip_2(jvar) ) + + enddo ! jvar = ivar+1, d_variables + + ! Transform the correlations (in-precip) between two precipitating + ! hydrometeors to standard space. + do ivar = iiPDF_Ncn+1, d_variables-1 + do jvar = ivar+1, d_variables + + ! Transform the correlation (in-precip) between two precipitating + ! hydrometeors (for example, r_r and N_r) to standard space in PDF + ! component 1. + corr_array_1(jvar, ivar) & + = corr_NN2LL( corr_array_1_n(jvar, ivar), & + sigma_x_1_n(ivar), sigma_x_1_n(jvar), & + sigma2_on_mu2_ip_1(ivar), sigma2_on_mu2_ip_1(jvar) ) + + ! Transform the correlation (in-precip) between two precipitating + ! hydrometeors (for example, r_r and N_r) to standard space in PDF + ! component 2. + corr_array_2(jvar, ivar) & + = corr_NN2LL( corr_array_2_n(jvar, ivar), & + sigma_x_2_n(ivar), sigma_x_2_n(jvar), & + sigma2_on_mu2_ip_2(ivar), sigma2_on_mu2_ip_2(jvar) ) + + enddo ! jvar = ivar+1, d_variables + enddo ! ivar = iiPDF_Ncn+1, d_variables-1 + + + return + + end subroutine denorm_transform_corr + + !============================================================================= + subroutine calc_corr_w_hm_n( wm, wphydrometp, & + mu_w_1, mu_w_2, & + mu_hm_1, mu_hm_2, & + sigma_w_1, sigma_w_2, & + sigma_hm_1, sigma_hm_2, & + sigma_hm_1_n, sigma_hm_2_n, & + mixt_frac, precip_frac_1, precip_frac_2, & + corr_w_hm_1_n, corr_w_hm_2_n, & + hm_tol ) + + ! Description: + ! Calculates the PDF component correlation (in-precip) between vertical + ! velocity, w, and the natural logarithm of a hydrometeor, ln hm. The + ! overall covariance of w and hm, can be written in terms of the PDF + ! parameters. When both w and hm vary in both PDF components, the equation + ! is written as: + ! + ! = mixt_frac * precip_frac_1 + ! * ( mu_w_1 - + ! + corr_w_hm_1_n * sigma_w_1 * sigma_hm_1_n ) * mu_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( mu_w_2 - + ! + corr_w_hm_2_n * sigma_w_2 * sigma_hm_2_n ) * mu_hm_2. + ! + ! The overall covariance is provided, so the component correlation is solved + ! by setting corr_w_hm_1_n = corr_w_hm_2_n ( = corr_w_hm_n ). The equation + ! is: + ! + ! corr_w_hm_n + ! = ( + ! - mixt_frac * precip_frac_1 * ( mu_w_1 - ) * mu_hm_1 + ! - ( 1 - mixt_frac ) * precip_frac_2 * ( mu_w_2 - ) * mu_hm_2 ) + ! / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1_n * mu_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * sigma_w_2 * sigma_hm_2_n * mu_hm_2 ); + ! + ! again, where corr_w_hm_1_n = corr_w_hm_2_n = corr_w_hm_n. When either w + ! or hm is constant in one PDF component, but both w and hm vary in the + ! other PDF component, the equation for is written as: + ! + ! = mixt_frac * precip_frac_1 + ! * ( mu_w_1 - + ! + corr_w_hm_1_n * sigma_w_1 * sigma_hm_1_n ) * mu_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( mu_w_2 - ) * mu_hm_2. + ! + ! In the above equation, either w or hm (or both) is (are) constant in PDF + ! component 2, but both w and hm vary in PDF component 1. When both w and + ! hm vary in PDF component 2, but at least one of w or hm is constant in PDF + ! component 1, the equation is similar. The above equation can be rewritten + ! to solve for corr_w_hm_1_n, such that: + ! + ! corr_w_hm_1_n + ! = ( + ! - mixt_frac * precip_frac_1 * ( mu_w_1 - ) * mu_hm_1 + ! - ( 1 - mixt_frac ) * precip_frac_2 * ( mu_w_2 - ) * mu_hm_2 ) + ! / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1_n * mu_hm_1 ). + ! + ! Since either w or hm is constant in PDF component 2, corr_w_hm_2_n is + ! undefined. When both w and hm vary in PDF component 2, but at least one + ! of w or hm is constant in PDF component 1, the equation is similar, but + ! is in terms of corr_w_hm_2_n, while corr_w_hm_1_n is undefined. When + ! either w or hm is constant in both PDF components, the equation for + ! is: + ! + ! = mixt_frac * precip_frac_1 + ! * ( mu_w_1 - ) * mu_hm_1 + ! + ( 1 - mixt_frac ) * precip_frac_2 + ! * ( mu_w_2 - ) * mu_hm_2. + ! + ! When this is the case, both corr_w_hm_1_n and corr_w_hm_2_n are undefined. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one, & ! Constant(s) + zero, & + max_mag_correlation, & + w_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + wm, & ! Mean vertical velocity (overall), [m/s] + wphydrometp, & ! Covariance of w and hm (overall), [m/s(hm un)] + mu_w_1, & ! Mean of w (1st PDF component) [m/s] + mu_w_2, & ! Mean of w (2nd PDF component) [m/s] + mu_hm_1, & ! Mean of hm (1st PDF component) in-precip (ip) [hm un] + mu_hm_2, & ! Mean of hm (2nd PDF component) ip [hm un] + sigma_w_1, & ! Standard deviation of w (1st PDF component) [m/s] + sigma_w_2, & ! Standard deviation of w (2nd PDF component) [m/s] + sigma_hm_1, & ! Standard deviation of hm (1st PDF component) ip [hm un] + sigma_hm_2, & ! Standard deviation of hm (2nd PDF component) ip [hm un] + sigma_hm_1_n, & ! Standard deviation of ln hm (1st PDF component) ip [-] + sigma_hm_2_n, & ! Standard deviation of ln hm (2nd PDF component) ip [-] + mixt_frac, & ! Mixture fraction [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2, & ! Precipitation fraction (2nd PDF component) [-] + hm_tol ! Hydrometeor tolerance value [hm un] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + corr_w_hm_1_n, & ! Correlation of w and ln hm (1st PDF component) ip [-] + corr_w_hm_2_n ! Correlation of w and ln hm (2nd PDF component) ip [-] + + ! Local Variables + real( kind = core_rknd ) :: & + corr_w_hm_n ! Correlation of w and ln hm (both PDF components) ip [-] + + + ! Calculate the PDF component correlation of vertical velocity, w, and the + ! natural logarithm of a hydrometeor, ln hm, in precipitation. + if ( sigma_w_1 > w_tol .and. sigma_hm_1 > hm_tol .and. & + sigma_w_2 > w_tol .and. sigma_hm_2 > hm_tol ) then + + ! Both w and hm vary in both PDF components. + ! Calculate corr_w_hm_n (where corr_w_hm_1_n = corr_w_hm_2_n + ! = corr_w_hm_n). + corr_w_hm_n & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1_n * mu_hm_1 & + + ( one - mixt_frac ) * precip_frac_2 & + * sigma_w_2 * sigma_hm_2_n * mu_hm_2 ) + + ! Check that the PDF component correlations have reasonable values. + if ( corr_w_hm_n > max_mag_correlation ) then + corr_w_hm_n = max_mag_correlation + elseif ( corr_w_hm_n < -max_mag_correlation ) then + corr_w_hm_n = -max_mag_correlation + endif + + ! The PDF component correlations between w and ln hm (in-precip) are + ! equal. + corr_w_hm_1_n = corr_w_hm_n + corr_w_hm_2_n = corr_w_hm_n + + + elseif ( sigma_w_1 > w_tol .and. sigma_hm_1 > hm_tol ) then + + ! Both w and hm vary in PDF component 1, but at least one of w and hm is + ! constant in PDF component 2. + ! Calculate the PDF component 1 correlation of w and ln hm (in-precip). + corr_w_hm_1_n & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( mixt_frac * precip_frac_1 * sigma_w_1 * sigma_hm_1_n * mu_hm_1 ) + + ! Check that the PDF component 1 correlation has a reasonable value. + if ( corr_w_hm_1_n > max_mag_correlation ) then + corr_w_hm_1_n = max_mag_correlation + elseif ( corr_w_hm_1_n < -max_mag_correlation ) then + corr_w_hm_1_n = -max_mag_correlation + endif + + ! The PDF component 2 correlation is undefined. + corr_w_hm_2_n = zero + + + elseif ( sigma_w_2 > w_tol .and. sigma_hm_2 > hm_tol ) then + + ! Both w and hm vary in PDF component 2, but at least one of w and hm is + ! constant in PDF component 1. + ! Calculate the PDF component 2 correlation of w and ln hm (in-precip). + corr_w_hm_2_n & + = ( wphydrometp & + - mixt_frac * precip_frac_1 * ( mu_w_1 - wm ) * mu_hm_1 & + - ( one - mixt_frac ) * precip_frac_2 * ( mu_w_2 - wm ) * mu_hm_2 ) & + / ( ( one - mixt_frac ) * precip_frac_2 & + * sigma_w_2 * sigma_hm_2_n * mu_hm_2 ) + + ! Check that the PDF component 2 correlation has a reasonable value. + if ( corr_w_hm_2_n > max_mag_correlation ) then + corr_w_hm_2_n = max_mag_correlation + elseif ( corr_w_hm_2_n < -max_mag_correlation ) then + corr_w_hm_2_n = -max_mag_correlation + endif + + ! The PDF component 1 correlation is undefined. + corr_w_hm_1_n = zero + + + else ! sigma_w_1 * sigma_hm_1 = 0 .and. sigma_w_2 * sigma_hm_2 = 0. + + ! At least one of w and hm is constant in both PDF components. + + ! The PDF component 1 and component 2 correlations are both undefined. + corr_w_hm_1_n = zero + corr_w_hm_2_n = zero + + + endif + + + return + + end subroutine calc_corr_w_hm_n + + !============================================================================= + subroutine pdf_param_hm_stats( d_variables, level, hm_1, hm_2, & + mu_x_1, mu_x_2, & + sigma_x_1, sigma_x_2, & + corr_array_1, corr_array_2, & + l_stats_samp ) + + ! Description: + ! Record statistics for standard PDF parameters involving hydrometeors. + + ! References: + !----------------------------------------------------------------------- + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only : & + ihm_1, & ! Variable(s) + ihm_2, & + imu_hm_1, & + imu_hm_2, & + imu_Ncn_1, & + imu_Ncn_2, & + isigma_hm_1, & + isigma_hm_2, & + isigma_Ncn_1, & + isigma_Ncn_2 + + use stats_variables, only : & + icorr_w_chi_1, & ! Variable(s) + icorr_w_chi_2, & + icorr_w_eta_1, & + icorr_w_eta_2, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_w_Ncn_1, & + icorr_w_Ncn_2, & + icorr_chi_eta_1_ca, & + icorr_chi_eta_2_ca, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_chi_Ncn_1, & + icorr_chi_Ncn_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_eta_Ncn_1, & + icorr_eta_Ncn_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + stats_zt + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variables in the correlation array + level ! Vertical level index + + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm_1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Local Variable + integer :: ivar, jvar ! Loop indices + + + !!! Output the statistics for hydrometeor PDF parameters. + + ! Statistics + if ( l_stats_samp ) then + + do ivar = 1, hydromet_dim, 1 + + if ( ihm_1(ivar) > 0 ) then + ! Mean of the precipitating hydrometeor in PDF component 1. + call stat_update_var_pt( ihm_1(ivar), level, hm_1(ivar), stats_zt ) + endif + + if ( ihm_2(ivar) > 0 ) then + ! Mean of the precipitating hydrometeor in PDF component 2. + call stat_update_var_pt( ihm_2(ivar), level, hm_2(ivar), stats_zt ) + endif + + enddo ! ivar = 1, hydromet_dim, 1 + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of the precipitating hydrometeor (in-precip) + ! in PDF component 1. + if ( imu_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( imu_hm_1(pdf2hydromet_idx(ivar)), & + level, mu_x_1(ivar), stats_zt ) + endif + + ! Mean of the precipitating hydrometeor (in-precip) + ! in PDF component 2. + if ( imu_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( imu_hm_2(pdf2hydromet_idx(ivar)), & + level, mu_x_2(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of cloud nuclei concentration in PDF component 1. + if ( imu_Ncn_1 > 0 ) then + call stat_update_var_pt( imu_Ncn_1, level, mu_x_1(iiPDF_Ncn), & + stats_zt ) + endif + + ! Mean of cloud nuclei concentration in PDF component 2. + if ( imu_Ncn_2 > 0 ) then + call stat_update_var_pt( imu_Ncn_2, level, mu_x_2(iiPDF_Ncn), & + stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of the precipitating hydrometeor (in-precip) + ! in PDF component 1. + if ( isigma_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_1(pdf2hydromet_idx(ivar)), & + level, sigma_x_1(ivar), stats_zt ) + endif + + ! Standard deviation of the precipitating hydrometeor (in-precip) + ! in PDF component 2. + if ( isigma_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_2(pdf2hydromet_idx(ivar)), & + level, sigma_x_2(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of cloud nuclei concentration in PDF component 1. + if ( isigma_Ncn_1 > 0 ) then + call stat_update_var_pt( isigma_Ncn_1, level, & + sigma_x_1(iiPDF_Ncn), stats_zt ) + endif + + ! Standard deviation of cloud nuclei concentration in PDF component 2. + if ( isigma_Ncn_2 > 0 ) then + call stat_update_var_pt( isigma_Ncn_2, level, & + sigma_x_2(iiPDF_Ncn), stats_zt ) + endif + + ! Correlation of w and chi (old s) in PDF component 1. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_chi_1 > 0 ) then + call stat_update_var_pt( icorr_w_chi_1, level, & + corr_array_1(iiPDF_w,iiPDF_chi), stats_zt ) + endif + + ! Correlation of w and chi (old s) in PDF component 2. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_chi_2 > 0 ) then + call stat_update_var_pt( icorr_w_chi_2, level, & + corr_array_2(iiPDF_w,iiPDF_chi), stats_zt ) + endif + + ! Correlation of w and eta (old t) in PDF component 1. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_eta_1 > 0 ) then + call stat_update_var_pt( icorr_w_eta_1, level, & + corr_array_1(iiPDF_w,iiPDF_eta), stats_zt ) + endif + + ! Correlation of w and eta (old t) in PDF component 2. + ! This correlation should always be 0 because both the correlation + ! between w and rt and the correlation of w and theta-l within each + ! PDF component are defined to be 0 by CLUBB standards. + if ( icorr_w_eta_2 > 0 ) then + call stat_update_var_pt( icorr_w_eta_2, level, & + corr_array_2(iiPDF_w,iiPDF_eta), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of w and the precipitating hydrometeor + ! in PDF component 1. + if ( icorr_w_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_w), & + stats_zt ) + endif + + ! Correlation (in-precip) of w and the precipitating hydrometeor + ! in PDF component 2. + if ( icorr_w_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_w), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of w and N_cn in PDF component 1. + if ( icorr_w_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of w and N_cn in PDF component 2. + if ( icorr_w_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of chi (old s) and eta (old t) in PDF component 1 found in + ! the correlation array. + ! The true correlation of chi and eta in each PDF component is solved for + ! by an equation and is part of CLUBB's PDF parameters. However, there + ! is an option in CLUBB, l_fix_chi_eta_correlations, that sets the + ! component correlation of chi and eta to a constant, prescribed value + ! because of SILHS. The correlation of chi and eta in PDF component 1 + ! that is calculated by an equation is stored in stats as + ! "corr_chi_eta_1". Here, "corr_chi_eta_1_ca" outputs whatever value is + ! found in the correlation array, whether or not it matches + ! "corr_chi_eta_1". + if ( icorr_chi_eta_1_ca > 0 ) then + call stat_update_var_pt( icorr_chi_eta_1_ca, level, & + corr_array_1(iiPDF_eta,iiPDF_chi), stats_zt ) + endif + + ! Correlation of chi (old s) and eta (old t) in PDF component 2 found in + ! the correlation array. + ! The true correlation of chi and eta in each PDF component is solved for + ! by an equation and is part of CLUBB's PDF parameters. However, there + ! is an option in CLUBB, l_fix_chi_eta_correlations, that sets the + ! component correlation of chi and eta to a constant, prescribed value + ! because of SILHS. The correlation of chi and eta in PDF component 2 + ! that is calculated by an equation is stored in stats as + ! "corr_chi_eta_2". Here, "corr_chi_eta_2_ca" outputs whatever value is + ! found in the correlation array, whether or not it matches + ! "corr_chi_eta_2". + if ( icorr_chi_eta_2_ca > 0 ) then + call stat_update_var_pt( icorr_chi_eta_2_ca, level, & + corr_array_2(iiPDF_eta,iiPDF_chi), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of chi (old s) and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_chi_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_chi_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_chi), & + stats_zt ) + endif + + ! Correlation (in-precip) of chi (old s) and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_chi_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_chi_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_chi), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of chi (old s) and N_cn in PDF component 1. + if ( icorr_chi_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + ! Correlation of chi (old s) and N_cn in PDF component 2. + if ( icorr_chi_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_chi), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of eta (old t) and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_eta_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_eta_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_eta), & + stats_zt ) + endif + + ! Correlation (in-precip) of eta (old t) and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_eta_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_eta_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_eta), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of eta (old t) and N_cn in PDF component 1. + if ( icorr_eta_Ncn_1 > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_1, level, & + corr_array_1(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + ! Correlation of eta (old t) and N_cn in PDF component 2. + if ( icorr_eta_Ncn_2 > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_2, level, & + corr_array_2(iiPDF_Ncn,iiPDF_eta), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of N_cn and the precipitating + ! hydrometeor in PDF component 1. + if ( icorr_Ncn_hm_1(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_Ncn_hm_1(pdf2hydromet_idx(ivar)), & + level, corr_array_1(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + ! Correlation (in-precip) of N_cn and the precipitating + ! hydrometeor in PDF component 2. + if ( icorr_Ncn_hm_2(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_Ncn_hm_2(pdf2hydromet_idx(ivar)), & + level, corr_array_2(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + do ivar = iiPDF_Ncn+1, d_variables, 1 + do jvar = ivar+1, d_variables, 1 + + ! Correlation (in-precip) of two different hydrometeors (hmx and + ! hmy) in PDF component 1. + if ( icorr_hmx_hmy_1(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)) & + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_1(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_1(jvar,ivar), stats_zt ) + endif + + ! Correlation (in-precip) of two different hydrometeors (hmx and + ! hmy) in PDF component 2. + if ( icorr_hmx_hmy_2(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)) & + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_2(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_2(jvar,ivar), stats_zt ) + endif + + enddo ! jvar = ivar+1, d_variables, 1 + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + endif ! l_stats_samp + + + return + + end subroutine pdf_param_hm_stats + + !============================================================================= + subroutine pdf_param_ln_hm_stats( d_variables, level, mu_x_1_n, & + mu_x_2_n, sigma_x_1_n, & + sigma_x_2_n, corr_array_1_n, & + corr_array_2_n, l_stats_samp ) + + ! Description: + ! Record statistics for normal space PDF parameters involving hydrometeors. + + ! References: + !----------------------------------------------------------------------- + + use index_mapping, only: & + pdf2hydromet_idx ! Procedure(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + use stats_type_utilities, only: & + stat_update_var_pt ! Procedure(s) + + use stats_variables, only : & + imu_hm_1_n, & ! Variable(s) + imu_hm_2_n, & + imu_Ncn_1_n, & + imu_Ncn_2_n, & + isigma_hm_1_n, & + isigma_hm_2_n, & + isigma_Ncn_1_n, & + isigma_Ncn_2_n + + use stats_variables, only : & + icorr_w_hm_1_n, & ! Variables + icorr_w_hm_2_n, & + icorr_w_Ncn_1_n, & + icorr_w_Ncn_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_chi_Ncn_1_n, & + icorr_chi_Ncn_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_eta_Ncn_1_n, & + icorr_eta_Ncn_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n, & + stats_zt + + implicit none + + ! Input Variables + integer, intent(in) :: & + d_variables, & ! Number of variables in the correlation array + level ! Vertical level index + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1_n, & ! Mean array (normal space): PDF vars. (comp. 1) [un. vary] + mu_x_2_n, & ! Mean array (normal space): PDF vars. (comp. 2) [un. vary] + sigma_x_1_n, & ! Std. dev. array (normal space): PDF vars (comp. 1) [u.v.] + sigma_x_2_n ! Std. dev. array (normal space): PDF vars (comp. 2) [u.v.] + + real( kind = core_rknd ), dimension(d_variables, d_variables), & + intent(in) :: & + corr_array_1_n, & ! Corr. array (normal space) of PDF vars. (comp. 1) [-] + corr_array_2_n ! Corr. array (normal space) of PDF vars. (comp. 2) [-] + + logical, intent(in) :: & + l_stats_samp ! Flag to record statistical output. + + ! Local Variable + integer :: ivar, jvar ! Loop indices + + + !!! Output the statistics for normal space hydrometeor PDF parameters. + + ! Statistics + if ( l_stats_samp ) then + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean (in-precip) of ln hm in PDF component 1. + if ( imu_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + if ( mu_x_1_n(ivar) > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_hm_1_n(pdf2hydromet_idx(ivar)), & + level, mu_x_1_n(ivar), stats_zt ) + else + ! When hm_1 is 0 (or below tolerance value), mu_hm_1_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some + ! compilers have issues outputting to stats files (in single + ! precision) when the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_hm_1_n(pdf2hydromet_idx(ivar)), & + level, real( -huge( 0.0 ), & + kind = core_rknd ), & + stats_zt ) + endif + endif + + ! Mean (in-precip) of ln hm in PDF component 2. + if ( imu_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + if ( mu_x_2_n(ivar) > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_hm_2_n(pdf2hydromet_idx(ivar)), & + level, mu_x_2_n(ivar), stats_zt ) + else + ! When hm_2 is 0 (or below tolerance value), mu_hm_2_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some + ! compilers have issues outputting to stats files (in single + ! precision) when the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_hm_2_n(pdf2hydromet_idx(ivar)), & + level, real( -huge( 0.0 ), & + kind = core_rknd ), & + stats_zt ) + endif + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Mean of ln N_cn in PDF component 1. + if ( imu_Ncn_1_n > 0 ) then + if ( mu_x_1_n(iiPDF_Ncn) & + > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_Ncn_1_n, level, & + mu_x_1_n(iiPDF_Ncn), stats_zt ) + else + ! When Ncnm is 0 (or below tolerance value), mu_Ncn_1_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some compilers + ! have issues outputting to stats files (in single precision) when + ! the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_Ncn_1_n, level, & + real( -huge( 0.0 ), kind = core_rknd ), & + stats_zt ) + endif + endif + + ! Mean of ln N_cn in PDF component 2. + if ( imu_Ncn_2_n > 0 ) then + if ( mu_x_2_n(iiPDF_Ncn) & + > real( -huge( 0.0 ), kind = core_rknd ) ) then + call stat_update_var_pt( imu_Ncn_2_n, level, & + mu_x_2_n(iiPDF_Ncn), stats_zt ) + else + ! When Ncnm is 0 (or below tolerance value), mu_Ncn_2_n is -inf, + ! and is set to -huge for the default CLUBB kind. Some compilers + ! have issues outputting to stats files (in single precision) when + ! the default CLUBB kind is in double precision. + ! Set to -huge for single precision. + call stat_update_var_pt( imu_Ncn_2_n, level, & + real( -huge( 0.0 ), kind = core_rknd ), & + stats_zt ) + endif + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation (in-precip) of ln hm in PDF component 1. + if ( isigma_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_1_n(pdf2hydromet_idx(ivar)), & + level, sigma_x_1_n(ivar), stats_zt ) + endif + + ! Standard deviation (in-precip) of ln hm in PDF component 2. + if ( isigma_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( isigma_hm_2_n(pdf2hydromet_idx(ivar)), & + level, sigma_x_2_n(ivar), stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Standard deviation of ln N_cn in PDF component 1. + if ( isigma_Ncn_1_n > 0 ) then + call stat_update_var_pt( isigma_Ncn_1_n, level, & + sigma_x_1_n(iiPDF_Ncn), stats_zt ) + endif + + ! Standard deviation of ln N_cn in PDF component 2. + if ( isigma_Ncn_2_n > 0 ) then + call stat_update_var_pt( isigma_Ncn_2_n, level, & + sigma_x_2_n(iiPDF_Ncn), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of w and ln hm in PDF component 1. + if ( icorr_w_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_w), & + stats_zt ) + endif + + ! Correlation (in-precip) of w and ln hm in PDF component 2. + if ( icorr_w_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt( icorr_w_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_w), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of w and ln N_cn in PDF component 1. + if ( icorr_w_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + ! Correlation of w and ln N_cn in PDF component 2. + if ( icorr_w_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_w_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_w), stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of chi (old s) and ln hm in PDF component 1. + if ( icorr_chi_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_chi_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_chi), & + stats_zt ) + endif + + ! Correlation (in-precip) of chi( old s) and ln hm in PDF component 2. + if ( icorr_chi_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_chi_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_chi), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of chi (old s) and ln N_cn in PDF component 1. + if ( icorr_chi_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_chi), & + stats_zt ) + endif + + ! Correlation of chi(old s) and ln N_cn in PDF component 2. + if ( icorr_chi_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_chi_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_chi), & + stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of eta (old t) and ln hm in PDF component 1. + if ( icorr_eta_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_eta_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_eta), & + stats_zt ) + endif + + ! Correlation (in-precip) of eta (old t) and ln hm in PDF component 2. + if ( icorr_eta_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_eta_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_eta), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation of eta (old t) and ln N_cn in PDF component 1. + if ( icorr_eta_Ncn_1_n > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_1_n, level, & + corr_array_1_n(iiPDF_Ncn,iiPDF_eta), & + stats_zt ) + endif + + ! Correlation of eta (old t) and ln N_cn in PDF component 2. + if ( icorr_eta_Ncn_2_n > 0 ) then + call stat_update_var_pt( icorr_eta_Ncn_2_n, level, & + corr_array_2_n(iiPDF_Ncn,iiPDF_eta), & + stats_zt ) + endif + + do ivar = iiPDF_Ncn+1, d_variables, 1 + + ! Correlation (in-precip) of ln N_cn and ln hm in PDF + ! component 1. + if ( icorr_Ncn_hm_1_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_Ncn_hm_1_n(pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + ! Correlation (in-precip) of ln N_cn and ln hm in PDF + ! component 2. + if ( icorr_Ncn_hm_2_n(pdf2hydromet_idx(ivar)) > 0 ) then + call stat_update_var_pt(icorr_Ncn_hm_2_n(pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(ivar,iiPDF_Ncn), & + stats_zt ) + endif + + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + do ivar = iiPDF_Ncn+1, d_variables, 1 + do jvar = ivar+1, d_variables, 1 + + ! Correlation (in-precip) of ln hmx and ln hmy (two different + ! hydrometeors) in PDF component 1. + if (icorr_hmx_hmy_1_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar))& + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_1_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_1_n(jvar,ivar), stats_zt ) + endif + + ! Correlation (in-precip) of ln hmx and ln hmy (two different + ! hydrometeors) in PDF component 2. + if (icorr_hmx_hmy_2_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar))& + > 0 ) then + call stat_update_var_pt( & + icorr_hmx_hmy_2_n(pdf2hydromet_idx(jvar),pdf2hydromet_idx(ivar)), & + level, corr_array_2_n(jvar,ivar), stats_zt ) + endif + + enddo ! jvar = ivar+1, d_variables, 1 + enddo ! ivar = iiPDF_Ncn+1, d_variables, 1 + + endif ! l_stats_samp + + + return + + end subroutine pdf_param_ln_hm_stats + + !============================================================================= + subroutine pack_pdf_params( hm_1, hm_2, d_variables, & ! In + mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & ! In + corr_array_1, corr_array_2, precip_frac, & ! In + precip_frac_1, precip_frac_2, & ! In + hydromet_pdf_params ) ! Out + + ! Description: + ! Pack the standard means and variances involving hydrometeors, as well as a + ! few other variables, into the structure hydromet_pdf_params. + + ! References: + !----------------------------------------------------------------------- + + use constants_clubb, only: & + one ! Constant(s) + + use hydromet_pdf_parameter_module, only: & + hydromet_pdf_parameter ! Variable(s) + + use index_mapping, only: & + hydromet2pdf_idx ! Procedure(s) + + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use corr_varnce_module, only: & + iiPDF_w, & ! Variable(s) + iiPDF_chi, & + iiPDF_eta, & + iiPDF_Ncn + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(hydromet_dim), intent(in) :: & + hm_1, & ! Mean of a precip. hydrometeor (1st PDF component) [units vary] + hm_2 ! Mean of a precip. hydrometeor (2nd PDF component) [units vary] + + integer, intent(in) :: & + d_variables ! Number of variables in the mean/stdev arrays + + real( kind = core_rknd ), dimension(d_variables), intent(in) :: & + mu_x_1, & ! Mean array of PDF vars. (1st PDF component) [units vary] + mu_x_2, & ! Mean array of PDF vars. (2nd PDF component) [units vary] + sigma_x_1, & ! Standard deviation array of PDF vars (comp. 1) [units vary] + sigma_x_2 ! Standard deviation array of PDF vars (comp. 2) [units vary] + + real( kind = core_rknd ), dimension(d_variables,d_variables), & + intent(in) :: & + corr_array_1, & ! Correlation array of PDF vars. (comp. 1) [-] + corr_array_2 ! Correlation array of PDF vars. (comp. 2) [-] + + real( kind = core_rknd ), intent(in) :: & + precip_frac, & ! Precipitation fraction (overall) [-] + precip_frac_1, & ! Precipitation fraction (1st PDF component) [-] + precip_frac_2 ! Precipitation fraction (2nd PDF component) [-] + + ! Output Variable + type(hydromet_pdf_parameter), intent(out) :: & + hydromet_pdf_params ! Hydrometeor PDF parameters [units vary] + + ! Local Variables + integer :: ivar, jvar ! Loop indices + + + ! Pack remaining means and standard deviations into hydromet_pdf_params. + do ivar = 1, hydromet_dim, 1 + + ! Mean of a hydrometeor (overall) in the 1st PDF component. + hydromet_pdf_params%hm_1(ivar) = hm_1(ivar) + ! Mean of a hydrometeor (overall) in the 2nd PDF component. + hydromet_pdf_params%hm_2(ivar) = hm_2(ivar) + + ! Mean of a hydrometeor (in-precip) in the 1st PDF component. + hydromet_pdf_params%mu_hm_1(ivar) = mu_x_1(hydromet2pdf_idx(ivar)) + ! Mean of a hydrometeor (in-precip) in the 2nd PDF component. + hydromet_pdf_params%mu_hm_2(ivar) = mu_x_2(hydromet2pdf_idx(ivar)) + + ! Standard deviation of a hydrometeor (in-precip) in the + ! 1st PDF component. + hydromet_pdf_params%sigma_hm_1(ivar) = sigma_x_1(hydromet2pdf_idx(ivar)) + ! Standard deviation of a hydrometeor (in-precip) in the + ! 2nd PDF component. + hydromet_pdf_params%sigma_hm_2(ivar) = sigma_x_2(hydromet2pdf_idx(ivar)) + + ! Correlation (in-precip) of w and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_w_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_w ) + + ! Correlation (in-precip) of w and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_w_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_w ) + + ! Correlation (in-precip) of chi and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_chi_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_chi ) + + ! Correlation (in-precip) of chi and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_chi_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_chi ) + + ! Correlation (in-precip) of eta and a hydrometeor in the 1st PDF + ! component. + hydromet_pdf_params%corr_eta_hm_1(ivar) & + = corr_array_1( hydromet2pdf_idx(ivar), iiPDF_eta ) + + ! Correlation (in-precip) of eta and a hydrometeor in the 2nd PDF + ! component. + hydromet_pdf_params%corr_eta_hm_2(ivar) & + = corr_array_2( hydromet2pdf_idx(ivar), iiPDF_eta ) + + ! Correlation (in-precip) of two hydrometeors, hmx and hmy, in the 1st + ! PDF component. + hydromet_pdf_params%corr_hmx_hmy_1(ivar,ivar) = one + + do jvar = ivar+1, hydromet_dim, 1 + + hydromet_pdf_params%corr_hmx_hmy_1(jvar,ivar) & + = corr_array_1( hydromet2pdf_idx(jvar), hydromet2pdf_idx(ivar) ) + + hydromet_pdf_params%corr_hmx_hmy_1(ivar,jvar) & + = hydromet_pdf_params%corr_hmx_hmy_1(jvar,ivar) + + enddo ! jvar = ivar+1, hydromet_dim, 1 + + ! Correlation (in-precip) of two hydrometeors, hmx and hmy, in the 2nd + ! PDF component. + hydromet_pdf_params%corr_hmx_hmy_2(ivar,ivar) = one + + do jvar = ivar+1, hydromet_dim, 1 + + hydromet_pdf_params%corr_hmx_hmy_2(jvar,ivar) & + = corr_array_2( hydromet2pdf_idx(jvar), hydromet2pdf_idx(ivar) ) + + hydromet_pdf_params%corr_hmx_hmy_2(ivar,jvar) & + = hydromet_pdf_params%corr_hmx_hmy_2(jvar,ivar) + + enddo ! jvar = ivar+1, hydromet_dim, 1 + + enddo ! ivar = 1, hydromet_dim, 1 + + ! Mean of Ncn (overall) in the 1st PDF component. + hydromet_pdf_params%mu_Ncn_1 = mu_x_1(iiPDF_Ncn) + ! Mean of Ncn (overall) in the 2nd PDF component. + hydromet_pdf_params%mu_Ncn_2 = mu_x_2(iiPDF_Ncn) + + ! Standard deviation of Ncn (overall) in the 1st PDF component. + hydromet_pdf_params%sigma_Ncn_1 = sigma_x_1(iiPDF_Ncn) + ! Standard deviation of Ncn (overall) in the 2nd PDF component. + hydromet_pdf_params%sigma_Ncn_2 = sigma_x_2(iiPDF_Ncn) + + ! Precipitation fraction (overall). + hydromet_pdf_params%precip_frac = precip_frac + ! Precipitation fraction (1st PDF component). + hydromet_pdf_params%precip_frac_1 = precip_frac_1 + ! Precipitation fraction (2nd PDF component). + hydromet_pdf_params%precip_frac_2 = precip_frac_2 + + + return + + end subroutine pack_pdf_params + + !============================================================================= + elemental function compute_rtp2_from_chi( pdf_params, corr_chi_eta_1, & + corr_chi_eta_2 ) & + result( rtp2_zt_from_chi ) + + ! Description: + ! Compute the variance of rt from the distribution of chi and eta. The + ! resulting variance will be consistent with CLUBB's extended PDF + ! involving chi and eta, including if l_fix_chi_eta_correlations = .true. . + + ! References: + ! None + !----------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Constant + + use pdf_utilities, only: & + compute_variance_binormal ! Procedure + + use constants_clubb, only: & + one_half, & ! Constant(s) + one, & + two + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + implicit none + + ! Input Variables + type(pdf_parameter), intent(in) :: & + pdf_params + + real( kind = core_rknd ), intent(in) :: & + corr_chi_eta_1, & ! Correlation of chi and eta in 1st PDF component [-] + corr_chi_eta_2 ! Correlation of chi and eta in 2nd PDF component [-] + + ! Output Variable + real( kind = core_rknd ) :: & + rtp2_zt_from_chi ! Grid-box variance of rtp2 on thermo. levels [kg/kg] + + ! Local Variables + real( kind = core_rknd ) :: & + varnce_rt_1_zt_from_chi, varnce_rt_2_zt_from_chi + + real( kind = core_rknd ) :: & + sigma_chi_1, & ! Standard deviation of chi (1st PDF comp.) [kg/kg] + sigma_chi_2, & ! Standard deviation of chi (2nd PDF comp.) [kg/kg] + sigma_eta_1, & ! Standard deviation of eta (1st PDF comp.) [kg/kg] + sigma_eta_2, & ! Standard deviation of eta (2nd PDF comp.) [kg/kg] + crt_1, & ! Coef. of r_t in chi/eta eqns. (1st comp.) [-] + crt_2, & ! Coef. of r_t in chi/eta eqns. (2nd comp.) [-] + rt_1, & ! Mean of rt (1st PDF component) [kg/kg] + rt_2, & ! Mean of rt (2nd PDF component) [kg/kg] + rtm, & ! Mean of rt (overall) [kg/kg] + sigma_rt_1_from_chi, & ! Standard deviation of rt (1st PDF comp.) [kg/kg] + sigma_rt_2_from_chi, & ! Standard deviation of rt (2nd PDF comp.) [kg/kg] + mixt_frac ! Weight of 1st gaussian PDF component [-] + + !----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Enter some PDF parameters + sigma_chi_1 = pdf_params%stdev_chi_1 + sigma_chi_2 = pdf_params%stdev_chi_2 + sigma_eta_1 = pdf_params%stdev_eta_1 + sigma_eta_2 = pdf_params%stdev_eta_2 + rt_1 = pdf_params%rt_1 + rt_2 = pdf_params%rt_2 + crt_1 = pdf_params%crt_1 + crt_2 = pdf_params%crt_2 + mixt_frac = pdf_params%mixt_frac + + varnce_rt_1_zt_from_chi & + = ( corr_chi_eta_1 * sigma_chi_1 * sigma_eta_1 & + + one_half * sigma_chi_1**2 + one_half * sigma_eta_1**2 ) & + / ( two * crt_1**2 ) + + varnce_rt_2_zt_from_chi & + = ( corr_chi_eta_2 * sigma_chi_2 * sigma_eta_2 & + + one_half * sigma_chi_2**2 + one_half * sigma_eta_2**2 ) & + / ( two * crt_2**2 ) + + rtm = mixt_frac*rt_1 + (one-mixt_frac)*rt_2 + + sigma_rt_1_from_chi = sqrt( varnce_rt_1_zt_from_chi ) + sigma_rt_2_from_chi = sqrt( varnce_rt_2_zt_from_chi ) + + rtp2_zt_from_chi & + = compute_variance_binormal( rtm, rt_1, rt_2, sigma_rt_1_from_chi, & + sigma_rt_2_from_chi, mixt_frac ) + + + return + + end function compute_rtp2_from_chi + +!=============================================================================== + +end module setup_clubb_pdf_params diff --git a/src/physics/clubb/sigma_sqd_w_module.F90 b/src/physics/clubb/sigma_sqd_w_module.F90 new file mode 100644 index 0000000000..8f0987e2a7 --- /dev/null +++ b/src/physics/clubb/sigma_sqd_w_module.F90 @@ -0,0 +1,66 @@ +!------------------------------------------------------------------------- +! $Id: sigma_sqd_w_module.F90 6849 2014-04-22 21:52:30Z charlass@uwm.edu $ +!=============================================================================== +module sigma_sqd_w_module + + implicit none + + public :: compute_sigma_sqd_w + + private ! Default scope + + contains +!--------------------------------------------------------------------------------------------------- + elemental function compute_sigma_sqd_w( gamma_Skw_fnc, wp2, thlp2, rtp2, wpthlp, wprtp ) & + result( sigma_sqd_w ) +! Description: +! Compute the variable sigma_sqd_w (PDF width parameter) +! +! References: +! Eqn 22 in ``Equations for CLUBB'' +!--------------------------------------------------------------------------------------------------- + use constants_clubb, only: & + w_tol, & ! Constant(s) + rt_tol, & + thl_tol + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: min, max, sqrt + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + gamma_Skw_fnc, & ! Gamma as a function of skewness [-] + wp2, & ! Variance of vertical velocity [m^2/s^2] + thlp2, & ! Variance of liquid pot. temp. [K^2] + rtp2, & ! Variance of total water [kg^2/kg^2] + wpthlp, & ! Flux of liquid pot. temp. [m/s K] + wprtp ! Flux of total water [m/s kg/kg] + + ! Output Variable + real( kind = core_rknd ) :: sigma_sqd_w ! PDF width parameter [-] + + ! ---- Begin Code ---- + + !---------------------------------------------------------------- + ! Compute sigma_sqd_w with new formula from Vince + !---------------------------------------------------------------- + + sigma_sqd_w = gamma_Skw_fnc * & + ( 1.0_core_rknd - min( & + max( ( wpthlp / ( sqrt( wp2 * thlp2 ) & + + 0.01_core_rknd * w_tol * thl_tol ) )**2, & + ( wprtp / ( sqrt( wp2 * rtp2 ) & + + 0.01_core_rknd * w_tol * rt_tol ) )**2 & + ), & ! max + 1.0_core_rknd ) & ! min - Known magic number (eq. 22 from "Equations for CLUBB") + ) + + return + end function compute_sigma_sqd_w + +end module sigma_sqd_w_module diff --git a/src/physics/clubb/sponge_layer_damping.F90 b/src/physics/clubb/sponge_layer_damping.F90 new file mode 100644 index 0000000000..472083e5a6 --- /dev/null +++ b/src/physics/clubb/sponge_layer_damping.F90 @@ -0,0 +1,215 @@ +!------------------------------------------------------------------------- +!$Id: sponge_layer_damping.F90 7185 2014-08-11 17:45:21Z betlej@uwm.edu $ +!=============================================================================== +module sponge_layer_damping +! Description: +! This module is used for damping variables in upper altitudes of the grid. +! +! References: +! None +!--------------------------------------------------------------------------------------------------- + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + public :: sponge_damp_xm, initialize_tau_sponge_damp, finalize_tau_sponge_damp, & + sponge_damp_settings, sponge_damp_profile + + + type sponge_damp_settings + + real( kind = core_rknd ) :: & + tau_sponge_damp_min, & ! Minimum damping time-scale (at the top) [s] + tau_sponge_damp_max, & ! Maximum damping time-scale (base of damping layer) [s] + sponge_damp_depth ! damping depth as a fraction of domain height [-] + + logical :: & + l_sponge_damping ! True if damping is being used + + end type sponge_damp_settings + + type sponge_damp_profile + real( kind = core_rknd ), allocatable, dimension(:) :: & + tau_sponge_damp ! Damping factor + + integer :: & + n_sponge_damp ! Number of levels damped + + end type sponge_damp_profile + + + type(sponge_damp_settings), public :: & + thlm_sponge_damp_settings, & + rtm_sponge_damp_settings, & + uv_sponge_damp_settings +!$omp threadprivate( thlm_sponge_damp_settings, rtm_sponge_damp_settings, uv_sponge_damp_settings ) + + type(sponge_damp_profile), public :: & + thlm_sponge_damp_profile, & + rtm_sponge_damp_profile, & + uv_sponge_damp_profile +!$omp threadprivate( thlm_sponge_damp_profile, rtm_sponge_damp_profile, uv_sponge_damp_profile ) + + + private + + contains + + !--------------------------------------------------------------------------------------------- + function sponge_damp_xm( dt, xm_ref, xm, damping_profile ) result( xm_p ) + ! + ! Description: + ! Damps specified variable. The module must be initialized for + ! this function to work. Otherwise a stop is issued. + ! + ! References: + ! None + !------------------------------------------------------------------------------------------- + + ! "Sponge"-layer damping at the domain top region + + use grid_class, only: gr ! Variable(s) + + use clubb_precision, only: core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: allocated + + ! Input Variable(s) + real( kind = core_rknd ), intent(in) :: dt ! Model Timestep + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm_ref ! Reference to damp to [-] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + xm ! Variable being damped [-] + + type(sponge_damp_profile), intent(in) :: & + damping_profile + + ! Output Variable(s) + real( kind = core_rknd ), dimension(gr%nz) :: xm_p ! Variable damped [-] + + real( kind = core_rknd ) :: dt_on_tau ! Ratio of timestep to damping timescale [-] + + integer :: k + + ! ---- Begin Code ---- + + if ( allocated( damping_profile%tau_sponge_damp ) ) then + + xm_p = xm + + do k = gr%nz, gr%nz-damping_profile%n_sponge_damp, -1 + +! Vince Larson used implicit discretization in order to +! reduce noise in rtm in cloud_feedback_s12 (CGILS) +! xm_p(k) = xm(k) - real( ( ( xm(k) - xm_ref(k) ) / & +! damping_profile%tau_sponge_damp(k) ) * dt ) + dt_on_tau = dt / damping_profile%tau_sponge_damp(k) + +! Really, we should be using xm_ref at time n+1 rather than n. +! However, for steady profiles of xm_ref, it won't matter. + xm_p(k) = ( xm(k) + dt_on_tau * xm_ref(k) ) / & + ( 1.0_core_rknd + dt_on_tau ) +! End Vince Larson's change + end do ! k + + else + + stop "tau_sponge_damp in damping used before initialization" + + end if + + return + end function sponge_damp_xm + + !--------------------------------------------------------------------------------------------- + subroutine initialize_tau_sponge_damp( dt, settings, damping_profile ) + ! + ! Description: + ! Initialize tau_sponge_damp used for damping + ! + ! References: + ! None + !------------------------------------------------------------------------------------------- + use clubb_precision, only: core_rknd ! Variable(s) + + use constants_clubb, only: fstderr ! Constant(s) + + use grid_class, only: gr ! Variable(s) + + use interpolation, only: lin_interpolate_two_points ! function + + implicit none + + ! Input Variable(s) + real( kind = core_rknd ), intent(in) :: dt ! Model Timestep [s] + + type(sponge_damp_settings), intent(in) :: & + settings + + type(sponge_damp_profile), intent(out) :: & + damping_profile + + integer :: k ! Loop iterator + + ! ---- Begin Code ---- + + allocate( damping_profile%tau_sponge_damp(1:gr%nz)) + + if( settings%tau_sponge_damp_min < 2._core_rknd * dt ) then + write(fstderr,*) 'Error: in damping() tau_sponge_damp_min is too small!' + stop + end if + + do k=gr%nz,1,-1 + if(gr%zt(gr%nz)-gr%zt(k) < settings%sponge_damp_depth*gr%zt(gr%nz)) then + damping_profile%n_sponge_damp=gr%nz-k+1 + endif + end do + + do k=gr%nz,gr%nz-damping_profile%n_sponge_damp,-1 +! Vince Larson added code to use standard linear interpolation. +! damping_profile%tau_sponge_damp(k) = settings%tau_sponge_damp_min *& +! (settings%tau_sponge_damp_max/settings%tau_sponge_damp_min)** & +! ( ( gr%zt(gr%nz)-gr%zt(k) ) / & +! (gr%zt(gr%nz) - gr%zt( gr%nz-damping_profile%n_sponge_damp ) ) ) + damping_profile%tau_sponge_damp(k) = & + lin_interpolate_two_points( gr%zt(k), gr%zt(gr%nz), & + gr%zt(gr%nz) - gr%zt( gr%nz-damping_profile%n_sponge_damp ) , & + settings%tau_sponge_damp_min, settings%tau_sponge_damp_max ) +! End Vince Larson's change + end do + + return + end subroutine initialize_tau_sponge_damp + + !--------------------------------------------------------------------------------------------- + subroutine finalize_tau_sponge_damp( damping_profile ) + ! + ! Description: + ! Frees memory allocated in initialize_tau_sponge_damp + ! + ! References: + ! None + !------------------------------------------------------------------------------------------- + implicit none + + ! Input/Output Variable(s) + type(sponge_damp_profile), intent(inout) :: & + damping_profile ! Information for damping the profile + + ! ---- Begin Code ---- + + deallocate( damping_profile%tau_sponge_damp ) + + return + end subroutine finalize_tau_sponge_damp + + +end module sponge_layer_damping diff --git a/src/physics/clubb/stat_file_module.F90 b/src/physics/clubb/stat_file_module.F90 new file mode 100644 index 0000000000..f413abf5e5 --- /dev/null +++ b/src/physics/clubb/stat_file_module.F90 @@ -0,0 +1,105 @@ +!------------------------------------------------------------------------------- +! $Id: stat_file_module.F90 7140 2014-07-31 19:14:05Z betlej@uwm.edu $ +!=============================================================================== +module stat_file_module + + +! Description: +! Contains two derived types for describing the contents and location of +! either NetCDF or GrADS files. +!------------------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable + time_precision, & + core_rknd + + implicit none + + public :: variable, stat_file + + ! These are used in a 2D or 3D host model to output multiple columns + ! Set clubb_i and clubb_j according to the column within the host model; + ! The indices must not exceed nlon (for i) or nlat (for j). + integer, save, public :: clubb_i = 1, clubb_j = 1 +!$omp threadprivate(clubb_i, clubb_j) + + private ! Default scope + + ! Structure to hold the description of a variable + + type variable + ! Pointer to the array + real(kind=stat_rknd), dimension(:,:,:), pointer :: ptr + + character(len = 30) :: name ! Variable name + character(len = 100) :: description ! Variable description + character(len = 20) :: units ! Variable units + + integer :: indx ! NetCDF module Id for var / GrADS index + + logical :: l_silhs ! If true, we sample this variable once for each SILHS + ! sample point per timestep, rather than just once per + ! timestep. + end type variable + + ! Structure to hold the description of a NetCDF output file + ! This makes the new code as compatible as possible with the + ! GrADS output code + + type stat_file + + ! File information + + character(len = 200) :: & + fname, & ! File name without suffix + fdir ! Path where fname resides + + integer :: iounit ! This number is used internally by the + ! NetCDF module to track the data set, or by + ! GrADS to track the actual file unit. + integer :: & + nrecord, & ! Number of records written + ntimes ! Number of times written + + logical :: & + l_defined, & ! Whether nf90_enddef() has been called + l_byte_swapped ! Is this a file in the opposite byte ordering? + + ! NetCDF datafile dimensions indices + integer :: & + LatDimId, LongDimId, AltDimId, TimeDimId, & + LatVarId, LongVarId, AltVarId, TimeVarId + + ! Grid information + + integer :: ia, iz ! Vertical extent + + integer :: nlat, nlon ! The number of points in the X and Y + + real( kind = core_rknd ), dimension(:), allocatable :: & + z ! Height of vertical levels [m] + + ! Time information + + integer :: day, month, year ! Date of starting time + + real( kind = core_rknd ), dimension(:), allocatable :: & + rlat, & ! Latitude [Degrees N] + rlon ! Longitude [Degrees E] + + real( kind = core_rknd ) :: & + dtwrite ! Interval between output [Seconds] + + real( kind = time_precision ) :: & + time ! Start time [Seconds] + + ! Statistical Variables + + integer :: nvar ! Number of variables for this file + + type (variable), dimension(:), allocatable :: & + var ! List and variable description + + end type stat_file + + end module stat_file_module diff --git a/src/physics/clubb/stats_clubb_utilities.F90 b/src/physics/clubb/stats_clubb_utilities.F90 new file mode 100644 index 0000000000..0a126e40f6 --- /dev/null +++ b/src/physics/clubb/stats_clubb_utilities.F90 @@ -0,0 +1,3162 @@ +!----------------------------------------------------------------------- +! $Id: stats_clubb_utilities.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_clubb_utilities + + implicit none + + private ! Set Default Scope + + public :: stats_init, stats_begin_timestep, stats_end_timestep, & + stats_accumulate, stats_finalize, stats_accumulate_hydromet, & + stats_accumulate_lh_tend + + private :: stats_zero, stats_avg, stats_check_num_samples + + contains + + !----------------------------------------------------------------------- + subroutine stats_init( iunit, fname_prefix, fdir, l_stats_in, & + stats_fmt_in, stats_tsamp_in, stats_tout_in, fnamelist, & + nzmax, nlon, nlat, gzt, gzm, nnrad_zt, & + grad_zt, nnrad_zm, grad_zm, day, month, year, & + rlon, rlat, time_current, delt, l_silhs_out_in ) + ! + ! Description: + ! Initializes the statistics saving functionality of the CLUBB model. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + 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: & + l_silhs_out, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc + + use stats_variables, only: & + stats_zm, & ! Variables + zmscr01, & + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15, & + zmscr16, & + zmscr17, & + stats_rad_zt + + use stats_variables, only: & + stats_rad_zm, & + stats_sfc, & + l_stats, & + l_output_rad_files, & + stats_tsamp, & + stats_tout, & + l_stats_samp, & + l_stats_last, & + fname_zt, & + fname_lh_zt, & + fname_lh_sfc, & + fname_zm, & + fname_rad_zt, & + fname_rad_zm, & + fname_sfc, & + l_netcdf, & + l_grads + + use clubb_precision, only: & + time_precision, & ! Constant(s) + core_rknd + + use output_grads, only: & + open_grads ! Procedure + +#ifdef NETCDF + use output_netcdf, only: & + open_netcdf_for_writing ! Procedure +#endif + + use stats_zm_module, only: & + nvarmax_zm, & ! Constant(s) + stats_init_zm ! Procedure(s) + + use stats_zt_module, only: & + nvarmax_zt, & ! Constant(s) + stats_init_zt ! Procedure(s) + + use stats_lh_zt_module, only: & + nvarmax_lh_zt, & ! Constant(s) + stats_init_lh_zt ! Procedure(s) + + use stats_lh_sfc_module, only: & + nvarmax_lh_sfc, & ! Constant(s) + stats_init_lh_sfc ! Procedure(s) + + use stats_rad_zt_module, only: & + nvarmax_rad_zt, & ! Constant(s) + stats_init_rad_zt ! Procedure(s) + + use stats_rad_zm_module, only: & + nvarmax_rad_zm, & ! Constant(s) + stats_init_rad_zm ! Procedure(s) + + use stats_sfc_module, only: & + nvarmax_sfc, & ! Constant(s) + stats_init_sfc ! Procedure(s) + + use error_code, only: & + clubb_at_least_debug_level ! Function + + use constants_clubb, only: & + fstdout, fstderr, var_length ! Constants + + use parameters_model, only: & + hydromet_dim, & ! Variable(s) + sclr_dim, & + edsclr_dim + + implicit none + + ! Local Constants + integer, parameter :: & + silhs_num_importance_categories = 8 + + ! Input Variables + integer, intent(in) :: iunit ! File unit for fnamelist + + character(len=*), intent(in) :: & + fname_prefix, & ! Start of the stats filenames + fdir ! Directory to output to + + logical, intent(in) :: & + l_stats_in ! Stats on? T/F + + character(len=*), intent(in) :: & + stats_fmt_in ! Format of the stats file output + + real( kind = core_rknd ), intent(in) :: & + stats_tsamp_in, & ! Sampling interval [s] + stats_tout_in ! Output interval [s] + + character(len=*), intent(in) :: & + fnamelist ! Filename holding the &statsnl + + integer, intent(in) :: & + nlon, & ! Number of points in the X direction [-] + nlat, & ! Number of points in the Y direction [-] + nzmax ! Grid points in the vertical [-] + + real( kind = core_rknd ), intent(in), dimension(nzmax) :: & + gzt, gzm ! Thermodynamic and momentum levels [m] + + integer, intent(in) :: nnrad_zt ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zt) :: grad_zt ! Radiation levels [m] + + integer, intent(in) :: nnrad_zm ! Grid points in the radiation grid [count] + + real( kind = core_rknd ), intent(in), dimension(nnrad_zm) :: grad_zm ! Radiation levels [m] + + integer, intent(in) :: day, month, year ! Time of year + + real( kind = core_rknd ), dimension(nlon), intent(in) :: & + rlon ! Longitude(s) [Degrees E] + + real( kind = core_rknd ), dimension(nlat), intent(in) :: & + rlat ! Latitude(s) [Degrees N] + + real( kind = time_precision ), intent(in) :: & + time_current ! Model time [s] + + real( kind = core_rknd ), intent(in) :: & + delt ! Timestep (dt_main in CLUBB) [s] + + logical, intent(in) :: & + l_silhs_out_in ! Whether to output SILHS files (stats_lh_zt, stats_lh_sfc) [boolean] + + ! Local Variables + logical :: l_error + + character(len=200) :: fname + + integer :: ivar, ntot, read_status + + ! Namelist Variables + + character(len=10) :: stats_fmt ! File storage convention + + character(len=var_length), dimension(nvarmax_zt) :: & + vars_zt ! Variables on the thermodynamic levels + + character(len=var_length), dimension(nvarmax_lh_zt) :: & + vars_lh_zt ! Latin Hypercube variables on the thermodynamic levels + + character(len=var_length), dimension(nvarmax_lh_sfc) :: & + vars_lh_sfc ! Latin Hypercube variables at the surface + + character(len=var_length), dimension(nvarmax_zm) :: & + vars_zm ! Variables on the momentum levels + + character(len=var_length), dimension(nvarmax_rad_zt) :: & + vars_rad_zt ! Variables on the radiation levels + + character(len=var_length), dimension(nvarmax_rad_zm) :: & + vars_rad_zm ! Variables on the radiation levels + + character(len=var_length), dimension(nvarmax_sfc) :: & + vars_sfc ! Variables at the model surface + + namelist /statsnl/ & + vars_zt, & + vars_zm, & + vars_lh_zt, & + vars_lh_sfc, & + vars_rad_zt, & + vars_rad_zm, & + vars_sfc + + ! ---- Begin Code ---- + + ! Initialize + l_error = .false. + + ! Set stats_variables variables with inputs from calling subroutine + l_stats = l_stats_in + + stats_tsamp = stats_tsamp_in + stats_tsamp = stats_tsamp_in + stats_tout = stats_tout_in + stats_fmt = trim( stats_fmt_in ) + l_silhs_out = l_silhs_out_in + + if ( .not. l_stats ) then + l_stats_samp = .false. + l_stats_last = .false. + return + end if + + ! Initialize namelist variables + + vars_zt = '' + vars_zm = '' + vars_lh_zt = '' + vars_lh_sfc = '' + vars_rad_zt = '' + vars_rad_zm = '' + vars_sfc = '' + + ! Reads list of variables that should be output to GrADS/NetCDF (namelist &statsnl) + + open(unit=iunit, file=fnamelist) + read(unit=iunit, nml=statsnl, iostat=read_status, end=100) + if ( read_status /= 0 ) then + if ( read_status > 0 ) then + write(fstderr,*) "Error reading stats namelist in file ", & + trim( fnamelist ) + else ! Read status < 0 + write(fstderr,*) "End of file marker reached while reading stats namelist in file ", & + trim( fnamelist ) + end if + write(fstderr,*) "One cause is having more statistical variables ", & + "listed in the namelist for var_zt, var_zm, or ", & + "var_sfc than allowed by nvarmax_zt, nvarmax_zm, ", & + "or nvarmax_sfc, respectively." + write(fstderr,*) "Maximum variables allowed for var_zt = ", nvarmax_zt + write(fstderr,*) "Maximum variables allowed for var_zm = ", nvarmax_zm + write(fstderr,*) "Maximum variables allowed for var_rad_zt = ", nvarmax_rad_zt + write(fstderr,*) "Maximum variables allowed for var_rad_zm = ", nvarmax_rad_zm + write(fstderr,*) "Maximum variables allowed for var_sfc = ", nvarmax_sfc + stop "stats_init: Error reading stats namelist." + end if ! read_status /= 0 + + close(unit=iunit) + + if ( clubb_at_least_debug_level( 1 ) ) then + write(fstdout,*) "--------------------------------------------------" + + write(fstdout,*) "Statistics" + + write(fstdout,*) "--------------------------------------------------" + write(fstdout,*) "vars_zt = " + ivar = 1 + do while ( vars_zt(ivar) /= '' ) + write(fstdout,*) vars_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_zm = " + ivar = 1 + do while ( vars_zm(ivar) /= '' ) + write(fstdout,*) vars_zm(ivar) + ivar = ivar + 1 + end do + + if ( l_silhs_out ) then + write(fstdout,*) "vars_lh_zt = " + ivar = 1 + do while ( vars_lh_zt(ivar) /= '' ) + write(fstdout,*) vars_lh_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_lh_sfc = " + ivar = 1 + do while ( vars_lh_sfc(ivar) /= '' ) + write(fstdout,*) vars_lh_sfc(ivar) + ivar = ivar + 1 + end do + end if ! l_silhs_out + + if ( l_output_rad_files ) then + write(fstdout,*) "vars_rad_zt = " + ivar = 1 + do while ( vars_rad_zt(ivar) /= '' ) + write(fstdout,*) vars_rad_zt(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "vars_rad_zm = " + ivar = 1 + do while ( vars_rad_zm(ivar) /= '' ) + write(fstdout,*) vars_rad_zm(ivar) + ivar = ivar + 1 + end do + end if ! l_output_rad_files + + write(fstdout,*) "vars_sfc = " + ivar = 1 + do while ( vars_sfc(ivar) /= '' ) + write(fstdout,*) vars_sfc(ivar) + ivar = ivar + 1 + end do + + write(fstdout,*) "--------------------------------------------------" + end if ! clubb_at_least_debug_level 1 + + ! Determine file names for GrADS or NetCDF files + fname_zt = trim( fname_prefix )//"_zt" + fname_zm = trim( fname_prefix )//"_zm" + fname_lh_zt = trim( fname_prefix )//"_lh_zt" + fname_lh_sfc = trim( fname_prefix )//"_lh_sfc" + fname_rad_zt = trim( fname_prefix )//"_rad_zt" + fname_rad_zm = trim( fname_prefix )//"_rad_zm" + fname_sfc = trim( fname_prefix )//"_sfc" + + ! Parse the file type for stats output. Currently only GrADS and + ! netCDF > version 3.5 are supported by this code. + select case ( trim( stats_fmt ) ) + case ( "GrADS", "grads", "gr" ) + l_netcdf = .false. + l_grads = .true. + + case ( "NetCDF", "netcdf", "nc" ) + l_netcdf = .true. + l_grads = .false. + + case default + write(fstderr,*) "In module stats_clubb_utilities subroutine stats_init: " + write(fstderr,*) "Invalid stats output format "//trim( stats_fmt ) + stop "Fatal error" + + end select + + ! Check sampling and output frequencies + + ! The model time step length, delt (which is dt_main), should multiply + ! evenly into the statistical sampling time step length, stats_tsamp. + if ( abs( stats_tsamp/delt - real( floor( stats_tsamp/delt ), kind=core_rknd ) ) & + > 1.e-8_core_rknd) 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 dt_main). Check the appropriate ', & + 'model.in file.' + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + write(fstderr,*) 'delt = ', delt + end if + + ! The statistical sampling time step length, stats_tsamp, should multiply + ! evenly into the statistical output time step length, stats_tout. + if ( abs( stats_tout/stats_tsamp & + - real( floor( stats_tout/stats_tsamp ), kind=core_rknd) ) & + > 1.e-8_core_rknd) then + l_error = .true. ! This will cause the run to stop. + write(fstderr,*) 'Error: stats_tout should be an even multiple of ', & + 'stats_tsamp. Check the appropriate model.in file.' + write(fstderr,*) 'stats_tout = ', stats_tout + write(fstderr,*) 'stats_tsamp = ', stats_tsamp + end if + + ! Initialize zt (mass points) + + ivar = 1 + do while ( ichar(vars_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + + if ( any( vars_zt == "hm_i" ) ) then + ! Correct for number of variables found under "hm_i". + ! Subtract "hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_hm_i" ) ) then + ! Correct for number of variables found under "mu_hm_i". + ! Subtract "mu_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_Ncn_i" ) ) then + ! Correct for number of variables found under "mu_Ncn_i". + ! Subtract "mu_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "mu_hm_i_n" ) ) then + ! Correct for number of variables found under "mu_hm_i_n". + ! Subtract "mu_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "mu_Ncn_i_n" ) ) then + ! Correct for number of variables found under "mu_Ncn_i_n". + ! Subtract "mu_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "sigma_hm_i" ) ) then + ! Correct for number of variables found under "sigma_hm_i". + ! Subtract "sigma_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "sigma_Ncn_i" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i". + ! Subtract "sigma_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "sigma_hm_i_n" ) ) then + ! Correct for number of variables found under "sigma_hm_i_n". + ! Subtract "sigma_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "sigma_Ncn_i_n" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i_n". + ! Subtract "sigma_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + + if ( any( vars_zt == "corr_w_hm_i" ) ) then + ! Correct for number of variables found under "corr_w_hm_i". + ! Subtract "corr_w_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_w_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_w_Ncn_i". + ! Subtract "corr_w_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_chi_hm_i" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i". + ! Subtract "corr_chi_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_chi_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i". + ! Subtract "corr_chi_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_eta_hm_i" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i". + ! Subtract "corr_eta_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_eta_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i". + ! Subtract "corr_eta_Ncn_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_Ncn_hm_i" ) ) then + ! Correct for number of variables found under "corr_Ncn_hm_i". + ! Subtract "corr_Ncn_hm_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_hmx_hmy_i" ) ) then + ! Correct for number of variables found under "corr_hmx_hmy_i". + ! Subtract "corr_hmx_hmy_i" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of correlations of two hydrometeors, which is found by: + ! (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! to the number of zt statistical variables. + ntot = ntot + hydromet_dim * ( hydromet_dim - 1 ) + endif + + if ( any( vars_zt == "corr_w_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_w_hm_i_n". + ! Subtract "corr_w_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_w_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_w_Ncn_i_n". + ! Subtract "corr_w_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_chi_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i_n". + ! Subtract "corr_chi_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_chi_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i_n". + ! Subtract "corr_chi_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_eta_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i_n". + ! Subtract "corr_eta_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_eta_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i_n". + ! Subtract "corr_eta_Ncn_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) to the number of zt + ! statistical variables. + ntot = ntot + 2 + endif + if ( any( vars_zt == "corr_Ncn_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_Ncn_hm_i_n". + ! Subtract "corr_Ncn_hm_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) for each hydrometeor + ! to the number of zt statistical variables. + ntot = ntot + 2 * hydromet_dim + endif + if ( any( vars_zt == "corr_hmx_hmy_i_n" ) ) then + ! Correct for number of variables found under "corr_hmx_hmy_i_n". + ! Subtract "corr_hmx_hmy_i_n" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of normal space correlations of two hydrometeors, which is + ! found by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! to the number of zt statistical variables. + ntot = ntot + hydromet_dim * ( hydromet_dim - 1 ) + endif + + if ( any( vars_zt == "hmp2_zt" ) ) then + ! Correct for number of variables found under "hmp2_zt". + ! Subtract "hmp2_zt" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zt statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zt == "wp2hmp" ) ) then + ! Correct for number of variables found under "wp2hmp". + ! Subtract "wp2hmp" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zt statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zt == "sclrm" ) ) then + ! Correct for number of variables found under "sclrm". + ! Subtract "sclrm" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zt statistical variables. + ntot = ntot + sclr_dim + endif + + if ( any( vars_zt == "sclrm_f" ) ) then + ! Correct for number of variables found under "sclrm_f". + ! Subtract "sclrm_f" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zt statistical variables. + ntot = ntot + sclr_dim + endif + + if ( any( vars_zt == "edsclrm" ) ) then + ! Correct for number of variables found under "edsclrm". + ! Subtract "edsclrm" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zt statistical variables. + ntot = ntot + edsclr_dim + endif + + if ( any( vars_zt == "edsclrm_f" ) ) then + ! Correct for number of variables found under "edsclrm_f". + ! Subtract "edsclrm_f" from the number of zt statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zt statistical variables. + ntot = ntot + edsclr_dim + endif + + if ( ntot >= nvarmax_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_zt." + write(fstderr,*) "Check the number of variables listed for vars_zt ", & + "in the stats namelist, or change nvarmax_zt." + write(fstderr,*) "nvarmax_zt = ", nvarmax_zt + stop "stats_init: number of zt statistical variables exceeds limit" + end if + + stats_zt%num_output_fields = ntot + stats_zt%kk = nzmax + stats_zt%ii = nlon + stats_zt%jj = nlat + + allocate( stats_zt%z( stats_zt%kk ) ) + stats_zt%z = gzt + + allocate( stats_zt%accum_field_values( stats_zt%ii, stats_zt%jj, & + stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt %accum_num_samples( stats_zt%ii, stats_zt%jj, & + stats_zt%kk, stats_zt%num_output_fields ) ) + allocate( stats_zt%l_in_update( stats_zt%ii, stats_zt%jj, stats_zt%kk, & + stats_zt%num_output_fields ) ) + call stats_zero( stats_zt%ii, stats_zt%jj, 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_core_rknd + ztscr02 = 0.0_core_rknd + ztscr03 = 0.0_core_rknd + ztscr04 = 0.0_core_rknd + ztscr05 = 0.0_core_rknd + ztscr06 = 0.0_core_rknd + ztscr07 = 0.0_core_rknd + ztscr08 = 0.0_core_rknd + ztscr09 = 0.0_core_rknd + ztscr10 = 0.0_core_rknd + ztscr11 = 0.0_core_rknd + ztscr12 = 0.0_core_rknd + ztscr13 = 0.0_core_rknd + ztscr14 = 0.0_core_rknd + ztscr15 = 0.0_core_rknd + ztscr16 = 0.0_core_rknd + ztscr17 = 0.0_core_rknd + ztscr18 = 0.0_core_rknd + ztscr19 = 0.0_core_rknd + ztscr20 = 0.0_core_rknd + ztscr21 = 0.0_core_rknd + + fname = trim( fname_zt ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_zt%kk, nlat, nlon, stats_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_zt%num_output_fields, stats_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, stats_zt%kk, stats_zt%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_zt%num_output_fields, & ! In + stats_zt%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + ! Default initialization for array indices for zt + + call stats_init_zt( vars_zt, l_error ) + + + ! Setup output file for stats_lh_zt (Latin Hypercube stats) + + if ( l_silhs_out ) then + + ivar = 1 + do while ( ichar(vars_lh_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_lh_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_lh_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( any( vars_lh_zt == "silhs_variance_category" ) ) then + ! Correct for number of variables found under "silhs_variance_category". + ! Subtract "silhs_variance_category" from the number of lh_zt statistical + ! variables. + ntot = ntot - 1 + ! Add 1 for each SILHS category to the number of lh_zt statistical variables + ntot = ntot + silhs_num_importance_categories + end if + + if ( any( vars_lh_zt == "lh_samp_frac_category" ) ) then + ! Correct for number of variables found under "lh_samp_frac_category". + ! Subtract "lh_samp_frac_category" from the number of lh_zt statistical + ! variables. + ntot = ntot - 1 + ! Add 1 for each SILHS category to the number of lh_zt statistical variables + ntot = ntot + silhs_num_importance_categories + end if + + if ( ntot == nvarmax_lh_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_lh_zt." + write(fstderr,*) "Check the number of variables listed for vars_lh_zt ", & + "in the stats namelist, or change nvarmax_lh_zt." + write(fstderr,*) "nvarmax_lh_zt = ", nvarmax_lh_zt + stop "stats_init: number of lh_zt statistical variables exceeds limit" + end if + + stats_lh_zt%num_output_fields = ntot + stats_lh_zt%kk = nzmax + stats_lh_zt%ii = nlon + stats_lh_zt%jj = nlat + + allocate( stats_lh_zt%z( stats_lh_zt%kk ) ) + stats_lh_zt%z = gzt + + allocate( stats_lh_zt%accum_field_values( stats_lh_zt%ii, stats_lh_zt%jj, & + stats_lh_zt%kk, stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%accum_num_samples( stats_lh_zt%ii, stats_lh_zt%jj, & + stats_lh_zt%kk, stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%l_in_update( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields ) ) + call stats_zero( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, & + stats_lh_zt%accum_field_values, stats_lh_zt %accum_num_samples, stats_lh_zt%l_in_update ) + + allocate( stats_lh_zt%file%var( stats_lh_zt%num_output_fields ) ) + allocate( stats_lh_zt%file%z( stats_lh_zt%kk ) ) + + + fname = trim( fname_lh_zt ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_lh_zt%kk, nlat, nlon, stats_lh_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_lh_zt%num_output_fields, stats_lh_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, stats_lh_zt%kk, & ! In + stats_lh_zt%z, day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_lh_zt%num_output_fields, & ! In + stats_lh_zt%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + call stats_init_lh_zt( vars_lh_zt, l_error ) + + ivar = 1 + do while ( ichar(vars_lh_sfc(ivar)(1:1)) /= 0 & + .and. len_trim(vars_lh_sfc(ivar)) /= 0 & + .and. ivar <= nvarmax_lh_sfc ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_lh_sfc ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zt than allowed for by nvarmax_lh_sfc." + write(fstderr,*) "Check the number of variables listed for vars_lh_sfc ", & + "in the stats namelist, or change nvarmax_lh_sfc." + write(fstderr,*) "nvarmax_lh_sfc = ", nvarmax_lh_sfc + stop "stats_init: number of lh_sfc statistical variables exceeds limit" + end if + + stats_lh_sfc%num_output_fields = ntot + stats_lh_sfc%kk = 1 + stats_lh_sfc%ii = nlon + stats_lh_sfc%jj = nlat + + allocate( stats_lh_sfc%z( stats_lh_sfc%kk ) ) + stats_lh_sfc%z = gzm(1) + + allocate( stats_lh_sfc%accum_field_values( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc %accum_num_samples( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc%l_in_update( stats_lh_sfc%ii, stats_lh_sfc%jj, & + stats_lh_sfc%kk, stats_lh_sfc%num_output_fields ) ) + + call stats_zero( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc %accum_num_samples, stats_lh_sfc%l_in_update ) + + allocate( stats_lh_sfc%file%var( stats_lh_sfc%num_output_fields ) ) + allocate( stats_lh_sfc%file%z( stats_lh_sfc%kk ) ) + + fname = trim( fname_lh_sfc ) + + if ( l_grads ) then + + ! Open GrADS file + call open_grads( iunit, fdir, fname, & + 1, stats_lh_sfc%kk, nlat, nlon, stats_lh_sfc%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, stats_lh_sfc%kk, & ! In + stats_lh_sfc%z, day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_lh_sfc%num_output_fields, & ! In + stats_lh_sfc%file ) ! InOut +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + + end if + + call stats_init_lh_sfc( vars_lh_sfc, l_error ) + + end if ! l_silhs_out + + ! Initialize stats_zm (momentum points) + + ivar = 1 + do while ( ichar(vars_zm(ivar)(1:1)) /= 0 & + .and. len_trim(vars_zm(ivar)) /= 0 & + .and. ivar <= nvarmax_zm ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + + if ( any( vars_zm == "hydrometp2" ) ) then + ! Correct for number of variables found under "hydrometp2". + ! Subtract "hydrometp2" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "wphydrometp" ) ) then + ! Correct for number of variables found under "wphydrometp". + ! Subtract "wphydrometp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "rtphmp" ) ) then + ! Correct for number of variables found under "rtphmp". + ! Subtract "rtphmp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "thlphmp" ) ) then + ! Correct for number of variables found under "thlphmp". + ! Subtract "thlphmp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "hmxphmyp" ) ) then + ! Correct for number of variables found under "hmxphmyp". + ! Subtract "hmxphmyp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add the number of overall covariances of two hydrometeors, which is + ! found by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! to the number of zm statistical variables. + ntot = ntot + hydromet_dim * ( hydromet_dim - 1 ) / 2 + endif + + if ( any( vars_zm == "K_hm" ) ) then + ! Correct for number of variables found under "K_hm". + ! Subtract "K_hm" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each hydrometeor to the number of zm statistical variables. + ntot = ntot + hydromet_dim + endif + + if ( any( vars_zm == "sclrprtp" ) ) then + ! Correct for number of variables found under "sclrprtp". + ! Subtract "sclrprtp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + if ( any( vars_zm == "sclrp2" ) ) then + ! Correct for number of variables found under "sclrp2". + ! Subtract "sclrp2" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "sclrpthvp" ) ) then + ! Correct for number of variables found under "sclrpthvp". + ! Subtract "sclrpthvp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "sclrpthlp" ) ) then + ! Correct for number of variables found under "sclrpthlp". + ! Subtract "sclrpthlp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "sclrprcp" ) ) then + ! Correct for number of variables found under "sclrprcp". + ! Subtract "sclrprcp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wpsclrp" ) ) then + ! Correct for number of variables found under "wpsclrp". + ! Subtract "wpsclrp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wpsclrp2" ) ) then + ! Correct for number of variables found under "wpsclrp2". + ! Subtract "wpsclrp2" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wp2sclrp" ) ) then + ! Correct for number of variables found under "wp2sclrp". + ! Subtract "wp2sclrp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wpsclrprtp" ) ) then + ! Correct for number of variables found under "wpsclrprtp". + ! Subtract "wpsclrprtp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wpsclrpthlp" ) ) then + ! Correct for number of variables found under "wpsclrpthlp". + ! Subtract "wpsclrpthlp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + sclr_dim + endif + + + if ( any( vars_zm == "wpedsclrp" ) ) then + ! Correct for number of variables found under "wpedsclrp". + ! Subtract "wpedsclrp" from the number of zm statistical variables. + ntot = ntot - 1 + ! Add 1 for each scalar to the number of zm statistical variables. + ntot = ntot + edsclr_dim + endif + + + + if ( ntot == nvarmax_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_zm than allowed for by nvarmax_zm." + write(fstderr,*) "Check the number of variables listed for vars_zm ", & + "in the stats namelist, or change nvarmax_zm." + write(fstderr,*) "nvarmax_zm = ", nvarmax_zm + stop "stats_init: number of zm statistical variables exceeds limit" + end if + + stats_zm%num_output_fields = ntot + stats_zm%kk = nzmax + stats_zm%ii = nlon + stats_zm%jj = nlat + + allocate( stats_zm%z( stats_zm%kk ) ) + stats_zm%z = gzm + + allocate( stats_zm%accum_field_values( stats_zm%ii, stats_zm%jj, & + stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm %accum_num_samples( stats_zm%ii, stats_zm%jj, & + stats_zm%kk, stats_zm%num_output_fields ) ) + allocate( stats_zm%l_in_update( stats_zm%ii, stats_zm%jj, stats_zm%kk, & + stats_zm%num_output_fields ) ) + + call stats_zero( stats_zm%ii, stats_zm%jj, 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) ) + + ! Initialize to 0 + zmscr01 = 0.0_core_rknd + zmscr02 = 0.0_core_rknd + zmscr03 = 0.0_core_rknd + zmscr04 = 0.0_core_rknd + zmscr05 = 0.0_core_rknd + zmscr06 = 0.0_core_rknd + zmscr07 = 0.0_core_rknd + zmscr08 = 0.0_core_rknd + zmscr09 = 0.0_core_rknd + zmscr10 = 0.0_core_rknd + zmscr11 = 0.0_core_rknd + zmscr12 = 0.0_core_rknd + zmscr13 = 0.0_core_rknd + zmscr14 = 0.0_core_rknd + zmscr15 = 0.0_core_rknd + zmscr16 = 0.0_core_rknd + zmscr17 = 0.0_core_rknd + + + fname = trim( fname_zm ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_zm%kk, nlat, nlon, stats_zm%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_zm%num_output_fields, stats_zm%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, stats_zm%kk, stats_zm%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_zm%num_output_fields, & ! In + stats_zm%file ) ! InOut + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_zm( vars_zm, l_error ) + + ! Initialize stats_rad_zt (radiation points) + + if (l_output_rad_files) then + + ivar = 1 + do while ( ichar(vars_rad_zt(ivar)(1:1)) /= 0 & + .and. len_trim(vars_rad_zt(ivar)) /= 0 & + .and. ivar <= nvarmax_rad_zt ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_rad_zt ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_rad_zt than allowed for by nvarmax_rad_zt." + write(fstderr,*) "Check the number of variables listed for vars_rad_zt ", & + "in the stats namelist, or change nvarmax_rad_zt." + write(fstderr,*) "nvarmax_rad_zt = ", nvarmax_rad_zt + stop "stats_init: number of rad_zt statistical variables exceeds limit" + end if + + stats_rad_zt%num_output_fields = ntot + stats_rad_zt%kk = nnrad_zt + stats_rad_zt%ii = nlon + stats_rad_zt%jj = nlat + allocate( stats_rad_zt%z( stats_rad_zt%kk ) ) + stats_rad_zt%z = grad_zt + + allocate( stats_rad_zt%accum_field_values( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%accum_num_samples( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + allocate( stats_rad_zt%l_in_update( stats_rad_zt%ii, stats_rad_zt%jj, & + stats_rad_zt%kk, stats_rad_zt%num_output_fields ) ) + + call stats_zero( stats_rad_zt%ii, stats_rad_zt%jj, 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 ) ) + + fname = trim( fname_rad_zt ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_rad_zt%kk, nlat, nlon, stats_rad_zt%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout, kind=time_precision), stats_tout, & + stats_rad_zt%num_output_fields, stats_rad_zt%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, & + 1, stats_rad_zt%kk, stats_rad_zt%z, & + day, month, year, rlat, rlon, & + time_current, stats_tout, & + stats_rad_zt%num_output_fields, stats_rad_zt%file ) + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_rad_zt( vars_rad_zt, l_error ) + + ! Initialize stats_rad_zm (radiation points) + + ivar = 1 + do while ( ichar(vars_rad_zm(ivar)(1:1)) /= 0 & + .and. len_trim(vars_rad_zm(ivar)) /= 0 & + .and. ivar <= nvarmax_rad_zm ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_rad_zm ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_rad_zm than allowed for by nvarmax_rad_zm." + write(fstderr,*) "Check the number of variables listed for vars_rad_zm ", & + "in the stats namelist, or change nvarmax_rad_zm." + write(fstderr,*) "nvarmax_rad_zm = ", nvarmax_rad_zm + stop "stats_init: number of rad_zm statistical variables exceeds limit" + end if + + stats_rad_zm%num_output_fields = ntot + stats_rad_zm%kk = nnrad_zm + stats_rad_zm%ii = nlon + stats_rad_zm%jj = nlat + + allocate( stats_rad_zm%z( stats_rad_zm%kk ) ) + stats_rad_zm%z = grad_zm + + allocate( stats_rad_zm%accum_field_values( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%accum_num_samples( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + allocate( stats_rad_zm%l_in_update( stats_rad_zm%ii, stats_rad_zm%jj, & + stats_rad_zm%kk, stats_rad_zm%num_output_fields ) ) + + call stats_zero( stats_rad_zm%ii, stats_rad_zm%jj, 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 ) ) + + fname = trim( fname_rad_zm ) + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_rad_zm%kk, nlat, nlon, stats_rad_zm%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_rad_zm%num_output_fields, stats_rad_zm%file ) + + else ! Open NetCDF file +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, & + 1, stats_rad_zm%kk, stats_rad_zm%z, & + day, month, year, rlat, rlon, & + time_current, stats_tout, & + stats_rad_zm%num_output_fields, stats_rad_zm%file ) + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_rad_zm( vars_rad_zm, l_error ) + end if ! l_output_rad_files + + + ! Initialize stats_sfc (surface point) + + ivar = 1 + do while ( ichar(vars_sfc(ivar)(1:1)) /= 0 & + .and. len_trim(vars_sfc(ivar)) /= 0 & + .and. ivar <= nvarmax_sfc ) + ivar = ivar + 1 + end do + ntot = ivar - 1 + if ( ntot == nvarmax_sfc ) then + write(fstderr,*) "There are more statistical variables listed in ", & + "vars_sfc than allowed for by nvarmax_sfc." + write(fstderr,*) "Check the number of variables listed for vars_sfc ", & + "in the stats namelist, or change nvarmax_sfc." + write(fstderr,*) "nvarmax_sfc = ", nvarmax_sfc + stop "stats_init: number of sfc statistical variables exceeds limit" + end if + + stats_sfc%num_output_fields = ntot + stats_sfc%kk = 1 + stats_sfc%ii = nlon + stats_sfc%jj = nlat + + allocate( stats_sfc%z( stats_sfc%kk ) ) + stats_sfc%z = gzm(1) + + allocate( stats_sfc%accum_field_values( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%accum_num_samples( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + allocate( stats_sfc%l_in_update( stats_sfc%ii, stats_sfc%jj, & + stats_sfc%kk, stats_sfc%num_output_fields ) ) + + call stats_zero( stats_sfc%ii, stats_sfc%jj, 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 ) ) + + fname = trim( fname_sfc ) + + if ( l_grads ) then + + ! Open GrADS files + call open_grads( iunit, fdir, fname, & + 1, stats_sfc%kk, nlat, nlon, stats_sfc%z, & + day, month, year, rlat, rlon, & + time_current+real(stats_tout,kind=time_precision), stats_tout, & + stats_sfc%num_output_fields, stats_sfc%file ) + + else ! Open NetCDF files +#ifdef NETCDF + call open_netcdf_for_writing( nlat, nlon, fdir, fname, 1, stats_sfc%kk, stats_sfc%z, & ! In + day, month, year, rlat, rlon, & ! In + time_current, stats_tout, stats_sfc%num_output_fields, & ! In + stats_sfc%file ) ! InOut + +#else + stop "This CLUBB program was not compiled with netCDF support." +#endif + end if + + call stats_init_sfc( vars_sfc, l_error ) + + ! Check for errors + + if ( l_error ) then + write(fstderr,*) 'stats_init: errors found' + stop "Fatal error" + endif + + return + + ! If namelist was not found in input file, turn off statistics + + 100 continue + write(fstderr,*) 'Error with statsnl, statistics is turned off' + l_stats = .false. + l_stats_samp = .false. + l_stats_last = .false. + + return + end subroutine stats_init + !----------------------------------------------------------------------- + subroutine stats_zero( ii, jj, kk, nn, x, n, l_in_update ) + + ! Description: + ! Initialize stats to zero + ! References: + ! None + !----------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + implicit none + + ! Input Variable(s) + integer, intent(in) :: ii, jj, kk, nn + + ! Output Variable(s) + real(kind=stat_rknd), dimension(ii,jj,kk,nn), intent(out) :: x + integer(kind=stat_nknd), dimension(ii,jj,kk,nn), intent(out) :: n + logical, dimension(ii,jj,kk,nn), intent(out) :: l_in_update + + ! Zero out arrays + + if ( nn > 0 ) then + x(:,:,:,:) = 0.0_stat_rknd + n(:,:,:,:) = 0_stat_nknd + l_in_update(:,:,:,:) = .false. + end if + + return + end subroutine stats_zero + + !----------------------------------------------------------------------- + subroutine stats_avg( ii, jj, kk, nn, x, n ) + + ! Description: + ! Compute the average of stats fields + ! References: + ! None + !----------------------------------------------------------------------- + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! External + intrinsic :: real + + ! Input Variable(s) + integer, intent(in) :: & + ii, & ! Number of points in X (i.e. latitude) dimension + jj, & ! Number of points in Y (i.e. longitude) dimension + kk, & ! Number of levels in vertical (i.e. Z) dimension + nn ! Number of variables being output to disk (e.g. cloud_frac, rain rate, etc.) + + integer(kind=stat_nknd), dimension(ii,jj,kk,nn), intent(in) :: & + n ! n is the number of samples for each of the nn fields + ! and each of the kk vertical levels + + ! Output Variable(s) + real(kind=stat_rknd), dimension(ii,jj,kk,nn), intent(inout) :: & + x ! The variable x contains the cumulative sums of n sample values of each of + ! the nn output fields (e.g. the sum of the sampled rain rate values) + + ! ---- Begin Code ---- + + ! Compute averages + where ( n(1,1,1:kk,1:nn) > 0 ) + x(clubb_i,clubb_j,1:kk,1:nn) = x(clubb_i,clubb_j,1:kk,1:nn) & + / real( n(clubb_i,clubb_j,1:kk,1:nn), kind=stat_rknd ) + end where + + return + end subroutine stats_avg + + !----------------------------------------------------------------------- + subroutine stats_begin_timestep( itime, stats_nsamp, stats_nout) + + ! Description: + ! Given the elapsed time, set flags determining specifics such as + ! if this time set should be sampled or if this is the first or + ! last time step. + !----------------------------------------------------------------------- + + use stats_variables, only: & + l_stats, & ! Variable(s) + l_stats_samp, & + l_stats_last + + + implicit none + + ! External + intrinsic :: mod + + ! Input Variable(s) + integer, intent(in) :: & + itime, & ! Elapsed model time [timestep] + stats_nsamp, & ! Stats sampling interval [timestep] + stats_nout ! Stats output interval [timestep] + + if ( .not. l_stats ) return + + ! Only sample time steps that are multiples of "stats_tsamp" + ! in a case's "model.in" file to shorten length of run + if ( mod( itime, stats_nsamp ) == 0 ) then + l_stats_samp = .true. + else + l_stats_samp = .false. + end if + + ! Indicates the end of the sampling time period. Signals to start writing to the file + if ( mod( itime, stats_nout ) == 0 ) then + l_stats_last = .true. + else + l_stats_last = .false. + end if + + return + + end subroutine stats_begin_timestep + + !----------------------------------------------------------------------- + subroutine stats_end_timestep( ) + + ! Description: + ! Called when the stats timestep has ended. This subroutine + ! is responsible for calling statistics to be written to the output + ! format. + ! + ! References: + ! None + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc, & + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_stats_last, & + l_output_rad_files, & + l_grads, & + l_silhs_out + + use output_grads, only: & + write_grads ! Procedure(s) + + use stat_file_module, only: & + clubb_i, & ! Variable(s) + clubb_j + +#ifdef NETCDF + use output_netcdf, only: & + write_netcdf ! Procedure(s) +#endif + + implicit none + + ! External + intrinsic :: floor + + ! Local Variables + + logical :: l_error + + ! ---- Begin Code ---- + + ! Check if it is time to write to file + + if ( .not. l_stats_last ) return + + ! Initialize + l_error = .false. + + call stats_check_num_samples( stats_zt, l_error ) + call stats_check_num_samples( stats_zm, l_error ) + call stats_check_num_samples( stats_sfc, l_error ) + if ( l_silhs_out ) then + call stats_check_num_samples( stats_lh_zt, l_error ) + call stats_check_num_samples( stats_lh_sfc, l_error ) + end if + if ( l_output_rad_files ) then + call stats_check_num_samples( stats_rad_zt, l_error ) + call stats_check_num_samples( stats_rad_zm, l_error ) + end if + + ! 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.' + stop 'stats_end_timestep: error(s) found' + end if ! l_error + + ! Compute averages + call stats_avg( stats_zt%ii, stats_zt%jj, stats_zt%kk, stats_zt%num_output_fields, & + stats_zt%accum_field_values, stats_zt%accum_num_samples ) + call stats_avg( stats_zm%ii, stats_zm%jj, stats_zm%kk, stats_zm%num_output_fields, & + stats_zm%accum_field_values, stats_zm%accum_num_samples ) + if ( l_silhs_out ) then + call stats_avg( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, stats_lh_zt%accum_field_values, & + stats_lh_zt%accum_num_samples ) + call stats_avg( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc%accum_num_samples ) + end if + if ( l_output_rad_files ) then + call stats_avg( stats_rad_zt%ii, stats_rad_zt%jj, 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%ii, stats_rad_zm%jj, 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%ii, stats_sfc%jj, stats_sfc%kk, stats_sfc%num_output_fields, & + stats_sfc%accum_field_values, stats_sfc%accum_num_samples ) + + ! Only write to the file and zero out the stats fields if we've reach the horizontal + ! limits of the domain (this is always true in the single-column case because it's 1x1). + if ( clubb_i == stats_zt%ii .and. clubb_j == stats_zt%jj ) then + ! Write to file + if ( l_grads ) then + call write_grads( stats_zt%file ) + call write_grads( stats_zm%file ) + if ( l_silhs_out ) then + call write_grads( stats_lh_zt%file ) + call write_grads( stats_lh_sfc%file ) + end if + if ( l_output_rad_files ) then + call write_grads( stats_rad_zt%file ) + call write_grads( stats_rad_zm%file ) + end if + call write_grads( stats_sfc%file ) + else ! l_netcdf +#ifdef NETCDF + call write_netcdf( stats_zt%file ) + call write_netcdf( stats_zm%file ) + if ( l_silhs_out ) then + call write_netcdf( stats_lh_zt%file ) + call write_netcdf( stats_lh_sfc%file ) + end if + if ( l_output_rad_files ) then + call write_netcdf( stats_rad_zt%file ) + call write_netcdf( stats_rad_zm%file ) + end if + call write_netcdf( stats_sfc%file ) +#else + stop "This program was not compiled with netCDF support" +#endif /* NETCDF */ + end if ! l_grads + + ! Reset sample fields + call stats_zero( stats_zt%ii, stats_zt%jj, 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%ii, stats_zm%jj, 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_silhs_out ) then + call stats_zero( stats_lh_zt%ii, stats_lh_zt%jj, stats_lh_zt%kk, & + stats_lh_zt%num_output_fields, stats_lh_zt%accum_field_values, & + stats_lh_zt%accum_num_samples, stats_lh_zt%l_in_update ) + call stats_zero( stats_lh_sfc%ii, stats_lh_sfc%jj, stats_lh_sfc%kk, & + stats_lh_sfc%num_output_fields, stats_lh_sfc%accum_field_values, & + stats_lh_sfc%accum_num_samples, stats_lh_sfc%l_in_update ) + end if + if ( l_output_rad_files ) then + call stats_zero( stats_rad_zt%ii, stats_rad_zt%jj, 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_zt%ii, stats_rad_zt%jj, 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%ii, stats_sfc%jj, stats_sfc%kk, stats_sfc%num_output_fields, & + stats_sfc%accum_field_values, & + stats_sfc%accum_num_samples, stats_sfc%l_in_update ) + + end if ! clubb_i = stats_zt%ii .and. clubb_j == stats_zt%jj + + + return + end subroutine stats_end_timestep + + !---------------------------------------------------------------------- + subroutine stats_accumulate & + ( um, vm, upwp, vpwp, up2, vp2, & + thlm, rtm, wprtp, wpthlp, & + wp2, wp3, rtp2, rtp3, thlp2, thlp3, rtpthlp, & + p_in_Pa, exner, rho, rho_zm, & + rho_ds_zm, rho_ds_zt, thv_ds_zm, & + thv_ds_zt, wm_zt, wm_zm, rcm, wprcp, rc_coef, & + rcm_zm, rtm_zm, thlm_zm, cloud_frac, ice_supersat_frac, & + cloud_frac_zm, ice_supersat_frac_zm, rcm_in_layer, & + cloud_cover, sigma_sqd_w, pdf_params, & + sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & + wpsclrp, edsclrm, edsclrm_forcing ) + + ! Description: + ! Accumulate those stats variables that are preserved in CLUBB from timestep to + ! timestep, but not those stats that are not, (e.g. budget terms, longwave and + ! shortwave components, etc.) + ! + ! References: + ! None + !---------------------------------------------------------------------- + + use constants_clubb, only: & + cloud_frac_min ! Constant + + + use pdf_utilities, only: & + compute_variance_binormal ! Procedure + + use stats_variables, only: & + stats_zt, & ! Variables + stats_zm, & + stats_sfc, & + l_stats_samp, & + ithlm, & + iT_in_K, & + ithvm, & + irtm, & + ircm, & + ium, & + ivm, & + iwm_zt, & + iwm_zm, & + iug, & + ivg, & + icloud_frac, & + iice_supersat_frac, & + ircm_in_layer, & + icloud_cover + + use stats_variables, only: & + ip_in_Pa, & + iexner, & + irho_ds_zt, & + ithv_ds_zt, & + iLscale, & + iwp3, & + iwp3_zm, & + iwpthlp2, & + iwp2thlp, & + iwprtp2, & + iwp2rtp, & + iLscale_up, & + iLscale_down, & + itau_zt, & + iKh_zt + + use stats_variables, only: & + iwp2thvp, & ! Variable(s) + iwp2rcp, & + iwprtpthlp, & + isigma_sqd_w_zt, & + irho, & + irsat, & + irsati + + use stats_variables, only: & + imixt_frac, & ! Variable(s) + iw_1, & + iw_2, & + ivarnce_w_1, & + ivarnce_w_2, & + ithl_1, & + ithl_2, & + ivarnce_thl_1, & + ivarnce_thl_2, & + irt_1, & + irt_2, & + ivarnce_rt_1, & + ivarnce_rt_2, & + irc_1, & + irc_2, & + irsatl_1, & + irsatl_2, & + icloud_frac_1, & + icloud_frac_2 + + use stats_variables, only: & + ichi_1, & ! Variable(s) + ichi_2, & + istdev_chi_1, & + istdev_chi_2, & + ichip2, & + istdev_eta_1, & + istdev_eta_2, & + icovar_chi_eta_1, & + icovar_chi_eta_2, & + icorr_chi_eta_1, & + icorr_chi_eta_2, & + icrt_1, & + icrt_2, & + icthl_1, & + icthl_2, & + irrtthl, & + ichi + + use stats_variables, only: & + iwp2_zt, & ! Variable(s) + ithlp2_zt, & + iwpthlp_zt, & + iwprtp_zt, & + irtp2_zt, & + irtpthlp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt, & + iwp2, & + irtp2, & + irtp3, & + ithlp2, & + ithlp3, & + irtpthlp, & + iwprtp, & + iwpthlp, & + iwp4, & + iwpthvp, & + irtpthvp + + use stats_variables, only: & + ithlpthvp, & ! Variable(s) + itau_zm, & + iKh_zm, & + iwprcp, & + irc_coef, & + ithlprcp, & + irtprcp, & + ircp2, & + iupwp, & + ivpwp, & + iup2, & + ivp2, & + irho_zm, & + isigma_sqd_w, & + irho_ds_zm, & + ithv_ds_zm, & + iem + + use stats_variables, only: & + ishear, & ! Variable(s) + iFrad, & + icc, & + iz_cloud_base, & + ilwp, & + ivwp, & + ithlm_vert_avg, & + irtm_vert_avg, & + ium_vert_avg, & + ivm_vert_avg, & + iwp2_vert_avg, & + iup2_vert_avg, & + ivp2_vert_avg, & + irtp2_vert_avg, & + ithlp2_vert_avg + + use stats_variables, only: & + isclrm, & ! Variable(s) + isclrm_f, & + iedsclrm, & + iedsclrm_f, & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + icloud_frac_zm, & + iice_supersat_frac_zm, & + ircm_zm, & + irtm_zm, & + ithlm_zm + + use stats_variables, only: & + iwp3_on_wp2, & + iwp3_on_wp2_zt, & + iSkw_velocity + + use stats_variables, only: & + ia3_coef, & ! Variables + ia3_coef_zt, & + ircm_in_cloud + + use grid_class, only: & + gr ! Variable + + use grid_class, only: & + zt2zm ! Procedure(s) + + use variables_diagnostic_module, only: & + thvm, & ! Variable(s) + ug, & + vg, & + Lscale, & + wpthlp2, & + wp2thlp, & + wprtp2, & + wp2rtp, & + Lscale_up, & + Lscale_down, & + tau_zt, & + Kh_zt, & + wp2thvp, & + wp2rcp, & + wprtpthlp, & + sigma_sqd_w_zt, & + rsat + + use variables_diagnostic_module, only: & + wp2_zt, & ! Variable(s) + thlp2_zt, & + wpthlp_zt, & + wprtp_zt, & + rtp2_zt, & + rtpthlp_zt, & + up2_zt, & + vp2_zt, & + upwp_zt, & + vpwp_zt, & + wp4, & + rtpthvp, & + thlpthvp, & + wpthvp, & + tau_zm, & + Kh_zm, & + thlprcp, & + rtprcp, & + rcp2, & + em, & + Frad, & + sclrpthvp, & + sclrprcp, & + wp2sclrp, & + wpsclrp2, & + wpsclrprtp, & + wpsclrpthlp, & + wpedsclrp + + use variables_diagnostic_module, only: & + a3_coef, & ! Variable(s) + a3_coef_zt, & + wp3_zm, & + wp3_on_wp2, & + wp3_on_wp2_zt, & + Skw_velocity + + use pdf_parameter_module, only: & + pdf_parameter ! Type + + use T_in_K_module, only: & + thlm2T_in_K ! Procedure + + use constants_clubb, only: & + rc_tol ! Constant(s) + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use fill_holes, only: & + vertical_avg, & ! Procedure(s) + vertical_integral + + use interpolation, only: & + lin_interpolate_two_points ! Procedure + + use saturation, only: & + sat_mixrat_ice ! Procedure + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variable(s) + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + um, & ! u wind [m/s] + vm, & ! v wind [m/s] + upwp, & ! vertical u momentum flux [m^2/s^2] + vpwp, & ! vertical v momentum flux [m^2/s^2] + up2, & ! u'^2 [m^2/s^2] + vp2, & ! v'^2 [m^2/s^2] + thlm, & ! liquid potential temperature [K] + rtm, & ! total water mixing ratio [kg/kg] + wprtp, & ! w'rt' [(kg/kg) m/s] + wpthlp, & ! w'thl' [m K /s] + wp2, & ! w'^2 [m^2/s^2] + wp3, & ! w'^3 [m^3/s^3] + rtp2, & ! rt'^2 [(kg/kg)^2] + rtp3, & ! rt'^3 [(kg/kg)^3] + thlp2, & ! thl'^2 [K^2] + thlp3, & ! thl'^3 [K^3] + rtpthlp ! rt'thl' [kg/kg K] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + p_in_Pa, & ! Pressure (Pa) on thermodynamic points [Pa] + exner, & ! Exner function = ( p / p0 ) ** kappa [-] + rho, & ! Density [kg/m^3] + rho_zm, & ! Density [kg/m^3] + rho_ds_zm, & ! Dry, static density (momentum levels) [kg/m^3] + rho_ds_zt, & ! Dry, static density (thermo. levs.) [kg/m^3] + thv_ds_zm, & ! Dry, base-state theta_v (momentum levs.) [K] + thv_ds_zt, & ! Dry, base-state theta_v (thermo. levs.) [K] + wm_zt, & ! w on thermodynamic levels [m/s] + wm_zm ! w on momentum levels [m/s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + rcm_zm, & ! Total water mixing ratio [kg/kg] + rtm_zm, & ! Total water mixing ratio [kg/kg] + thlm_zm, & ! Liquid potential temperature [K] + rcm, & ! Cloud water mixing ratio [kg/kg] + wprcp, & ! w'rc' [(kg/kg) m/s] + rc_coef, & ! Coefficient of X' R_l' in Eq. (34) [-] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fracion [-] + cloud_frac_zm, & ! Cloud fraction on zm levels [-] + ice_supersat_frac_zm, & ! Ice cloud fraction on zm levels [-] + rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] + cloud_cover ! Cloud cover [-] + + real( kind = core_rknd ), intent(in), dimension(gr%nz) :: & + sigma_sqd_w ! PDF width parameter (momentum levels) [-] + + type(pdf_parameter), dimension(gr%nz), intent(in) :: & + pdf_params ! PDF parameters [units vary] + + real( kind = core_rknd ), intent(in), dimension(gr%nz,sclr_dim) :: & + sclrm, & ! High-order passive scalar [units vary] + sclrp2, & ! High-order passive scalar variance [units^2] + sclrprtp, & ! High-order passive scalar covariance [units kg/kg] + sclrpthlp, & ! High-order passive scalar covariance [units K] + sclrm_forcing, & ! Large-scale forcing of scalar [units/s] + wpsclrp ! w'sclr' [units m/s] + + real( kind = core_rknd ), intent(in), dimension(gr%nz,edsclr_dim) :: & + edsclrm, & ! Eddy-diff passive scalar [units vary] + edsclrm_forcing ! Large-scale forcing of edscalar [units vary] + + ! Local Variables + + integer :: isclr, k + + real( kind = core_rknd ), dimension(gr%nz) :: & + T_in_K, & ! Absolute temperature [K] + rsati, & ! Saturation w.r.t ice [kg/kg] + shear, & ! Wind shear production term [m^2/s^3] + chi, & ! Mellor's 's' [kg/kg] + chip2, & ! Variance of Mellor's 's' [kg/kg] + rcm_in_cloud ! rcm in cloud [kg/kg] + + real( kind = core_rknd ) :: xtmp + + ! ---- Begin Code ---- + + ! Sample fields + + if ( l_stats_samp ) then + + ! stats_zt variables + + + if ( iT_in_K > 0 .or. irsati > 0 ) then + T_in_K = thlm2T_in_K( thlm, exner, rcm ) + else + T_in_K = -999._core_rknd + end if + + call stat_update_var( iT_in_K, T_in_K, stats_zt ) + + call stat_update_var( ithlm, thlm, stats_zt ) + call stat_update_var( ithvm, thvm, stats_zt ) + call stat_update_var( irtm, rtm, stats_zt ) + call stat_update_var( ircm, rcm, stats_zt ) + call stat_update_var( ium, um, stats_zt ) + call stat_update_var( ivm, vm, stats_zt ) + call stat_update_var( iwm_zt, wm_zt, stats_zt ) + call stat_update_var( iwm_zm, wm_zm, stats_zm ) + call stat_update_var( iug, ug, stats_zt ) + call stat_update_var( ivg, vg, stats_zt ) + call stat_update_var( icloud_frac, cloud_frac, stats_zt ) + call stat_update_var( iice_supersat_frac, ice_supersat_frac, stats_zt) + call stat_update_var( ircm_in_layer, rcm_in_layer, stats_zt ) + call stat_update_var( icloud_cover, cloud_cover, stats_zt ) + call stat_update_var( ip_in_Pa, p_in_Pa, stats_zt ) + call stat_update_var( iexner, exner, stats_zt ) + call stat_update_var( irho_ds_zt, rho_ds_zt, stats_zt ) + call stat_update_var( ithv_ds_zt, thv_ds_zt, stats_zt ) + call stat_update_var( iLscale, Lscale, stats_zt ) + call stat_update_var( iwp3, wp3, stats_zt ) + call stat_update_var( iwpthlp2, wpthlp2, stats_zt ) + call stat_update_var( iwp2thlp, wp2thlp, stats_zt ) + call stat_update_var( iwprtp2, wprtp2, stats_zt ) + call stat_update_var( iwp2rtp, wp2rtp, stats_zt ) + call stat_update_var( iLscale_up, Lscale_up, stats_zt ) + call stat_update_var( iLscale_down, Lscale_down, stats_zt ) + call stat_update_var( itau_zt, tau_zt, stats_zt ) + call stat_update_var( iKh_zt, Kh_zt, stats_zt ) + call stat_update_var( iwp2thvp, wp2thvp, stats_zt ) + call stat_update_var( iwp2rcp, wp2rcp, stats_zt ) + call stat_update_var( iwprtpthlp, wprtpthlp, stats_zt ) + call stat_update_var( isigma_sqd_w_zt, sigma_sqd_w_zt, stats_zt ) + call stat_update_var( irho, rho, stats_zt ) + call stat_update_var( irsat, rsat, stats_zt ) + if ( irsati > 0 ) then + rsati = sat_mixrat_ice( p_in_Pa, T_in_K ) + call stat_update_var( irsati, rsati, stats_zt ) + end if + + call stat_update_var( imixt_frac, pdf_params%mixt_frac, stats_zt ) + call stat_update_var( iw_1, pdf_params%w_1, stats_zt ) + call stat_update_var( iw_2, pdf_params%w_2, stats_zt ) + call stat_update_var( ivarnce_w_1, pdf_params%varnce_w_1, stats_zt ) + call stat_update_var( ivarnce_w_2, pdf_params%varnce_w_2, stats_zt ) + call stat_update_var( ithl_1, pdf_params%thl_1, stats_zt ) + call stat_update_var( ithl_2, pdf_params%thl_2, stats_zt ) + call stat_update_var( ivarnce_thl_1, pdf_params%varnce_thl_1, stats_zt ) + call stat_update_var( ivarnce_thl_2, pdf_params%varnce_thl_2, stats_zt ) + call stat_update_var( irt_1, pdf_params%rt_1, stats_zt ) + call stat_update_var( irt_2, pdf_params%rt_2, stats_zt ) + call stat_update_var( ivarnce_rt_1, pdf_params%varnce_rt_1, stats_zt ) + call stat_update_var( ivarnce_rt_2, pdf_params%varnce_rt_2, stats_zt ) + call stat_update_var( irc_1, pdf_params%rc_1, stats_zt ) + call stat_update_var( irc_2, pdf_params%rc_2, stats_zt ) + call stat_update_var( irsatl_1, pdf_params%rsatl_1, stats_zt ) + call stat_update_var( irsatl_2, pdf_params%rsatl_2, stats_zt ) + call stat_update_var( icloud_frac_1, pdf_params%cloud_frac_1, stats_zt ) + call stat_update_var( icloud_frac_2, pdf_params%cloud_frac_2, stats_zt ) + call stat_update_var( ichi_1, pdf_params%chi_1, stats_zt ) + call stat_update_var( ichi_2, pdf_params%chi_2, stats_zt ) + call stat_update_var( istdev_chi_1, pdf_params%stdev_chi_1, stats_zt ) + call stat_update_var( istdev_chi_2, pdf_params%stdev_chi_2, stats_zt ) + call stat_update_var( istdev_eta_1, pdf_params%stdev_eta_1, stats_zt ) + call stat_update_var( istdev_eta_2, pdf_params%stdev_eta_2, stats_zt ) + call stat_update_var( icovar_chi_eta_1, pdf_params%covar_chi_eta_1, stats_zt ) + call stat_update_var( icovar_chi_eta_2, pdf_params%covar_chi_eta_2, stats_zt ) + call stat_update_var( icorr_chi_eta_1, pdf_params%corr_chi_eta_1, stats_zt ) + call stat_update_var( icorr_chi_eta_2, pdf_params%corr_chi_eta_2, stats_zt ) + call stat_update_var( irrtthl, pdf_params%rrtthl, stats_zt ) + call stat_update_var( icrt_1, pdf_params%crt_1, stats_zt ) + call stat_update_var( icrt_2, pdf_params%crt_2, stats_zt ) + call stat_update_var( icthl_1, pdf_params%cthl_1, stats_zt ) + call stat_update_var( icthl_2, pdf_params%cthl_2, stats_zt ) + call stat_update_var( iwp2_zt, wp2_zt, stats_zt ) + call stat_update_var( ithlp2_zt, thlp2_zt, stats_zt ) + call stat_update_var( ithlp3, thlp3, stats_zt ) + call stat_update_var( iwpthlp_zt, wpthlp_zt, stats_zt ) + call stat_update_var( iwprtp_zt, wprtp_zt, stats_zt ) + call stat_update_var( irtp2_zt, rtp2_zt, stats_zt ) + call stat_update_var( irtp3, rtp3, stats_zt ) + call stat_update_var( irtpthlp_zt, rtpthlp_zt, stats_zt ) + call stat_update_var( iup2_zt, up2_zt, stats_zt ) + call stat_update_var( ivp2_zt, vp2_zt, stats_zt ) + call stat_update_var( iupwp_zt, upwp_zt, stats_zt ) + call stat_update_var( ivpwp_zt, vpwp_zt, stats_zt ) + call stat_update_var( ia3_coef_zt, a3_coef_zt, stats_zt ) + call stat_update_var( iwp3_on_wp2_zt, wp3_on_wp2_zt, stats_zt ) + + if ( ichi > 0 ) then + ! Determine 's' from Mellor (1977) (extended liquid water) + chi(:) = pdf_params%mixt_frac * pdf_params%chi_1 & + + (1.0_core_rknd-pdf_params%mixt_frac) * pdf_params%chi_2 + call stat_update_var( ichi, chi, stats_zt ) + end if + + ! Calculate variance of chi + if ( ichip2 > 0 ) then + chip2 = compute_variance_binormal( chi, pdf_params%chi_1, pdf_params%chi_2, & + pdf_params%stdev_chi_1, pdf_params%stdev_chi_2, & + pdf_params%mixt_frac ) + call stat_update_var( ichip2, chip2, stats_zt ) + end if + + if ( sclr_dim > 0 ) then + do isclr=1, sclr_dim + call stat_update_var( isclrm(isclr), sclrm(:,isclr), stats_zt ) + call stat_update_var( isclrm_f(isclr), sclrm_forcing(:,isclr), stats_zt ) + end do + end if + + if ( edsclr_dim > 0 ) then + do isclr = 1, edsclr_dim + call stat_update_var( iedsclrm(isclr), edsclrm(:,isclr), stats_zt ) + call stat_update_var( iedsclrm_f(isclr), edsclrm_forcing(:,isclr), stats_zt ) + end do + end if + + ! Calculate rcm in cloud + if ( ircm_in_cloud > 0 ) then + where ( cloud_frac(:) > cloud_frac_min ) + rcm_in_cloud(:) = rcm / cloud_frac + else where + rcm_in_cloud(:) = rcm + end where + + call stat_update_var( ircm_in_cloud, rcm_in_cloud, stats_zt ) + end if + + ! stats_zm variables + + call stat_update_var( iwp2, wp2, stats_zm ) + call stat_update_var( iwp3_zm, wp3_zm, stats_zm ) + call stat_update_var( irtp2, rtp2, stats_zm ) + call stat_update_var( ithlp2, thlp2, stats_zm ) + call stat_update_var( irtpthlp, rtpthlp, stats_zm ) + call stat_update_var( iwprtp, wprtp, stats_zm ) + call stat_update_var( iwpthlp, wpthlp, stats_zm ) + call stat_update_var( iwp4, wp4, stats_zm ) + call stat_update_var( iwpthvp, wpthvp, stats_zm ) + call stat_update_var( irtpthvp, rtpthvp, stats_zm ) + call stat_update_var( ithlpthvp, thlpthvp, stats_zm ) + call stat_update_var( itau_zm, tau_zm, stats_zm ) + call stat_update_var( iKh_zm, Kh_zm, stats_zm ) + call stat_update_var( iwprcp, wprcp, stats_zm ) + call stat_update_var( irc_coef, rc_coef, stats_zm ) + call stat_update_var( ithlprcp, thlprcp, stats_zm ) + call stat_update_var( irtprcp, rtprcp, stats_zm ) + call stat_update_var( ircp2, rcp2, stats_zm ) + call stat_update_var( iupwp, upwp, stats_zm ) + call stat_update_var( ivpwp, vpwp, stats_zm ) + call stat_update_var( ivp2, vp2, stats_zm ) + call stat_update_var( iup2, up2, stats_zm ) + call stat_update_var( irho_zm, rho_zm, stats_zm ) + call stat_update_var( isigma_sqd_w, sigma_sqd_w, stats_zm ) + call stat_update_var( irho_ds_zm, rho_ds_zm, stats_zm ) + call stat_update_var( ithv_ds_zm, thv_ds_zm, stats_zm ) + call stat_update_var( iem, em, stats_zm ) + call stat_update_var( iFrad, Frad, stats_zm ) + + call stat_update_var( iSkw_velocity, Skw_velocity, stats_zm ) + call stat_update_var( ia3_coef, a3_coef, stats_zm ) + call stat_update_var( iwp3_on_wp2, wp3_on_wp2, stats_zm ) + + call stat_update_var( icloud_frac_zm, cloud_frac_zm, stats_zm ) + call stat_update_var( iice_supersat_frac_zm, ice_supersat_frac_zm, stats_zm ) + call stat_update_var( ircm_zm, rcm_zm, stats_zm ) + call stat_update_var( irtm_zm, rtm_zm, stats_zm ) + call stat_update_var( ithlm_zm, thlm_zm, stats_zm ) + + if ( sclr_dim > 0 ) then + do isclr=1, sclr_dim + call stat_update_var( isclrp2(isclr), sclrp2(:,isclr), stats_zm ) + call stat_update_var( isclrprtp(isclr), sclrprtp(:,isclr), stats_zm ) + call stat_update_var( isclrpthvp(isclr), sclrpthvp(:,isclr), stats_zm ) + call stat_update_var( isclrpthlp(isclr), sclrpthlp(:,isclr), stats_zm ) + call stat_update_var( isclrprcp(isclr), sclrprcp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrp(isclr), wpsclrp(:,isclr), stats_zm ) + call stat_update_var( iwp2sclrp(isclr), wp2sclrp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrp2(isclr), wpsclrp2(:,isclr), stats_zm ) + call stat_update_var( iwpsclrprtp(isclr), wpsclrprtp(:,isclr), stats_zm ) + call stat_update_var( iwpsclrpthlp(isclr), wpsclrpthlp(:,isclr), stats_zm ) + end do + end if + if ( edsclr_dim > 0 ) then + do isclr = 1, edsclr_dim + call stat_update_var( iwpedsclrp(isclr), wpedsclrp(:,isclr), stats_zm ) + end do + end if + + ! Calculate shear production + if ( ishear > 0 ) then + do k = 1, gr%nz-1, 1 + shear(k) = - upwp(k) * ( um(k+1) - um(k) ) * gr%invrs_dzm(k) & + - vpwp(k) * ( vm(k+1) - vm(k) ) * gr%invrs_dzm(k) + enddo + shear(gr%nz) = 0.0_core_rknd + end if + call stat_update_var( ishear, shear, stats_zm ) + + ! stats_sfc variables + + ! Cloud cover + call stat_update_var_pt( icc, 1, maxval( cloud_frac(1:gr%nz) ), stats_sfc ) + + ! Cloud base + if ( iz_cloud_base > 0 ) then + + k = 1 + do while ( rcm(k) < rc_tol .and. k < gr%nz ) + k = k + 1 + enddo + + if ( k > 1 .and. k < gr%nz) then + + ! Use linear interpolation to find the exact height of the + ! rc_tol kg/kg level. Brian. + call stat_update_var_pt( iz_cloud_base, 1, lin_interpolate_two_points( rc_tol, rcm(k), & + rcm(k-1), gr%zt(k), gr%zt(k-1) ), stats_sfc ) + + else + + ! Set the cloud base output to -10m, if it's clear. + ! Known magic number + call stat_update_var_pt( iz_cloud_base, 1, -10.0_core_rknd , stats_sfc ) + + end if ! k > 1 and k < gr%nz + + end if ! iz_cloud_base > 0 + + ! Liquid Water Path + if ( ilwp > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + rcm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( ilwp, 1, xtmp, stats_sfc ) + + end if + + ! Vapor Water Path (Preciptable Water) + if ( ivwp > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + ( rtm(2:gr%nz) - rcm(2:gr%nz) ), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( ivwp, 1, xtmp, stats_sfc ) + + end if + + + ! Vertical average of thermodynamic level variables. + + ! Find the vertical average of thermodynamic level variables, averaged from + ! level 2 (the first thermodynamic level above model surface) through + ! level gr%nz (the top of the model). Use the vertical averaging function + ! found in fill_holes.F90. + + ! Vertical average of thlm. + call stat_update_var_pt( ithlm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + thlm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of rtm. + call stat_update_var_pt( irtm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + rtm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of um. + call stat_update_var_pt( ium_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + um(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of vm. + call stat_update_var_pt( ivm_vert_avg, 1, & + vertical_avg( (gr%nz-2+1), rho_ds_zt(2:gr%nz), & + vm(2:gr%nz), gr%invrs_dzt(2:gr%nz) ), & + stats_sfc ) + + ! Vertical average of momentum level variables. + + ! Find the vertical average of momentum level variables, averaged over the + ! entire vertical profile (level 1 through level gr%nz). Use the vertical + ! averaging function found in fill_holes.F90. + + ! Vertical average of wp2. + call stat_update_var_pt( iwp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + wp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of up2. + call stat_update_var_pt( iup2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + up2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of vp2. + call stat_update_var_pt( ivp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + vp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of rtp2. + call stat_update_var_pt( irtp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + rtp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + ! Vertical average of thlp2. + call stat_update_var_pt( ithlp2_vert_avg, 1, & + vertical_avg( (gr%nz-1+1), rho_ds_zm(1:gr%nz), & + thlp2(1:gr%nz), gr%invrs_dzm(1:gr%nz) ), & + stats_sfc ) + + + end if ! l_stats_samp + + + return + end subroutine stats_accumulate +!------------------------------------------------------------------------------ + subroutine stats_accumulate_hydromet( hydromet, rho_ds_zt ) +! Description: +! Compute stats related the hydrometeors + +! References: +! None +!------------------------------------------------------------------------------ + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + use array_index, only: & + iirrm, iirsm, iirim, iirgm, & ! Variable(s) + iiNrm, iiNsm, iiNim, iiNgm + + use stats_variables, only: & + stats_sfc, & ! Variable(s) + irrm, & + irsm, & + irim, & + irgm, & + iNim, & + iNrm, & + iNsm, & + iNgm, & + iswp, & + irwp, & + iiwp + + use fill_holes, only: & + vertical_integral ! Procedure(s) + + use stats_type_utilities, only: & + stat_update_var, & ! Procedure(s) + stat_update_var_pt + + use stats_variables, only: & + stats_zt, & ! Variables + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + hydromet ! All hydrometeors except for rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + rho_ds_zt ! Dry, static density (thermo. levs.) [kg/m^3] + + ! Local Variables + real(kind=core_rknd) :: xtmp + + ! ---- Begin Code ---- + + if ( l_stats_samp ) then + + if ( iirrm > 0 ) then + call stat_update_var( irrm, hydromet(:,iirrm), stats_zt ) + end if + + if ( iirsm > 0 ) then + call stat_update_var( irsm, hydromet(:,iirsm), stats_zt ) + end if + + if ( iirim > 0 ) then + call stat_update_var( irim, hydromet(:,iirim), stats_zt ) + end if + + if ( iirgm > 0 ) then + call stat_update_var( irgm, & + hydromet(:,iirgm), stats_zt ) + end if + + if ( iiNim > 0 ) then + call stat_update_var( iNim, hydromet(:,iiNim), stats_zt ) + end if + + if ( iiNrm > 0 ) then + call stat_update_var( iNrm, hydromet(:,iiNrm), stats_zt ) + end if + + if ( iiNsm > 0 ) then + call stat_update_var( iNsm, hydromet(:,iiNsm), stats_zt ) + end if + + if ( iiNgm > 0 ) then + call stat_update_var( iNgm, hydromet(:,iiNgm), stats_zt ) + end if + + ! Snow Water Path + if ( iswp > 0 .and. iirsm > 0 ) then + + ! Calculate snow water path + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirsm), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( iswp, 1, xtmp, stats_sfc ) + + end if ! iswp > 0 .and. iirsm > 0 + + ! Ice Water Path + if ( iiwp > 0 .and. iirim > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirim), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( iiwp, 1, xtmp, stats_sfc ) + + end if + + ! Rain Water Path + if ( irwp > 0 .and. iirrm > 0 ) then + + xtmp & + = vertical_integral & + ( (gr%nz - 2 + 1), rho_ds_zt(2:gr%nz), & + hydromet(2:gr%nz,iirrm), gr%invrs_dzt(2:gr%nz) ) + + call stat_update_var_pt( irwp, 1, xtmp, stats_sfc ) + + end if ! irwp > 0 .and. irrm > 0 + end if ! l_stats_samp + + return + end subroutine stats_accumulate_hydromet +!------------------------------------------------------------------------------ + subroutine stats_accumulate_lh_tend( lh_hydromet_mc, lh_Ncm_mc, & + lh_thlm_mc, lh_rvm_mc, lh_rcm_mc ) +! Description: +! Compute stats for the tendency of latin hypercube sample points. + +! References: +! None +!------------------------------------------------------------------------------ + use parameters_model, only: & + hydromet_dim ! Variable(s) + + use grid_class, only: & + gr ! Variable(s) + + use array_index, only: & + iirrm, iirsm, iirim, iirgm, & ! Variable(s) + iiNrm, iiNsm, iiNim, iiNgm + + use stats_variables, only: & + ilh_rrm_mc, & ! Variable(s) + ilh_rsm_mc, & + ilh_rim_mc, & + ilh_rgm_mc, & + ilh_Ncm_mc, & + ilh_Nim_mc, & + ilh_Nrm_mc, & + ilh_Nsm_mc, & + ilh_Ngm_mc, & + ilh_rcm_mc, & + ilh_rvm_mc, & + ilh_thlm_mc + + use stats_variables, only: & + iAKstd, & ! Variable(s) + iAKstd_cld, & + iAKm_rcm, & + iAKm_rcc, & + iAKm, & + ilh_AKm, & + ilh_rcm_avg + + use variables_diagnostic_module, only: & + AKm, & ! Variable(s) + lh_AKm, & + AKstd, & + lh_rcm_avg, & + AKstd_cld, & + AKm_rcm, & + AKm_rcc + + use stats_type_utilities, only: & + stat_update_var ! Procedure(s) + + use stats_variables, only: & + stats_lh_zt, & ! Variables + l_stats_samp + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + real( kind = core_rknd ), dimension(gr%nz,hydromet_dim), intent(in) :: & + lh_hydromet_mc ! Tendency of hydrometeors except for rvm/rcm [units vary] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + lh_Ncm_mc, & ! Tendency of cloud droplet concentration [num/kg/s] + lh_thlm_mc, & ! Tendency of liquid potential temperature [kg/kg/s] + lh_rcm_mc, & ! Tendency of cloud water [kg/kg/s] + lh_rvm_mc ! Tendency of vapor [kg/kg/s] + + if ( l_stats_samp ) then + + call stat_update_var( ilh_thlm_mc, lh_thlm_mc, stats_lh_zt ) + call stat_update_var( ilh_rcm_mc, lh_rcm_mc, stats_lh_zt ) + call stat_update_var( ilh_rvm_mc, lh_rvm_mc, stats_lh_zt ) + + call stat_update_var( ilh_Ncm_mc, lh_Ncm_mc, stats_lh_zt ) + + if ( iirrm > 0 ) then + call stat_update_var( ilh_rrm_mc, lh_hydromet_mc(:,iirrm), stats_lh_zt ) + end if + + if ( iirsm > 0 ) then + call stat_update_var( ilh_rsm_mc, lh_hydromet_mc(:,iirsm), stats_lh_zt ) + end if + + if ( iirim > 0 ) then + call stat_update_var( ilh_rim_mc, lh_hydromet_mc(:,iirim), stats_lh_zt ) + end if + + if ( iirgm > 0 ) then + call stat_update_var( ilh_rgm_mc, lh_hydromet_mc(:,iirgm), stats_lh_zt ) + end if + + if ( iiNim > 0 ) then + call stat_update_var( ilh_Nim_mc, lh_hydromet_mc(:,iiNim), stats_lh_zt ) + end if + + if ( iiNrm > 0 ) then + call stat_update_var( ilh_Nrm_mc, lh_hydromet_mc(:,iiNrm), stats_lh_zt ) + end if + + if ( iiNsm > 0 ) then + call stat_update_var( ilh_Nsm_mc, lh_hydromet_mc(:,iiNsm), stats_lh_zt ) + end if + + if ( iiNgm > 0 ) then + call stat_update_var( ilh_Ngm_mc, lh_hydromet_mc(:,iiNgm), stats_lh_zt ) + end if + + call stat_update_var( iAKm, AKm, stats_lh_zt ) + call stat_update_var( ilh_AKm, lh_AKm, stats_lh_zt) + call stat_update_var( ilh_rcm_avg, lh_rcm_avg, stats_lh_zt ) + call stat_update_var( iAKstd, AKstd, stats_lh_zt ) + call stat_update_var( iAKstd_cld, AKstd_cld, stats_lh_zt ) + + call stat_update_var( iAKm_rcm, AKm_rcm, stats_lh_zt) + call stat_update_var( iAKm_rcc, AKm_rcc, stats_lh_zt ) + + end if ! l_stats_samp + + return + end subroutine stats_accumulate_lh_tend + + !----------------------------------------------------------------------- + subroutine stats_finalize( ) + + ! Description: + ! Close NetCDF files and deallocate scratch space and + ! stats file structures. + !----------------------------------------------------------------------- + + use stats_variables, only: & + stats_zt, & ! Variable(s) + stats_lh_zt, & + stats_lh_sfc, & + stats_zm, & + stats_rad_zt, & + stats_rad_zm, & + stats_sfc, & + l_netcdf, & + l_stats, & + l_output_rad_files, & + l_silhs_out + + use stats_variables, only: & + ztscr01, & ! Variable(s) + ztscr02, & + ztscr03, & + ztscr04, & + ztscr05, & + ztscr06, & + ztscr07, & + ztscr08, & + ztscr09, & + ztscr10, & + ztscr11, & + ztscr12, & + ztscr13, & + ztscr14, & + ztscr15, & + ztscr16, & + ztscr17, & + ztscr18, & + ztscr19, & + ztscr20, & + ztscr21 + + use stats_variables, only: & + zmscr01, & ! Variable(s) + zmscr02, & + zmscr03, & + zmscr04, & + zmscr05, & + zmscr06, & + zmscr07, & + zmscr08, & + zmscr09, & + zmscr10, & + zmscr11, & + zmscr12, & + zmscr13, & + zmscr14, & + zmscr15, & + zmscr16, & + zmscr17 + + use stats_variables, only: & + isclrm, & + isclrm_f, & + iedsclrm, & + iedsclrm_f, & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + ihm_1, & + ihm_2, & + imu_hm_1, & + imu_hm_2, & + imu_hm_1_n, & + imu_hm_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + icorr_w_hm_1_n, & + icorr_w_hm_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n, & + ihmp2_zt, & + iwp2hmp, & + ihydrometp2, & + iwphydrometp, & + iK_hm, & + irtphmp, & + ithlphmp, & + ihmxphmyp + + use stats_variables, only: & + isilhs_variance_category, & ! Variable(s) + ilh_samp_frac_category + +#ifdef NETCDF + use output_netcdf, only: & + close_netcdf ! Procedure +#endif + + implicit none + + if ( l_stats .and. l_netcdf ) then +#ifdef NETCDF + call close_netcdf( stats_zt%file ) + call close_netcdf( stats_lh_zt%file ) + call close_netcdf( stats_lh_sfc%file ) + call close_netcdf( stats_zm%file ) + call close_netcdf( stats_rad_zt%file ) + call close_netcdf( stats_rad_zm%file ) + call close_netcdf( stats_sfc%file ) +#else + stop "This program was not compiled with netCDF support" +#endif + end if + + if ( l_stats ) then + ! De-allocate all stats_zt variables + if (allocated(stats_zt%z)) then + deallocate( stats_zt%z ) + + deallocate( stats_zt%accum_field_values ) + + deallocate( stats_zt%accum_num_samples ) + deallocate( stats_zt%l_in_update ) + + + deallocate( stats_zt%file%var ) + deallocate( stats_zt%file%z ) + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated( stats_zt%file%rlat ) ) then + deallocate( stats_zt%file%rlat ) + end if + if ( allocated( stats_zt%file%rlon ) ) then + deallocate( stats_zt%file%rlon ) + end if + + deallocate ( ztscr01 ) + deallocate ( ztscr02 ) + deallocate ( ztscr03 ) + deallocate ( ztscr04 ) + deallocate ( ztscr05 ) + deallocate ( ztscr06 ) + deallocate ( ztscr07 ) + deallocate ( ztscr08 ) + deallocate ( ztscr09 ) + deallocate ( ztscr10 ) + deallocate ( ztscr11 ) + deallocate ( ztscr12 ) + deallocate ( ztscr13 ) + deallocate ( ztscr14 ) + deallocate ( ztscr15 ) + deallocate ( ztscr16 ) + deallocate ( ztscr17 ) + deallocate ( ztscr18 ) + deallocate ( ztscr19 ) + deallocate ( ztscr20 ) + deallocate ( ztscr21 ) + end if + + if ( l_silhs_out .and. allocated(stats_lh_zt%z) ) then + ! De-allocate all stats_lh_zt variables + deallocate( stats_lh_zt%z ) + + deallocate( stats_lh_zt%accum_field_values ) + + deallocate( stats_lh_zt%accum_num_samples ) + deallocate( stats_lh_zt%l_in_update ) + + + deallocate( stats_lh_zt%file%var ) + deallocate( stats_lh_zt%file%z ) + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated(stats_lh_zt%file%rlat ) ) then + deallocate( stats_lh_zt%file%rlat ) + end if + if ( allocated(stats_lh_zt%file%rlon ) ) then + deallocate( stats_lh_zt%file%rlon ) + end if + + ! De-allocate all stats_lh_sfc variables + deallocate( stats_lh_sfc%z ) + + deallocate( stats_lh_sfc%accum_field_values ) + + deallocate( stats_lh_sfc%accum_num_samples ) + deallocate( stats_lh_sfc%l_in_update ) + + + deallocate( stats_lh_sfc%file%var ) + deallocate( stats_lh_sfc%file%z ) + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated( stats_lh_sfc%file%rlat ) ) then + deallocate( stats_lh_sfc%file%rlat ) + end if + if ( allocated( stats_lh_sfc%file%rlon ) ) then + deallocate( stats_lh_sfc%file%rlon ) + end if + end if ! l_silhs_out + + ! De-allocate all stats_zm variables + if (allocated(stats_zm%z)) then + deallocate( stats_zm%z ) + + deallocate( stats_zm%accum_field_values ) + deallocate( stats_zm%accum_num_samples ) + + deallocate( stats_zm%file%var ) + deallocate( stats_zm%file%z ) + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated( stats_zm%file%rlat ) ) then + deallocate( stats_zm%file%rlat ) + end if + if ( allocated( stats_zm%file%rlon ) ) then + deallocate( stats_zm%file%rlon ) + end if + deallocate( stats_zm%l_in_update ) + + deallocate ( zmscr01 ) + deallocate ( zmscr02 ) + deallocate ( zmscr03 ) + deallocate ( zmscr04 ) + deallocate ( zmscr05 ) + deallocate ( zmscr06 ) + deallocate ( zmscr07 ) + deallocate ( zmscr08 ) + deallocate ( zmscr09 ) + deallocate ( zmscr10 ) + deallocate ( zmscr11 ) + deallocate ( zmscr12 ) + deallocate ( zmscr13 ) + deallocate ( zmscr14 ) + deallocate ( zmscr15 ) + deallocate ( zmscr16 ) + deallocate ( zmscr17 ) + end if + + if ( l_output_rad_files ) then + ! De-allocate all stats_rad_zt variables + if (allocated(stats_rad_zt%z)) then + deallocate( stats_rad_zt%z ) + + deallocate( stats_rad_zt%accum_field_values ) + deallocate( stats_rad_zt%accum_num_samples ) + + deallocate( stats_rad_zt%file%var ) + deallocate( stats_rad_zt%file%z ) + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated( stats_rad_zt%file%rlat ) ) then + deallocate( stats_rad_zt%file%rlat ) + end if + if ( allocated( stats_rad_zt%file%rlon ) ) then + deallocate( stats_rad_zt%file%rlon ) + end if + deallocate( stats_rad_zt%l_in_update ) + + ! De-allocate all stats_rad_zm variables + deallocate( stats_rad_zm%z ) + + deallocate( stats_rad_zm%accum_field_values ) + deallocate( stats_rad_zm%accum_num_samples ) + + deallocate( stats_rad_zm%file%var ) + deallocate( stats_rad_zm%file%z ) + deallocate( stats_rad_zm%l_in_update ) + end if + + end if ! l_output_rad_files + + ! De-allocate all stats_sfc variables + if (allocated(stats_sfc%z)) then + deallocate( stats_sfc%z ) + + deallocate( stats_sfc%accum_field_values ) + deallocate( stats_sfc %accum_num_samples ) + deallocate( stats_sfc%l_in_update ) + + deallocate( stats_sfc%file%var ) + deallocate( stats_sfc%file%z ) + end if + + ! Check if pointer is allocated to prevent crash in netcdf (ticket 765) + if ( allocated( stats_sfc%file%rlat ) ) then + deallocate( stats_sfc%file%rlat ) + end if + if ( allocated( stats_sfc%file%rlon ) ) then + deallocate( stats_sfc%file%rlon ) + end if + + ! De-allocate scalar indices + if (allocated(isclrm)) then + deallocate( isclrm ) + deallocate( isclrm_f ) + deallocate( iedsclrm ) + deallocate( iedsclrm_f ) + deallocate( isclrprtp ) + deallocate( isclrp2 ) + deallocate( isclrpthvp ) + deallocate( isclrpthlp ) + deallocate( isclrprcp ) + deallocate( iwpsclrp ) + deallocate( iwp2sclrp ) + deallocate( iwpsclrp2 ) + deallocate( iwpsclrprtp ) + deallocate( iwpsclrpthlp ) + deallocate( iwpedsclrp ) + end if + + ! De-allocate hyderometeor statistical variables + if (allocated(ihm_1)) then + deallocate( ihm_1 ) + deallocate( ihm_2 ) + deallocate( imu_hm_1 ) + deallocate( imu_hm_2 ) + deallocate( imu_hm_1_n ) + deallocate( imu_hm_2_n ) + deallocate( isigma_hm_1 ) + deallocate( isigma_hm_2 ) + deallocate( isigma_hm_1_n ) + deallocate( isigma_hm_2_n ) + deallocate( icorr_w_hm_1 ) + deallocate( icorr_w_hm_2 ) + deallocate( icorr_chi_hm_1 ) + deallocate( icorr_chi_hm_2 ) + deallocate( icorr_eta_hm_1 ) + deallocate( icorr_eta_hm_2 ) + deallocate( icorr_Ncn_hm_1 ) + deallocate( icorr_Ncn_hm_2 ) + deallocate( icorr_hmx_hmy_1 ) + deallocate( icorr_hmx_hmy_2 ) + deallocate( icorr_w_hm_1_n ) + deallocate( icorr_w_hm_2_n ) + deallocate( icorr_chi_hm_1_n ) + deallocate( icorr_chi_hm_2_n ) + deallocate( icorr_eta_hm_1_n ) + deallocate( icorr_eta_hm_2_n ) + deallocate( icorr_Ncn_hm_1_n ) + deallocate( icorr_Ncn_hm_2_n ) + deallocate( icorr_hmx_hmy_1_n ) + deallocate( icorr_hmx_hmy_2_n ) + deallocate( ihmp2_zt ) + deallocate( iwp2hmp ) + deallocate( ihydrometp2 ) + deallocate( iwphydrometp ) + deallocate( irtphmp ) + deallocate( ithlphmp ) + deallocate( ihmxphmyp ) + deallocate( iK_hm ) + end if + + if ( allocated( isilhs_variance_category ) ) then + deallocate( isilhs_variance_category ) + deallocate( ilh_samp_frac_category ) + end if + + end if ! l_stats + + return + end subroutine stats_finalize + +!=============================================================================== + +!----------------------------------------------------------------------- +subroutine stats_check_num_samples( stats_grid, l_error ) + +! Description: +! Ensures that each variable in a stats grid is sampled the correct +! number of times. +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant + + use stats_type, only: & + stats ! Type + + use stats_variables, only: & + stats_tsamp, & ! Variable(s) + stats_tout + + use error_code, only: & + clubb_at_least_debug_level ! Procedure + + implicit none + + ! Input Variables + type (stats), intent(in) :: & + stats_grid ! Grid type [grid] + + ! Input/Output Variables + logical, intent(inout) :: & + l_error ! Indicates an error [boolean] + + ! Local Variables + integer :: ivar, kvar ! Loop variable [index] + + logical :: l_proper_sample + +!----------------------------------------------------------------------- + + !----- Begin Code ----- + + ! Look for errors by checking the number of sampling points + ! for each variable in the statistics grid at each vertical level. + do ivar = 1, stats_grid%num_output_fields + do kvar = 1, stats_grid%kk + + l_proper_sample = ( stats_grid %accum_num_samples(1,1,kvar,ivar) == 0 .or. & + stats_grid %accum_num_samples(1,1,kvar,ivar) == & + floor(stats_tout/stats_tsamp) ) + + if ( .not. l_proper_sample ) 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_grid%file%var(ivar)%name), ' in stats_grid ', & + 'at k = ', kvar, & + '; stats_grid %accum_num_samples(',kvar,',',ivar,') = ', & + stats_grid %accum_num_samples(1,1,kvar,ivar) + end if ! clubb_at_lest_debug_level 1 + + + end if ! .not. l_proper_sample + + end do ! kvar = 1 .. stats_grid%kk + end do ! ivar = 1 .. stats_grid%num_output_fields + + return +end subroutine stats_check_num_samples +!----------------------------------------------------------------------- + +end module stats_clubb_utilities diff --git a/src/physics/clubb/stats_lh_sfc_module.F90 b/src/physics/clubb/stats_lh_sfc_module.F90 new file mode 100644 index 0000000000..c503821a3b --- /dev/null +++ b/src/physics/clubb/stats_lh_sfc_module.F90 @@ -0,0 +1,111 @@ +!----------------------------------------------------------------------- +! $Id: stats_lh_sfc_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_lh_sfc_module + + + implicit none + + private ! Set Default Scope + + public :: stats_init_lh_sfc + + ! Constant parameters + integer, parameter, public :: nvarmax_lh_sfc = 10 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_lh_sfc( vars_lh_sfc, l_error ) + +! Description: +! Initializes array indices for stats_lh_sfc +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_lh_sfc ! Variable(s) + + use stats_variables, only: & + ilh_morr_snow_rate, & ! Variable(s) + ilh_vwp, & + ilh_lwp, & + ik_lh_start + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_lh_sfc), intent(in) :: vars_lh_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_sfc is zero (see module + ! stats_variables) + + ! Assign pointers for statistics variables stats_sfc + + k = 1 + do i = 1, stats_lh_sfc%num_output_fields + + select case ( trim( vars_lh_sfc(i) ) ) + + case ( 'lh_morr_snow_rate' ) + ilh_morr_snow_rate = k + call stat_assign( var_index=ilh_morr_snow_rate, var_name="lh_morr_snow_rate", & + var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & + var_units="mm/day", l_silhs=.true., grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'lh_vwp' ) + ilh_vwp = k + call stat_assign( var_index=ilh_vwp, var_name="lh_vwp", & + var_description="Vapor water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'lh_lwp' ) + ilh_lwp = k + call stat_assign( var_index=ilh_lwp, var_name="lh_lwp", & + var_description="Liquid water path [kg/m^2]", var_units="kg/m^2", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case ( 'k_lh_start' ) + ik_lh_start = k + call stat_assign( var_index=ik_lh_start, var_name="k_lh_start", & + var_description="Index of height level for SILHS sampling preferentially within & + &cloud [integer]", var_units="integer", l_silhs=.true., & + grid_kind=stats_lh_sfc ) + k = k + 1 + + case default + write(fstderr,*) 'Error: unrecognized variable in vars_lh_sfc: ', & + trim( vars_lh_sfc(i) ) + l_error = .true. ! This will stop the run. + + end select + + end do ! i = 1, stats_lh_sfc%num_output_fields + + return + end subroutine stats_init_lh_sfc + +end module stats_lh_sfc_module + diff --git a/src/physics/clubb/stats_lh_zt_module.F90 b/src/physics/clubb/stats_lh_zt_module.F90 new file mode 100644 index 0000000000..505423ee8d --- /dev/null +++ b/src/physics/clubb/stats_lh_zt_module.F90 @@ -0,0 +1,700 @@ +!----------------------------------------------------------------------- +! $Id: stats_lh_zt_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_lh_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_lh_zt + +! Constant parameters + integer, parameter, public :: nvarmax_lh_zt = 100 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_lh_zt( vars_lh_zt, l_error ) + +! Description: +! Initializes array indices for stats_zt + +! Note: +! All code that is within subroutine stats_init_zt, including variable +! allocation code, is not called if l_stats is false. This subroutine is +! called only when l_stats is true. + +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_lh_zt ! Variable + + use stats_variables, only: & + iAKm, & ! Variable(s) + ilh_AKm, & + iAKstd, & + iAKstd_cld, & + iAKm_rcm, & + iAKm_rcc + + use stats_variables, only: & + ilh_thlm_mc, & ! Variable(s) + ilh_rvm_mc, & + ilh_rcm_mc, & + ilh_Ncm_mc, & + ilh_rrm_mc, & + ilh_Nrm_mc, & + ilh_rsm_mc, & + ilh_Nsm_mc, & + ilh_rgm_mc, & + ilh_Ngm_mc, & + ilh_rim_mc, & + ilh_Nim_mc, & + ilh_Vrr, & + ilh_VNr, & + ilh_rcm_avg + + use stats_variables, only: & + ilh_rrm, & ! Variable(s) + ilh_Nrm, & + ilh_rim, & + ilh_Nim, & + ilh_rsm, & + ilh_Nsm, & + ilh_rgm, & + ilh_Ngm, & + ilh_thlm, & + ilh_rcm, & + ilh_Ncm, & + ilh_Ncnm, & + ilh_rvm, & + ilh_wm, & + ilh_wp2_zt, & + ilh_rcp2_zt, & + ilh_rtp2_zt, & + ilh_thlp2_zt, & + ilh_rrp2_zt, & + ilh_Nrp2_zt, & + ilh_Ncp2_zt, & + ilh_Ncnp2_zt, & + ilh_cloud_frac, & + ilh_chi, & + ilh_eta, & + ilh_chip2, & + ilh_rrm_auto, & + ilh_rrm_accr, & + ilh_rrm_evap, & + ilh_Nrm_auto, & + ilh_Nrm_cond + + use stats_variables, only: & + ilh_cloud_frac_unweighted, & + ilh_precip_frac_unweighted,& + ilh_mixt_frac_unweighted + + use stats_variables, only: & + ilh_rrm_src_adj, & ! Variable(s) + ilh_rrm_cond_adj, & + ilh_Nrm_src_adj, & + ilh_Nrm_cond_adj, & + ilh_rrm_mc_nonadj + + use stats_variables, only: & + ilh_precip_frac, & + ilh_mixt_frac, & + ilh_m_vol_rad_rain + + use stats_variables, only: & + isilhs_variance_category, & ! Variable + ilh_samp_frac_category + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Local Constants + integer, parameter :: & + silhs_num_importance_categories = 8 + + ! Input Variable + character(len= * ), dimension(nvarmax_lh_zt), intent(in) :: vars_lh_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k, tot_loops, icategory + + character( len = 1 ) :: category_num_as_string + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_lh_zt is zero (see module + ! stats_variables) + + allocate( isilhs_variance_category(silhs_num_importance_categories), & + ilh_samp_frac_category(silhs_num_importance_categories) ) + isilhs_variance_category(:) = 0 + ilh_samp_frac_category(:) = 0 + + ! Assign pointers for statistics variables stats_zt + + tot_loops = stats_lh_zt%num_output_fields + + if ( any( vars_lh_zt == "silhs_variance_category" ) ) then + ! Correct for number of variables found under "silhs_variance_category". + ! Subtract 1 from the loop size for each SILHS importance category. + tot_loops = tot_loops - silhs_num_importance_categories + ! Add 1 for "silhs_variance_category" to the loop size. + tot_loops = tot_loops + 1 + end if + + if ( any( vars_lh_zt == "lh_samp_frac_category" ) ) then + ! Correct for number of variables found under "lh_samp_frac_category". + ! Subtract 1 from the loop size for each SILHS importance category. + tot_loops = tot_loops - silhs_num_importance_categories + ! Add 1 for "lh_samp_frac_category" to the loop size. + tot_loops = tot_loops + 1 + end if + + k = 1 + do i = 1, tot_loops + + select case ( trim( vars_lh_zt(i) ) ) + case ( 'AKm' ) ! Vince Larson 22 May 2005 + iAKm = k + call stat_assign( var_index=iAKm, var_name="AKm", & + var_description="Analytic Kessler ac [kg/kg]", var_units="kg/kg", l_silhs=.true., & + grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_AKm' ) ! Vince Larson 22 May 2005 + ilh_AKm = k + + call stat_assign( var_index=ilh_AKm, var_name="lh_AKm", & + var_description="LH Kessler estimate [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKstd' ) + iAKstd = k + + call stat_assign( var_index=iAKstd, var_name="AKstd", & + var_description="Exact standard deviation of gba Kessler [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKstd_cld' ) + iAKstd_cld = k + + call stat_assign( var_index=iAKstd_cld, var_name="AKstd_cld", & + var_description="Exact w/in cloud std of gba Kessler [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKm_rcm' ) + iAKm_rcm = k + + call stat_assign( var_index=iAKm_rcm, var_name="AKm_rcm", & + var_description="Exact local gba auto based on rcm [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'AKm_rcc' ) + iAKm_rcc = k + + call stat_assign( var_index=iAKm_rcc, var_name="AKm_rcc", & + var_description="Exact local gba based on w/in cloud rc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rvm_mc' ) + ilh_rvm_mc = k + + call stat_assign( var_index=ilh_rvm_mc, var_name="lh_rvm_mc", & + var_description="Latin hypercube estimate of rvm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlm_mc' ) + ilh_thlm_mc = k + + call stat_assign( var_index=ilh_thlm_mc, var_name="lh_thlm_mc", & + var_description="Latin hypercube estimate of thlm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm_mc' ) + ilh_rcm_mc = k + + call stat_assign( var_index=ilh_rcm_mc, var_name="lh_rcm_mc", & + var_description="Latin hypercube estimate of rcm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncm_mc' ) + ilh_Ncm_mc = k + + call stat_assign( var_index=ilh_Ncm_mc, var_name="lh_Ncm_mc", & + var_description="Latin hypercube estimate of Ncm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_mc' ) + ilh_rrm_mc = k + + call stat_assign( var_index=ilh_rrm_mc, var_name="lh_rrm_mc", & + var_description="Latin hypercube estimate of rrm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_mc' ) + ilh_Nrm_mc = k + + call stat_assign( var_index=ilh_Nrm_mc, var_name="lh_Nrm_mc", & + var_description="Latin hypercube estimate of Nrm_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case('lh_rsm_mc') + ilh_rsm_mc = k + + call stat_assign( var_index=ilh_rsm_mc, var_name="lh_rsm_mc", & + var_description="Latin hypercube estimate of rsm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nsm_mc' ) + ilh_Nsm_mc = k + + call stat_assign( var_index=ilh_Nsm_mc, var_name="lh_Nsm_mc", & + var_description="Latin hypercube estimate of Nsm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rgm_mc' ) + ilh_rgm_mc = k + + call stat_assign( var_index=ilh_rgm_mc, var_name="lh_rgm_mc", & + var_description="Latin hypercube estimate of rgm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ngm_mc' ) + ilh_Ngm_mc = k + + call stat_assign( var_index=ilh_Ngm_mc, var_name="lh_Ngm_mc", & + var_description="Latin hypercube estimate of Ngm_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rim_mc' ) + ilh_rim_mc = k + + call stat_assign( var_index=ilh_rim_mc, var_name="lh_rim_mc", & + var_description="Latin hypercube estimate of rim_mc [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nim_mc' ) + ilh_Nim_mc = k + + call stat_assign( var_index=ilh_Nim_mc, var_name="lh_Nim_mc", & + var_description="Latin hypercube estimate of Nim_mc [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Vrr' ) + ilh_Vrr = k + + call stat_assign( var_index=ilh_Vrr, var_name="lh_Vrr", & + var_description="Latin hypercube estimate of rrm sedimentation velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_VNr' ) + ilh_VNr = k + + call stat_assign( var_index=ilh_VNr, var_name="lh_VNr", & + var_description="Latin hypercube estimate of Nrm sedimentation velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm_avg' ) + ilh_rcm_avg = k + + call stat_assign( var_index=ilh_rcm_avg, var_name="lh_rcm_avg", & + var_description="Latin hypercube average estimate of rcm [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + + k = k + 1 + + case ( 'lh_rrm' ) + ilh_rrm = k + + call stat_assign( var_index=ilh_rrm, var_name="lh_rrm", & + var_description="Latin hypercube estimate of rrm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm' ) + ilh_Nrm = k + + call stat_assign( var_index=ilh_Nrm, var_name="lh_Nrm", & + var_description="Latin hypercube estimate of Nrm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rim' ) + ilh_rim = k + + call stat_assign( var_index=ilh_rim, var_name="lh_rim", & + var_description="Latin hypercube estimate of rim [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nim' ) + ilh_Nim = k + + call stat_assign( var_index=ilh_Nim, var_name="lh_Nim", & + var_description="Latin hypercube estimate of Nim [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rsm' ) + ilh_rsm = k + + call stat_assign( var_index=ilh_rsm, var_name="lh_rsm", & + var_description="Latin hypercube estimate of rsm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nsm' ) + ilh_Nsm = k + + call stat_assign( var_index=ilh_Nsm, var_name="lh_Nsm", & + var_description="Latin hypercube estimate of Nsm [count/kg]", & + var_units="count/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + + case ( 'lh_rgm' ) + ilh_rgm = k + + call stat_assign( var_index=ilh_rgm, var_name="lh_rgm", & + var_description="Latin hypercube estimate of rgm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ngm' ) + ilh_Ngm = k + + call stat_assign( var_index=ilh_Ngm, var_name="lh_Ngm", & + var_description="Latin hypercube estimate of Ngm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlm' ) + ilh_thlm = k + + call stat_assign( var_index=ilh_thlm, var_name="lh_thlm", & + var_description="Latin hypercube estimate of thlm [K]", var_units="K", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcm' ) + ilh_rcm = k + + call stat_assign( var_index=ilh_rcm, var_name="lh_rcm", & + var_description="Latin hypercube estimate of rcm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncm' ) + ilh_Ncm = k + + call stat_assign( var_index=ilh_Ncm, var_name="lh_Ncm", & + var_description="Latin hypercube estimate of Ncm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncnm' ) + ilh_Ncnm = k + + call stat_assign( var_index=ilh_Ncnm, var_name="lh_Ncnm", & + var_description="Latin hypercube estimate of Ncnm [count/kg]", var_units="count/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + + case ( 'lh_rvm' ) + ilh_rvm = k + + call stat_assign( var_index=ilh_rvm, var_name="lh_rvm", & + var_description="Latin hypercube estimate of rvm [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_wm' ) + ilh_wm = k + + call stat_assign( var_index=ilh_wm, var_name="lh_wm", & + var_description="Latin hypercube estimate of vertical velocity [m/s]", & + var_units="m/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_cloud_frac' ) + ilh_cloud_frac = k + + ! Note: count is the udunits compatible unit + call stat_assign( var_index=ilh_cloud_frac, var_name="lh_cloud_frac", & + var_description="Latin hypercube estimate of cloud fraction [count]", & + var_units="count", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_cloud_frac_unweighted' ) + ilh_cloud_frac_unweighted = k + + call stat_assign( var_index=ilh_cloud_frac_unweighted, & + var_name="lh_cloud_frac_unweighted", var_description="Unweighted fraction of & + &silhs sample points that are in cloud [-]", var_units="-", l_silhs=.false., & + grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_chi' ) + ilh_chi = k + call stat_assign( var_index=ilh_chi, var_name="lh_chi", & + var_description="Latin hypercube estimate of Mellor's s (extended liq) [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_eta' ) + ilh_eta = k + call stat_assign( var_index=ilh_eta, var_name="lh_eta", & + var_description="Latin hypercube estimate of Mellor's t [kg/kg]", var_units="kg/kg", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_chip2' ) + ilh_chip2 = k + call stat_assign( var_index=ilh_chip2, var_name="lh_chip2", & + var_description="Latin hypercube estimate of variance of chi(s) [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_wp2_zt' ) + ilh_wp2_zt = k + call stat_assign( var_index=ilh_wp2_zt, var_name="lh_wp2_zt", & + var_description="Variance of the latin hypercube estimate of w [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncnp2_zt' ) + ilh_Ncnp2_zt = k + call stat_assign( var_index=ilh_Ncnp2_zt, var_name="lh_Ncnp2_zt", & + var_description="Variance of the latin hypercube estimate of Ncn [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Ncp2_zt' ) + ilh_Ncp2_zt = k + call stat_assign( var_index=ilh_Ncp2_zt, var_name="lh_Ncp2_zt", & + var_description="Variance of the latin hypercube estimate of Nc [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrp2_zt' ) + ilh_Nrp2_zt = k + call stat_assign( var_index=ilh_Nrp2_zt, var_name="lh_Nrp2_zt", & + var_description="Variance of the latin hypercube estimate of Nr [count^2/kg^2]", & + var_units="count^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rcp2_zt' ) + ilh_rcp2_zt = k + call stat_assign( var_index=ilh_rcp2_zt, var_name="lh_rcp2_zt", & + var_description="Variance of the latin hypercube estimate of rc [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rtp2_zt' ) + ilh_rtp2_zt = k + call stat_assign( var_index=ilh_rtp2_zt, var_name="lh_rtp2_zt", & + var_description="Variance of the latin hypercube estimate of rt [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_thlp2_zt' ) + ilh_thlp2_zt = k + call stat_assign( var_index=ilh_thlp2_zt, var_name="lh_thlp2_zt", & + var_description="Variance of the latin hypercube estimate of thl [K^2]", & + var_units="K^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrp2_zt' ) + ilh_rrp2_zt = k + call stat_assign( var_index=ilh_rrp2_zt, var_name="lh_rrp2_zt", & + var_description="Variance of the latin hypercube estimate of rr [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_auto' ) + ilh_rrm_auto = k + call stat_assign( var_index=ilh_rrm_auto, var_name="lh_rrm_auto", & + var_description="Latin hypercube estimate of autoconversion [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_accr' ) + ilh_rrm_accr = k + call stat_assign( var_index=ilh_rrm_accr, var_name="lh_rrm_accr", & + var_description="Latin hypercube estimate of accretion [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_evap' ) + ilh_rrm_evap = k + call stat_assign( var_index=ilh_rrm_evap, var_name="lh_rrm_evap", & + var_description="Latin hypercube estimate of evaporation [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_auto' ) + ilh_Nrm_auto = k + call stat_assign( var_index=ilh_Nrm_auto, var_name="lh_Nrm_auto", & + var_description="Latin hypercube estimate of Nrm autoconversion [num/kg/s]", & + var_units="num/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_cond' ) + ilh_Nrm_cond = k + call stat_assign( var_index=ilh_Nrm_cond, var_name="lh_Nrm_cond", & + var_description="Latin hypercube estimate of Nrm evaporation [num/kg/s]", & + var_units="num/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_src_adj' ) + ilh_rrm_src_adj = k + call stat_assign( var_index=ilh_rrm_src_adj, var_name="lh_rrm_src_adj", & + var_description="Latin hypercube estimate of source adjustment (KK only!) [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_cond_adj' ) + ilh_rrm_cond_adj = k + call stat_assign( var_index=ilh_rrm_cond_adj, var_name="lh_rrm_cond_adj", & + var_description="Latin hypercube estimate of evap adjustment (KK only!) [kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_src_adj' ) + ilh_Nrm_src_adj = k + call stat_assign( var_index=ilh_Nrm_src_adj, var_name="lh_Nrm_src_adj", & + var_description="Latin hypercube estimate of Nrm source adjustment (KK only!) & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_Nrm_cond_adj' ) + ilh_Nrm_cond_adj = k + call stat_assign( var_index=ilh_Nrm_cond_adj, var_name="lh_Nrm_cond_adj", & + var_description="Latin hypercube estimate of Nrm evap adjustment (KK only!) & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_precip_frac' ) + ilh_precip_frac = k + call stat_assign( var_index=ilh_precip_frac, var_name="lh_precip_frac", & + var_description="Latin hypercube estimate of precipitation fraction [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_precip_frac_unweighted' ) + ilh_precip_frac_unweighted = k + call stat_assign( var_index=ilh_precip_frac_unweighted, & + var_name="lh_precip_frac_unweighted", & + var_description="Unweighted fraction of sample points in precipitation [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_mixt_frac' ) + ilh_mixt_frac = k + call stat_assign( var_index=ilh_mixt_frac, var_name="lh_mixt_frac", & + var_description="Latin hypercube estimate of mixture fraction (weight of 1st PDF & + &component [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_mixt_frac_unweighted' ) + ilh_mixt_frac_unweighted = k + call stat_assign( var_index=ilh_mixt_frac_unweighted, var_name="lh_mixt_frac_unweighted", & + var_description="Unweighted fraction of sample points in first PDF component [-]", & + var_units="-", l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_m_vol_rad_rain' ) + ilh_m_vol_rad_rain = k + call stat_assign( var_index=ilh_m_vol_rad_rain, var_name="lh_m_vol_rad_rain", & + var_description="SILHS est. of rain radius", var_units="m", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'lh_rrm_mc_nonadj' ) + ilh_rrm_mc_nonadj = k + call stat_assign( var_index=ilh_rrm_mc_nonadj, var_name="lh_rrm_mc_nonadj", & + var_description="SILHS est. of rrm_mc_nonadj [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.true., grid_kind=stats_lh_zt ) + k = k + 1 + + case ( 'silhs_variance_category' ) + + do icategory=1, silhs_num_importance_categories + + isilhs_variance_category(icategory) = k + write(category_num_as_string,'(I1)') icategory + call stat_assign( var_index=isilhs_variance_category(icategory), & + var_name="silhs_var_cat_"//category_num_as_string, & + var_description="Variance of SILHS variable in importance category " // & + category_num_as_string, var_units="various", l_silhs=.false., grid_kind=stats_lh_zt ) + k = k + 1 + + end do + + case ( 'lh_samp_frac_category' ) + + do icategory=1, silhs_num_importance_categories + + ilh_samp_frac_category(icategory) = k + write(category_num_as_string,'(I1)') icategory + call stat_assign( var_index=ilh_samp_frac_category(icategory), & + var_name="lh_samp_frac_"//category_num_as_string, & + var_description="Number of samples in importance category " // & + category_num_as_string // " [-]", var_units="-", l_silhs=.false., & + grid_kind=stats_lh_zt ) + k = k + 1 + + end do + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_lh_zt: ', trim( vars_lh_zt(i) ) + + l_error = .true. ! This will stop the run. + + end select + + end do ! i = 1, stats_lh_zt%num_output_fields + + return + end subroutine stats_init_lh_zt + +end module stats_lh_zt_module diff --git a/src/physics/clubb/stats_rad_zm_module.F90 b/src/physics/clubb/stats_rad_zm_module.F90 new file mode 100644 index 0000000000..d36d2eeb09 --- /dev/null +++ b/src/physics/clubb/stats_rad_zm_module.F90 @@ -0,0 +1,168 @@ +!----------------------------------------------------------------------- +! $Id: stats_rad_zm_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_rad_zm_module + + implicit none + + private ! Default Scope + + public :: stats_init_rad_zm + +! Constant parameters + integer, parameter, public :: nvarmax_rad_zm = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_rad_zm( vars_rad_zm, l_error ) + +! Description: +! Initializes array indices for stats_rad_zm variables +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_rad_zm, & + iFrad_LW_rad, & ! Variable(s) + iFrad_SW_rad, & + iFrad_SW_up_rad, & + iFrad_LW_up_rad, & + iFrad_SW_down_rad, & + iFrad_LW_down_rad + + use stats_variables, only: & + ifulwcl, ifdlwcl, ifdswcl, ifuswcl ! Variable(s) + + use stats_type_utilities, only: & + stat_assign ! Procedure + + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zm), intent(in) :: vars_rad_zm + + ! Input/Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_rad_zm + + iFrad_LW_rad = 0 + iFrad_SW_rad = 0 + iFrad_SW_up_rad = 0 + iFrad_LW_up_rad = 0 + iFrad_SW_down_rad = 0 + iFrad_LW_down_rad = 0 + + ifulwcl = 0 + ifdlwcl = 0 + ifdswcl = 0 + ifuswcl = 0 + +! Assign pointers for statistics variables stats_rad_zm + + k = 1 + do i=1,stats_rad_zm%num_output_fields + + select case ( trim(vars_rad_zm(i)) ) + + case('fulwcl') + ifulwcl = k + call stat_assign( var_index=ifulwcl, var_name="fulwcl", & + var_description="Upward clear-sky LW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fdlwcl' ) + ifdlwcl = k + call stat_assign( var_index=ifdlwcl, var_name="fdlwcl", & + var_description="Downward clear-sky LW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fdswcl' ) + ifdswcl = k + call stat_assign( var_index=ifdswcl, var_name="fdswcl", & + var_description="Downward clear-sky SW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case( 'fuswcl' ) + ifuswcl = k + call stat_assign( var_index=ifuswcl, var_name="fuswcl", & + var_description="Upward clear-sky SW flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_rad') + iFrad_LW_rad = k + + call stat_assign( var_index=iFrad_LW_rad, var_name="Frad_LW_rad", & + var_description="Net long-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_rad') + iFrad_SW_rad = k + + call stat_assign( var_index=iFrad_SW_rad, var_name="Frad_SW_rad", & + var_description="Net short-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_up_rad') + iFrad_SW_up_rad = k + + call stat_assign( var_index=iFrad_SW_up_rad, var_name="Frad_SW_up_rad", & + var_description="Short-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_up_rad') + iFrad_LW_up_rad = k + + call stat_assign( var_index=iFrad_LW_up_rad, var_name="Frad_LW_up_rad", & + var_description="Long-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_SW_down_rad') + iFrad_SW_down_rad = k + + call stat_assign( var_index=iFrad_SW_down_rad, var_name="Frad_SW_down_rad", & + var_description="Short-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case ('Frad_LW_down_rad') + iFrad_LW_down_rad = k + + call stat_assign( var_index=iFrad_LW_down_rad, var_name="Frad_LW_down_rad", & + var_description="Long-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_rad_zm ) + k = k + 1 + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_rad_zm: ', trim( vars_rad_zm(i) ) + + l_error = .true. ! This will stop the run. + + + end select + + end do + + return + end subroutine stats_init_rad_zm + +end module stats_rad_zm_module diff --git a/src/physics/clubb/stats_rad_zt_module.F90 b/src/physics/clubb/stats_rad_zt_module.F90 new file mode 100644 index 0000000000..0dc65d20f0 --- /dev/null +++ b/src/physics/clubb/stats_rad_zt_module.F90 @@ -0,0 +1,195 @@ +!----------------------------------------------------------------------- +! $Id: stats_rad_zt_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== + +module stats_rad_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_rad_zt + + ! Constant parameters + integer, parameter, public :: nvarmax_rad_zt = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_rad_zt( vars_rad_zt, l_error ) + +! Description: +! Initializes array indices for stats_zt +! +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_rad_zt, & + iT_in_K_rad, & ! Variable(s) + ircil_rad, & + io3l_rad, & + irsm_rad, & + ircm_in_cloud_rad, & + icloud_frac_rad, & + iice_supersat_frac_rad, & + iradht_rad, & + iradht_LW_rad, & + iradht_SW_rad, & + ip_in_mb_rad, & + isp_humidity_rad + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! Input Variable + character(len= * ), dimension(nvarmax_rad_zt), intent(in) :: vars_rad_zt + + ! Input/Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_rad_zt + + iT_in_K_rad = 0 + ircil_rad = 0 + io3l_rad = 0 + irsm_rad = 0 + ircm_in_cloud_rad = 0 + icloud_frac_rad = 0 + iice_supersat_frac_rad = 0 + iradht_rad = 0 + iradht_LW_rad = 0 + iradht_SW_rad = 0 + ip_in_mb_rad = 0 + isp_humidity_rad = 0 + + + ! Assign pointers for statistics variables stats_rad_zt + + k = 1 + do i=1,stats_rad_zt%num_output_fields + + select case ( trim(vars_rad_zt(i)) ) + + case ('T_in_K_rad') + iT_in_K_rad = k + + call stat_assign( var_index=iT_in_K_rad, var_name="T_in_K_rad", & + var_description="Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rcil_rad') + ircil_rad = k + + call stat_assign( var_index=ircil_rad, var_name="rcil_rad", & + var_description="Ice mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('o3l_rad') + io3l_rad = k + + call stat_assign( var_index=io3l_rad, var_name="o3l_rad", & + var_description="Ozone mixing ratio [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rsm_rad') + irsm_rad = k + + call stat_assign( var_index=irsm_rad, var_name="rsm_rad", & + var_description="Snow water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('rcm_in_cloud_rad') + ircm_in_cloud_rad = k + + call stat_assign( var_index=ircm_in_cloud_rad, var_name="rcm_in_cloud_rad", & + var_description="rcm in cloud layer [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_rad_zt ) + k = k + 1 + + case ('cloud_frac_rad') + icloud_frac_rad = k + + call stat_assign( var_index=icloud_frac_rad, var_name="cloud_frac_rad", & + var_description="Cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('ice_supersat_frac_rad') + iice_supersat_frac_rad = k + + call stat_assign( var_index=iice_supersat_frac_rad, var_name="ice_supersat_frac_rad", & + var_description="Ice cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_rad') + iradht_rad = k + + call stat_assign( var_index=iradht_rad, var_name="radht_rad", & + var_description="Total radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_LW_rad') + iradht_LW_rad = k + + call stat_assign( var_index=iradht_LW_rad, var_name="radht_LW_rad", & + var_description="Long-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('radht_SW_rad') + iradht_SW_rad = k + + call stat_assign( var_index=iradht_SW_rad, var_name="radht_SW_rad", & + var_description="Short-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('p_in_mb_rad') + ip_in_mb_rad = k + + call stat_assign( var_index=ip_in_mb_rad, var_name="p_in_mb_rad", & + var_description="Pressure [hPa]", var_units="hPa", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case ('sp_humidity_rad') + isp_humidity_rad = k + + call stat_assign( var_index=isp_humidity_rad, var_name="sp_humidity_rad", & + var_description="Specific humidity [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_rad_zt ) + k = k + 1 + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_rad_zt: ', trim( vars_rad_zt(i) ) + + l_error = .true. ! This will stop the run. + + + end select + + end do + + return + end subroutine stats_init_rad_zt + +end module stats_rad_zt_module diff --git a/src/physics/clubb/stats_sfc_module.F90 b/src/physics/clubb/stats_sfc_module.F90 new file mode 100644 index 0000000000..a306e03eab --- /dev/null +++ b/src/physics/clubb/stats_sfc_module.F90 @@ -0,0 +1,472 @@ +!----------------------------------------------------------------------- +! $Id: stats_sfc_module.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_sfc_module + + + implicit none + + private ! Set Default Scope + + public :: stats_init_sfc + + ! Constant parameters + integer, parameter, public :: nvarmax_sfc = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_sfc( vars_sfc, l_error ) + +! Description: +! Initializes array indices for stats_sfc +! References: +! None +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_sfc, & ! Variables + iustar, & + isoil_heat_flux, & + iveg_T_in_K, & + isfc_soil_T_in_K,& + ideep_soil_T_in_K, & + ilh, & + ish, & + icc, & + ilwp, & + ivwp, & + iiwp, & + iswp, & + irwp, & + iz_cloud_base, & + iz_inversion, & + iprecip_rate_sfc, & + irain_flux_sfc, & + irrm_sfc, & + iprecip_frac_tol + + use stats_variables, only: & + iwpthlp_sfc, & + iwprtp_sfc, & + iupwp_sfc, & + ivpwp_sfc, & + ithlm_vert_avg, & + irtm_vert_avg, & + ium_vert_avg, & + ivm_vert_avg, & + iwp2_vert_avg, & + iup2_vert_avg, & + ivp2_vert_avg, & + irtp2_vert_avg, & + ithlp2_vert_avg, & + iT_sfc + + use stats_variables, only: & + iwp23_matrix_condt_num, & + irtm_matrix_condt_num, & + ithlm_matrix_condt_num, & + irtp2_matrix_condt_num, & + ithlp2_matrix_condt_num, & + irtpthlp_matrix_condt_num, & + iup2_vp2_matrix_condt_num, & + iwindm_matrix_condt_num + + use stats_variables, only: & + imorr_snow_rate ! Variable(s) + + use stats_variables, only: & + irtm_spur_src, & + ithlm_spur_src, & + irsm_sd_morr_int + + use stats_type_utilities, only: & + stat_assign ! Procedure + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_sfc), intent(in) :: vars_sfc + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: i, k + + ! ---- Begin Code ---- + + ! Default initialization for array indices for stats_sfc is zero (see module + ! stats_variables) + + ! Assign pointers for statistics variables stats_sfc using stat_assign + + k = 1 + do i = 1, stats_sfc%num_output_fields + + select case ( trim( vars_sfc(i) ) ) + case ('soil_heat_flux') + isoil_heat_flux = k + + call stat_assign( var_index=isoil_heat_flux, var_name="soil_heat_flux", & + var_description="soil_heat_flux[W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('ustar') + iustar = k + + call stat_assign( var_index=iustar, var_name="ustar", & + var_description="Friction velocity [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('veg_T_in_K') + iveg_T_in_K = k + + call stat_assign( var_index=iveg_T_in_K, var_name="veg_T_in_K", & + var_description="Surface Vegetation Temperature [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + case ('sfc_soil_T_in_K') + isfc_soil_T_in_K = k + + call stat_assign( var_index=isfc_soil_T_in_K, var_name="sfc_soil_T_in_K", & + var_description="Surface soil temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + case ('deep_soil_T_in_K') + ideep_soil_T_in_K = k + + call stat_assign( var_index=ideep_soil_T_in_K, var_name="deep_soil_T_in_K", & + var_description="Deep soil Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('lh') + ilh = k + call stat_assign( var_index=ilh, var_name="lh", & + var_description="Surface latent heating [W/m^2]", var_units="W/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('sh') + ish = k + call stat_assign( var_index=ish, var_name="sh", & + var_description="Surface sensible heating [W/m^2]", var_units="W/m2", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('cc') + icc = k + call stat_assign( var_index=icc, var_name="cc", var_description="Cloud cover [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('lwp') + ilwp = k + call stat_assign( var_index=ilwp, var_name="lwp", & + var_description="Liquid water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('vwp') + ivwp = k + call stat_assign( var_index=ivwp, var_name="vwp", & + var_description="Vapor water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('iwp') + iiwp = k + call stat_assign( var_index=iiwp, var_name="iwp", & + var_description="Ice water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('swp') + iswp = k + call stat_assign( var_index=iswp, var_name="swp", & + var_description="Snow water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('rwp') + irwp = k + call stat_assign( var_index=irwp, var_name="rwp", & + var_description="Rain water path [kg/m^2]", var_units="kg/m2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('z_cloud_base') + iz_cloud_base = k + call stat_assign( var_index=iz_cloud_base, var_name="z_cloud_base", & + var_description="Cloud base altitude [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('z_inversion') + iz_inversion = k + call stat_assign( var_index=iz_inversion, var_name="z_inversion", & + var_description="Inversion altitude [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('precip_rate_sfc') ! Brian + iprecip_rate_sfc = k + call stat_assign( var_index=iprecip_rate_sfc, var_name="precip_rate_sfc", & + var_description="Surface rainfall rate [mm/day]", var_units="mm/day", & + l_silhs=.true., grid_kind=stats_sfc ) + k = k + 1 + + case ('rain_flux_sfc') ! Brian + irain_flux_sfc = k + + call stat_assign( var_index=irain_flux_sfc, var_name="rain_flux_sfc", & + var_description="Surface rain flux [W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('rrm_sfc') ! Brian + irrm_sfc = k + + call stat_assign( var_index=irrm_sfc, var_name="rrm_sfc", & + var_description="Surface rain water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('precip_frac_tol') + iprecip_frac_tol = k + + call stat_assign( var_index=iprecip_frac_tol, & + var_name="precip_frac_tol", & + var_description="Smallest allowable precipitation " & + // "fraction when hydrometeors are present [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ( 'morr_snow_rate' ) + imorr_snow_rate = k + call stat_assign( var_index=imorr_snow_rate, var_name="morr_snow_rate", & + var_description="Snow+Ice+Graupel fallout rate from Morrison scheme [mm/day]", & + var_units="mm/day", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('wpthlp_sfc') + iwpthlp_sfc = k + + call stat_assign( var_index=iwpthlp_sfc, var_name="wpthlp_sfc", & + var_description="wpthlp surface flux [K m/s]", var_units="K m/s", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('wprtp_sfc') + iwprtp_sfc = k + + call stat_assign( var_index=iwprtp_sfc, var_name="wprtp_sfc", & + var_description="wprtp surface flux [kg/kg]", var_units="(kg/kg) m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('upwp_sfc') + iupwp_sfc = k + + call stat_assign( var_index=iupwp_sfc, var_name="upwp_sfc", & + var_description="upwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('vpwp_sfc') + ivpwp_sfc = k + + call stat_assign( var_index=ivpwp_sfc, var_name="vpwp_sfc", & + var_description="vpwp surface flux [m^2/s^2]", var_units="m^2/s^2", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_vert_avg') + ithlm_vert_avg = k + + call stat_assign( var_index=ithlm_vert_avg, var_name="thlm_vert_avg", & + var_description="Vertical average (density-weighted) of thlm [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtm_vert_avg') + irtm_vert_avg = k + + call stat_assign( var_index=irtm_vert_avg, var_name="rtm_vert_avg", & + var_description="Vertical average (density-weighted) of rtm [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('um_vert_avg') + ium_vert_avg = k + + call stat_assign( var_index=ium_vert_avg, var_name="um_vert_avg", & + var_description="Vertical average (density-weighted) of um [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('vm_vert_avg') + ivm_vert_avg = k + + call stat_assign( var_index=ivm_vert_avg, var_name="vm_vert_avg", & + var_description="Vertical average (density-weighted) of vm [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('wp2_vert_avg') + iwp2_vert_avg = k + + call stat_assign( var_index=iwp2_vert_avg, var_name="wp2_vert_avg", & + var_description="Vertical average (density-weighted) of wp2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('up2_vert_avg') + iup2_vert_avg = k + + call stat_assign( var_index=iup2_vert_avg, var_name="up2_vert_avg", & + var_description="Vertical average (density-weighted) of up2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('vp2_vert_avg') + ivp2_vert_avg = k + + call stat_assign( var_index=ivp2_vert_avg, var_name="vp2_vert_avg", & + var_description="Vertical average (density-weighted) of vp2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtp2_vert_avg') + irtp2_vert_avg = k + + call stat_assign( var_index=irtp2_vert_avg, var_name="rtp2_vert_avg", & + var_description="Vertical average (density-weighted) of rtp2 [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlp2_vert_avg') + ithlp2_vert_avg = k + + call stat_assign( var_index=ithlp2_vert_avg, var_name="thlp2_vert_avg", & + var_description="Vertical average (density-weighted) of thlp2 [K^2]", & + var_units="K^2", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('T_sfc') + iT_sfc = k + + call stat_assign( var_index=iT_sfc, var_name="T_sfc", & + var_description="Surface Temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_sfc ) + k = k + 1 + + case ('wp23_matrix_condt_num') + iwp23_matrix_condt_num = k + call stat_assign( var_index=iwp23_matrix_condt_num, var_name="wp23_matrix_condt_num", & + var_description="Estimate of the condition number for wp2/3 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_matrix_condt_num') + ithlm_matrix_condt_num = k + call stat_assign( var_index=ithlm_matrix_condt_num, var_name="thlm_matrix_condt_num", & + var_description="Estimate of the condition number for thlm/wpthlp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtm_matrix_condt_num') + irtm_matrix_condt_num = k + + call stat_assign( var_index=irtm_matrix_condt_num, var_name="rtm_matrix_condt_num", & + var_description="Estimate of the condition number for rtm/wprtp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlp2_matrix_condt_num') + ithlp2_matrix_condt_num = k + + call stat_assign( var_index=ithlp2_matrix_condt_num, var_name="thlp2_matrix_condt_num", & + var_description="Estimate of the condition number for thlp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtp2_matrix_condt_num') + irtp2_matrix_condt_num = k + call stat_assign( var_index=irtp2_matrix_condt_num, var_name="rtp2_matrix_condt_num", & + var_description="Estimate of the condition number for rtp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rtpthlp_matrix_condt_num') + irtpthlp_matrix_condt_num = k + call stat_assign( var_index=irtpthlp_matrix_condt_num, & + var_name="rtpthlp_matrix_condt_num", & + var_description="Estimate of the condition number for rtpthlp [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('up2_vp2_matrix_condt_num') + iup2_vp2_matrix_condt_num = k + call stat_assign( var_index=iup2_vp2_matrix_condt_num, & + var_name="up2_vp2_matrix_condt_num", & + var_description="Estimate of the condition number for up2/vp2 [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('windm_matrix_condt_num') + iwindm_matrix_condt_num = k + call stat_assign( var_index=iwindm_matrix_condt_num, var_name="windm_matrix_condt_num", & + var_description="Estimate of the condition number for the mean wind [count]", & + var_units="count", l_silhs=.false., grid_kind=stats_sfc ) + + k = k + 1 + + case ('rtm_spur_src') + irtm_spur_src = k + + call stat_assign( var_index=irtm_spur_src, var_name="rtm_spur_src", & + var_description="rtm spurious source [kg/(m^2 s)]", var_units="kg/(m^2 s)", & + l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('thlm_spur_src') + ithlm_spur_src = k + + call stat_assign( var_index=ithlm_spur_src, var_name="thlm_spur_src", & + var_description="thlm spurious source [(K kg) / (m^2 s)]", & + var_units="(K kg) / (m^2 s)", l_silhs=.false., grid_kind=stats_sfc ) + k = k + 1 + + case ('rs_sd_morr_int') + irsm_sd_morr_int = k + + call stat_assign( var_index=irsm_sd_morr_int, var_name="rs_sd_morr_int", & + var_description="rsm_sd_morr vertical integral [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_sfc ) + k = k + 1 + + case default + write(fstderr,*) 'Error: unrecognized variable in vars_sfc: ', & + trim( vars_sfc(i) ) + l_error = .true. ! This will stop the run. + + end select + + end do ! 1 .. stats_sfc%num_output_fields + + return + + end subroutine stats_init_sfc + + +end module stats_sfc_module + diff --git a/src/physics/clubb/stats_type.F90 b/src/physics/clubb/stats_type.F90 new file mode 100644 index 0000000000..e9cb384633 --- /dev/null +++ b/src/physics/clubb/stats_type.F90 @@ -0,0 +1,62 @@ +!----------------------------------------------------------------------- +! $Id: stats_type.F90 6952 2014-06-17 15:59:47Z schemena@uwm.edu $ +!=============================================================================== +module stats_type + + ! Description: + ! Contains derived data type 'stats'. + ! Used for storing output statistics to disk. + !----------------------------------------------------------------------- + + use stat_file_module, only: & + stat_file ! Type + + use clubb_precision, only: & + stat_rknd, & ! Variable(s) + stat_nknd, & + core_rknd + + implicit none + + private ! Set Default Scope + + public :: stats + + ! Derived data types to store GrADS/netCDF statistics + type stats + + ! Number of fields to sample + integer :: num_output_fields ! Number of variables being output to disk (e.g. + ! cloud_frac, rain rate, etc.) + + integer :: & + ii, & ! Horizontal extent of the variables (Usually 1 for the single-column model) + jj, & ! Horizontal extent of the variables (Usually 1 for the single-column model) + kk ! Vertical extent of the variables (Usually gr%nz from grid_class) + + ! Vertical levels + real( kind = core_rknd ), allocatable, dimension(:) :: z ! altitude [m] + + ! Array to store sampled fields + + real(kind=stat_rknd), allocatable, dimension(:,:,:,:) :: accum_field_values + ! The variable accum_field_values contains the cumulative sums + ! of accum_num_samples sample values of each + ! of the num_output_fields (e.g. the sum of the sampled rain rate values) + + integer(kind=stat_nknd), allocatable, dimension(:,:,:,:) :: accum_num_samples + ! accum_num_samples is the number of samples for each of the num_output_fields fields + ! and each of the kk vertical levels + + ! Tracks if a field is in the process of an update + logical, allocatable, dimension(:,:,:,:) :: l_in_update + + ! Data for GrADS / netCDF output + + type (stat_file) :: file + + end type stats + +end module stats_type + + diff --git a/src/physics/clubb/stats_type_utilities.F90 b/src/physics/clubb/stats_type_utilities.F90 new file mode 100644 index 0000000000..4954b9c054 --- /dev/null +++ b/src/physics/clubb/stats_type_utilities.F90 @@ -0,0 +1,525 @@ +!----------------------------------------------------------------------- +! $Id: stats_type_utilities.F90 7315 2014-09-30 20:49:54Z schemena@uwm.edu $ +!=============================================================================== +module stats_type_utilities + + ! Description: + ! Contains subroutines for interfacing with type, stats + !----------------------------------------------------------------------- + + use stats_type, only: & + stats ! type + + use clubb_precision, only: & + core_rknd + + implicit none + + private ! Set Default Scope + + public :: stat_assign, & + stat_update_var, & + stat_update_var_pt, & + stat_begin_update, & + stat_begin_update_pt, & + stat_end_update, & + stat_end_update_pt, & + stat_modify, & + stat_modify_pt + contains + + !============================================================================= + subroutine stat_assign( var_index, var_name, & + var_description, var_units, & + l_silhs, grid_kind ) + + ! Description: + ! Assigns pointers for statistics variables in grid. There is an + ! option to make the variable a SILHS variable (updated n_microphys_calls + ! times per timestep rather than just once). + + ! + ! References: + ! None + !----------------------------------------------------------------------- + + implicit none + + ! Input Variables + + integer,intent(in) :: var_index ! Variable index [#] + character(len = *), intent(in) :: var_name ! Variable name [] + character(len = *), intent(in) :: var_description ! Variable description [] + character(len = *), intent(in) :: var_units ! Variable units [] + + logical, intent(in) :: l_silhs ! SILHS variable [boolean] + + ! Input/Output Variable + + ! Which grid the variable is located on (e.g., zt, zm, sfc) + type(stats), target, intent(inout) :: grid_kind + + grid_kind%file%var(var_index)%ptr => grid_kind%accum_field_values(:,:,:,var_index) + grid_kind%file%var(var_index)%name = var_name + grid_kind%file%var(var_index)%description = var_description + grid_kind%file%var(var_index)%units = var_units + + grid_kind%file%var(var_index)%l_silhs = l_silhs + + !Example of the old format + !changed by Joshua Fasching 23 August 2007 + + !stats_zt%file%var(ithlm)%ptr => stats_zt%accum_field_values(:,k) + !stats_zt%file%var(ithlm)%name = "thlm" + !stats_zt%file%var(ithlm)%description = "thetal (K)" + !stats_zt%file%var(ithlm)%units = "K" + + return + + end subroutine stat_assign + + !============================================================================= + subroutine stat_update_var( var_index, value, grid_kind ) + + ! Description: + ! This updates the value of a statistics variable located at var_index + ! associated with grid type 'grid_kind' (zt, zm, or sfc). + ! + ! This subroutine is used when a statistical variable needs to be updated + ! only once during a model timestep. + ! + ! In regards to budget terms, this subroutine is used for variables that + ! are either completely implicit (e.g. wprtp_ma) or completely explicit + ! (e.g. wp2_pr3). For completely implicit terms, once the variable has been + ! solved for, the implicit contribution can be finalized. The finalized + ! implicit contribution is sent into stat_update_var_pt. For completely + ! explicit terms, the explicit contribution is sent into stat_update_var_pt + ! once it has been calculated. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc ) + + ! Input Variable(s) NOTE: Due to the implicit none above, these must + ! be declared below to allow the use of grid_kind + + real( kind = core_rknd ), dimension(grid_kind%kk), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + integer :: k + + if ( var_index > 0 ) then + do k = 1, grid_kind%kk + grid_kind%accum_field_values(clubb_i,clubb_j,k,var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,k,var_index) + real( value(k), & + kind=stat_rknd ) + grid_kind%accum_num_samples(clubb_i,clubb_j,k,var_index) = & + grid_kind%accum_num_samples(clubb_i,clubb_j,k,var_index) + 1 + end do + endif + + return + end subroutine stat_update_var + + !============================================================================= + subroutine stat_update_var_pt( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This updates the value of a statistics variable located at var_index + ! associated with grid type 'grid_kind' at a specific grid_level. + ! + ! See the description of stat_update_var for more details. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + if ( var_index > 0 ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index) + & + real( value, kind=stat_rknd ) + + grid_kind%accum_num_samples(clubb_i,clubb_j,grid_level,var_index) = & + grid_kind%accum_num_samples(clubb_i,clubb_j,grid_level,var_index) + 1 + + endif + + return + end subroutine stat_update_var_pt + + !============================================================================= + subroutine stat_begin_update( var_index, value, & + grid_kind ) + + ! Description: + ! This begins an update of the value of a statistics variable located at + ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with + ! subroutine stat_end_update. + ! + ! This subroutine is used when a statistical variable needs to be updated + ! more than one time during a model timestep. Commonly, this is used for + ! beginning a budget term calculation. + ! + ! In this type of stats calculation, we first subtract the field + ! (e.g. rtm / dt ) from the statistic, then update rtm by a term + ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the + ! statistic. + ! + ! Example: + ! + ! call stat_begin_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! !!! Perform clipping of rtm !!! + ! + ! call stat_end_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! This subroutine is often used with stats budget terms for variables that + ! have both implicit and explicit components (e.g. wp3_ta). The explicit + ! component is sent into stat_begin_update_pt (with the sign reversed + ! because stat_begin_update_pt automatically subtracts the value sent into + ! it). Then, once the variable has been solved for, the implicit + ! statistical contribution can be finalized. The finalized implicit + ! component is sent into stat_end_update_pt. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: i + + do i = 1, gr%nz + + call stat_begin_update_pt & + ( var_index, i, value(i), grid_kind ) + + enddo + + return + end subroutine stat_begin_update + + !============================================================================= + subroutine stat_begin_update_pt & + ( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This begins an update of the value of a statistics variable located at + ! var_index associated with the grid type (grid_kind) at a specific + ! grid_level. It is used in conjunction with subroutine stat_end_update_pt. + ! + ! Notes: + ! Commonly this is used for beginning a budget. See the description of + ! stat_begin_update for more details. + ! + ! References: + ! None + !--------------------------------------------------------------------- + + use error_code, only: clubb_debug ! Procedure(s) + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then ! Are we storing this variable? + + ! Can we begin an update? + if ( .not. grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level, var_index) = & + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level, var_index) - & + real( value, kind=stat_rknd ) + + grid_kind%l_in_update(clubb_i,clubb_j,grid_level, var_index) = .true. ! Start Record + + else + + call clubb_debug( 1, & + "Beginning an update before finishing previous for variable: "// & + trim( grid_kind%file%var(var_index)%name ) ) + endif + + endif + + return + end subroutine stat_begin_update_pt + + !============================================================================= + subroutine stat_end_update( var_index, value, grid_kind ) + + ! Description: + ! This ends an update of the value of a statistics variable located at + ! var_index on the (zt, zm, or sfc) grid. It is used in conjunction with + ! subroutine stat_begin_update. + ! + ! This subroutine is used when a statistical variable needs to be updated + ! more than one time during a model timestep. Commonly, this is used for + ! finishing a budget term calculation. + ! + ! In this type of stats calculation, we first subtract the field + ! (e.g. rtm / dt ) from the statistic, then update rtm by a term + ! (e.g. clip rtm), and then re-add the field (e.g. rtm / dt) to the + ! statistic. + ! + ! Example: + ! + ! call stat_begin_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! !!! Perform clipping of rtm !!! + ! + ! call stat_end_update( irtm_bt, real(rtm / dt), stats_zt ) + ! + ! This subroutine is often used with stats budget terms for variables that + ! have both implicit and explicit components (e.g. wp3_ta). The explicit + ! component is sent into stat_begin_update_pt (with the sign reversed + ! because stat_begin_update_pt automatically subtracts the value sent into + ! it). Then, once the variable has been solved for, the implicit + ! statistical contribution can be finalized. The finalized implicit + ! component is sent into stat_end_update_pt. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: k + + ! ---- Begin Code ---- + + do k = 1,gr%nz + call stat_end_update_pt & + ( var_index, k, value(k), grid_kind ) + enddo + + return + end subroutine stat_end_update + + !============================================================================= + subroutine stat_end_update_pt & + ( var_index, grid_level, value, grid_kind ) + + ! Description: + ! This ends an update of the value of a statistics variable located at + ! var_index associated with the grid type (grid_kind) at a specific + ! grid_level. It is used in conjunction with subroutine + ! stat_begin_update_pt. + ! + ! Commonly this is used for finishing a budget. See the description of + ! stat_end_update for more details. + !--------------------------------------------------------------------- + + use error_code, only: clubb_debug ! Procedure(s) + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index, & ! The index at which the variable is stored [] + grid_level ! The level at which the variable is to be modified [] + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then ! Are we storing this variable? + + ! Can we end an update? + if ( grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) ) then + + call stat_update_var_pt & + ( var_index, grid_level, value, grid_kind ) + + grid_kind%l_in_update(clubb_i,clubb_j,grid_level,var_index) = .false. ! End Record + + else + + call clubb_debug( 1, "Ending before beginning update. For variable "// & + grid_kind%file%var(var_index)%name ) + + endif + + endif + + return + end subroutine stat_end_update_pt + + !============================================================================= + subroutine stat_modify( var_index, value, & + grid_kind ) + + ! Description: + ! This modifies the value of a statistics variable located at var_index on + ! the (zt, zm, or sfc) grid. It does not increment the sampling count. + ! + ! This subroutine is normally used when a statistical variable needs to be + ! updated more than twice during a model timestep. Commonly, this is used + ! if a budget term calculation needs an intermediate modification between + ! stat_begin_update and stat_end_update. + !--------------------------------------------------------------------- + + use grid_class, only: gr ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + real( kind = core_rknd ), dimension(gr%nz), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + integer :: k + + ! ---- Begin Code ---- + + do k = 1, gr%nz + + call stat_modify_pt( var_index, k, value(k), grid_kind ) + + enddo + + return + end subroutine stat_modify + + !============================================================================= + subroutine stat_modify_pt( var_index, grid_level, value, & + grid_kind ) + + ! Description: + ! This modifies the value of a statistics variable located at var_index on + ! the grid at a specific point. It does not increment the sampling count. + ! + ! Commonly this is used for intermediate updates to a budget. See the + ! description of stat_modify for more details. + !--------------------------------------------------------------------- + + use clubb_precision, only: & + stat_rknd ! Constant + + use stat_file_module, only: & + clubb_i, clubb_j ! Variable(s) + + implicit none + + ! Input Variables(s) + + integer, intent(in) :: & + var_index ! The index at which the variable is stored [] + + + real( kind = core_rknd ), intent(in) :: & + value ! Value of field being added to the statistic [Units Vary] + + integer, intent(in) :: & + grid_level ! The level at which the variable is to be modified [] + + ! Input/Output Variable(s) + type(stats), intent(inout) :: & + grid_kind ! Which grid the variable is located on (zt, zm, rad, or sfc). + + ! ---- Begin Code ---- + + if ( var_index > 0 ) then + + grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index ) & + = grid_kind%accum_field_values(clubb_i,clubb_j,grid_level,var_index ) + & + real( value, kind=stat_rknd ) + + end if + + return + end subroutine stat_modify_pt + +!=============================================================================== + +end module stats_type_utilities diff --git a/src/physics/clubb/stats_variables.F90 b/src/physics/clubb/stats_variables.F90 new file mode 100644 index 0000000000..2f42c8e9a4 --- /dev/null +++ b/src/physics/clubb/stats_variables.F90 @@ -0,0 +1,1359 @@ +!------------------------------------------------------------------------------- +! $Id: stats_variables.F90 7383 2014-11-13 17:43:38Z schemena@uwm.edu $ +!------------------------------------------------------------------------------- + +! Description: +! Holds pointers and other variables for statistics to be written to +! GrADS files and netCDF files. +!------------------------------------------------------------------------------- +module stats_variables + + + use stats_type, only: & + stats ! Type + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Set Default Scope + + ! Sampling and output frequencies + real( kind = core_rknd ), public :: & + stats_tsamp = 0._core_rknd, & ! Sampling interval [s] + stats_tout = 0._core_rknd ! Output interval [s] + +!$omp threadprivate(stats_tsamp, stats_tout) + + logical, public :: & + l_stats = .false., & ! Main flag to turn statistics on/off + l_output_rad_files = .false., & ! Flag to turn off radiation statistics output + l_netcdf = .false., & ! Output to NetCDF format + l_grads = .false., & ! Output to GrADS format + l_silhs_out = .false., & ! Output SILHS files (stats_lh_zt and stats_lh_sfc) + l_allow_small_stats_tout = .false. ! Do not stop if output timestep is too low for + ! requested format, e.g. l_grads = .true. and + ! stats_tout < 60.0 + +!$omp threadprivate(l_stats, l_output_rad_files, l_netcdf, l_grads, l_silhs_out, & +!$omp l_allow_small_stats_tout) + + logical, public :: & + l_stats_samp = .false., & ! Sample flag for current time step + l_stats_last = .false. ! Last time step of output period + +!$omp threadprivate(l_stats_samp, l_stats_last) + + character(len=200), public :: & + fname_zt = '', & ! Name of the stats file for thermodynamic grid fields + fname_lh_zt = '', & ! Name of the stats file for LH variables on the stats_zt grid + fname_lh_sfc = '', & ! Name of the stats file for LH variables on the stats_zt grid + fname_zm = '', & ! Name of the stats file for momentum grid fields + fname_rad_zt = '', & ! Name of the stats file for the stats_zt radiation grid fields + fname_rad_zm = '', & ! Name of the stats file for the stats_zm radiation grid fields + fname_sfc = '' ! Name of the stats file for surface only fields + +!$omp threadprivate(fname_zt, fname_lh_zt, fname_lh_sfc, fname_zm, fname_rad_zt, & +!$omp fname_rad_zm, fname_sfc) + +! Indices for statistics in stats_zt file + + integer, public :: & + ithlm = 0, & + ithvm = 0, & + irtm = 0, & + ircm = 0, & + irvm = 0, & + ium = 0, & + ivm = 0, & + iwm_zt = 0, & + iwm_zm = 0, & + ium_ref = 0,& + ivm_ref = 0, & + iug = 0, & + ivg = 0, & + icloud_frac = 0, & + iice_supersat_frac = 0, & + ircm_in_layer = 0, & + ircm_in_cloud = 0, & + icloud_cover = 0, & + ip_in_Pa = 0, & + iexner = 0, & + irho_ds_zt = 0, & + ithv_ds_zt = 0, & + iLscale = 0, & + iwp3 = 0, & + ithlp3 = 0, & + irtp3 = 0, & + iwpthlp2 = 0, & + iwp2thlp = 0, & + iwprtp2 = 0, & + iwp2rtp = 0, & + iSkw_zt = 0, & + iSkthl_zt = 0, & + iSkrt_zt = 0 +!$omp threadprivate(ithlm, ithvm, irtm, ircm, irvm, ium, ivm, ium_ref, ivm_ref, & +!$omp iwm_zt, iwm_zm, iug, ivg, icloud_frac, iice_supersat_frac, ircm_in_layer, & +!$omp ircm_in_cloud, icloud_cover, & +!$omp ip_in_Pa, iexner, irho_ds_zt, ithv_ds_zt, iLscale, iwp3, ithlp3, irtp3, & +!$omp iwpthlp2, iwp2thlp, iwprtp2, iwp2rtp, iSkw_zt, iSkthl_zt, iSkrt_zt ) + + integer, public :: & + iLscale_up = 0, & + iLscale_down = 0, & + iLscale_pert_1 = 0, & + iLscale_pert_2 = 0, & + itau_zt = 0, & + iKh_zt = 0, & + iwp2thvp = 0, & + iwp2rcp = 0, & + iwprtpthlp = 0, & + isigma_sqd_w_zt = 0, & + irho = 0 +!$omp threadprivate( iLscale_up, iLscale_down, & +!$omp iLscale_pert_1, iLscale_pert_2, & +!$omp itau_zt, iKh_zt, iwp2thvp, iwp2rcp, iwprtpthlp, isigma_sqd_w_zt, irho ) + + integer, dimension(:), allocatable, public :: & + ihm_1, & + ihm_2 +!$omp threadprivate( ihm_1, ihm_2 ) + + integer, public :: & + iprecip_frac = 0, & + iprecip_frac_1 = 0, & + iprecip_frac_2 = 0, & + iNcnm = 0 +!$omp threadprivate( iprecip_frac, iprecip_frac_1, iprecip_frac_2, iNcnm ) + + integer, dimension(:), allocatable, public :: & + imu_hm_1, & + imu_hm_2, & + imu_hm_1_n, & + imu_hm_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_w_hm_1_n, & + icorr_w_hm_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n +!$omp threadprivate( imu_hm_1, imu_hm_2, imu_hm_1_n, imu_hm_2_n, & +!$omp isigma_hm_1, isigma_hm_2, isigma_hm_1_n, isigma_hm_2_n, & +!$omp icorr_w_hm_1, icorr_w_hm_2, icorr_chi_hm_1, icorr_chi_hm_2, & +!$omp icorr_eta_hm_1, icorr_eta_hm_2, icorr_Ncn_hm_1, icorr_Ncn_hm_2, & +!$omp icorr_w_hm_1_n, icorr_w_hm_2_n, icorr_chi_hm_1_n, icorr_chi_hm_2_n, & +!$omp icorr_eta_hm_1_n, icorr_eta_hm_2_n, icorr_Ncn_hm_1_n, icorr_Ncn_hm_2_n ) + + integer, dimension(:,:), allocatable, public :: & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n +!$omp threadprivate( icorr_hmx_hmy_1, icorr_hmx_hmy_2, & +!$omp icorr_hmx_hmy_1_n, icorr_hmx_hmy_2_n ) + + integer, public :: & + imu_Ncn_1 = 0, & + imu_Ncn_2 = 0, & + imu_Ncn_1_n = 0, & + imu_Ncn_2_n = 0, & + isigma_Ncn_1 = 0, & + isigma_Ncn_2 = 0, & + isigma_Ncn_1_n = 0, & + isigma_Ncn_2_n = 0 +!$omp threadprivate( imu_Ncn_1, imu_Ncn_2, imu_Ncn_1_n, imu_Ncn_2_n, & +!$omp isigma_Ncn_1, isigma_Ncn_2, isigma_Ncn_1_n, isigma_Ncn_2_n ) + + integer, public :: & + icorr_w_chi_1 = 0, & + icorr_w_chi_2 = 0, & + icorr_w_eta_1 = 0, & + icorr_w_eta_2 = 0, & + icorr_w_Ncn_1 = 0, & + icorr_w_Ncn_2 = 0, & + icorr_chi_eta_1_ca = 0, & + icorr_chi_eta_2_ca = 0, & + icorr_chi_Ncn_1 = 0, & + icorr_chi_Ncn_2 = 0, & + icorr_eta_Ncn_1 = 0, & + icorr_eta_Ncn_2 = 0 +!$omp threadprivate( icorr_w_chi_1, icorr_w_chi_2, icorr_w_eta_1, & +!$omp icorr_w_eta_2, icorr_w_Ncn_1, icorr_w_Ncn_2, icorr_chi_eta_1_ca, & +!$omp icorr_chi_eta_2_ca, icorr_chi_Ncn_1, icorr_chi_Ncn_2, icorr_eta_Ncn_1, & +!$omp icorr_eta_Ncn_2 ) + + integer, public :: & + icorr_w_Ncn_1_n = 0, & + icorr_w_Ncn_2_n = 0, & + icorr_chi_Ncn_1_n = 0, & + icorr_chi_Ncn_2_n = 0, & + icorr_eta_Ncn_1_n = 0, & + icorr_eta_Ncn_2_n = 0 +!$omp threadprivate( icorr_w_Ncn_1_n, icorr_w_Ncn_2_n, icorr_chi_Ncn_1_n, & +!$omp icorr_chi_Ncn_2_n, icorr_eta_Ncn_1_n, icorr_eta_Ncn_2_n ) + + integer, dimension(:), allocatable, public :: & + isilhs_variance_category, & + ilh_samp_frac_category + +!$omp threadprivate( isilhs_variance_category ) + + integer, public :: & + iNcm = 0, & ! Brian + iNccnm = 0, & + iNc_in_cloud = 0, & + iNc_activated = 0, & + isnowslope = 0, & ! Adam Smith, 22 April 2008 + ised_rcm = 0, & ! Brian + irsat = 0, & ! Brian + irsati = 0, & + irrm = 0, & ! Brian + im_vol_rad_rain = 0, & ! Brian + im_vol_rad_cloud = 0, & ! COAMPS only. dschanen 6 Dec 2006 + iprecip_rate_zt = 0, & ! Brian + iAKm = 0, & ! analytic Kessler. Vince Larson 22 May 2005 + ilh_AKm = 0, & ! LH Kessler. Vince Larson 22 May 2005 + iradht = 0, & ! Radiative heating. + iradht_LW = 0, & ! " " Long-wave component + iradht_SW = 0, & ! " " Short-wave component + irel_humidity = 0 +!$omp threadprivate( iNcm, iNccnm, iNc_in_cloud, iNc_activated, isnowslope, & +!$omp ised_rcm, irsat, irsati, irrm, & +!$omp im_vol_rad_rain, im_vol_rad_cloud, & +!$omp iprecip_rate_zt, iAKm, ilh_AKm, & +!$omp iradht, iradht_LW, iradht_SW, & +!$omp irel_humidity ) + + integer, public :: & + iAKstd = 0, & + iAKstd_cld = 0, & + iAKm_rcm = 0, & + iAKm_rcc = 0 +!$omp threadprivate( iAKstd, iAKstd_cld, iAKm_rcm, iAKm_rcc ) + + + integer, public :: & + irfrzm = 0 +!$omp threadprivate(irfrzm) + + ! Skewness functions on stats_zt grid + integer, public :: & + iC11_Skw_fnc = 0 + +!$omp threadprivate(iC11_Skw_fnc) + + integer, public :: & + icloud_frac_zm = 0, & + iice_supersat_frac_zm = 0, & + ircm_zm = 0, & + irtm_zm = 0, & + ithlm_zm = 0 + +!$omp threadprivate(icloud_frac_zm, iice_supersat_frac_zm, ircm_zm, irtm_zm, ithlm_zm) + + integer, public :: & + ilh_rcm_avg = 0, & + ik_lh_start = 0 + +!$omp threadprivate(ilh_rcm_avg, ik_lh_start) + + integer, public :: & + iNrm = 0, & ! Rain droplet number concentration + iNim = 0, & ! Ice number concentration + iNsm = 0, & ! Snow number concentration + iNgm = 0 ! Graupel number concentration +!$omp threadprivate(iNrm, iNim, iNsm, iNgm) + + integer, public :: & + iT_in_K ! Absolute temperature +!$omp threadprivate(iT_in_K) + + integer, public :: & + ieff_rad_cloud = 0, & + ieff_rad_ice = 0, & + ieff_rad_snow = 0, & + ieff_rad_rain = 0, & + ieff_rad_graupel = 0 + +!$omp threadprivate(ieff_rad_cloud, ieff_rad_ice, ieff_rad_snow) +!$omp threadprivate(ieff_rad_rain, ieff_rad_graupel) + + integer, public :: & + irsm = 0, & + irgm = 0, & + irim = 0, & + idiam = 0, & ! Diameter of ice crystal [m] + imass_ice_cryst = 0, & ! Mass of a single ice crystal [kg] + ircm_icedfs = 0, & ! Change in liquid water due to ice [kg/kg/s] + iu_T_cm = 0 ! Fallspeed of ice crystal in cm/s [cm s^{-1}] + +!$omp threadprivate(irsm, irgm, irim, idiam, & +!$omp imass_ice_cryst, ircm_icedfs, iu_T_cm) + + + ! thlm/rtm budget terms + integer, public :: & + irtm_bt = 0, & ! rtm total time tendency + irtm_ma = 0, & ! rtm mean advect. term + irtm_ta = 0, & ! rtm turb. advect. term + irtm_forcing = 0, & ! rtm large scale forcing term + irtm_mc = 0, & ! rtm change from microphysics + irtm_sdmp = 0, & ! rtm change from sponge damping + irvm_mc = 0, & ! rvm change from microphysics + ircm_mc = 0, & ! rcm change from microphysics + ircm_sd_mg_morr = 0, & ! rcm sedimentation tendency + irtm_mfl = 0, & ! rtm change due to monotonic flux limiter + irtm_tacl = 0, & ! rtm correction from turbulent advection (wprtp) clipping + irtm_cl = 0, & ! rtm clipping term + irtm_pd = 0, & ! thlm postive definite adj term + ithlm_bt = 0, & ! thlm total time tendency + ithlm_ma = 0, & ! thlm mean advect. term + ithlm_ta = 0, & ! thlm turb. advect. term + ithlm_forcing = 0, & ! thlm large scale forcing term + ithlm_sdmp = 0, & ! thlm change from sponge damping + ithlm_mc = 0, & ! thlm change from microphysics + ithlm_mfl = 0, & ! thlm change due to monotonic flux limiter + ithlm_tacl = 0, & ! thlm correction from turbulent advection (wpthlp) clipping + ithlm_cl = 0 ! thlm clipping term + +!$omp threadprivate(irtm_bt, irtm_ma, irtm_ta, irtm_forcing, & +!$omp irtm_mc, irtm_sdmp, irtm_mfl, irtm_tacl, irtm_cl, irtm_pd, & +!$omp irvm_mc, ircm_mc, ircm_sd_mg_morr, & +!$omp ithlm_bt, ithlm_ma, ithlm_ta, ithlm_forcing, & +!$omp ithlm_mc, ithlm_sdmp, ithlm_mfl, ithlm_tacl, ithlm_cl) + + !monatonic flux limiter diagnostic terms + integer, public :: & + ithlm_mfl_min = 0, & + ithlm_mfl_max = 0, & + iwpthlp_entermfl = 0, & + iwpthlp_exit_mfl = 0, & + iwpthlp_mfl_min = 0, & + iwpthlp_mfl_max = 0, & + irtm_mfl_min = 0, & + irtm_mfl_max = 0, & + iwprtp_enter_mfl = 0, & + iwprtp_exit_mfl = 0, & + iwprtp_mfl_min = 0, & + iwprtp_mfl_max = 0, & + ithlm_enter_mfl = 0, & + ithlm_exit_mfl = 0, & + ithlm_old = 0, & + ithlm_without_ta = 0, & + irtm_enter_mfl = 0, & + irtm_exit_mfl = 0, & + irtm_old = 0, & + irtm_without_ta = 0 + +!$omp threadprivate(ithlm_mfl_min, ithlm_mfl_max, iwpthlp_entermfl) +!$omp threadprivate(iwpthlp_exit_mfl, iwpthlp_mfl_min, iwpthlp_mfl_max) +!$omp threadprivate(irtm_mfl_min, irtm_mfl_max, iwprtp_enter_mfl) +!$omp threadprivate(iwprtp_exit_mfl, iwprtp_mfl_min, iwprtp_mfl_max) +!$omp threadprivate(ithlm_enter_mfl, ithlm_exit_mfl, ithlm_old, ithlm_without_ta) +!$omp threadprivate(irtm_enter_mfl, irtm_exit_mfl, irtm_old, irtm_without_ta) + + integer, public :: & + iwp3_bt = 0, & + iwp3_ma = 0, & + iwp3_ta = 0, & + iwp3_tp = 0, & + iwp3_ac = 0, & + iwp3_bp1 = 0, & + iwp3_bp2 = 0, & + iwp3_pr1 = 0, & + iwp3_pr2 = 0, & + iwp3_dp1 = 0, & + iwp3_cl = 0 + +!$omp threadprivate(iwp3_bt, iwp3_ma, iwp3_ta, iwp3_tp, iwp3_ac, iwp3_bp1) +!$omp threadprivate(iwp3_bp2, iwp3_pr1, iwp3_pr2, iwp3_dp1, iwp3_cl) + + ! Rain mixing ratio budgets + integer, public :: & + irrm_bt = 0, & + irrm_ma = 0, & + irrm_ta = 0, & + irrm_sd = 0, & + irrm_ts = 0, & + irrm_sd_morr = 0, & + irrm_cond = 0, & + irrm_auto = 0, & + irrm_accr = 0, & + irrm_cond_adj = 0, & + irrm_src_adj = 0, & + irrm_mc_nonadj = 0, & + irrm_mc = 0, & + irrm_hf = 0, & + irrm_wvhf = 0, & + irrm_cl = 0 + +!$omp threadprivate(irrm_bt, irrm_ma, irrm_ta, irrm_sd) +!$omp threadprivate(irrm_ts, irrm_sd_morr) +!$omp threadprivate(irrm_cond, irrm_auto, irrm_accr) +!$omp threadprivate(irrm_cond_adj, irrm_src_adj ) +!$omp threadprivate(irrm_mc, irrm_hf, irrm_wvhf, irrm_cl) + + integer, public :: & + iNrm_bt = 0, & + iNrm_ma = 0, & + iNrm_ta = 0, & + iNrm_sd = 0, & + iNrm_ts = 0, & + iNrm_cond = 0, & + iNrm_auto = 0, & + iNrm_cond_adj = 0, & + iNrm_src_adj = 0, & + iNrm_mc = 0, & + iNrm_cl = 0 + +!$omp threadprivate(iNrm_bt, iNrm_ma, iNrm_ta, iNrm_sd, iNrm_ts, iNrm_cond) +!$omp threadprivate(iNrm_auto, iNrm_cond_adj, iNrm_src_adj ) +!$omp threadprivate(iNrm_mc, iNrm_cl) + + + ! Snow/Ice/Graupel mixing ratio budgets + integer, public :: & + irsm_bt = 0, & + irsm_ma = 0, & + irsm_sd = 0, & + irsm_sd_morr = 0, & + irsm_ta = 0, & + irsm_mc = 0, & + irsm_hf = 0, & + irsm_wvhf = 0, & + irsm_cl = 0, & + irsm_sd_morr_int = 0 + +!$omp threadprivate(irsm_bt, irsm_ma, irsm_sd, irsm_sd_morr, irsm_ta) +!$omp threadprivate(irsm_mc, irsm_hf, irsm_wvhf, irsm_cl, irsm_sd_morr_int) + + integer, public :: & + irgm_bt = 0, & + irgm_ma = 0, & + irgm_sd = 0, & + irgm_sd_morr = 0, & + irgm_ta = 0, & + irgm_mc = 0, & + irgm_hf = 0, & + irgm_wvhf = 0, & + irgm_cl = 0 + +!$omp threadprivate(irgm_bt, irgm_ma, irgm_sd, irgm_sd_morr) +!$omp threadprivate(irgm_ta, irgm_mc) +!$omp threadprivate(irgm_hf, irgm_wvhf, irgm_cl) + + integer, public :: & + irim_bt = 0, & + irim_ma = 0, & + irim_sd = 0, & + irim_sd_mg_morr = 0, & + irim_ta = 0, & + irim_mc = 0, & + irim_hf = 0, & + irim_wvhf = 0, & + irim_cl = 0 + +!$omp threadprivate(irim_bt, irim_ma, irim_sd, irim_sd_mg_morr, irim_ta) +!$omp threadprivate(irim_mc, irim_hf, irim_wvhf, irim_cl) + + integer, public :: & + iNsm_bt = 0, & + iNsm_ma = 0, & + iNsm_sd = 0, & + iNsm_ta = 0, & + iNsm_mc = 0, & + iNsm_cl = 0 + +!$omp threadprivate(iNsm_bt, iNsm_ma, iNsm_sd, iNsm_ta, & +!$omp iNsm_mc, iNsm_cl) + + integer, public :: & + iNgm_bt = 0, & + iNgm_ma = 0, & + iNgm_sd = 0, & + iNgm_ta = 0, & + iNgm_mc = 0, & + iNgm_cl = 0 + +!$omp threadprivate(iNgm_bt, iNgm_ma, iNgm_sd, & +!$omp iNgm_ta, iNgm_mc, iNgm_cl) + + integer, public :: & + iNim_bt = 0, & + iNim_ma = 0, & + iNim_sd = 0, & + iNim_ta = 0, & + iNim_mc = 0, & + iNim_cl = 0 + +!$omp threadprivate(iNim_bt, iNim_ma, iNim_sd, iNim_ta, & +!$omp iNim_mc, iNim_cl) + + integer, public :: & + iNcm_bt = 0, & + iNcm_ma = 0, & + iNcm_ta = 0, & + iNcm_mc = 0, & + iNcm_cl = 0, & + iNcm_act = 0 + +!$omp threadprivate(iNcm_bt, iNcm_ma, iNcm_ta, & +!$omp iNcm_mc, iNcm_cl, iNcm_act) + + ! Covariances between w, r_t, theta_l and KK microphysics tendencies. + ! Additionally, covariances between r_r and N_r and KK rain drop mean + ! volume radius. These are all calculated on thermodynamic grid levels. + integer, public :: & + iw_KK_evap_covar_zt = 0, & ! Covariance of w and KK evaporation tendency. + irt_KK_evap_covar_zt = 0, & ! Covariance of r_t and KK evaporation tendency. + ithl_KK_evap_covar_zt = 0, & ! Covariance of theta_l and KK evap. tendency. + iw_KK_auto_covar_zt = 0, & ! Covariance of w and KK autoconversion tendency. + irt_KK_auto_covar_zt = 0, & ! Covariance of r_t and KK autoconversion tendency. + ithl_KK_auto_covar_zt = 0, & ! Covariance of theta_l and KK autoconv. tendency. + iw_KK_accr_covar_zt = 0, & ! Covariance of w and KK accretion tendency. + irt_KK_accr_covar_zt = 0, & ! Covariance of r_t and KK accretion tendency. + ithl_KK_accr_covar_zt = 0, & ! Covariance of theta_l and KK accretion tendency. + irr_KK_mvr_covar_zt = 0, & ! Covariance of r_r and KK mean volume radius. + iNr_KK_mvr_covar_zt = 0, & ! Covariance of N_r and KK mean volume radius. + iKK_mvr_variance_zt = 0 ! Variance of KK rain drop mean volume radius. + +!$omp threadprivate( iw_KK_evap_covar_zt, irt_KK_evap_covar_zt, & +!$omp ithl_KK_evap_covar_zt, iw_KK_auto_covar_zt, irt_KK_auto_covar_zt, & +!$omp ithl_KK_auto_covar_zt, iw_KK_accr_covar_zt, irt_KK_accr_covar_zt, & +!$omp ithl_KK_accr_covar_zt, irr_KK_mvr_covar_zt, iNr_KK_mvr_covar_zt, & +!$omp iKK_mvr_variance_zt ) + + ! Wind budgets + integer, public :: & + ivm_bt = 0, & + ivm_ma = 0, & + ivm_ta = 0, & + ivm_gf = 0, & + ivm_cf = 0, & + ivm_f = 0, & + ivm_sdmp = 0, & + ivm_ndg = 0 + +!$omp threadprivate(ivm_bt, ivm_ma, ivm_ta, ivm_gf, ivm_cf, ivm_f, ivm_sdmp, ivm_ndg) + + integer, public :: & + ium_bt = 0, & + ium_ma = 0, & + ium_ta = 0, & + ium_gf = 0, & + ium_cf = 0, & + ium_f = 0, & + ium_sdmp = 0, & + ium_ndg = 0 + +!$omp threadprivate(ium_bt, ium_ma, ium_ta, ium_gf, ium_cf, ium_f, ium_sdmp, ium_ndg) + + + ! PDF parameters + integer, public :: & + imixt_frac = 0, & + iw_1 = 0, & + iw_2 = 0, & + ivarnce_w_1 = 0, & + ivarnce_w_2 = 0, & + ithl_1 = 0, & + ithl_2 = 0, & + ivarnce_thl_1 = 0, & + ivarnce_thl_2 = 0, & + irt_1 = 0, & + irt_2 = 0, & + ivarnce_rt_1 = 0, & + ivarnce_rt_2 = 0, & + irc_1 = 0, & + irc_2 = 0, & + irsatl_1 = 0, & + irsatl_2 = 0, & + icloud_frac_1 = 0, & + icloud_frac_2 = 0 +!$omp threadprivate(imixt_frac, iw_1, iw_2, ivarnce_w_1, ivarnce_w_2, ithl_1, ithl_2, & +!$omp ivarnce_thl_1, ivarnce_thl_2, irt_1, irt_2, ivarnce_rt_1, ivarnce_rt_2, irc_1, irc_2, & +!$omp irsatl_1, irsatl_2, icloud_frac_1, icloud_frac_2 ) + + integer, public :: & + ichi_1 = 0, & + ichi_2 = 0, & + istdev_chi_1 = 0, & + istdev_chi_2 = 0, & + ichip2 = 0, & + istdev_eta_1 = 0, & + istdev_eta_2 = 0, & + icovar_chi_eta_1 = 0, & + icovar_chi_eta_2 = 0, & + icorr_chi_eta_1 = 0, & + icorr_chi_eta_2 = 0, & + irrtthl = 0, & + icrt_1 = 0, & + icrt_2 = 0, & + icthl_1 = 0, & + icthl_2 = 0 +!$omp threadprivate( ichi_1, ichi_2, istdev_chi_1, istdev_chi_2, ichip2, & +!$omp istdev_eta_1, istdev_eta_2, icovar_chi_eta_1, icovar_chi_eta_2, & +!$omp icorr_chi_eta_1, icorr_chi_eta_2, irrtthl, icrt_1, icrt_2, icthl_1, & +!$omp icthl_2 ) + + integer, public :: & + iwp2_zt = 0, & + ithlp2_zt = 0, & + iwpthlp_zt = 0, & + iwprtp_zt = 0, & + irtp2_zt = 0, & + irtpthlp_zt = 0, & + iup2_zt = 0, & + ivp2_zt = 0, & + iupwp_zt = 0, & + ivpwp_zt = 0 + +!$omp threadprivate( iwp2_zt, ithlp2_zt, iwpthlp_zt, iwprtp_zt, irtp2_zt, & +!$omp irtpthlp_zt, iup2_zt, ivp2_zt, iupwp_zt, ivpwp_zt ) + + integer, dimension(:), allocatable, public :: & + iwp2hmp + +!$omp threadprivate( iwp2hmp ) + + integer, dimension(:), allocatable, public :: & + ihydrometp2, & + iwphydrometp, & + irtphmp, & + ithlphmp + +!$omp threadprivate( ihydrometp2, iwphydrometp, irtphmp, ithlphmp ) + + integer, dimension(:,:), allocatable, public :: & + ihmxphmyp + +!$omp threadprivate( ihmxphmyp ) + + integer, dimension(:), allocatable, public :: & + ihmp2_zt + +!$omp threadprivate( ihmp2_zt ) + + integer, public :: & + ichi = 0 +!$omp threadprivate(ichi) + + integer, target, allocatable, dimension(:), public :: & + isclrm, & ! Passive scalar mean (1) + isclrm_f ! Passive scalar forcing (1) +!$omp threadprivate(isclrm, isclrm_f) + +! Used to calculate clear-sky radiative fluxes. + integer, public :: & + ifulwcl = 0, ifdlwcl = 0, ifdswcl = 0, ifuswcl = 0 + +!$omp threadprivate( ifulwcl, ifdlwcl, ifdswcl, ifuswcl ) + + integer, target, allocatable, dimension(:), public :: & + iedsclrm, & ! Eddy-diff. scalar term (1) + iedsclrm_f ! Eddy-diffusivity scalar forcing (1) + +!$omp threadprivate(iedsclrm, iedsclrm_f) + + integer, public :: & + ilh_thlm_mc = 0, & ! Latin hypercube estimate of thlm_mc + ilh_rvm_mc = 0, & ! Latin hypercube estimate of rvm_mc + ilh_rcm_mc = 0, & ! Latin hypercube estimate of rcm_mc + ilh_Ncm_mc = 0, & ! Latin hypercube estimate of Ncm_mc + ilh_rrm_mc = 0, & ! Latin hypercube estimate of rrm_mc + ilh_Nrm_mc = 0, & ! Latin hypercube estimate of Nrm_mc + ilh_rsm_mc = 0, & ! Latin hypercube estimate of rsm_mc + ilh_Nsm_mc = 0, & ! Latin hypercube estimate of Nsm_mc + ilh_rgm_mc = 0, & ! Latin hypercube estimate of rgm_mc + ilh_Ngm_mc = 0, & ! Latin hypercube estimate of Ngm_mc + ilh_rim_mc = 0, & ! Latin hypercube estimate of rim_mc + ilh_Nim_mc = 0 ! Latin hypercube estimate of Nim_mc +!$omp threadprivate( ilh_thlm_mc, ilh_rvm_mc, ilh_rcm_mc, ilh_Ncm_mc, & +!$omp ilh_rrm_mc, ilh_Nrm_mc, ilh_rsm_mc, ilh_Nsm_mc, & +!$omp ilh_rgm_mc, ilh_Ngm_mc, ilh_rim_mc, ilh_Nim_mc ) + + integer, public :: & + ilh_rrm_auto = 0, & ! Latin hypercube estimate of autoconversion + ilh_rrm_accr = 0, & ! Latin hypercube estimate of accretion + ilh_rrm_evap = 0, & ! Latin hypercube estimate of evaporation + ilh_Nrm_auto = 0, & ! Latin hypercube estimate of Nrm autoconversion + ilh_Nrm_cond = 0, & ! Latin hypercube estimate of Nrm evaporation + ilh_m_vol_rad_rain = 0, & + ilh_rrm_mc_nonadj = 0 + +!$omp threadprivate( ilh_rrm_auto, ilh_rrm_accr, ilh_rrm_evap, & +!$omp ilh_Nrm_auto, ilh_Nrm_cond, ilh_m_vol_rad_rain, & +!$omp ilh_rrm_mc_nonadj ) + + integer, public :: & + ilh_rrm_src_adj = 0, & ! Latin hypercube estimate of source adjustment (KK only!) + ilh_rrm_cond_adj = 0, & ! Latin hypercube estimate of evap adjustment (KK only!) + ilh_Nrm_src_adj = 0, & ! Latin hypercube estimate of Nrm source adjustmet (KK only!) + ilh_Nrm_cond_adj = 0 ! Latin hypercube estimate of Nrm evap adjustment (KK only!) +!$omp threadprivate( ilh_rrm_src_adj, ilh_rrm_cond_adj, ilh_Nrm_src_adj, & +!$omp ilh_Nrm_cond_adj ) + + integer, public :: & + ilh_Vrr = 0, & ! Latin hypercube estimate of rrm sedimentation velocity + ilh_VNr = 0 ! Latin hypercube estimate of Nrm sedimentation velocity +!$omp threadprivate(ilh_Vrr, ilh_VNr) + + integer, public :: & + ilh_rrm = 0, & + ilh_Nrm = 0, & + ilh_rim = 0, & + ilh_Nim = 0, & + ilh_rsm = 0, & + ilh_Nsm = 0, & + ilh_rgm = 0, & + ilh_Ngm = 0, & + ilh_thlm = 0, & + ilh_rcm = 0, & + ilh_Ncm = 0, & + ilh_Ncnm = 0, & + ilh_rvm = 0, & + ilh_wm = 0, & + ilh_cloud_frac = 0, & + ilh_chi = 0, & + ilh_eta = 0, & + ilh_precip_frac = 0, & + ilh_mixt_frac = 0 + +!$omp threadprivate(ilh_rrm, ilh_Nrm, ilh_rim, ilh_Nim, ilh_rsm, ilh_Nsm, & +!$omp ilh_rgm, ilh_Ngm, & +!$omp ilh_thlm, ilh_rcm, ilh_Ncm, ilh_Ncnm, ilh_rvm, ilh_wm, ilh_cloud_frac, & +!$omp ilh_chi, ilh_eta, ilh_precip_frac, ilh_mixt_frac ) + + integer, public :: & + ilh_cloud_frac_unweighted = 0, & + ilh_precip_frac_unweighted = 0, & + ilh_mixt_frac_unweighted = 0 + +!$omp threadprivate( ilh_cloud_frac_unweighted, ilh_precip_frac_unweighted, & +!$omp ilh_mixt_frac_unweighted ) + + integer, public :: & + ilh_wp2_zt = 0, & + ilh_Nrp2_zt = 0, & + ilh_Ncnp2_zt = 0, & + ilh_Ncp2_zt = 0, & + ilh_rcp2_zt = 0, & + ilh_rtp2_zt = 0, & + ilh_thlp2_zt = 0, & + ilh_rrp2_zt = 0, & + ilh_chip2 = 0 ! Eric Raut +!$omp threadprivate( ilh_wp2_zt, ilh_Nrp2_zt, ilh_Ncnp2_zt, ilh_Ncp2_zt, & +!$omp ilh_rcp2_zt, ilh_rtp2_zt, ilh_thlp2_zt, ilh_rrp2_zt, ilh_chip2 ) + + ! SILHS covariance estimate indicies + integer, public :: & + ilh_rtp2_mc = 0, & + ilh_thlp2_mc = 0, & + ilh_wprtp_mc = 0, & + ilh_wpthlp_mc = 0, & + ilh_rtpthlp_mc = 0 + + !$omp threadprivate( ilh_rtp2_mc, ilh_thlp2_mc, ilh_wprtp_mc, ilh_wpthlp_mc, ilh_rtpthlp_mc ) + + ! Indices for Morrison budgets + integer, public :: & + iPSMLT = 0, & + iEVPMS = 0, & + iPRACS = 0, & + iEVPMG = 0, & + iPRACG = 0, & + iPGMLT = 0, & + iMNUCCC = 0, & + iPSACWS = 0, & + iPSACWI = 0, & + iQMULTS = 0, & + iQMULTG = 0, & + iPSACWG = 0, & + iPGSACW = 0, & + iPRD = 0, & + iPRCI = 0, & + iPRAI = 0, & + iQMULTR = 0, & + iQMULTRG = 0, & + iMNUCCD = 0, & + iPRACI = 0, & + iPRACIS = 0, & + iEPRD = 0, & + iMNUCCR = 0, & + iPIACR = 0, & + iPIACRS = 0, & + iPGRACS = 0, & + iPRDS = 0, & + iEPRDS = 0, & + iPSACR = 0, & + iPRDG = 0, & + iEPRDG = 0 + +!$omp threadprivate( iPSMLT, iEVPMS, iPRACS, iEVPMG, iPRACG, iPGMLT, iMNUCCC, iPSACWS, iPSACWI, & +!$omp iQMULTS, iQMULTG, iPSACWG, iPGSACW, iPRD, iPRCI, iPRAI, iQMULTR, & +!$omp iQMULTRG, iMNUCCD, iPRACI, iPRACIS, iEPRD, iMNUCCR, iPIACR, iPIACRS, & +!$omp iPGRACS, iPRDS, iEPRDS, iPSACR, iPRDG, iEPRDG ) + + ! More indices for Morrison budgets!! + integer, public :: & + iNGSTEN = 0, & + iNRSTEN = 0, & + iNISTEN = 0, & + iNSSTEN = 0, & + iNCSTEN = 0, & + iNPRC1 = 0, & + iNRAGG = 0, & + iNPRACG = 0, & + iNSUBR = 0, & + iNSMLTR = 0, & + iNGMLTR = 0, & + iNPRACS = 0, & + iNNUCCR = 0, & + iNIACR = 0, & + iNIACRS = 0, & + iNGRACS = 0, & + iNSMLTS = 0, & + iNSAGG = 0, & + iNPRCI = 0, & + iNSCNG = 0, & + iNSUBS = 0, & + iPRC = 0, & + iPRA = 0, & + iPRE = 0 + +!$omp threadprivate( iNGSTEN, iNRSTEN, iNISTEN, iNSSTEN, iNCSTEN, iNPRC1, iNRAGG, & +!$omp iNPRACG, iNSUBR, iNSMLTR, iNGMLTR, iNPRACS, iNNUCCR, iNIACR, & +!$omp iNIACRS, iNGRACS, iNSMLTS, iNSAGG, iNPRCI, iNSCNG, iNSUBS, iPRC, iPRA, iPRE ) + + ! More indices for Morrison budgets!! + integer, public :: & + iPCC = 0, & + iNNUCCC = 0, & + iNPSACWS = 0, & + iNPRA = 0, & + iNPRC = 0, & + iNPSACWI = 0, & + iNPSACWG = 0, & + iNPRAI = 0, & + iNMULTS = 0, & + iNMULTG = 0, & + iNMULTR = 0, & + iNMULTRG = 0, & + iNNUCCD = 0, & + iNSUBI = 0, & + iNGMLTG = 0, & + iNSUBG = 0, & + iNACT = 0 + + integer, public :: & + iSIZEFIX_NR = 0, & + iSIZEFIX_NC = 0, & + iSIZEFIX_NI = 0, & + iSIZEFIX_NS = 0, & + iSIZEFIX_NG = 0, & + iNEGFIX_NR = 0, & + iNEGFIX_NC = 0, & + iNEGFIX_NI = 0, & + iNEGFIX_NS = 0, & + iNEGFIX_NG = 0, & + iNIM_MORR_CL = 0, & + iQC_INST = 0, & + iQR_INST = 0, & + iQI_INST = 0, & + iQS_INST = 0, & + iQG_INST = 0, & + iNC_INST = 0, & + iNR_INST = 0, & + iNI_INST = 0, & + iNS_INST = 0, & + iNG_INST = 0, & + iT_in_K_mc = 0, & + ihl_on_Cp_residual = 0, & + iqto_residual = 0 + +!$omp threadprivate(iPCC, iNNUCCC, iNPSACWS, iNPRA, iNPRC, iNPSACWI, iNPSACWG, iNPRAI, & +!$omp iNMULTS, iNMULTG, iNMULTR, iNMULTRG, iNNUCCD, iNSUBI, iNGMLTG, iNSUBG, iNACT, & +!$omp iSIZEFIX_NR, iSIZEFIX_NC, iSIZEFIX_NI, iSIZEFIX_NS, iSIZEFIX_NG, iNEGFIX_NR, & +!$omp iNEGFIX_NC, iNEGFIX_NI, iNEGFIX_NS, iNEGFIX_NG, iNIM_MORR_CL, iQC_INST, iQR_INST, & +!$omp iQI_INST, iQS_INST, iQG_INST, iNC_INST, iNR_INST, iNI_INST, iNS_INST, & +!$omp iNG_INST, iT_in_K_mc, ihl_on_Cp_residual, iqto_residual ) + + ! Indices for statistics in stats_zm file + integer, public :: & + iwp2 = 0, & + irtp2 = 0, & + ithlp2 = 0, & + irtpthlp = 0, & + iwprtp = 0, & + iwpthlp = 0, & + iwp4 = 0, & + iwpthvp = 0, & + irtpthvp = 0, & + ithlpthvp = 0, & + itau_zm = 0, & + iKh_zm = 0, & + iwprcp = 0, & + irc_coef = 0, & + ithlprcp = 0, & + irtprcp = 0, & + ircp2 = 0, & + iupwp = 0, & + ivpwp = 0, & + iSkw_zm = 0, & + iSkthl_zm = 0, & + iSkrt_zm = 0 + + integer, public :: & + irho_zm = 0, & + isigma_sqd_w = 0, & + irho_ds_zm = 0, & + ithv_ds_zm = 0, & + iem = 0, & + ishear = 0, & ! Brian + imean_w_up = 0, & + imean_w_down = 0, & + iFrad = 0, & + iFrad_LW = 0, & ! Brian + iFrad_SW = 0, & ! Brian + iFrad_LW_up = 0, & + iFrad_SW_up = 0, & + iFrad_LW_down = 0, & + iFrad_SW_down = 0, & + iFprec = 0, & ! Brian + iFcsed = 0 ! Brian + + ! Stability correction applied to Kh_N2_zm (diffusion on rtm and thlm) + integer, public :: & + istability_correction = 0 ! schemena + +!$omp threadprivate(istability_correction) +!$omp threadprivate(iwp2, irtp2, ithlp2, irtpthlp, iwprtp, iwpthlp) +!$omp threadprivate(iwp4, iwpthvp, irtpthvp, ithlpthvp, itau_zm, iKh_zm) +!$omp threadprivate(iwprcp, irc_coef, ithlprcp, irtprcp, ircp2, iupwp, ivpwp) +!$omp threadprivate(iSkw_zm, iSkthl_zm, iSkrt_zm) +!$omp threadprivate(irho_zm, isigma_sqd_w, irho_ds_zm, ithv_ds_zm, iem, ishear) +!$omp threadprivate(imean_w_up, imean_w_down) +!$omp threadprivate(iFrad, iFrad_LW, iFrad_SW, iFrad_SW_up, iFrad_SW_down) +!$omp threadprivate(iFrad_LW_up, iFrad_LW_down, iFprec, iFcsed) + + integer, dimension(:), allocatable, public :: & + iK_hm +!$omp threadprivate(iK_hm) + + ! Skewness Functions on stats_zm grid + integer, public :: & + igamma_Skw_fnc = 0, & + iC6rt_Skw_fnc = 0, & + iC6thl_Skw_fnc = 0, & + iC7_Skw_fnc = 0, & + iC1_Skw_fnc = 0, & + ibrunt_vaisala_freq_sqd = 0, & + iRichardson_num = 0 + +!$omp threadprivate(igamma_Skw_fnc, iC6rt_Skw_fnc, iC6thl_Skw_fnc) +!$omp threadprivate(iC7_Skw_fnc, iC1_Skw_fnc) + + ! Covariance of w and cloud droplet concentration, < w'N_c' > + integer, public :: & + iwpNcp = 0 + +!$omp threadprivate( iwpNcp ) + + ! Sedimentation velocities + integer, public :: & + iVNr = 0, & + iVrr = 0, & + iVNc = 0, & + iVrc = 0, & + iVNs = 0, & + iVrs = 0, & + iVNi = 0, & + iVri = 0, & + iVrg = 0 + +!$omp threadprivate(iVNr, iVrr, iVNc, iVrc, iVNs, iVrs, iVNi, iVri, iVrg) + + ! Covariance of sedimentation velocity and hydrometeor, . + integer, public :: & + iVrrprrp = 0, & + iVNrpNrp = 0, & + iVrrprrp_expcalc = 0, & + iVNrpNrp_expcalc = 0 + +!$omp threadprivate(iVrrprrp, iVNrpNrp, iVrrprrp_expcalc, iVNrpNrp_expcalc) + + integer, public :: & + iwp2_bt = 0, & + iwp2_ma = 0, & + iwp2_ta = 0, & + iwp2_ac = 0, & + iwp2_bp = 0, & + iwp2_pr1 = 0, & + iwp2_pr2 = 0, & + iwp2_pr3 = 0, & + iwp2_dp1 = 0, & + iwp2_dp2 = 0, & + iwp2_pd = 0, & + iwp2_cl = 0, & + iwp2_sf = 0 + +!$omp threadprivate(iwp2_bt, iwp2_ma, iwp2_ta, iwp2_ac, iwp2_bp) +!$omp threadprivate(iwp2_pr1, iwp2_pr2, iwp2_pr3) +!$omp threadprivate(iwp2_dp1, iwp2_dp2) +!$omp threadprivate(iwp2_pd, iwp2_cl, iwp2_sf) + + integer, public :: & + iwprtp_bt = 0, & + iwprtp_ma = 0, & + iwprtp_ta = 0, & + iwprtp_tp = 0, & + iwprtp_ac = 0, & + iwprtp_bp = 0, & + iwprtp_pr1 = 0, & + iwprtp_pr2 = 0, & + iwprtp_pr3 = 0, & + iwprtp_dp1 = 0, & + iwprtp_mfl = 0, & + iwprtp_cl = 0, & + iwprtp_sicl = 0, & + iwprtp_pd = 0, & + iwprtp_forcing = 0, & + iwprtp_mc = 0 + +!$omp threadprivate(iwprtp_bt, iwprtp_ma, iwprtp_ta, iwprtp_tp) +!$omp threadprivate(iwprtp_ac, iwprtp_bp, iwprtp_pr1, iwprtp_pr2) +!$omp threadprivate(iwprtp_pr3, iwprtp_dp1, iwprtp_mfl, iwprtp_cl) +!$omp threadprivate(iwprtp_sicl, iwprtp_pd, iwprtp_forcing, iwprtp_mc) + + integer, public :: & + iwpthlp_bt = 0, & + iwpthlp_ma = 0, & + iwpthlp_ta = 0, & + iwpthlp_tp = 0, & + iwpthlp_ac = 0, & + iwpthlp_bp = 0, & + iwpthlp_pr1 = 0, & + iwpthlp_pr2 = 0, & + iwpthlp_pr3 = 0, & + iwpthlp_dp1 = 0, & + iwpthlp_mfl = 0, & + iwpthlp_cl = 0, & + iwpthlp_sicl = 0, & + iwpthlp_forcing = 0, & + iwpthlp_mc = 0 + +!$omp threadprivate(iwpthlp_bt, iwpthlp_ma, iwpthlp_ta, iwpthlp_tp) +!$omp threadprivate(iwpthlp_ac, iwpthlp_bp, iwpthlp_pr1, iwpthlp_pr2) +!$omp threadprivate(iwpthlp_pr3, iwpthlp_dp1, iwpthlp_mfl, iwpthlp_cl) +!$omp threadprivate(iwpthlp_sicl, iwpthlp_forcing, iwpthlp_mc) + +! Dr. Golaz's new variance budget terms +! qt was changed to rt to avoid confusion + + integer, public :: & + irtp2_bt = 0, & + irtp2_ma = 0, & + irtp2_ta = 0, & + irtp2_tp = 0, & + irtp2_dp1 = 0, & + irtp2_dp2 = 0, & + irtp2_pd = 0, & + irtp2_cl = 0, & + irtp2_sf = 0, & + irtp2_forcing = 0, & + irtp2_mc = 0 + +!$omp threadprivate(irtp2_bt, irtp2_ma, irtp2_ta, irtp2_tp, irtp2_dp1) +!$omp threadprivate(irtp2_dp2, irtp2_pd, irtp2_cl, irtp2_sf, irtp2_forcing) +!$omp threadprivate(irtp2_mc) + + integer, public :: & + ithlp2_bt = 0, & + ithlp2_ma = 0, & + ithlp2_ta = 0, & + ithlp2_tp = 0, & + ithlp2_dp1 = 0, & + ithlp2_dp2 = 0, & + ithlp2_pd = 0, & + ithlp2_cl = 0, & + ithlp2_sf = 0, & + ithlp2_forcing = 0, & + ithlp2_mc = 0 + +!$omp threadprivate(ithlp2_bt, ithlp2_ma, ithlp2_ta, ithlp2_tp, ithlp2_dp1) +!$omp threadprivate(ithlp2_dp2, ithlp2_pd, ithlp2_cl, ithlp2_sf) +!$omp threadprivate(ithlp2_forcing, ithlp2_mc) + + integer, public :: & + irtpthlp_bt = 0, & + irtpthlp_ma = 0, & + irtpthlp_ta = 0, & + irtpthlp_tp1 = 0, & + irtpthlp_tp2 = 0, & + irtpthlp_dp1 = 0, & + irtpthlp_dp2 = 0, & + irtpthlp_cl = 0, & + irtpthlp_sf = 0, & + irtpthlp_forcing = 0, & + irtpthlp_mc = 0 + +!$omp threadprivate(irtpthlp_bt, irtpthlp_ma, irtpthlp_ta) +!$omp threadprivate(irtpthlp_tp1, irtpthlp_tp2, irtpthlp_dp1) +!$omp threadprivate(irtpthlp_dp2, irtpthlp_cl, irtpthlp_sf, irtpthlp_forcing) +!$omp threadprivate(irtpthlp_mc) + + integer, public :: & + iup2 = 0, & + ivp2 = 0 + +!$omp threadprivate(iup2, ivp2) + + integer, public :: & + iup2_bt = 0, & + iup2_ta = 0, & + iup2_tp = 0, & + iup2_ma = 0, & + iup2_dp1 = 0, & + iup2_dp2 = 0, & + iup2_pr1 = 0, & + iup2_pr2 = 0, & + iup2_pd = 0, & + iup2_cl = 0, & + iup2_sf = 0, & + ivp2_bt = 0, & + ivp2_ta = 0, & + ivp2_tp = 0, & + ivp2_ma = 0, & + ivp2_dp1 = 0, & + ivp2_dp2 = 0, & + ivp2_pr1 = 0, & + ivp2_pr2 = 0, & + ivp2_pd = 0, & + ivp2_cl = 0, & + ivp2_sf = 0 + +!$omp threadprivate(iup2_bt, iup2_ta, iup2_tp, iup2_ma, iup2_dp1) +!$omp threadprivate(iup2_dp2, iup2_pr1, iup2_pr2, iup2_cl, iup2_sf) +!$omp threadprivate(ivp2_bt, ivp2_ta, ivp2_tp, ivp2_ma, ivp2_dp1) +!$omp threadprivate(ivp2_dp2, ivp2_pr1, ivp2_pr2, ivp2_cl) +!$omp threadprivate(iup2_pd, ivp2_pd, ivp2_sf) + +! Passive scalars. Note that floating point roundoff may make +! mathematically equivalent variables different values. + integer,target, allocatable, dimension(:), public :: & + isclrprtp, & ! sclr'(1)rt' / rt'^2 + isclrp2, & ! sclr'(1)^2 / rt'^2 + isclrpthvp, & ! sclr'(1)th_v' / rt'th_v' + isclrpthlp, & ! sclr'(1)th_l' / rt'th_l' + isclrprcp, & ! sclr'(1)rc' / rt'rc' + iwpsclrp, & ! w'slcr'(1) / w'rt' + iwp2sclrp, & ! w'^2 sclr'(1) / w'^2 rt' + iwpsclrp2, & ! w'sclr'(1)^2 / w'rt'^2 + iwpsclrprtp, & ! w'sclr'(1)rt' / w'rt'^2 + iwpsclrpthlp ! w'sclr'(1)th_l' / w'rt'th_l' + +!$omp threadprivate(isclrprtp, isclrp2, isclrpthvp, isclrpthlp) +!$omp threadprivate(isclrprcp, iwpsclrp, iwp2sclrp, iwpsclrp2) +!$omp threadprivate(iwpsclrprtp, iwpsclrpthlp) + + integer, target, allocatable, dimension(:), public :: & + iwpedsclrp ! eddy sclr'(1)w' + +!$omp threadprivate(iwpedsclrp) + + ! Indices for statistics in stats_rad_zt file + integer, public :: & + iT_in_K_rad = 0, & + ircil_rad = 0, & + io3l_rad = 0, & + irsm_rad = 0, & + ircm_in_cloud_rad = 0, & + icloud_frac_rad = 0, & + iice_supersat_frac_rad = 0, & + iradht_rad = 0, & + iradht_LW_rad = 0, & + iradht_SW_rad = 0, & + ip_in_mb_rad = 0, & + isp_humidity_rad = 0 + +!$omp threadprivate( iT_in_K_rad, ircil_rad, io3l_rad, & +!$omp irsm_rad, ircm_in_cloud_rad, icloud_frac_rad, & +!$omp iice_supersat_frac_rad, & +!$omp iradht_rad, iradht_LW_rad, iradht_SW_rad, & +!$omp ip_in_mb_rad, isp_humidity_rad ) + + ! Indices for statistics in stats_rad_zm file + integer, public :: & + iFrad_LW_rad = 0, & + iFrad_SW_rad = 0, & + iFrad_SW_up_rad = 0, & + iFrad_LW_up_rad = 0, & + iFrad_SW_down_rad = 0, & + iFrad_LW_down_rad = 0 + +!$omp threadprivate(iFrad_LW_rad, iFrad_SW_rad, iFrad_SW_up_rad) +!$omp threadprivate(iFrad_LW_up_rad, iFrad_SW_down_rad, iFrad_LW_down_rad) + + ! Indices for statistics in stats_sfc file + + integer, public :: & + iustar = 0, & + isoil_heat_flux = 0,& + iveg_T_in_K = 0,& + isfc_soil_T_in_K = 0, & + ideep_soil_T_in_K = 0,& + ilh = 0, & + ish = 0, & + icc = 0, & + ilwp = 0, & + ivwp = 0, & ! nielsenb + iiwp = 0, & ! nielsenb + iswp = 0, & ! nielsenb + irwp = 0, & + iz_cloud_base = 0, & + iz_inversion = 0, & + iprecip_rate_sfc = 0, & ! Brian + irain_flux_sfc = 0, & ! Brian + irrm_sfc = 0, & ! Brian + iwpthlp_sfc = 0, & + iprecip_frac_tol = 0 +!$omp threadprivate(iustar, isoil_heat_flux, iveg_T_in_K, isfc_soil_T_in_K, ideep_soil_T_in_K, & +!$omp ilh, ish, icc, ilwp, ivwp, iiwp, iswp, irwp, iz_cloud_base, iz_inversion, & +!$omp iprecip_rate_sfc, irain_flux_sfc, irrm_sfc, & +!$omp iwpthlp_sfc, iprecip_frac_tol ) + + integer, public :: & + iwprtp_sfc = 0, & + iupwp_sfc = 0, & + ivpwp_sfc = 0, & + ithlm_vert_avg = 0, & + irtm_vert_avg = 0, & + ium_vert_avg = 0, & + ivm_vert_avg = 0, & + iwp2_vert_avg = 0, & ! nielsenb + iup2_vert_avg = 0, & + ivp2_vert_avg = 0, & + irtp2_vert_avg = 0, & + ithlp2_vert_avg = 0, & + iT_sfc ! kcwhite +!$omp threadprivate(iwprtp_sfc, iupwp_sfc, ivpwp_sfc, & +!$omp ithlm_vert_avg, irtm_vert_avg, ium_vert_avg, ivm_vert_avg, & +!$omp iwp2_vert_avg, iup2_vert_avg, ivp2_vert_avg, irtp2_vert_avg, ithlp2_vert_avg, iT_sfc) + + integer, public :: & + iwp23_matrix_condt_num = 0, & + irtm_matrix_condt_num = 0, & + ithlm_matrix_condt_num = 0, & + irtp2_matrix_condt_num = 0, & + ithlp2_matrix_condt_num = 0, & + irtpthlp_matrix_condt_num = 0, & + iup2_vp2_matrix_condt_num = 0, & + iwindm_matrix_condt_num = 0 +!$omp threadprivate(iwp23_matrix_condt_num, irtm_matrix_condt_num, ithlm_matrix_condt_num, & +!$omp irtp2_matrix_condt_num, ithlp2_matrix_condt_num, irtpthlp_matrix_condt_num, & +!$omp iup2_vp2_matrix_condt_num, iwindm_matrix_condt_num) + + integer, public :: & + imorr_snow_rate = 0 + +!$omp threadprivate( imorr_snow_rate) + + integer, public :: & + irtm_spur_src = 0, & + ithlm_spur_src = 0 + +!$omp threadprivate(irtm_spur_src, ithlm_spur_src) + + integer, public :: & + iSkw_velocity = 0, & ! Skewness velocity + iwp3_zm = 0, & + ithlp3_zm = 0, & + irtp3_zm = 0, & + ia3_coef = 0, & + ia3_coef_zt = 0 +!$omp threadprivate(iSkw_velocity, iwp3_zm, ithlp3_zm, irtp3_zm, ia3_coef, ia3_coef_zt) + + integer, public :: & + iwp3_on_wp2 = 0, & ! w'^3 / w'^2 [m/s] + iwp3_on_wp2_zt = 0 ! w'^3 / w'^2 [m/s] +!$omp threadprivate(iwp3_on_wp2, iwp3_on_wp2_zt) + + integer, public :: & + ilh_morr_snow_rate = 0 +!$omp threadprivate( ilh_morr_snow_rate ) + + integer, public :: & + ilh_vwp = 0, & + ilh_lwp = 0 +!$omp threadprivate( ilh_vwp, ilh_lwp ) + + + integer, public :: & + icloud_frac_refined = 0, & + ircm_refined = 0 +!$omp threadprivate( icloud_frac_refined, ircm_refined ) + + integer, public :: & + irtp2_from_chi = 0 + +!$omp threadprivate( irtp2_from_chi ) + + ! Variables that contains all the statistics + + type (stats), target, public :: stats_zt, & ! stats_zt grid + stats_zm, & ! stats_zm grid + stats_lh_zt, & ! stats_lh_zt grid + stats_lh_sfc, & ! stats_lh_sfc grid + stats_rad_zt, & ! stats_rad_zt grid + stats_rad_zm, & ! stats_rad_zm grid + stats_sfc ! stats_sfc + +!$omp threadprivate(stats_zt, stats_zm, stats_lh_zt, stats_lh_sfc) +!$omp threadprivate(stats_rad_zt, stats_rad_zm, stats_sfc) + + ! Scratch space + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + ztscr01, ztscr02, ztscr03, & + ztscr04, ztscr05, ztscr06, & + ztscr07, ztscr08, ztscr09, & + ztscr10, ztscr11, ztscr12, & + ztscr13, ztscr14, ztscr15, & + ztscr16, ztscr17, ztscr18, & + ztscr19, ztscr20, ztscr21 + +!$omp threadprivate(ztscr01, ztscr02, ztscr03, ztscr04, ztscr05) +!$omp threadprivate(ztscr06, ztscr07, ztscr08, ztscr09, ztscr10) +!$omp threadprivate(ztscr11, ztscr12, ztscr13, ztscr14, ztscr15) +!$omp threadprivate(ztscr16, ztscr17, ztscr18, ztscr19, ztscr20) +!$omp threadprivate(ztscr21) + + real( kind = core_rknd ), dimension(:), allocatable, public :: & + zmscr01, zmscr02, zmscr03, & + zmscr04, zmscr05, zmscr06, & + zmscr07, zmscr08, zmscr09, & + zmscr10, zmscr11, zmscr12, & + zmscr13, zmscr14, zmscr15, & + zmscr16, zmscr17 + +!$omp threadprivate(zmscr01, zmscr02, zmscr03, zmscr04, zmscr05) +!$omp threadprivate(zmscr06, zmscr07, zmscr08, zmscr09, zmscr10) +!$omp threadprivate(zmscr11, zmscr12, zmscr13, zmscr14, zmscr15) +!$omp threadprivate(zmscr16, zmscr17) + +end module stats_variables diff --git a/src/physics/clubb/stats_zm_module.F90 b/src/physics/clubb/stats_zm_module.F90 new file mode 100644 index 0000000000..f013763fc7 --- /dev/null +++ b/src/physics/clubb/stats_zm_module.F90 @@ -0,0 +1,2203 @@ +!----------------------------------------------------------------------- +! $Id: stats_zm_module.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_zm_module + + implicit none + + private ! Default Scope + + public :: stats_init_zm + + ! Constant parameters + integer, parameter, public :: nvarmax_zm = 250 ! Maximum variables allowed + + contains + +!----------------------------------------------------------------------- + subroutine stats_init_zm( vars_zm, l_error ) + +! Description: +! Initializes array indices for stats_zm + +! Note: +! All code that is within subroutine stats_init_zm, including variable +! allocation code, is not called if l_stats is false. This subroutine is +! called only when l_stats is true. + +!----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + stats_zm, & + iwp2, & + irtp2, & + ithlp2, & + irtpthlp, & + iwprtp, & + iwpthlp, & + iwp3_zm, & + ithlp3_zm, & + irtp3_zm, & + iwp4, & + iwpthvp, & + irtpthvp, & + ithlpthvp, & + itau_zm, & + iKh_zm, & + iK_hm, & + iwprcp, & + irc_coef, & + ithlprcp, & + irtprcp, & + ircp2, & + iSkw_zm, & + iSkthl_zm, & + iSkrt_zm + + use stats_variables, only: & + iupwp, & + ivpwp, & + irho_zm, & + isigma_sqd_w, & + irho_ds_zm, & + ithv_ds_zm, & + iem, & + ishear, & + imean_w_up, & + imean_w_down, & + iFrad, & + iFrad_LW, & + iFrad_SW, & + iFrad_LW_up, & + iFrad_SW_up, & + iFrad_LW_down, & + iFrad_SW_down, & + iFprec, & + iFcsed, & + istability_correction + + use stats_variables, only: & + iup2, & + ivp2, & + iup2_bt, & + iup2_ta, & + iup2_tp, & + iup2_ma, & + iup2_dp1, & + iup2_dp2, & + iup2_pr1, & + iup2_pr2, & + iup2_cl, & + iup2_pd, & + iup2_sf, & + ivp2_bt, & + ivp2_ta, & + ivp2_tp, & + ivp2_ma, & + ivp2_dp1, & + ivp2_dp2, & + ivp2_pr1, & + ivp2_pr2, & + ivp2_cl, & + ivp2_pd, & + ivp2_sf + + use stats_variables, only: & + iwpNcp + + use stats_variables, only: & + iVNr, & + iVrr, & + iVNc, & + iVrc, & + iVNi, & + iVri, & + iVNs, & + iVrs, & + iVrg, & + iVrrprrp, & + iVNrpNrp, & + iVrrprrp_expcalc, & + iVNrpNrp_expcalc + + use stats_variables, only: & + iwp2_bt, & + iwp2_ma, & + iwp2_ta, & + iwp2_ac, & + iwp2_bp, & + iwp2_pr1, & + iwp2_pr2, & + iwp2_pr3, & + iwp2_dp1, & + iwp2_dp2, & + iwp2_cl, & + iwp2_pd, & + iwp2_sf + + use stats_variables, only: & + iwprtp_bt, & + iwprtp_ma, & + iwprtp_ta, & + iwprtp_tp, & + iwprtp_ac, & + iwprtp_bp, & + iwprtp_pr1, & + iwprtp_pr2, & + iwprtp_pr3, & + iwprtp_dp1, & + iwprtp_mfl, & + iwprtp_cl, & + iwprtp_sicl, & + iwprtp_pd, & + iwprtp_forcing, & + iwprtp_mc, & + iwpthlp_bt, & + iwpthlp_ma, & + iwpthlp_ta + + use stats_variables, only: & + iwpthlp_tp, & + iwpthlp_ac, & + iwpthlp_bp, & + iwpthlp_pr1, & + iwpthlp_pr2, & + iwpthlp_pr3, & + iwpthlp_dp1, & + iwpthlp_mfl, & + iwpthlp_cl, & + iwpthlp_sicl, & + iwpthlp_forcing, & + iwpthlp_mc + + use stats_variables, only: & + irtp2_bt, & + irtp2_ma, & + irtp2_ta, & + irtp2_tp, & + irtp2_dp1, & + irtp2_dp2, & + irtp2_cl, & + irtp2_pd, & + irtp2_sf, & + irtp2_forcing, & + irtp2_mc, & + ithlp2_bt, & + ithlp2_ma, & + ithlp2_ta, & + ithlp2_tp, & + ithlp2_dp1, & + ithlp2_dp2, & + ithlp2_cl, & + ithlp2_pd + + use stats_variables, only: & + ithlp2_sf, & + ithlp2_forcing, & + ithlp2_mc, & + irtpthlp_bt, & + irtpthlp_ma, & + irtpthlp_ta, & + irtpthlp_tp1, & + irtpthlp_tp2, & + irtpthlp_dp1, & + irtpthlp_dp2, & + irtpthlp_cl, & + irtpthlp_sf, & + irtpthlp_forcing, & + irtpthlp_mc + + use stats_variables, only: & + iwpthlp_entermfl, & ! Variable(s) + iwpthlp_exit_mfl, & + iwpthlp_mfl_min, & + iwpthlp_mfl_max, & + iwprtp_enter_mfl, & + iwprtp_exit_mfl, & + iwprtp_mfl_min, & + iwprtp_mfl_max + + use stats_variables, only: & + iwm_zm, & ! Variable + icloud_frac_zm, & + iice_supersat_frac_zm, & + ircm_zm, & + irtm_zm, & + ithlm_zm + + use stats_variables, only: & + isclrprtp, & + isclrp2, & + isclrpthvp, & + isclrpthlp, & + isclrprcp, & + iwpsclrp, & + iwp2sclrp, & + iwpsclrp2, & + iwpsclrprtp, & + iwpsclrpthlp, & + iwpedsclrp + + use stats_variables, only: & + ia3_coef, & + iwp3_on_wp2, & + iSkw_velocity, & + igamma_Skw_fnc, & + iC6rt_Skw_fnc, & + iC6thl_Skw_fnc, & + iC7_Skw_fnc, & + iC1_Skw_fnc, & + ibrunt_vaisala_freq_sqd, & + iRichardson_num, & + ihydrometp2, & + iwphydrometp, & + irtphmp, & + ithlphmp, & + ihmxphmyp + + use stats_variables, only: & + irtp2_from_chi + + use stats_variables, only: & + ilh_rtp2_mc, & + ilh_thlp2_mc, & + ilh_wprtp_mc, & + ilh_wpthlp_mc, & + ilh_rtpthlp_mc + + use stats_type_utilities, only: & + stat_assign ! Procedure + + use parameters_model, only: & + hydromet_dim, & ! Variable(s) + sclr_dim, & + edsclr_dim + + use array_index, only: & + hydromet_list, & ! Variable(s) + l_mix_rat_hm + + implicit none + + ! External + intrinsic :: trim + + ! Input Variable + character(len= * ), dimension(nvarmax_zm), intent(in) :: vars_zm ! stats_zm variable names + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: tot_zm_loops + + integer :: hm_idx, hmx_idx, hmy_idx + + character(len=10) :: hm_type, hmx_type, hmy_type + + integer :: i, j, k + + character(len=50) :: sclr_idx + + ! The default initialization for array indices for stats_zm is zero (see module + ! stats_variables) + + allocate( ihydrometp2(1:hydromet_dim) ) + allocate( iwphydrometp(1:hydromet_dim) ) + allocate( irtphmp(1:hydromet_dim) ) + allocate( ithlphmp(1:hydromet_dim) ) + allocate( ihmxphmyp(1:hydromet_dim,1:hydromet_dim) ) + allocate( iK_hm(1:hydromet_dim) ) + + ihydrometp2(:) = 0 + iwphydrometp(:) = 0 + irtphmp(:) = 0 + ithlphmp(:) = 0 + ihmxphmyp(:,:) = 0 + iK_hm(:) = 0 + + ! Allocate and then zero out passive scalar arrays on the stats_zm grid (fluxes, + ! variances and other high-order moments) + allocate(isclrprtp(1:sclr_dim)) + allocate(isclrp2(1:sclr_dim)) + allocate(isclrpthvp(1:sclr_dim)) + allocate(isclrpthlp(1:sclr_dim)) + allocate(isclrprcp(1:sclr_dim)) + allocate(iwpsclrp(1:sclr_dim)) + allocate(iwp2sclrp(1:sclr_dim)) + allocate(iwpsclrp2(1:sclr_dim)) + allocate(iwpsclrprtp(1:sclr_dim)) + allocate(iwpsclrpthlp(1:sclr_dim)) + + allocate(iwpedsclrp(1:edsclr_dim)) + + isclrprtp(:) = 0 + isclrp2(:) = 0 + isclrpthvp(:) = 0 + isclrpthlp(:) = 0 + isclrprcp(:) = 0 + iwpsclrp(:) = 0 + iwp2sclrp(:) = 0 + iwpsclrp2(:) = 0 + iwpsclrprtp(:) = 0 + iwpsclrpthlp(:) = 0 + + iwpedsclrp(:) = 0 + + ! Assign pointers for statistics variables stats_zm using stat_assign + + tot_zm_loops = stats_zm%num_output_fields + + if ( any( vars_zm == "hydrometp2" ) ) then + ! Correct for number of variables found under "hydrometp2". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "hydrometp2" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wphydrometp" ) ) then + ! Correct for number of variables found under "wphydrometp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "wphydrometp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "rtphmp" ) ) then + ! Correct for number of variables found under "rtphmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "rtphmp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "thlphmp" ) ) then + ! Correct for number of variables found under "thlphmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "thlphmp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "hmxphmyp" ) ) then + ! Correct for number of variables found under "hmxphmyp". + ! Subtract the number of overall covariances of two hydrometeors, which + ! is found by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! from the loop size. + tot_zm_loops = tot_zm_loops - hydromet_dim * ( hydromet_dim - 1 ) / 2 + ! Add 1 for "hmxphmyp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "K_hm" ) ) then + ! Correct for number of variables found under "K_hm". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zm_loops = tot_zm_loops - hydromet_dim + ! Add 1 for "K_hm" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "sclrprtp" ) ) then + ! Correct for number of variables found under "sclrprtp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "sclrprtp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "sclrp2" ) ) then + ! Correct for number of variables found under "sclrp2". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "sclrp2" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "sclrpthvp" ) ) then + ! Correct for number of variables found under "sclrpthvp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "sclrpthvp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "sclrpthlp" ) ) then + ! Correct for number of variables found under "sclrpthlp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "sclrpthlp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "sclrprcp" ) ) then + ! Correct for number of variables found under "sclrprcp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "sclrprcp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wpsclrp" ) ) then + ! Correct for number of variables found under "wpsclrp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "wpsclrp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wpsclrp2" ) ) then + ! Correct for number of variables found under "wpsclrp2". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "wpsclrp2" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wp2sclrp" ) ) then + ! Correct for number of variables found under "wp2sclrp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "wp2sclrp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wpsclrprtp" ) ) then + ! Correct for number of variables found under "wpsclrprtp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "wpsclrprtp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wpsclrpthlp" ) ) then + ! Correct for number of variables found under "wpsclrpthlp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - sclr_dim + ! Add 1 for "wpsclrpthlp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + if ( any( vars_zm == "wpedsclrp" ) ) then + ! Correct for number of variables found under "wpedsclrp". + ! Subtract 1 from the loop size for each scalar. + tot_zm_loops = tot_zm_loops - edsclr_dim + ! Add 1 for "wpedsclrp" to the loop size. + tot_zm_loops = tot_zm_loops + 1 + endif + + + + k = 1 + + do i = 1, tot_zm_loops + + select case ( trim( vars_zm(i) ) ) + + case ('wp2') + iwp2 = k + call stat_assign( var_index=iwp2, var_name="wp2", & + var_description="w'^2, Variance of vertical air velocity [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2') + irtp2 = k + call stat_assign( var_index=irtp2, var_name="rtp2", & + var_description="rt'^2, Variance of rt [(kg/kg)^2]", var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2') + ithlp2 = k + call stat_assign( var_index=ithlp2, var_name="thlp2", & + var_description="thl'^2, Variance of thl [K^2]", var_units="K^2", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthlp') + irtpthlp = k + call stat_assign( var_index=irtpthlp, var_name="rtpthlp", & + var_description="rt'thl', Covariance of rt and thl [(kg K)/kg]", & + var_units="(kg K)/kg", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp') + iwprtp = k + + call stat_assign( var_index=iwprtp, var_name="wprtp", & + var_description="w'rt', Vertical turbulent flux of rt [(kg/kg) m/s]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp') + iwpthlp = k + + call stat_assign( var_index=iwpthlp, var_name="wpthlp", & + var_description="w'thl', Vertical turbulent flux of thl [K m/s]", & + var_units="(m K)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp3_zm') + iwp3_zm = k + call stat_assign( var_index=iwp3_zm, var_name="wp3_zm", & + var_description="w'^3 interpolated to moment. levels [m^3/s^3]", & + var_units="(m^3)/(s^3)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp3_zm') + ithlp3_zm = k + call stat_assign( var_index=ithlp3_zm, var_name="thlp3_zm", & + var_description="thl'^3 interpolated to moment. levels [K^3]", & + var_units="K^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp3_zm') + irtp3_zm = k + call stat_assign( var_index=irtp3_zm, var_name="rtp3_zm", & + var_description="rt'^3 interpolated to moment. levels [kg^3/kg^3]", & + var_units="(kg^3)/(kg^3)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp4') + iwp4 = k + call stat_assign( var_index=iwp4, var_name="wp4", var_description="w'^4 [m^4/s^4]", & + var_units="(m^4)/(s^4)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthvp') + iwpthvp = k + call stat_assign( var_index=iwpthvp, var_name="wpthvp", & + var_description="Buoyancy flux [K m/s]", var_units="K m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthvp') + irtpthvp = k + call stat_assign( var_index=irtpthvp, var_name="rtpthvp", & + var_description="rt'thv' [(kg/kg) K]", var_units="(kg/kg) K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('thlpthvp') + ithlpthvp = k + call stat_assign( var_index=ithlpthvp, var_name="thlpthvp", & + var_description="thl'thv' [K^2]", var_units="K^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('tau_zm') + itau_zm = k + + call stat_assign( var_index=itau_zm, var_name="tau_zm", & + var_description="Time-scale tau on momentum levels [s]", var_units="s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Kh_zm') + iKh_zm = k + + call stat_assign( var_index=iKh_zm, var_name="Kh_zm", & + var_description="Eddy diffusivity on momentum levels [m^2/s]", var_units="m^2/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('K_hm') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iK_hm(hm_idx) = k + + + call stat_assign( var_index=iK_hm(hm_idx), & + var_name="K_hm_"//trim( hm_type(1:2) ), & + var_description="Eddy. diff. coef. of " & + // trim(hm_type(1:2)) & + // " [m^2/s]", & + var_units="[m^2/s]", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + end do + + + case ('wprcp') + iwprcp = k + call stat_assign( var_index=iwprcp, var_name="wprcp", & + var_description="w' rc' [(m/s) (kg/kg)]", var_units="(m/s) (kg/kg)", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rc_coef') + irc_coef = k + call stat_assign( var_index=irc_coef, var_name="rc_coef", & + var_description="Coefficient of X' R_l' in Eq. (34)", var_units="[-]", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlprcp') + ithlprcp = k + call stat_assign( var_index=ithlprcp, var_name="thlprcp", & + var_description="thl' rc' [K (kg/kg)]", var_units="K (kg/kg)", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rtprcp') + irtprcp = k + + call stat_assign( var_index=irtprcp, var_name="rtprcp", & + var_description="rt'rc' [(kg^2)/(kg^2)]", var_units="(kg^2)/(kg^2)", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rcp2') + ircp2 = k + call stat_assign( var_index=ircp2, var_name="rcp2", & + var_description="rc'^2 [(kg^2)/(kg^2)]", var_units="(kg^2)/(kg^2)", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('upwp') + iupwp = k + call stat_assign( var_index=iupwp, var_name="upwp", & + var_description="u'w', Vertical east-west momentum flux [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('vpwp') + ivpwp = k + call stat_assign( var_index=ivpwp, var_name="vpwp", & + var_description="v'w', Vertical north-south momentum flux [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rho_zm') + irho_zm = k + call stat_assign( var_index=irho_zm, var_name="rho_zm", & + var_description="Density on momentum levels [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('sigma_sqd_w') + isigma_sqd_w = k + call stat_assign( var_index=isigma_sqd_w, var_name="sigma_sqd_w", & + var_description="Nondimensionalized w variance of Gaussian component [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rho_ds_zm') + irho_ds_zm = k + call stat_assign( var_index=irho_ds_zm, var_name="rho_ds_zm", & + var_description="Dry, static, base-state density [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thv_ds_zm') + ithv_ds_zm = k + call stat_assign( var_index=ithv_ds_zm, var_name="thv_ds_zm", & + var_description="Dry, base-state theta_v [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('em') + iem = k + call stat_assign( var_index=iem, var_name="em", & + var_description="Turbulent kinetic energy, usu. 0.5*(u'^2+v'^2+w'^2) [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('shear') ! Brian + ishear = k + call stat_assign( var_index=ishear, var_name="shear", & + var_description="Wind shear production term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('mean_w_up') + imean_w_up = k + call stat_assign( var_index=imean_w_up, var_name="mean_w_up", & + var_description="Mean w >= w_ref [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('mean_w_down') + imean_w_down = k + call stat_assign( var_index=imean_w_down, var_name="mean_w_down", & + var_description="Mean w <= w_ref [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + case ('Frad') + iFrad = k + call stat_assign( var_index=iFrad, var_name="Frad", & + var_description="Total (sw+lw) net (up+down) radiative flux [W/m^2]", & + var_units="W/m^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_LW') ! Brian + iFrad_LW = k + call stat_assign( var_index=iFrad_LW, var_name="Frad_LW", & + var_description="Net long-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW') ! Brian + iFrad_SW = k + + call stat_assign( var_index=iFrad_SW, var_name="Frad_SW", & + var_description="Net short-wave radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Frad_LW_up') ! Brian + iFrad_LW_up = k + call stat_assign( var_index=iFrad_LW_up, var_name="Frad_LW_up", & + var_description="Long-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW_up') ! Brian + iFrad_SW_up = k + + call stat_assign( var_index=iFrad_SW_up, var_name="Frad_SW_up", & + var_description="Short-wave upwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Frad_LW_down') ! Brian + iFrad_LW_down = k + call stat_assign( var_index=iFrad_LW_down, var_name="Frad_LW_down", & + var_description="Long-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('Frad_SW_down') ! Brian + iFrad_SW_down = k + + call stat_assign( var_index=iFrad_SW_down, var_name="Frad_SW_down", & + var_description="Short-wave downwelling radiative flux [W/m^2]", var_units="W/m^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + + case ('Fprec') ! Brian + iFprec = k + + call stat_assign( var_index=iFprec, var_name="Fprec", & + var_description="Rain flux [W/m^2]", var_units="W/m^2", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('Fcsed') ! Brian + iFcsed = k + + call stat_assign( var_index=iFcsed, var_name="Fcsed", & + var_description="cloud water sedimentation flux [kg/(s*m^2)]", & + var_units="kg/(s*m^2)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case('hydrometp2') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The overall variance of the hydrometeor. + ihydrometp2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihydrometp2(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> [(kg/kg)^2]", & + var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=ihydrometp2(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> [(num/kg)^2]", & + var_units="(num/kg)^2", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('wphydrometp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iwphydrometp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=iwphydrometp(hm_idx), & + var_name="wp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(m/s) kg/kg]", & + var_units="(m/s) kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=iwphydrometp(hm_idx), & + var_name="wp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(m/s) num/kg]", & + var_units="(m/s) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('wpNcp') + iwpNcp = k + + call stat_assign( var_index=iwpNcp, var_name="wpNcp", & + var_description="Covariance of w and " & + // "N_c [(m/s) num/kg]", & + var_units="(m/s) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtphmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + irtphmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=irtphmp(hm_idx), & + var_name="rtp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of r_t and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [kg^2/kg^2]", & + var_units="kg^2/kg^2", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=irtphmp(hm_idx), & + var_name="rtp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of r_t and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [(kg/kg) num/kg]", & + var_units="(kg/kg) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('thlphmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ithlphmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ithlphmp(hm_idx), & + var_name="thlp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of th_l and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [K kg/kg]", & + var_units="K kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + else ! Concentration + + call stat_assign( var_index=ithlphmp(hm_idx), & + var_name="thlp"//trim( hm_type(1:2) )//"p", & + var_description="Covariance of th_l and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " [K num/kg]", & + var_units="K num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('hmxphmyp') + + do hmx_idx = 1, hydromet_dim, 1 + + hmx_type = hydromet_list(hmx_idx) + + do hmy_idx = hmx_idx+1, hydromet_dim, 1 + + hmy_type = hydromet_list(hmy_idx) + + ! The covariance (overall) of hmx and hmy. + ihmxphmyp(hmy_idx,hmx_idx) = k + + if ( l_mix_rat_hm(hmx_idx) .and. l_mix_rat_hm(hmy_idx) ) then + + ! Both hydrometeors are mixing ratios. + call stat_assign( var_index=ihmxphmyp(hmy_idx,hmx_idx), & + var_name=trim( hmx_type(1:2) )//"p" & + // trim( hmy_type(1:2) )//"p", & + var_description="Covariance of " & + // hmx_type(1:1)//"_"//trim(hmx_type(2:2)) & + // " and " & + // hmy_type(1:1)//"_"//trim(hmy_type(2:2)) & + // " [(kg/kg)^2]", & + var_units="(kg/kg)^2", l_silhs=.false., & + grid_kind=stats_zm ) + + elseif ( ( .not. l_mix_rat_hm(hmx_idx) ) & + .and. ( .not. l_mix_rat_hm(hmy_idx) ) ) then + + ! Both hydrometeors are concentrations. + call stat_assign( var_index=ihmxphmyp(hmy_idx,hmx_idx), & + var_name=trim( hmx_type(1:2) )//"p" & + // trim( hmy_type(1:2) )//"p", & + var_description="Covariance of " & + // hmx_type(1:1)//"_"//trim(hmx_type(2:2)) & + // " and " & + // hmy_type(1:1)//"_"//trim(hmy_type(2:2)) & + // " [(num/kg)^2]", & + var_units="(num/kg)^2", l_silhs=.false., & + grid_kind=stats_zm ) + + else + + ! One hydrometeor is a mixing ratio and the other hydrometeor + ! is a concentration. + call stat_assign( var_index=ihmxphmyp(hmy_idx,hmx_idx), & + var_name=trim( hmx_type(1:2) )//"p" & + // trim( hmy_type(1:2) )//"p", & + var_description="Covariance of " & + // hmx_type(1:1)//"_"//trim(hmx_type(2:2)) & + // " and " & + // hmy_type(1:1)//"_"//trim(hmy_type(2:2)) & + // " [(kg/kg) num/kg]", & + var_units="(kg/kg) num/kg", & + l_silhs=.false., grid_kind=stats_zm ) + + endif + + k = k + 1 + + enddo ! hmy_idx = hmx_idx+1, hydromet_dim, 1 + + enddo ! hmx_idx = 1, hydromet_dim, 1 + + case ('VNr') + iVNr = k + + call stat_assign( var_index=iVNr, var_name="VNr", & + var_description="rrm concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrr') + iVrr = k + + call stat_assign( var_index=iVrr, var_name="Vrr", & + var_description="rrm mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNc') + iVNc = k + + call stat_assign( var_index=iVNc, var_name="VNc", & + var_description="Nrm concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrc') + iVrc = k + + call stat_assign( var_index=iVrc, var_name="Vrc", & + var_description="Nrm mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNs') + iVNs = k + + call stat_assign( var_index=iVNs, var_name="VNs", & + var_description="Snow concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrs') + iVrs = k + + call stat_assign( var_index=iVrs, var_name="Vrs", & + var_description="Snow mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrg') + iVrg = k + + call stat_assign( var_index=iVrg, var_name="Vrg", & + var_description="Graupel sedimentation velocity [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNi') + iVNi = k + + call stat_assign( var_index=iVNi, var_name="VNi", & + var_description="Cloud ice concentration fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vri') + iVri = k + + call stat_assign( var_index=iVri, var_name="Vri", & + var_description="Cloud ice mixing ratio fallspeed [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrrprrp') + iVrrprrp = k + + call stat_assign( var_index=iVrrprrp, var_name="Vrrprrp", & + var_description="Covariance of V_rr (r_r sed. vel.) and r_r [(m/s)(kg/kg)]", & + var_units="(m/s)(kg/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNrpNrp') + iVNrpNrp = k + + call stat_assign( var_index=iVNrpNrp, var_name="VNrpNrp", & + var_description="Covariance of V_Nr (N_r sed. vel.) and N_r [(m/s)(num/kg)]", & + var_units="(m/s)(num/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('Vrrprrp_expcalc') + iVrrprrp_expcalc = k + + call stat_assign( var_index=iVrrprrp_expcalc, var_name="Vrrprrp_expcalc", & + var_description="< V_rr'r_r' > (completely explicit calculation) [(m/s)(kg/kg)]", & + var_units="(m/s)(kg/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('VNrpNrp_expcalc') + iVNrpNrp_expcalc = k + + call stat_assign( var_index=iVNrpNrp_expcalc, var_name="VNrpNrp_expcalc", & + var_description="< V_Nr'N_r' > (completely explicit calculation) [(m/s)(num/kg)]", & + var_units="(m/s)(num/kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_bt') + iwp2_bt = k + + call stat_assign( var_index=iwp2_bt, var_name="wp2_bt", & + var_description="wp2 budget: wp2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ma') + iwp2_ma = k + + call stat_assign( var_index=iwp2_ma, var_name="wp2_ma", & + var_description="wp2 budget: wp2 vertical mean advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ta') + iwp2_ta = k + + call stat_assign( var_index=iwp2_ta, var_name="wp2_ta", & + var_description="wp2 budget: wp2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_ac') + iwp2_ac = k + + call stat_assign( var_index=iwp2_ac, var_name="wp2_ac", & + var_description="wp2 budget: wp2 accumulation term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_bp') + iwp2_bp = k + + call stat_assign( var_index=iwp2_bp, var_name="wp2_bp", & + var_description="wp2 budget: wp2 buoyancy production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr1') + iwp2_pr1 = k + + call stat_assign( var_index=iwp2_pr1, var_name="wp2_pr1", & + var_description="wp2 budget: wp2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr2') + iwp2_pr2 = k + call stat_assign( var_index=iwp2_pr2, var_name="wp2_pr2", & + var_description="wp2 budget: wp2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_pr3') + iwp2_pr3 = k + call stat_assign( var_index=iwp2_pr3, var_name="wp2_pr3", & + var_description="wp2 budget: wp2 pressure term 3 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_dp1') + iwp2_dp1 = k + call stat_assign( var_index=iwp2_dp1, var_name="wp2_dp1", & + var_description="wp2 budget: wp2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wp2_dp2') + iwp2_dp2 = k + call stat_assign( var_index=iwp2_dp2, var_name="wp2_dp2", & + var_description="wp2 budget: wp2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_cl') + iwp2_cl = k + + call stat_assign( var_index=iwp2_cl, var_name="wp2_cl", & + var_description="wp2 budget: wp2 clipping term [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_pd') + iwp2_pd = k + + call stat_assign( var_index=iwp2_pd, var_name="wp2_pd", & + var_description="wp2 budget: wp2 positive definite adjustment [m^2/s^3]", & + var_units="m2/s3", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wp2_sf') + iwp2_sf = k + + call stat_assign( var_index=iwp2_sf, var_name="wp2_sf", & + var_description="wp2 budget: wp2 surface variance [m^2/s^3]", var_units="m2/s3", & + l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wprtp_bt') + iwprtp_bt = k + call stat_assign( var_index=iwprtp_bt, var_name="wprtp_bt", & + var_description="wprtp budget: wprtp time tendency [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ma') + iwprtp_ma = k + + call stat_assign( var_index=iwprtp_ma, var_name="wprtp_ma", & + var_description="wprtp budget: wprtp mean advection [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ta') + iwprtp_ta = k + + call stat_assign( var_index=iwprtp_ta, var_name="wprtp_ta", & + var_description="wprtp budget: wprtp turbulent advection [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_tp') + iwprtp_tp = k + + call stat_assign( var_index=iwprtp_tp, var_name="wprtp_tp", & + var_description="wprtp budget: wprtp turbulent production [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_ac') + iwprtp_ac = k + + call stat_assign( var_index=iwprtp_ac, var_name="wprtp_ac", & + var_description="wprtp budget: wprtp accumulation term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_bp') + iwprtp_bp = k + + call stat_assign( var_index=iwprtp_bp, var_name="wprtp_bp", & + var_description="wprtp budget: wprtp buoyancy production [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr1') + iwprtp_pr1 = k + + call stat_assign( var_index=iwprtp_pr1, var_name="wprtp_pr1", & + var_description="wprtp budget: wprtp pressure term 1 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr2') + iwprtp_pr2 = k + + call stat_assign( var_index=iwprtp_pr2, var_name="wprtp_pr2", & + var_description="wprtp budget: wprtp pressure term 2 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pr3') + iwprtp_pr3 = k + + call stat_assign( var_index=iwprtp_pr3, var_name="wprtp_pr3", & + var_description="wprtp budget: wprtp pressure term 3 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_dp1') + iwprtp_dp1 = k + + call stat_assign( var_index=iwprtp_dp1, var_name="wprtp_dp1", & + var_description="wprtp budget: wprtp dissipation term 1 [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl') + iwprtp_mfl = k + + call stat_assign( var_index=iwprtp_mfl, var_name="wprtp_mfl", & + var_description="wprtp budget: wprtp monotonic flux limiter [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_cl') + iwprtp_cl = k + + call stat_assign( var_index=iwprtp_cl, var_name="wprtp_cl", & + var_description="wprtp budget: wprtp clipping term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_sicl') + iwprtp_sicl = k + + call stat_assign( var_index=iwprtp_sicl, var_name="wprtp_sicl", & + var_description="wprtp budget: wprtp semi-implicit clipping term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_pd') + iwprtp_pd = k + + call stat_assign( var_index=iwprtp_pd, var_name="wprtp_pd", & + var_description="wprtp budget: wprtp flux corrected trans. term [(m kg)/(s^2 kg)]", & + var_units="(m kg)/(s^2 kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_forcing') + iwprtp_forcing = k + + call stat_assign( var_index=iwprtp_forcing, var_name="wprtp_forcing", & + var_description="wprtp budget: wprtp forcing (includes microphysics tendency) & + &[(m kg/kg)/s^2]", & + var_units="(m kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mc') + iwprtp_mc = k + + call stat_assign( var_index=iwprtp_mc, var_name="wprtp_mc", & + var_description="Microphysics tendency for wprtp (not in budget) [(m kg/kg)/s^2]", & + var_units="(m kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_bt') + iwpthlp_bt = k + + call stat_assign( var_index=iwpthlp_bt, var_name="wpthlp_bt", & + var_description="wpthlp budget: [(m K)/s^2]", var_units="(m K)/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_ma') + iwpthlp_ma = k + call stat_assign( var_index=iwpthlp_ma, var_name="wpthlp_ma", & + var_description="wpthlp budget: wpthlp mean advection [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_ta') + iwpthlp_ta = k + call stat_assign( var_index=iwpthlp_ta, var_name="wpthlp_ta", & + var_description="wpthlp budget: wpthlp turbulent advection [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_tp') + iwpthlp_tp = k + call stat_assign( var_index=iwpthlp_tp, var_name="wpthlp_tp", & + var_description="wpthlp budget: wpthlp turbulent production [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_ac') + iwpthlp_ac = k + call stat_assign( var_index=iwpthlp_ac, var_name="wpthlp_ac", & + var_description="wpthlp budget: wpthlp accumulation term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + + k = k + 1 + + case ('wpthlp_bp') + iwpthlp_bp = k + call stat_assign( var_index=iwpthlp_bp, var_name="wpthlp_bp", & + var_description="wpthlp budget: wpthlp buoyancy production [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr1') + iwpthlp_pr1 = k + + call stat_assign( var_index=iwpthlp_pr1, var_name="wpthlp_pr1", & + var_description="wpthlp budget: wpthlp pressure term 1 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr2') + iwpthlp_pr2 = k + + call stat_assign( var_index=iwpthlp_pr2, var_name="wpthlp_pr2", & + var_description="wpthlp budget: wpthlp pressure term 2 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_pr3') + iwpthlp_pr3 = k + call stat_assign( var_index=iwpthlp_pr3, var_name="wpthlp_pr3", & + var_description="wpthlp budget: wpthlp pressure term 3 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_dp1') + iwpthlp_dp1 = k + call stat_assign( var_index=iwpthlp_dp1, var_name="wpthlp_dp1", & + var_description="wpthlp budget: wpthlp dissipation term 1 [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl') + iwpthlp_mfl = k + call stat_assign( var_index=iwpthlp_mfl, var_name="wpthlp_mfl", & + var_description="wpthlp budget: wpthlp monotonic flux limiter [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_cl') + iwpthlp_cl = k + call stat_assign( var_index=iwpthlp_cl, var_name="wpthlp_cl", & + var_description="wpthlp budget: wpthlp clipping term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_sicl') + iwpthlp_sicl = k + call stat_assign( var_index=iwpthlp_sicl, var_name="wpthlp_sicl", & + var_description="wpthlp budget: wpthlp semi-implicit clipping term [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_forcing') + iwpthlp_forcing = k + + call stat_assign( var_index=iwpthlp_forcing, var_name="wpthlp_forcing", & + var_description="wpthlp budget: wpthlp forcing (includes microphysics tendency) & + &[(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mc') + iwpthlp_mc = k + + call stat_assign( var_index=iwpthlp_mc, var_name="wpthlp_mc", & + var_description="Microphysics tendency for wpthlp (not in budget) [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + ! Variance budgets + case ('rtp2_bt') + irtp2_bt = k + call stat_assign( var_index=irtp2_bt, var_name="rtp2_bt", & + var_description="rtp2 budget: rtp2 time tendency [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_ma') + irtp2_ma = k + call stat_assign( var_index=irtp2_ma, var_name="rtp2_ma", & + var_description="rtp2 budget: rtp2 mean advection [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_ta') + irtp2_ta = k + call stat_assign( var_index=irtp2_ta, var_name="rtp2_ta", & + var_description="rtp2 budget: rtp2 turbulent advection [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_tp') + irtp2_tp = k + call stat_assign( var_index=irtp2_tp, var_name="rtp2_tp", & + var_description="rtp2 budget: rtp2 turbulent production [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_dp1') + irtp2_dp1 = k + call stat_assign( var_index=irtp2_dp1, var_name="rtp2_dp1", & + var_description="rtp2 budget: rtp2 dissipation term 1 [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_dp2') + irtp2_dp2 = k + call stat_assign( var_index=irtp2_dp2, var_name="rtp2_dp2", & + var_description="rtp2 budget: rtp2 dissipation term 2 [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtp2_cl') + irtp2_cl = k + call stat_assign( var_index=irtp2_cl, var_name="rtp2_cl", & + var_description="rtp2 budget: rtp2 clipping term [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_pd') + irtp2_pd = k + call stat_assign( var_index=irtp2_pd, var_name="rtp2_pd", & + var_description="rtp2 budget: rtp2 positive definite adjustment [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_sf') + irtp2_sf = k + call stat_assign( var_index=irtp2_sf, var_name="rtp2_sf", & + var_description="rtp2 budget: rtp2 surface variance [(kg^2)/(kg^2 s)]", & + var_units="(kg^2)/(kg^2 s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_forcing') + irtp2_forcing = k + + call stat_assign( var_index=irtp2_forcing, var_name="rtp2_forcing", & + var_description="rtp2 budget: rtp2 forcing (includes microphysics tendency) & + &[(kg/kg)^2/s]", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtp2_mc') + irtp2_mc = k + + call stat_assign( var_index=irtp2_mc, var_name="rtp2_mc", & + var_description="Microphysics tendency for rtp2 (not in budget) [(kg/kg)^2/s]", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_bt') + ithlp2_bt = k + call stat_assign( var_index=ithlp2_bt, var_name="thlp2_bt", & + var_description="thlp2 budget: thlp2 time tendency [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_ma') + ithlp2_ma = k + call stat_assign( var_index=ithlp2_ma, var_name="thlp2_ma", & + var_description="thlp2 budget: thlp2 mean advection [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_ta') + ithlp2_ta = k + call stat_assign( var_index=ithlp2_ta, var_name="thlp2_ta", & + var_description="thlp2 budget: thlp2 turbulent advection [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_tp') + ithlp2_tp = k + call stat_assign( var_index=ithlp2_tp, var_name="thlp2_tp", & + var_description="thlp2 budget: thlp2 turbulent production [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_dp1') + ithlp2_dp1 = k + call stat_assign( var_index=ithlp2_dp1, var_name="thlp2_dp1", & + var_description="thlp2 budget: thlp2 dissipation term 1 [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_dp2') + ithlp2_dp2 = k + call stat_assign( var_index=ithlp2_dp2, var_name="thlp2_dp2", & + var_description="thlp2 budget: thlp2 dissipation term 2 [(K^2)/s]", & + var_units="(K^2)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_cl') + ithlp2_cl = k + call stat_assign( var_index=ithlp2_cl, var_name="thlp2_cl", & + var_description="thlp2 budget: thlp2 clipping term [(K^2)/s]", var_units="(K^2)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_pd') + ithlp2_pd = k + call stat_assign( var_index=ithlp2_pd, var_name="thlp2_pd", & + var_description="thlp2 budget: thlp2 positive definite adjustment [(K^2)/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlp2_sf') + ithlp2_sf = k + call stat_assign( var_index=ithlp2_sf, var_name="thlp2_sf", & + var_description="thlp2 budget: thlp2 surface variance [(K^2)/s]", var_units="K^2/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_forcing') + ithlp2_forcing = k + call stat_assign( var_index=ithlp2_forcing, var_name="thlp2_forcing", & + var_description="thlp2 budget: thlp2 forcing (includes microphysics tendency) & + &[K^2/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('thlp2_mc') + ithlp2_mc = k + call stat_assign( var_index=ithlp2_mc, var_name="thlp2_mc", & + var_description="Microphysics tendency for thlp2 (not in budget) [K^2/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtpthlp_bt') + irtpthlp_bt = k + call stat_assign( var_index=irtpthlp_bt, var_name="rtpthlp_bt", & + var_description="rtpthlp budget: rtpthlp time tendency [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_ma') + irtpthlp_ma = k + call stat_assign( var_index=irtpthlp_ma, var_name="rtpthlp_ma", & + var_description="rtpthlp budget: rtpthlp mean advection [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_ta') + irtpthlp_ta = k + call stat_assign( var_index=irtpthlp_ta, var_name="rtpthlp_ta", & + var_description="rtpthlp budget: rtpthlp turbulent advection [](kg K)/(kg s)", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_tp1') + irtpthlp_tp1 = k + call stat_assign( var_index=irtpthlp_tp1, var_name="rtpthlp_tp1", & + var_description="rtpthlp budget: rtpthlp turbulent production 1 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_tp2') + irtpthlp_tp2 = k + call stat_assign( var_index=irtpthlp_tp2, var_name="rtpthlp_tp2", & + var_description="rtpthlp budget: rtpthlp turbulent production 2 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_dp1') + irtpthlp_dp1 = k + call stat_assign( var_index=irtpthlp_dp1, var_name="rtpthlp_dp1", & + var_description="rtpthlp budget: rtpthlp dissipation term 1 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_dp2') + irtpthlp_dp2 = k + call stat_assign( var_index=irtpthlp_dp2, var_name="rtpthlp_dp2", & + var_description="rtpthlp budget: rtpthlp dissipation term 2 [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_cl') + irtpthlp_cl = k + call stat_assign( var_index=irtpthlp_cl, var_name="rtpthlp_cl", & + var_description="rtpthlp budget: rtpthlp clipping term [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_sf') + irtpthlp_sf = k + call stat_assign( var_index=irtpthlp_sf, var_name="rtpthlp_sf", & + var_description="rtpthlp budget: rtpthlp surface variance [(kg K)/(kg s)]", & + var_units="(kg K)/(kg s)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_forcing') + irtpthlp_forcing = k + call stat_assign( var_index=irtpthlp_forcing, var_name="rtpthlp_forcing", & + var_description="rtpthlp budget: rtpthlp forcing (includes microphysics tendency) & + &[(K kg/kg)/s]", & + var_units="(K kg/kg)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + case ('rtpthlp_mc') + irtpthlp_mc = k + call stat_assign( var_index=irtpthlp_mc, var_name="rtpthlp_mc", & + var_description="Microphysics tendency for rtpthlp (not in budget) [(K kg/kg)/s]", & + var_units="(K kg/kg)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2') + iup2 = k + call stat_assign( var_index=iup2, var_name="up2", & + var_description="u'^2 (momentum levels) [m^2/s^2]", var_units="m^2/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2') + ivp2 = k + call stat_assign( var_index=ivp2, var_name="vp2", & + var_description="v'^2 (momentum levels) [m^2/s^2]", var_units="m^2/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_bt') + iup2_bt = k + call stat_assign( var_index=iup2_bt, var_name="up2_bt", & + var_description="up2 budget: up2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_ma') + iup2_ma = k + call stat_assign( var_index=iup2_ma, var_name="up2_ma", & + var_description="up2 budget: up2 mean advection [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_ta') + iup2_ta = k + call stat_assign( var_index=iup2_ta, var_name="up2_ta", & + var_description="up2 budget: up2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_tp') + iup2_tp = k + call stat_assign( var_index=iup2_tp, var_name="up2_tp", & + var_description="up2 budget: up2 turbulent production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_dp1') + iup2_dp1 = k + call stat_assign( var_index=iup2_dp1, var_name="up2_dp1", & + var_description="up2 budget: up2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_dp2') + iup2_dp2 = k + call stat_assign( var_index=iup2_dp2, var_name="up2_dp2", & + var_description="up2 budget: up2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pr1') + iup2_pr1 = k + call stat_assign( var_index=iup2_pr1, var_name="up2_pr1", & + var_description="up2 budget: up2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pr2') + iup2_pr2 = k + call stat_assign( var_index=iup2_pr2, var_name="up2_pr2", & + var_description="up2 budget: up2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_cl') + iup2_cl = k + call stat_assign( var_index=iup2_cl, var_name="up2_cl", & + var_description="up2 budget: up2 clipping [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_pd') + iup2_pd = k + call stat_assign( var_index=iup2_pd, var_name="up2_pd", & + var_description="up2 budget: up2 positive definite adjustment [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('up2_sf') + iup2_sf = k + call stat_assign( var_index=iup2_sf, var_name="up2_sf", & + var_description="up2 budget: up2 surface variance [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_bt') + ivp2_bt = k + call stat_assign( var_index=ivp2_bt, var_name="vp2_bt", & + var_description="vp2 budget: vp2 time tendency [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_ma') + ivp2_ma = k + call stat_assign( var_index=ivp2_ma, var_name="vp2_ma", & + var_description="vp2 budget: vp2 mean advection [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_ta') + ivp2_ta = k + call stat_assign( var_index=ivp2_ta, var_name="vp2_ta", & + var_description="vp2 budget: vp2 turbulent advection [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_tp') + ivp2_tp = k + call stat_assign( var_index=ivp2_tp, var_name="vp2_tp", & + var_description="vp2 budget: vp2 turbulent production [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_dp1') + ivp2_dp1 = k + call stat_assign( var_index=ivp2_dp1, var_name="vp2_dp1", & + var_description="vp2 budget: vp2 dissipation term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_dp2') + ivp2_dp2 = k + call stat_assign( var_index=ivp2_dp2, var_name="vp2_dp2", & + var_description="vp2 budget: vp2 dissipation term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pr1') + ivp2_pr1 = k + call stat_assign( var_index=ivp2_pr1, var_name="vp2_pr1", & + var_description="vp2 budget: vp2 pressure term 1 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pr2') + ivp2_pr2 = k + call stat_assign( var_index=ivp2_pr2, var_name="vp2_pr2", & + var_description="vp2 budget: vp2 pressure term 2 [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_cl') + ivp2_cl = k + call stat_assign( var_index=ivp2_cl, var_name="vp2_cl", & + var_description="vp2 budget: vp2 clipping [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_pd') + ivp2_pd = k + call stat_assign( var_index=ivp2_pd, var_name="vp2_pd", & + var_description="vp2 budget: vp2 positive definite adjustment [m^2/s^3]", & + var_units="m^2/s^3", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('vp2_sf') + ivp2_sf = k + call stat_assign( var_index=ivp2_sf, var_name="vp2_sf", & + var_description="vp2 budget: vp2 surface variance [m^2/s^3]", var_units="m^2/s^3", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_entermfl') + iwpthlp_entermfl = k + call stat_assign( var_index=iwpthlp_entermfl, var_name="wpthlp_entermfl", & + var_description="Wpthlp entering flux limiter [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_exit_mfl') + iwpthlp_exit_mfl = k + call stat_assign( var_index=iwpthlp_exit_mfl, var_name="wpthlp_exit_mfl", & + var_description="Wpthlp exiting flux limiter [](m K)/s", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl_min') + iwpthlp_mfl_min = k + call stat_assign( var_index=iwpthlp_mfl_min, var_name="wpthlp_mfl_min", & + var_description="Minimum allowable wpthlp [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wpthlp_mfl_max') + iwpthlp_mfl_max = k + call stat_assign( var_index=iwpthlp_mfl_max, var_name="wpthlp_mfl_max", & + var_description="Maximum allowable wpthlp ((m K)/s) [(m K)/s]", var_units="(m K)/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl_min') + iwprtp_mfl_min = k + call stat_assign( var_index=iwprtp_mfl_min, var_name="wprtp_mfl_min", & + var_description="Minimum allowable wprtp [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_mfl_max') + iwprtp_mfl_max = k + call stat_assign( var_index=iwprtp_mfl_max, var_name="wprtp_mfl_max", & + var_description="Maximum allowable wprtp [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_enter_mfl') + iwprtp_enter_mfl = k + call stat_assign( var_index=iwprtp_enter_mfl, var_name="wprtp_enter_mfl", & + var_description="Wprtp entering flux limiter [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wprtp_exit_mfl') + iwprtp_exit_mfl = k + call stat_assign( var_index=iwprtp_exit_mfl, var_name="wprtp_exit_mfl", & + var_description="Wprtp exiting flux limiter [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('wm_zm') + iwm_zm = k + call stat_assign( var_index=iwm_zm, var_name="wm_zm", & + var_description="Vertical (w) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('cloud_frac_zm') + icloud_frac_zm = k + call stat_assign( var_index=icloud_frac_zm, var_name="cloud_frac_zm", & + var_description="Cloud fraction [-]", var_units="-", l_silhs=.false., grid_kind=stats_zm) + k = k + 1 + + case ('ice_supersat_frac_zm') + iice_supersat_frac_zm = k + call stat_assign( var_index=iice_supersat_frac_zm, var_name="ice_supersat_frac_zm", & + var_description="Ice cloud fraction", var_units="count", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ('rcm_zm') + ircm_zm = k + call stat_assign( var_index=ircm_zm, var_name="rcm_zm", & + var_description="Total water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('rtm_zm') + irtm_zm = k + call stat_assign( var_index=irtm_zm, var_name="rtm_zm", & + var_description="Total water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ('thlm_zm') + ithlm_zm = k + call stat_assign( var_index=ithlm_zm, var_name="thlm_zm", & + var_description="Liquid potential temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skw_velocity' ) + iSkw_velocity = k + call stat_assign( var_index=iSkw_velocity, var_name="Skw_velocity", & + var_description="Skewness velocity [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zm ) + k = k + 1 + + case ( 'gamma_Skw_fnc' ) + igamma_Skw_fnc = k + call stat_assign( var_index=igamma_Skw_fnc, var_name="gamma_Skw_fnc", & + var_description="Gamma as a function of skewness [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C6rt_Skw_fnc' ) + iC6rt_Skw_fnc = k + call stat_assign( var_index=iC6rt_Skw_fnc, var_name="C6rt_Skw_fnc", & + var_description="C_6rt parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C6thl_Skw_fnc' ) + iC6thl_Skw_fnc = k + call stat_assign( var_index=iC6thl_Skw_fnc, var_name="C6thl_Skw_fnc", & + var_description="C_6thl parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C7_Skw_fnc' ) + iC7_Skw_fnc = k + call stat_assign( var_index=iC7_Skw_fnc, var_name="C7_Skw_fnc", & + var_description="C_7 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'C1_Skw_fnc' ) + iC1_Skw_fnc = k + call stat_assign( var_index=iC1_Skw_fnc, var_name="C1_Skw_fnc", & + var_description="C_1 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'brunt_vaisala_freq_sqd' ) + ibrunt_vaisala_freq_sqd = k + call stat_assign( var_index=ibrunt_vaisala_freq_sqd, var_name="brunt_vaisala_freq_sqd", & + var_description="Brunt-Vaisala freqency squared, N^2 [1/s^2]", var_units="1/s^2", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'Richardson_num' ) + iRichardson_num = k + call stat_assign( var_index=iRichardson_num, var_name="Richardson_num", & + var_description="Richardson number [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'a3_coef' ) + ia3_coef = k + call stat_assign( var_index=ia3_coef, var_name="a3_coef", & + var_description="Quantity in formula 25 from Equations for CLUBB [-]", & + var_units="count", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'wp3_on_wp2' ) + iwp3_on_wp2 = k + call stat_assign( var_index=iwp3_on_wp2, var_name="wp3_on_wp2", & + var_description="Smoothed version of wp3 / wp2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skw_zm' ) + iSkw_zm = k + call stat_assign( var_index=iSkw_zm, var_name="Skw_zm", & + var_description="Skewness of w on momentum levels [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skthl_zm' ) + iSkthl_zm = k + call stat_assign( var_index=iSkthl_zm, var_name="Skthl_zm", & + var_description="Skewness of thl on momentum levels [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'Skrt_zm' ) + iSkrt_zm = k + call stat_assign( var_index=iSkrt_zm, var_name="Skrt_zm", & + var_description="Skewness of rt on momentum levels [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'stability_correction' ) + istability_correction = k + call stat_assign( var_index=istability_correction, var_name="stability_correction", & + var_description="Stability applied to diffusion of rtm and thlm [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'rtp2_from_chi' ) + irtp2_from_chi = k + call stat_assign( var_index=irtp2_from_chi, var_name="rtp2_from_chi", & + var_description="Variance of rt, computed from the chi/eta distribution [(kg/kg)^2]", & + var_units="(kg/kg)^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'lh_rtp2_mc' ) + ilh_rtp2_mc = k + call stat_assign( var_index=ilh_rtp2_mc, var_name="lh_rtp2_mc", & + var_description="LH est. of rtp2_mc [(kg/kg)^2/s]", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'lh_thlp2_mc' ) + ilh_thlp2_mc = k + call stat_assign( var_index=ilh_thlp2_mc, var_name="lh_thlp2_mc", & + var_description="LH est. of thlp2_mc [K^2/s]", & + var_units="K^2/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'lh_wprtp_mc' ) + ilh_wprtp_mc = k + call stat_assign( var_index=ilh_wprtp_mc, var_name="lh_wprtp_mc", & + var_description="LH est. of wprtp_mc [(m kg/kg)/s^2]", & + var_units="(m kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'lh_wpthlp_mc' ) + ilh_wpthlp_mc = k + call stat_assign( var_index=ilh_wpthlp_mc, var_name="lh_wpthlp_mc", & + var_description="LH est. of wpthlp_mc [(m K)/s^2]", & + var_units="(m K)/s^2", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'lh_rtpthlp_mc' ) + ilh_rtpthlp_mc = k + call stat_assign( var_index=ilh_rtpthlp_mc, var_name="lh_rtpthlp_mc", & + var_description="LH est. of rtpthlp_mc [(K kg/kg)/s]", & + var_units="(K kg/kg)/s", l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + + case ( 'sclrprtp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrprtp(j) = k + call stat_assign( var_index=isclrprtp(j), var_name="sclr"//trim(sclr_idx)//"prtp", & + var_description="scalar("//trim(sclr_idx)//")'rt'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'sclrp2' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrp2(j) = k + call stat_assign( var_index=isclrp2(j), var_name="sclr"//trim(sclr_idx)//"p2", & + var_description="scalar("//trim(sclr_idx)//")'^2'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'sclrpthvp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrpthvp(j) = k + call stat_assign( var_index=isclrpthvp(j), var_name="sclr"//trim(sclr_idx)//"pthvp", & + var_description="scalar("//trim(sclr_idx)//")'th_v'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'sclrpthlp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrpthlp(j) = k + call stat_assign( var_index=isclrpthlp(j), var_name="sclr"//trim(sclr_idx)//"pthlp", & + var_description="scalar("//trim(sclr_idx)//")'th_l'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'sclrprcp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrprcp(j) = k + call stat_assign( var_index=isclrprcp(j), var_name="sclr"//trim(sclr_idx)//"prcp", & + var_description="scalar("//trim(sclr_idx)//")'rc'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wpsclrp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwpsclrp(j) = k + call stat_assign( var_index=iwpsclrp(j), var_name="wpsclr"//trim(sclr_idx)//"p", & + var_description="'w'scalar("//trim(sclr_idx)//")", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wpsclrp2' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwpsclrp2(j) = k + call stat_assign( var_index=iwpsclrp2(j), var_name="wpsclr"//trim(sclr_idx)//"p2", & + var_description="'w'scalar("//trim(sclr_idx)//")'^2'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wp2sclrp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwp2sclrp(j) = k + call stat_assign( var_index=iwp2sclrp(j), var_name="wp2sclr"//trim(sclr_idx)//"p", & + var_description="'w'^2 scalar("//trim(sclr_idx)//")", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wpsclrprtp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwpsclrprtp(j) = k + call stat_assign( var_index=iwpsclrprtp(j), var_name="wpsclr"//trim(sclr_idx)//"prtp", & + var_description="'w' scalar("//trim(sclr_idx)//")'rt'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wpsclrpthlp' ) + do j = 1, sclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwpsclrpthlp(j) = k + call stat_assign( var_index=iwpsclrpthlp(j), var_name="wpsclr"//trim(sclr_idx)//"pthlp", & + var_description="'w' scalar("//trim(sclr_idx)//")'th_l'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case ( 'wpedsclrp' ) + do j = 1, edsclr_dim, 1 + write( sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iwpedsclrp(j) = k + call stat_assign( var_index=iwpedsclrp(j), var_name="wpedsclr"//trim(sclr_idx)//"p", & + var_description="eddy scalar("//trim(sclr_idx)//")'w'", var_units="unknown", & + l_silhs=.false., grid_kind=stats_zm ) + k = k + 1 + end do + + case default + write(fstderr,*) 'Error: unrecognized variable in vars_zm: ', trim(vars_zm(i)) + l_error = .true. ! This will stop the run. + + end select + + end do ! i = 1 .. stats_zm%num_output_fields + + return + end subroutine stats_init_zm + +end module stats_zm_module diff --git a/src/physics/clubb/stats_zt_module.F90 b/src/physics/clubb/stats_zt_module.F90 new file mode 100644 index 0000000000..53115136b6 --- /dev/null +++ b/src/physics/clubb/stats_zt_module.F90 @@ -0,0 +1,5006 @@ +!--------------------------------------------------------------------------- +! $Id: stats_zt_module.F90 7377 2014-11-11 02:43:45Z bmg2@uwm.edu $ +!=============================================================================== +module stats_zt_module + + implicit none + + private ! Default Scope + + public :: stats_init_zt + + ! Constant parameters + integer, parameter, public :: nvarmax_zt = 754 ! Maximum variables allowed + + contains + + !============================================================================= + subroutine stats_init_zt( vars_zt, l_error ) + + ! Description: + ! Initializes array indices for stats_zt + + ! Note: + ! All code that is within subroutine stats_init_zt, including variable + ! allocation code, is not called if l_stats is false. This subroutine is + ! called only when l_stats is true. + + !----------------------------------------------------------------------- + + use constants_clubb, only: & + fstderr ! Constant(s) + + use stats_variables, only: & + ithlm, & ! Variable(s) + iT_in_K, & + ithvm, & + irtm, & + ircm, & + irfrzm, & + irvm, & + ium, & + ivm, & + iwm_zt, & + ium_ref, & + ivm_ref, & + iug, & + ivg, & + icloud_frac, & + iice_supersat_frac, & + ircm_in_layer, & + ircm_in_cloud, & + icloud_cover, & + ip_in_Pa, & + iexner, & + irho_ds_zt, & + ithv_ds_zt, & + iLscale + + use stats_variables, only: & + iwp3, & ! Variable(s) + ithlp3, & + irtp3, & + iwpthlp2, & + iwp2thlp, & + iwprtp2, & + iwp2rtp, & + iLscale_up, & + iLscale_down, & + itau_zt, & + iKh_zt, & + iwp2thvp, & + iwp2rcp, & + iwprtpthlp, & + isigma_sqd_w_zt, & + iSkw_zt, & + iSkthl_zt, & + iSkrt_zt + + use stats_variables, only: & + ihm_1, & ! Variable(s) + ihm_2, & + iprecip_frac, & + iprecip_frac_1, & + iprecip_frac_2, & + iNcnm + + use stats_variables, only: & + imu_hm_1, & ! Variable(s) + imu_hm_2, & + imu_Ncn_1, & + imu_Ncn_2, & + imu_hm_1_n, & + imu_hm_2_n, & + imu_Ncn_1_n, & + imu_Ncn_2_n, & + isigma_hm_1, & + isigma_hm_2, & + isigma_Ncn_1, & + isigma_Ncn_2, & + isigma_hm_1_n, & + isigma_hm_2_n, & + isigma_Ncn_1_n, & + isigma_Ncn_2_n + + use stats_variables, only: & + icorr_w_chi_1, & ! Variable(s) + icorr_w_chi_2, & + icorr_w_eta_1, & + icorr_w_eta_2, & + icorr_w_hm_1, & + icorr_w_hm_2, & + icorr_w_Ncn_1, & + icorr_w_Ncn_2, & + icorr_chi_eta_1_ca, & + icorr_chi_eta_2_ca, & + icorr_chi_hm_1, & + icorr_chi_hm_2, & + icorr_chi_Ncn_1, & + icorr_chi_Ncn_2, & + icorr_eta_hm_1, & + icorr_eta_hm_2, & + icorr_eta_Ncn_1, & + icorr_eta_Ncn_2, & + icorr_Ncn_hm_1, & + icorr_Ncn_hm_2, & + icorr_hmx_hmy_1, & + icorr_hmx_hmy_2 + + use stats_variables, only: & + icorr_w_hm_1_n, & ! Variable(s) + icorr_w_hm_2_n, & + icorr_w_Ncn_1_n, & + icorr_w_Ncn_2_n, & + icorr_chi_hm_1_n, & + icorr_chi_hm_2_n, & + icorr_chi_Ncn_1_n, & + icorr_chi_Ncn_2_n, & + icorr_eta_hm_1_n, & + icorr_eta_hm_2_n, & + icorr_eta_Ncn_1_n, & + icorr_eta_Ncn_2_n, & + icorr_Ncn_hm_1_n, & + icorr_Ncn_hm_2_n, & + icorr_hmx_hmy_1_n, & + icorr_hmx_hmy_2_n + + use stats_variables, only: & + irel_humidity, & + irho, & + iNcm, & + iNc_in_cloud, & + iNc_activated, & + iNccnm, & + isnowslope, & + ised_rcm, & + irsat, & + irsati, & + irrm, & + iNrm, & + iprecip_rate_zt, & + iradht, & + iradht_LW, & + iradht_SW, & + idiam, & + imass_ice_cryst, & + ircm_icedfs, & + iu_T_cm, & + im_vol_rad_rain, & + im_vol_rad_cloud, & + irsm, & + irgm, & + irim + + use stats_variables, only: & + ieff_rad_cloud, & + ieff_rad_ice, & + ieff_rad_snow, & + ieff_rad_rain, & + ieff_rad_graupel + + use stats_variables, only: & + irtm_bt, & + irtm_ma, & + irtm_ta, & + irtm_forcing, & + irtm_mc, & + irtm_sdmp, & + ircm_mc, & + ircm_sd_mg_morr, & + irvm_mc, & + irtm_mfl, & + irtm_tacl, & + irtm_cl, & + irtm_pd, & + ithlm_bt, & + ithlm_ma, & + ithlm_ta, & + ithlm_forcing, & + ithlm_mc, & + ithlm_sdmp + + use stats_variables, only: & + ithlm_mfl, & + ithlm_tacl, & + ithlm_cl, & + iwp3_bt, & + iwp3_ma, & + iwp3_ta, & + iwp3_tp, & + iwp3_ac, & + iwp3_bp1, & + iwp3_bp2, & + iwp3_pr1, & + iwp3_pr2, & + iwp3_dp1, & + iwp3_cl + + ! Monotonic flux limiter diagnostic variables + use stats_variables, only: & + ithlm_mfl_min, & + ithlm_mfl_max, & + irtm_mfl_min, & + irtm_mfl_max, & + ithlm_enter_mfl, & + ithlm_exit_mfl, & + ithlm_old, & + ithlm_without_ta, & + irtm_enter_mfl, & + irtm_exit_mfl, & + irtm_old, & + irtm_without_ta + + use stats_variables, only: & + irrm_bt, & + irrm_ma, & + irrm_ta, & + irrm_sd, & + irrm_ts, & + irrm_sd_morr, & + irrm_cond, & + irrm_auto, & + irrm_accr, & + irrm_cond_adj, & + irrm_src_adj, & + irrm_mc_nonadj, & + irrm_mc, & + irrm_hf + + use stats_variables, only: & + irrm_wvhf, & + irrm_cl, & + iNrm_bt, & + iNrm_ma, & + iNrm_ta, & + iNrm_sd, & + iNrm_ts, & + iNrm_cond, & + iNrm_auto, & + iNrm_cond_adj, & + iNrm_src_adj, & + iNrm_mc, & + iNrm_cl + + use stats_variables, only: & + irsm_bt, & + irsm_ma, & + irsm_sd, & + irsm_sd_morr, & + irsm_ta, & + irsm_mc, & + irsm_hf, & + irsm_wvhf, & + irsm_cl, & + irgm_bt, & + irgm_ma, & + irgm_sd, & + irgm_sd_morr, & + irgm_ta, & + irgm_mc + + use stats_variables, only: & + irgm_hf, & + irgm_wvhf, & + irgm_cl, & + irim_bt, & + irim_ma, & + irim_sd, & + irim_sd_mg_morr, & + irim_ta, & + irim_mc, & + irim_hf, & + irim_wvhf, & + irim_cl + + use stats_variables, only: & + ivm_bt, & + ivm_ma, & + ivm_gf, & + ivm_cf, & + ivm_ta, & + ivm_f, & + ivm_sdmp, & + ivm_ndg, & + ium_bt, & + ium_ma, & + ium_gf, & + ium_cf, & + ium_ta, & + ium_f, & + ium_sdmp, & + ium_ndg + + use stats_variables, only: & + imixt_frac, & ! Variable(s) + iw_1, & + iw_2, & + ivarnce_w_1, & + ivarnce_w_2, & + ithl_1, & + ithl_2, & + ivarnce_thl_1, & + ivarnce_thl_2, & + irt_1, & + irt_2, & + ivarnce_rt_1, & + ivarnce_rt_2, & + irc_1, & + irc_2, & + irsatl_1, & + irsatl_2, & + icloud_frac_1, & + icloud_frac_2 + + use stats_variables, only: & + ichi_1, & + ichi_2, & + istdev_chi_1, & + istdev_chi_2, & + ichip2, & + istdev_eta_1, & + istdev_eta_2, & + icovar_chi_eta_1, & + icovar_chi_eta_2, & + icorr_chi_eta_1, & + icorr_chi_eta_2, & + irrtthl, & + icrt_1, & + icrt_2, & + icthl_1, & + icthl_2 + + use stats_variables, only: & + iwp2_zt, & + ithlp2_zt, & + iwpthlp_zt, & + iwprtp_zt, & + irtp2_zt, & + irtpthlp_zt, & + iup2_zt, & + ivp2_zt, & + iupwp_zt, & + ivpwp_zt + + use stats_variables, only: & + ihmp2_zt + + use stats_variables, only: & + stats_zt, & + isclrm, & + isclrm_f, & + iedsclrm, & + iedsclrm_f + + use stats_variables, only: & + iNsm, & ! Variable(s) + iNrm, & + iNgm, & + iNim, & + iNsm_bt, & + iNsm_mc, & + iNsm_ma, & + iNsm_ta, & + iNsm_sd, & + iNsm_cl, & + iNgm_bt, & + iNgm_mc, & + iNgm_ma, & + iNgm_ta, & + iNgm_sd, & + iNgm_cl, & + iNim_bt, & + iNim_mc, & + iNim_ma, & + iNim_ta, & + iNim_sd, & + iNim_cl + + use stats_variables, only: & + iNcm_bt, & + iNcm_mc, & + iNcm_ma, & + iNcm_ta, & + iNcm_cl, & + iNcm_act + + use stats_variables, only: & + iw_KK_evap_covar_zt, & + irt_KK_evap_covar_zt, & + ithl_KK_evap_covar_zt, & + iw_KK_auto_covar_zt, & + irt_KK_auto_covar_zt, & + ithl_KK_auto_covar_zt, & + iw_KK_accr_covar_zt, & + irt_KK_accr_covar_zt, & + ithl_KK_accr_covar_zt, & + irr_KK_mvr_covar_zt, & + iNr_KK_mvr_covar_zt, & + iKK_mvr_variance_zt + + use stats_variables, only: & + iC11_Skw_fnc, & ! Variable(s) + ichi, & + iwp3_on_wp2_zt, & + ia3_coef_zt + + use stats_variables, only: & + iLscale_pert_1, & ! Variable(s) + iLscale_pert_2 + + use stats_variables, only: & + iPSMLT, & ! Variable(s) + iEVPMS, & + iPRACS, & + iEVPMG, & + iPRACG, & + iPGMLT, & + iMNUCCC, & + iPSACWS, & + iPSACWI, & + iQMULTS, & + iQMULTG, & + iPSACWG, & + iPGSACW, & + iPRD, & + iPRCI, & + iPRAI, & + iQMULTR, & + iQMULTRG,& + iMNUCCD, & + iPRACI, & + iPRACIS, & + iEPRD, & + iMNUCCR, & + iPIACR, & + iPIACRS, & + iPGRACS, & + iPRDS, & + iEPRDS, & + iPSACR, & + iPRDG, & + iEPRDG + + use stats_variables, only: & + iNGSTEN, & ! Lots of variable(s) + iNRSTEN, & + iNISTEN, & + iNSSTEN, & + iNCSTEN, & + iNPRC1, & + iNRAGG, & + iNPRACG, & + iNSUBR, & + iNSMLTR, & + iNGMLTR, & + iNPRACS, & + iNNUCCR, & + iNIACR, & + iNIACRS, & + iNGRACS, & + iNSMLTS, & + iNSAGG, & + iNPRCI, & + iNSCNG, & + iNSUBS, & + iPRC, & + iPRA, & + iPRE + + use stats_variables, only: & + iPCC, & + iNNUCCC, & + iNPSACWS, & + iNPRA, & + iNPRC, & + iNPSACWI, & + iNPSACWG, & + iNPRAI, & + iNMULTS, & + iNMULTG, & + iNMULTR, & + iNMULTRG, & + iNNUCCD, & + iNSUBI, & + iNGMLTG, & + iNSUBG, & + iNACT, & + iSIZEFIX_NR, & + iSIZEFIX_NC, & + iSIZEFIX_NI, & + iSIZEFIX_NS, & + iSIZEFIX_NG, & + iNEGFIX_NR, & + iNEGFIX_NC, & + iNEGFIX_NI, & + iNEGFIX_NS, & + iNEGFIX_NG, & + iNIM_MORR_CL, & + iQC_INST, & + iQR_INST, & + iQI_INST, & + iQS_INST, & + iQG_INST, & + iNC_INST, & + iNR_INST, & + iNI_INST, & + iNS_INST, & + iNG_INST, & + iT_in_K_mc + + use stats_variables, only: & + iwp2hmp, & ! Variable(s) + icloud_frac_refined, & + ircm_refined, & + ihl_on_Cp_residual, & + iqto_residual + + use stats_type_utilities, only: & + stat_assign ! Procedure + + use parameters_model, only: & + hydromet_dim, & ! Variable(s) + sclr_dim, & + edsclr_dim + + use array_index, only: & + hydromet_list, & ! Variable(s) + l_mix_rat_hm + + implicit none + + ! External + intrinsic :: trim + + ! Local Constants + + ! Input Variable + character(len= * ), dimension(nvarmax_zt), intent(in) :: vars_zt + + ! Input / Output Variable + logical, intent(inout) :: l_error + + ! Local Varables + integer :: tot_zt_loops + + integer :: i, j, k + + integer :: hm_idx, hmx_idx, hmy_idx + + character(len=10) :: hm_type, hmx_type, hmy_type + + character(len=50) :: sclr_idx + + + ! The default initialization for array indices for stats_zt is zero (see module + ! stats_variables) + + ! Allocate and initialize hydrometeor statistical variables. + allocate( ihm_1(1:hydromet_dim) ) + allocate( ihm_2(1:hydromet_dim) ) + allocate( imu_hm_1(1:hydromet_dim) ) + allocate( imu_hm_2(1:hydromet_dim) ) + allocate( imu_hm_1_n(1:hydromet_dim) ) + allocate( imu_hm_2_n(1:hydromet_dim) ) + allocate( isigma_hm_1(1:hydromet_dim) ) + allocate( isigma_hm_2(1:hydromet_dim) ) + allocate( isigma_hm_1_n(1:hydromet_dim) ) + allocate( isigma_hm_2_n(1:hydromet_dim) ) + + allocate( icorr_w_hm_1(1:hydromet_dim) ) + allocate( icorr_w_hm_2(1:hydromet_dim) ) + allocate( icorr_chi_hm_1(1:hydromet_dim) ) + allocate( icorr_chi_hm_2(1:hydromet_dim) ) + allocate( icorr_eta_hm_1(1:hydromet_dim) ) + allocate( icorr_eta_hm_2(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_1(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_2(1:hydromet_dim) ) + allocate( icorr_hmx_hmy_1(1:hydromet_dim,1:hydromet_dim) ) + allocate( icorr_hmx_hmy_2(1:hydromet_dim,1:hydromet_dim) ) + + allocate( icorr_w_hm_1_n(1:hydromet_dim) ) + allocate( icorr_w_hm_2_n(1:hydromet_dim) ) + allocate( icorr_chi_hm_1_n(1:hydromet_dim) ) + allocate( icorr_chi_hm_2_n(1:hydromet_dim) ) + allocate( icorr_eta_hm_1_n(1:hydromet_dim) ) + allocate( icorr_eta_hm_2_n(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_1_n(1:hydromet_dim) ) + allocate( icorr_Ncn_hm_2_n(1:hydromet_dim) ) + allocate( icorr_hmx_hmy_1_n(1:hydromet_dim,1:hydromet_dim) ) + allocate( icorr_hmx_hmy_2_n(1:hydromet_dim,1:hydromet_dim) ) + + allocate( ihmp2_zt(1:hydromet_dim) ) + + allocate( iwp2hmp(1:hydromet_dim) ) + + ihm_1(:) = 0 + ihm_2(:) = 0 + imu_hm_1(:) = 0 + imu_hm_2(:) = 0 + imu_hm_1_n(:) = 0 + imu_hm_2_n(:) = 0 + isigma_hm_1(:) = 0 + isigma_hm_2(:) = 0 + isigma_hm_1_n(:) = 0 + isigma_hm_2_n(:) = 0 + + icorr_w_hm_1(:) = 0 + icorr_w_hm_2(:) = 0 + icorr_chi_hm_1(:) = 0 + icorr_chi_hm_2(:) = 0 + icorr_eta_hm_1(:) = 0 + icorr_eta_hm_2(:) = 0 + icorr_Ncn_hm_1(:) = 0 + icorr_Ncn_hm_2(:) = 0 + icorr_hmx_hmy_1(:,:) = 0 + icorr_hmx_hmy_2(:,:) = 0 + + icorr_w_hm_1_n(:) = 0 + icorr_w_hm_2_n(:) = 0 + icorr_chi_hm_1_n(:) = 0 + icorr_chi_hm_2_n(:) = 0 + icorr_eta_hm_1_n(:) = 0 + icorr_eta_hm_2_n(:) = 0 + icorr_Ncn_hm_1_n(:) = 0 + icorr_Ncn_hm_2_n(:) = 0 + icorr_hmx_hmy_1_n(:,:) = 0 + icorr_hmx_hmy_2_n(:,:) = 0 + + ihmp2_zt(:) = 0 + + iwp2hmp(:) = 0 + + ! Allocate and then zero out passive scalar arrays + allocate( isclrm(1:sclr_dim) ) + allocate( isclrm_f(1:sclr_dim) ) + + isclrm(:) = 0 + isclrm_f(:) = 0 + + allocate( iedsclrm(1:edsclr_dim) ) + allocate( iedsclrm_f(1:edsclr_dim) ) + + iedsclrm(:) = 0 + iedsclrm_f(:) = 0 + + ! Assign pointers for statistics variables stats_zt using stat_assign + + tot_zt_loops = stats_zt%num_output_fields + + if ( any( vars_zt == "hm_i" ) ) then + ! Correct for number of variables found under "hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_hm_i" ) ) then + ! Correct for number of variables found under "mu_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "mu_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_Ncn_i" ) ) then + ! Correct for number of variables found under "mu_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "mu_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_hm_i_n" ) ) then + ! Correct for number of variables found under "mu_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "mu_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "mu_Ncn_i_n" ) ) then + ! Correct for number of variables found under "mu_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "mu_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_hm_i" ) ) then + ! Correct for number of variables found under "sigma_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "sigma_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_Ncn_i" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "sigma_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_hm_i_n" ) ) then + ! Correct for number of variables found under "sigma_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "sigma_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "sigma_Ncn_i_n" ) ) then + ! Correct for number of variables found under "sigma_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "sigma_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "corr_w_hm_i" ) ) then + ! Correct for number of variables found under "corr_whm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_whm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_w_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_wNcn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_wNcn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_hm_i" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_chi_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_chi_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_hm_i" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_eta_hm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_Ncn_i" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_eta_Ncn_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_Ncn_hm_i" ) ) then + ! Correct for number of variables found under "corr_Ncnhm_i". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_Ncnhm_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_hmx_hmy_i" ) ) then + ! Correct for number of variables found under "corr_hmxhmy_i". + ! Subtract 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of correlations of two hydrometeors, which is found by: + ! (1/2) * hydromet_dim * ( hydromet_dim - 1 ); from the loop size. + tot_zt_loops = tot_zt_loops - hydromet_dim * ( hydromet_dim - 1 ) + ! Add 1 for "corr_hmxhmy_i" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "corr_w_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_whm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_whm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_w_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_wNcn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_wNcn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_chi_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_chi_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_chi_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_chi_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_hm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_eta_hm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_eta_Ncn_i_n" ) ) then + ! Correct for number of variables found under "corr_eta_Ncn_i_n". + ! Subtract 2 from the loop size (1st PDF comp. and 2nd PDF comp.). + tot_zt_loops = tot_zt_loops - 2 + ! Add 1 for "corr_eta_Ncn_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_Ncn_hm_i_n" ) ) then + ! Correct for number of variables found under "corr_Ncnhm_i_n". + ! Subtract 2 from the loop size (1st PDF component and 2nd PDF component) + ! for each hydrometeor. + tot_zt_loops = tot_zt_loops - 2 * hydromet_dim + ! Add 1 for "corr_Ncnhm_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + if ( any( vars_zt == "corr_hmx_hmy_i_n" ) ) then + ! Correct for number of variables found under "corr_hmxhmy_i_n". + ! Subtract 2 (1st PDF component and 2nd PDF component) multipled by the + ! number of normal space correlations of two hydrometeors, which is found + ! by: (1/2) * hydromet_dim * ( hydromet_dim - 1 ); + ! from the loop size. + tot_zt_loops = tot_zt_loops - hydromet_dim * ( hydromet_dim - 1 ) + ! Add 1 for "corr_hmxhmy_i_n" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "hmp2_zt" ) ) then + ! Correct for number of variables found under "hmp2_zt". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zt_loops = tot_zt_loops - hydromet_dim + ! Add 1 for "hmp2_zt" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "wp2hmp" ) ) then + ! Correct for number of variables found under "wp2hmp". + ! Subtract 1 from the loop size for each hydrometeor. + tot_zt_loops = tot_zt_loops - hydromet_dim + ! Add 1 for "wp2hmp" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "sclrm" ) ) then + ! Correct for number of variables found under "sclrm". + ! Subtract 1 from the loop size for each scalar. + tot_zt_loops = tot_zt_loops - sclr_dim + + ! Add 1 for "sclrm" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "sclrm_f" ) ) then + ! Correct for number of variables found under "sclrm_f". + ! Subtract 1 from the loop size for each scalar. + tot_zt_loops = tot_zt_loops - sclr_dim + ! Add 1 for "sclrm_f" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "edsclrm" ) ) then + ! Correct for number of variables found under "edsclrm". + ! Subtract 1 from the loop size for each scalar. + tot_zt_loops = tot_zt_loops - edsclr_dim + ! Add 1 for "edsclrm" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + if ( any( vars_zt == "edsclrm_f" ) ) then + ! Correct for number of variables found under "edsclrm_f". + ! Subtract 1 from the loop size for each scalar. + tot_zt_loops = tot_zt_loops - edsclr_dim + ! Add 1 for "edsclrm_f" to the loop size. + tot_zt_loops = tot_zt_loops + 1 + endif + + k = 1 + + do i = 1, tot_zt_loops + + select case ( trim( vars_zt(i) ) ) + case ('thlm') + ithlm = k + call stat_assign( var_index=ithlm, var_name="thlm", & + var_description="Liquid water potential temperature (theta_l) [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('T_in_K') + iT_in_K = k + call stat_assign( var_index=iT_in_K, var_name="T_in_K", & + var_description="Absolute temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thvm') + ithvm = k + call stat_assign( var_index=ithvm, var_name="thvm", & + var_description="Virtual potential temperature [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('rtm') + irtm = k + + call stat_assign( var_index=irtm, var_name="rtm", & + var_description="Total (vapor+liquid) water mixing ratio [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rcm') + ircm = k + call stat_assign( var_index=ircm, var_name="rcm", & + var_description="Cloud water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rfrzm') + irfrzm = k + call stat_assign( var_index=irfrzm, var_name="rfrzm", & + var_description="Total ice phase water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rvm') + irvm = k + call stat_assign( var_index=irvm, var_name="rvm", & + var_description="Vapor water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rel_humidity') + irel_humidity = k + call stat_assign( var_index=irel_humidity, var_name="rel_humidity", & + var_description="Relative humidity w.r.t. liquid (range [0,1]) [-]", & + var_units="[-]", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('um') + ium = k + call stat_assign( var_index=ium, var_name="um", & + var_description="East-west (u) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vm') + ivm = k + call stat_assign( var_index=ivm, var_name="vm", & + var_description="North-south (v) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('wm_zt') + iwm_zt = k + call stat_assign( var_index=iwm_zt, var_name="wm", & + var_description="Vertical (w) wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('um_ref') + ium_ref = k + call stat_assign( var_index=ium_ref, var_name="um_ref", & + var_description="reference u wind (m/s) [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vm_ref') + ivm_ref = k + call stat_assign( var_index=ivm_ref, var_name="vm_ref", & + var_description="reference v wind (m/s) [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('ug') + iug = k + call stat_assign( var_index=iug, var_name="ug", & + var_description="u geostrophic wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('vg') + ivg = k + call stat_assign( var_index=ivg, var_name="vg", & + var_description="v geostrophic wind [m/s]", var_units="m/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('cloud_frac') + icloud_frac = k + call stat_assign( var_index=icloud_frac, var_name="cloud_frac", & + var_description="Cloud fraction (between 0 and 1) [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('ice_supersat_frac') + iice_supersat_frac = k + call stat_assign( var_index=iice_supersat_frac, var_name="ice_supersat_frac", & + var_description="Ice cloud fraction (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_in_layer') + ircm_in_layer = k + call stat_assign( var_index=ircm_in_layer, var_name="rcm_in_layer", & + var_description="rcm in cloud layer [kg/kg]", var_units="kg/kg", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_in_cloud') + ircm_in_cloud = k + call stat_assign( var_index=ircm_in_cloud, var_name="rcm_in_cloud", & + var_description="in-cloud value of rcm (for microphysics) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_cover') + icloud_cover = k + call stat_assign( var_index=icloud_cover, var_name="cloud_cover", & + var_description="Cloud cover (between 0 and 1) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('p_in_Pa') + ip_in_Pa = k + call stat_assign( var_index=ip_in_Pa, var_name="p_in_Pa", & + var_description="Pressure [Pa]", var_units="Pa", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('exner') + iexner = k + call stat_assign( var_index=iexner, var_name="exner", & + var_description="Exner function = (p/p0)**(rd/cp) [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rho_ds_zt') + irho_ds_zt = k + call stat_assign( var_index=irho_ds_zt, var_name="rho_ds_zt", & + var_description="Dry, static, base-state density [kg/m^3]", var_units="kg m^{-3}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thv_ds_zt') + ithv_ds_zt = k + call stat_assign( var_index=ithv_ds_zt, var_name="thv_ds_zt", & + var_description="Dry, base-state theta_v [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + case ('Lscale') + iLscale = k + call stat_assign( var_index=iLscale, var_name="Lscale", & + var_description="Mixing length [m]", var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thlm_forcing') + ithlm_forcing = k + call stat_assign( var_index=ithlm_forcing, var_name="thlm_forcing", & + var_description="thlm budget: thetal forcing (includes thlm_mc and radht) [K s^{-1}]",& + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('thlm_mc') + ithlm_mc = k + call stat_assign( var_index=ithlm_mc, var_name="thlm_mc", & + var_description="Change in thlm due to microphysics (not in budget) [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + case ('rtm_forcing') + irtm_forcing = k + call stat_assign( var_index=irtm_forcing, var_name="rtm_forcing", & + var_description="rtm budget: rt forcing (includes rtm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mc') + irtm_mc = k + call stat_assign( var_index=irtm_mc, var_name="rtm_mc", & + var_description="Change in rt due to microphysics (not in budget) & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rvm_mc') + irvm_mc = k + call stat_assign( var_index=irvm_mc, var_name="rvm_mc", & + var_description="Time tendency of vapor mixing ratio due to microphysics [kg/kg/s]", & + var_units="kg/(kg s)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_mc') + ircm_mc = k + call stat_assign( var_index=ircm_mc, var_name="rcm_mc", & + var_description="Time tendency of liquid water mixing ratio due microphysics & + &[kg/kg/s]", & + var_units="kg/kg/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_sd_mg_morr') + ircm_sd_mg_morr = k + call stat_assign( var_index=ircm_sd_mg_morr, var_name="rcm_sd_mg_morr", & + var_description="rcm sedimentation when using morrision or MG microphysics & + &(not in budget, included in rcm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl_min') + ithlm_mfl_min = k + call stat_assign( var_index=ithlm_mfl_min, var_name="thlm_mfl_min", & + var_description="Minimum allowable thlm [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl_max') + ithlm_mfl_max = k + call stat_assign( var_index=ithlm_mfl_max, var_name="thlm_mfl_max", & + var_description="Maximum allowable thlm [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_enter_mfl') + ithlm_enter_mfl = k + call stat_assign( var_index=ithlm_enter_mfl, var_name="thlm_enter_mfl", & + var_description="Thlm before flux-limiter [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_exit_mfl') + ithlm_exit_mfl = k + call stat_assign( var_index=ithlm_exit_mfl, var_name="thlm_exit_mfl", & + var_description="Thlm exiting flux-limiter [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_old') + ithlm_old = k + call stat_assign( var_index=ithlm_old, var_name="thlm_old", & + var_description="Thlm at previous timestep [K]", var_units="K", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_without_ta') + ithlm_without_ta = k + call stat_assign( var_index=ithlm_without_ta, var_name="thlm_without_ta", & + var_description="Thlm without turbulent advection contribution [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl_min') + irtm_mfl_min = k + call stat_assign( var_index=irtm_mfl_min, var_name="rtm_mfl_min", & + var_description="Minimum allowable rtm [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl_max') + irtm_mfl_max = k + call stat_assign( var_index=irtm_mfl_max, var_name="rtm_mfl_max", & + var_description="Maximum allowable rtm [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_enter_mfl') + irtm_enter_mfl = k + call stat_assign( var_index=irtm_enter_mfl, var_name="rtm_enter_mfl", & + var_description="Rtm before flux-limiter [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_exit_mfl') + irtm_exit_mfl = k + call stat_assign( var_index=irtm_exit_mfl, var_name="rtm_exit_mfl", & + var_description="Rtm exiting flux-limiter [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_old') + irtm_old = k + call stat_assign( var_index=irtm_old, var_name="rtm_old", & + var_description="Rtm at previous timestep [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_without_ta') + irtm_without_ta = k + call stat_assign( var_index=irtm_without_ta, var_name="rtm_without_ta", & + var_description="Rtm without turbulent advection contribution [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3') + iwp3 = k + call stat_assign( var_index=iwp3, var_name="wp3", & + var_description="w third order moment [m^3/s^3]", var_units="m^3/s^3", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlp3') + ithlp3 = k + call stat_assign( var_index=ithlp3, var_name="thlp3", & + var_description="thl third order moment [K^3]", var_units="m^3/s^3", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtp3') + irtp3 = k + call stat_assign( var_index=irtp3, var_name="rtp3", & + var_description="rt third order moment [kg^3/kg^3]", var_units="m^3/s^3", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wpthlp2') + iwpthlp2 = k + call stat_assign( var_index=iwpthlp2, var_name="wpthlp2", & + var_description="w'thl'^2 [(m K^2)/s]", var_units="(m K^2)/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2thlp') + iwp2thlp = k + call stat_assign( var_index=iwp2thlp, var_name="wp2thlp", & + var_description="w'^2thl' [(m^2 K)/s^2]", var_units="(m^2 K)/s^2", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wprtp2') + iwprtp2 = k + call stat_assign( var_index=iwprtp2, var_name="wprtp2", & + var_description="w'rt'^2 [(m kg)/(s kg)]", var_units="(m kg)/(s kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp2rtp') + iwp2rtp = k + call stat_assign( var_index=iwp2rtp, var_name="wp2rtp", & + var_description="w'^2rt' [(m^2 kg)/(s^2 kg)]", var_units="(m^2 kg)/(s^2 kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_up') + iLscale_up = k + call stat_assign( var_index=iLscale_up, var_name="Lscale_up", & + var_description="Upward mixing length [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_down') + iLscale_down = k + call stat_assign( var_index=iLscale_down, var_name="Lscale_down", & + var_description="Downward mixing length [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_pert_1') + iLscale_pert_1 = k + call stat_assign( var_index=iLscale_pert_1, var_name="Lscale_pert_1", & + var_description="Mixing length using a perturbed value of rtm/thlm [m]", & + var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Lscale_pert_2') + iLscale_pert_2 = k + call stat_assign( var_index=iLscale_pert_2, var_name="Lscale_pert_2", & + var_description="Mixing length using a perturbed value of rtm/thlm [m]", & + var_units="m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('tau_zt') + itau_zt = k + call stat_assign( var_index=itau_zt, var_name="tau_zt", & + var_description="Dissipation time [s]", var_units="s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('Kh_zt') + iKh_zt = k + call stat_assign( var_index=iKh_zt, var_name="Kh_zt", & + var_description="Eddy diffusivity [m^2/s]", var_units="m^2/s", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2thvp') + iwp2thvp = k + call stat_assign( var_index=iwp2thvp, var_name="wp2thvp", & + var_description="w'^2thv' [K m^2/s^2]", var_units="K m^2/s^2", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('wp2rcp') + iwp2rcp = k + call stat_assign( var_index=iwp2rcp, var_name="wp2rcp", & + var_description="w'^2rc' [(m^2 kg)/(s^2 kg)]", var_units="(m^2 kg)/(s^2 kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wprtpthlp') + iwprtpthlp = k + call stat_assign( var_index=iwprtpthlp, var_name="wprtpthlp", & + var_description="w'rt'thl' [(m kg K)/(s kg)]", var_units="(m kg K)/(s kg)", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('sigma_sqd_w_zt') + isigma_sqd_w_zt = k + call stat_assign( var_index=isigma_sqd_w_zt, var_name="sigma_sqd_w_zt", & + var_description="Nondimensionalized w variance of Gaussian component [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rho') + irho = k + call stat_assign( var_index=irho, var_name="rho", var_description="Air density [kg/m^3]", & + var_units="kg m^{-3}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm') ! Brian + iNcm = k + call stat_assign( var_index=iNcm, var_name="Ncm", & + var_description="Cloud droplet number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nc_in_cloud') + iNc_in_cloud = k + + call stat_assign( var_index=iNc_in_cloud, var_name="Nc_in_cloud", & + var_description="In cloud droplet concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nc_activated') + iNc_activated = k + + call stat_assign( var_index=iNc_activated, var_name="Nc_activated", & + var_description="Droplets activated by GFDL activation [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nccnm') + iNccnm = k + call stat_assign( var_index=iNccnm, var_name="Nccnm", & + var_description="Cloud condensation nuclei concentration (COAMPS/MG) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim') ! Brian + iNim = k + call stat_assign( var_index=iNim, var_name="Nim", & + var_description="Ice crystal number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('snowslope') ! Adam Smith, 22 April 2008 + isnowslope = k + call stat_assign( var_index=isnowslope, var_name="snowslope", & + var_description="COAMPS microphysics snow slope parameter [1/m]", var_units="1/m", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm') ! Adam Smith, 22 April 2008 + iNsm = k + call stat_assign( var_index=iNsm, var_name="Nsm", & + var_description="Snow particle number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm') + iNgm = k + call stat_assign( var_index=iNgm, var_name="Ngm", & + var_description="Graupel number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('sed_rcm') ! Brian + ised_rcm = k + call stat_assign( var_index=ised_rcm, var_name="sed_rcm", & + var_description="d(rcm)/dt due to cloud sedimentation [kg / (m^2 s)]", & + var_units="kg / [m^2 s]", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsat') ! Brian + irsat = k + call stat_assign( var_index=irsat, var_name="rsat", & + var_description="Saturation mixing ratio over liquid [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsati') + irsati = k + call stat_assign( var_index=irsati, var_name="rsati", & + var_description="Saturation mixing ratio over ice [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm') ! Brian + irrm = k + call stat_assign( var_index=irrm, var_name="rrm", & + var_description="Rain water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm') + irsm = k + call stat_assign( var_index=irsm, var_name="rsm", & + var_description="Snow water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim') + irim = k + call stat_assign( var_index=irim, var_name="rim", & + var_description="Pristine ice water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm') + irgm = k + call stat_assign( var_index=irgm, var_name="rgm", & + var_description="Graupel water mixing ratio [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm') ! Brian + iNrm = k + call stat_assign( var_index=iNrm, var_name="Nrm", & + var_description="Rain drop number concentration [num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('m_vol_rad_rain') ! Brian + im_vol_rad_rain = k + call stat_assign( var_index=im_vol_rad_rain, var_name="mvrr", & + var_description="Rain drop mean volume radius [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('m_vol_rad_cloud') + im_vol_rad_cloud = k + call stat_assign( var_index=im_vol_rad_cloud, var_name="m_vol_rad_cloud", & + var_description="Cloud drop mean volume radius [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_cloud') + ieff_rad_cloud = k + call stat_assign( var_index=ieff_rad_cloud, var_name="eff_rad_cloud", & + var_description="Cloud drop effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_ice') + ieff_rad_ice = k + + call stat_assign( var_index=ieff_rad_ice, var_name="eff_rad_ice", & + var_description="Ice effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_snow') + ieff_rad_snow = k + call stat_assign( var_index=ieff_rad_snow, var_name="eff_rad_snow", & + var_description="Snow effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_rain') + ieff_rad_rain = k + call stat_assign( var_index=ieff_rad_rain, var_name="eff_rad_rain", & + var_description="Rain drop effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('eff_rad_graupel') + ieff_rad_graupel = k + call stat_assign( var_index=ieff_rad_graupel, var_name="eff_rad_graupel", & + var_description="Graupel effective volume radius [microns]", var_units="microns", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('precip_rate_zt') ! Brian + iprecip_rate_zt = k + + call stat_assign( var_index=iprecip_rate_zt, var_name="precip_rate_zt", & + var_description="Rain rate [mm/day]", var_units="mm/day", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('radht') + iradht = k + + call stat_assign( var_index=iradht, var_name="radht", & + var_description="Total (sw+lw) radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('radht_LW') + iradht_LW = k + + call stat_assign( var_index=iradht_LW, var_name="radht_LW", & + var_description="Long-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('radht_SW') + iradht_SW = k + call stat_assign( var_index=iradht_SW, var_name="radht_SW", & + var_description="Short-wave radiative heating rate [K/s]", var_units="K/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('diam') + idiam = k + + call stat_assign( var_index=idiam, var_name="diam", & + var_description="Ice crystal diameter [m]", var_units="m", l_silhs=.false., & + grid_kind=stats_zt ) + k = k + 1 + + case ('mass_ice_cryst') + imass_ice_cryst = k + call stat_assign( var_index=imass_ice_cryst, var_name="mass_ice_cryst", & + var_description="Mass of a single ice crystal [kg]", var_units="kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_icedfs') + + ircm_icedfs = k + call stat_assign( var_index=ircm_icedfs, var_name="rcm_icedfs", & + var_description="Change in liquid due to ice [kg/kg/s]", var_units="kg/kg/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('u_T_cm') + iu_T_cm = k + call stat_assign( var_index=iu_T_cm, var_name="u_T_cm", & + var_description="Ice crystal fallspeed [cm s^{-1}]", var_units="cm s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_bt') + irtm_bt = k + + call stat_assign( var_index=irtm_bt, var_name="rtm_bt", & + var_description="rtm budget: rtm time tendency [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_ma') + irtm_ma = k + + call stat_assign( var_index=irtm_ma, var_name="rtm_ma", & + var_description="rtm budget: rtm vertical mean advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_ta') + irtm_ta = k + + call stat_assign( var_index=irtm_ta, var_name="rtm_ta", & + var_description="rtm budget: rtm turbulent advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rtm_mfl') + irtm_mfl = k + + call stat_assign( var_index=irtm_mfl, var_name="rtm_mfl", & + var_description="rtm budget: rtm correction due to monotonic flux limiter & + &[kg kg^{-1} s^{-1}]", var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt) + k = k + 1 + + case ('rtm_tacl') + irtm_tacl = k + + call stat_assign( var_index=irtm_tacl, var_name="rtm_tacl", & + var_description="rtm budget: rtm correction due to ta term (wprtp) clipping & + &[kg kg^{-1} s^{-1}]", var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt) + + k = k + 1 + + case ('rtm_cl') + irtm_cl = k + + call stat_assign( var_index=irtm_cl, var_name="rtm_cl", & + var_description="rtm budget: rtm clipping [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + case ('rtm_sdmp') + irtm_sdmp = k + + call stat_assign( var_index=irtm_sdmp, var_name="rtm_sdmp", & + var_description="rtm budget: rtm correction due to sponge damping & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case ('rtm_pd') + irtm_pd = k + + call stat_assign( var_index=irtm_pd, var_name="rtm_pd", & + var_description="rtm budget: rtm positive definite adjustment [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('thlm_bt') + ithlm_bt = k + + call stat_assign( var_index=ithlm_bt, var_name="thlm_bt", & + var_description="thlm budget: thlm time tendency [K s^{-1}]", var_units="K s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_ma') + ithlm_ma = k + + call stat_assign( var_index=ithlm_ma, var_name="thlm_ma", & + var_description="thlm budget: thlm vertical mean advection [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_sdmp') + ithlm_sdmp = k + + call stat_assign( var_index=ithlm_sdmp, var_name="thlm_sdmp", & + var_description="thlm budget: thlm correction due to sponge damping [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case ('thlm_ta') + ithlm_ta = k + + call stat_assign( var_index=ithlm_ta, var_name="thlm_ta", & + var_description="thlm budget: thlm turbulent advection [K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_mfl') + ithlm_mfl = k + + call stat_assign( var_index=ithlm_mfl, var_name="thlm_mfl", & + var_description="thlm budget: thlm correction due to monotonic flux limiter & + &[K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_tacl') + ithlm_tacl = k + + call stat_assign( var_index=ithlm_tacl, var_name="thlm_tacl", & + var_description="thlm budget: thlm correction due to ta term (wpthlp) clipping & + &[K s^{-1}]", & + var_units="K s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thlm_cl') + ithlm_cl = k + + call stat_assign( var_index=ithlm_cl, var_name="thlm_cl", & + var_description="thlm budget: thlm_cl [K s^{-1}]", var_units="K s^{-1}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bt') + iwp3_bt = k + + call stat_assign( var_index=iwp3_bt, var_name="wp3_bt", & + var_description="wp3 budget: wp3 time tendency [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ma') + iwp3_ma = k + + call stat_assign( var_index=iwp3_ma, var_name="wp3_ma", & + var_description="wp3 budget: wp3 vertical mean advection [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ta') + iwp3_ta = k + + call stat_assign( var_index=iwp3_ta, var_name="wp3_ta", & + var_description="wp3 budget: wp3 turbulent advection [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('wp3_tp') + iwp3_tp = k + call stat_assign( var_index=iwp3_tp, var_name="wp3_tp", & + var_description="wp3 budget: wp3 turbulent transport [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_ac') + iwp3_ac = k + call stat_assign( var_index=iwp3_ac, var_name="wp3_ac", & + var_description="wp3 budget: wp3 accumulation term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bp1') + iwp3_bp1 = k + call stat_assign( var_index=iwp3_bp1, var_name="wp3_bp1", & + var_description="wp3 budget: wp3 buoyancy production [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_bp2') + iwp3_bp2 = k + call stat_assign( var_index=iwp3_bp2, var_name="wp3_bp2", & + var_description="wp3 budget: wp3 2nd buoyancy production term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_pr1') + iwp3_pr1 = k + call stat_assign( var_index=iwp3_pr1, var_name="wp3_pr1", & + var_description="wp3 budget: wp3 pressure term 1 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_pr2') + iwp3_pr2 = k + call stat_assign( var_index=iwp3_pr2, var_name="wp3_pr2", & + var_description="wp3 budget: wp3 pressure term 2 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('wp3_dp1') + iwp3_dp1 = k + call stat_assign( var_index=iwp3_dp1, var_name="wp3_dp1", & + var_description="wp3 budget: wp3 dissipation term 1 [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('wp3_cl') + iwp3_cl = k + call stat_assign( var_index=iwp3_cl, var_name="wp3_cl", & + var_description="wp3 budget: wp3 clipping term [m^{3} s^{-4}]", & + var_units="m^{3} s^{-4}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_bt') + irrm_bt = k + call stat_assign( var_index=irrm_bt, var_name="rrm_bt", & + var_description="rrm budget: rrm time tendency [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ma') + irrm_ma = k + + call stat_assign( var_index=irrm_ma, var_name="rrm_ma", & + var_description="rrm budget: rrm vertical mean advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_sd') + irrm_sd = k + + call stat_assign( var_index=irrm_sd, var_name="rrm_sd", & + var_description="rrm budget: rrm sedimentation [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ts') + irrm_ts = k + + call stat_assign( var_index=irrm_ts, var_name="rrm_ts", & + var_description="rrm budget: rrm turbulent sedimentation [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_sd_morr') + irrm_sd_morr = k + + call stat_assign( var_index=irrm_sd_morr, var_name="rrm_sd_morr", & + var_description="rrm sedimentation when using morrision microphysics & + &(not in budget, included in rrm_mc) [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_ta') + irrm_ta = k + + call stat_assign( var_index=irrm_ta, var_name="rrm_ta", & + var_description="rrm budget: rrm turbulent advection [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cond') + irrm_cond = k + + call stat_assign( var_index=irrm_cond, var_name="rrm_cond", & + var_description="rrm evaporation rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_auto') + irrm_auto = k + + call stat_assign( var_index=irrm_auto, var_name="rrm_auto", & + var_description="rrm autoconversion rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_accr') + irrm_accr = k + call stat_assign( var_index=irrm_accr, var_name="rrm_accr", & + var_description="rrm accretion rate [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cond_adj') + irrm_cond_adj = k + + call stat_assign( var_index=irrm_cond_adj, var_name="rrm_cond_adj", & + var_description="rrm evaporation adjustment due to over-evaporation & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_src_adj') + irrm_src_adj = k + + call stat_assign( var_index=irrm_src_adj, var_name="rrm_src_adj", & + var_description="rrm source term adjustment due to over-depletion & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_mc_nonadj') + irrm_mc_nonadj = k + + call stat_assign( var_index=irrm_mc_nonadj, var_name="rrm_mc_nonadj", & + var_description="Value of rrm_mc tendency before adjustment [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_hf') + irrm_hf = k + call stat_assign( var_index=irrm_hf, var_name="rrm_hf", & + var_description="rrm budget: rrm hole-filling term [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_wvhf') + irrm_wvhf = k + call stat_assign( var_index=irrm_wvhf, var_name="rrm_wvhf", & + var_description="rrm budget: rrm water vapor hole-filling term & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_cl') + irrm_cl = k + call stat_assign( var_index=irrm_cl, var_name="rrm_cl", & + var_description="rrm budget: rrm clipping term [kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrm_mc') + irrm_mc = k + + call stat_assign( var_index=irrm_mc, var_name="rrm_mc", & + var_description="rrm budget: Change in rrm due to microphysics & + &[kg kg^{-1} s^{-1}]", & + var_units="kg kg^{-1} s^{-1}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_bt') + iNrm_bt = k + call stat_assign( var_index=iNrm_bt, var_name="Nrm_bt", & + var_description="Nrm budget: Nrm time tendency [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_ma') + iNrm_ma = k + + call stat_assign( var_index=iNrm_ma, var_name="Nrm_ma", & + var_description="Nrm budget: Nrm vertical mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_sd') + iNrm_sd = k + + call stat_assign( var_index=iNrm_sd, var_name="Nrm_sd", & + var_description="Nrm budget: Nrm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_ts') + iNrm_ts = k + + call stat_assign( var_index=iNrm_ts, var_name="Nrm_ts", & + var_description="Nrm budget: Nrm turbulent sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_ta') + iNrm_ta = k + call stat_assign( var_index=iNrm_ta, var_name="Nrm_ta", & + var_description="Nrm budget: Nrm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_cond') + iNrm_cond = k + + call stat_assign( var_index=iNrm_cond, var_name="Nrm_cond", & + var_description="Nrm evaporation rate [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_auto') + iNrm_auto = k + + call stat_assign( var_index=iNrm_auto, var_name="Nrm_auto", & + var_description="Nrm autoconversion rate [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nrm_cond_adj') + iNrm_cond_adj = k + + call stat_assign( var_index=iNrm_cond_adj, var_name="Nrm_cond_adj", & + var_description="Nrm evaporation adjustment due to over-evaporation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_src_adj') + iNrm_src_adj = k + + call stat_assign( var_index=iNrm_src_adj, var_name="Nrm_src_adj", & + var_description="Nrm source term adjustment due to over-depletion [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_cl') + iNrm_cl = k + call stat_assign( var_index=iNrm_cl, var_name="Nrm_cl", & + var_description="Nrm budget: Nrm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nrm_mc') + iNrm_mc = k + call stat_assign( var_index=iNrm_mc, var_name="Nrm_mc", & + var_description="Nrm budget: Change in Nrm due to microphysics (Not in budget) & + &[(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_bt') + irsm_bt = k + call stat_assign( var_index=irsm_bt, var_name="rsm_bt", & + var_description="rsm budget: rsm time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rsm_ma') + irsm_ma = k + + call stat_assign( var_index=irsm_ma, var_name="rsm_ma", & + var_description="rsm budget: rsm vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_sd') + irsm_sd = k + call stat_assign( var_index=irsm_sd, var_name="rsm_sd", & + var_description="rsm budget: rsm sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_sd_morr') + irsm_sd_morr = k + call stat_assign( var_index=irsm_sd_morr, var_name="rsm_sd_morr", & + var_description="rsm sedimentation when using morrison microphysics & + &(Not in budget, included in rsm_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_ta') + irsm_ta = k + + call stat_assign( var_index=irsm_ta, var_name="rsm_ta", & + var_description="rsm budget: rsm turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_mc') + irsm_mc = k + + call stat_assign( var_index=irsm_mc, var_name="rsm_mc", & + var_description="rsm budget: Change in rsm due to microphysics [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_hf') + irsm_hf = k + + call stat_assign( var_index=irsm_hf, var_name="rsm_hf", & + var_description="rsm budget: rsm hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_wvhf') + irsm_wvhf = k + + call stat_assign( var_index=irsm_wvhf, var_name="rsm_wvhf", & + var_description="rsm budget: rsm water vapor hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsm_cl') + irsm_cl = k + + call stat_assign( var_index=irsm_cl, var_name="rsm_cl", & + var_description="rsm budget: rsm clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm_bt') + iNsm_bt = k + call stat_assign( var_index=iNsm_bt, var_name="Nsm_bt", & + var_description="Nsm budget: [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_ma') + iNsm_ma = k + + call stat_assign( var_index=iNsm_ma, var_name="Nsm_ma", & + var_description="Nsm budget: Nsm mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nsm_sd') + iNsm_sd = k + + call stat_assign( var_index=iNsm_sd, var_name="Nsm_sd", & + var_description="Nsm budget: Nsm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_ta') + iNsm_ta = k + call stat_assign( var_index=iNsm_ta, var_name="Nsm_ta", & + var_description="Nsm budget: Nsm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_mc') + iNsm_mc = k + call stat_assign( var_index=iNsm_mc, var_name="Nsm_mc", & + var_description="Nsm budget: Nsm microphysics [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nsm_cl') + iNsm_cl = k + + call stat_assign( var_index=iNsm_cl, var_name="Nsm_cl", & + var_description="Nsm budget: Nsm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_bt') + irim_bt = k + + call stat_assign( var_index=irim_bt, var_name="rim_bt", & + var_description="rim budget: rim time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rim_ma') + irim_ma = k + + call stat_assign( var_index=irim_ma, var_name="rim_ma", & + var_description="rim budget: rim vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_sd') + irim_sd = k + + call stat_assign( var_index=irim_sd, var_name="rim_sd", & + var_description="rim budget: rim sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_sd_mg_morr') + irim_sd_mg_morr = k + + call stat_assign( var_index=irim_sd_mg_morr, var_name="rim_sd_mg_morr", & + var_description="rim sedimentation when using morrison or MG microphysics & + &(not in budget, included in rim_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_ta') + irim_ta = k + + call stat_assign( var_index=irim_ta, var_name="rim_ta", & + var_description="rim budget: rim turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_mc') + irim_mc = k + + call stat_assign( var_index=irim_mc, var_name="rim_mc", & + var_description="rim budget: Change in rim due to microphysics [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_hf') + irim_hf = k + + call stat_assign( var_index=irim_hf, var_name="rim_hf", & + var_description="rim budget: rim hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_wvhf') + irim_wvhf = k + + call stat_assign( var_index=irim_wvhf, var_name="rim_wvhf", & + var_description="rim budget: rim water vapor hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rim_cl') + irim_cl = k + + call stat_assign( var_index=irim_cl, var_name="rim_cl", & + var_description="rim budget: rim clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_bt') + irgm_bt = k + + call stat_assign( var_index=irgm_bt, var_name="rgm_bt", & + var_description="rgm budget: rgm time tendency [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_ma') + irgm_ma = k + + call stat_assign( var_index=irgm_ma, var_name="rgm_ma", & + var_description="rgm budget: rgm vertical mean advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_sd') + irgm_sd = k + + call stat_assign( var_index=irgm_sd, var_name="rgm_sd", & + var_description="rgm budget: rgm sedimentation [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_sd_morr') + irgm_sd_morr = k + + call stat_assign( var_index=irgm_sd_morr, var_name="rgm_sd_morr", & + var_description="rgm sedimentation when using morrison microphysics & + &(not in budget, included in rgm_mc) [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_ta') + irgm_ta = k + + call stat_assign( var_index=irgm_ta, var_name="rgm_ta", & + var_description="rgm budget: rgm turbulent advection [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_mc') + irgm_mc = k + + call stat_assign( var_index=irgm_mc, var_name="rgm_mc", & + var_description="rgm budget: Change in rgm due to microphysics & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_hf') + irgm_hf = k + + call stat_assign( var_index=irgm_hf, var_name="rgm_hf", & + var_description="rgm budget: rgm hole-filling term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_wvhf') + irgm_wvhf = k + + call stat_assign( var_index=irgm_wvhf, var_name="rgm_wvhf", & + var_description="rgm budget: rgm water vapor hole-filling term & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rgm_cl') + irgm_cl = k + + call stat_assign( var_index=irgm_cl, var_name="rgm_cl", & + var_description="rgm budget: rgm clipping term [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_bt') + iNgm_bt = k + call stat_assign( var_index=iNgm_bt, var_name="Ngm_bt", & + var_description="Ngm budget: [(num/kg)/s]", var_units="(num/kg)/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_ma') + iNgm_ma = k + + call stat_assign( var_index=iNgm_ma, var_name="Ngm_ma", & + var_description="Ngm budget: Ngm mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_sd') + iNgm_sd = k + + call stat_assign( var_index=iNgm_sd, var_name="Ngm_sd", & + var_description="Ngm budget: Ngm sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_ta') + iNgm_ta = k + call stat_assign( var_index=iNgm_ta, var_name="Ngm_ta", & + var_description="Ngm budget: Ngm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ngm_mc') + iNgm_mc = k + + call stat_assign( var_index=iNgm_mc, var_name="Ngm_mc", & + var_description="Ngm budget: Ngm microphysics term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ngm_cl') + iNgm_cl = k + + call stat_assign( var_index=iNgm_cl, var_name="Ngm_cl", & + var_description="Ngm budget: Ngm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_bt') + iNim_bt = k + call stat_assign( var_index=iNim_bt, var_name="Nim_bt", & + var_description="Nim budget: [(num/kg)/s]", var_units="(num/kg)/s", l_silhs=.false., & + grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_ma') + iNim_ma = k + + call stat_assign( var_index=iNim_ma, var_name="Nim_ma", & + var_description="Nim budget: Nim mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_sd') + iNim_sd = k + + call stat_assign( var_index=iNim_sd, var_name="Nim_sd", & + var_description="Nim budget: Nim sedimentation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_ta') + iNim_ta = k + call stat_assign( var_index=iNim_ta, var_name="Nim_ta", & + var_description="Nim budget: Nim turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Nim_mc') + iNim_mc = k + + call stat_assign( var_index=iNim_mc, var_name="Nim_mc", & + var_description="Nim budget: Nim microphysics term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nim_cl') + iNim_cl = k + + call stat_assign( var_index=iNim_cl, var_name="Nim_cl", & + var_description="Nim budget: Nim clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_bt') + iNcm_bt = k + call stat_assign( var_index=iNcm_bt, var_name="Ncm_bt", & + var_description="Ncm budget: Cloud droplet number concentration budget [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_ma') + iNcm_ma = k + + call stat_assign( var_index=iNcm_ma, var_name="Ncm_ma", & + var_description="Ncm budget: Ncm vertical mean advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_act') + iNcm_act = k + + call stat_assign( var_index=iNcm_act, var_name="Ncm_act", & + var_description="Ncm budget: Change in Ncm due to activation [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_ta') + iNcm_ta = k + call stat_assign( var_index=iNcm_ta, var_name="Ncm_ta", & + var_description="Ncm budget: Ncm turbulent advection [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('Ncm_mc') + iNcm_mc = k + + call stat_assign( var_index=iNcm_mc, var_name="Ncm_mc", & + var_description="Ncm budget: Change in Ncm due to microphysics [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Ncm_cl') + iNcm_cl = k + + call stat_assign( var_index=iNcm_cl, var_name="Ncm_cl", & + var_description="Ncm budget: Ncm clipping term [(num/kg)/s]", & + var_units="(num/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('PSMLT') + iPSMLT = k + + call stat_assign( var_index=iPSMLT, var_name="PSMLT", & + var_description="Freezing of rain to form snow, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EVPMS') + iEVPMS = k + + call stat_assign( var_index=iEVPMS, var_name="EVPMS", & + var_description="Evaporation of melted snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACS') + iPRACS = k + + call stat_assign( var_index=iPRACS, var_name="PRACS", & + var_description="Collection of rain by snow, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EVPMG') + iEVPMG = k + + call stat_assign( var_index=iEVPMG, var_name="EVPMG", & + var_description="Evaporation of melted graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACG') + iPRACG = k + + call stat_assign( var_index=iPRACG, var_name="PRACG", & + var_description="Negative of collection of rain by graupel, +rrm, -rgm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGMLT') + iPGMLT = k + + call stat_assign( var_index=iPGMLT, var_name="PGMLT", & + var_description="Negative of melting of graupel, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCC') + iMNUCCC = k + + call stat_assign( var_index=iMNUCCC, var_name="MNUCCC", & + var_description="Contact freezing of cloud droplets, +rim, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWS') + iPSACWS = k + + call stat_assign( var_index=iPSACWS, var_name="PSACWS", & + var_description="Collection of cloud water by snow, +rsm, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWI') + iPSACWI = k + + call stat_assign( var_index=iPSACWI, var_name="PSACWI", & + var_description="Collection of cloud water by cloud ice, +rim, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTS') + iQMULTS = k + + call stat_assign( var_index=iQMULTS, var_name="QMULTS", & + var_description="Splintering from cloud droplets accreted onto snow, +rim, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTG') + iQMULTG = k + + call stat_assign( var_index=iQMULTG, var_name="QMULTG", & + var_description="Splintering from droplets accreted onto graupel, +rim, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACWG') + iPSACWG = k + + call stat_assign( var_index=iPSACWG, var_name="PSACWG", & + var_description="Collection of cloud water by graupel, +rgm, -rcm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGSACW') + iPGSACW = k + + call stat_assign( var_index=iPGSACW, var_name="PGSACW", & + var_description="Reclassification of rimed snow as graupel, +rgm, -rcm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRD') + iPRD = k + + call stat_assign( var_index=iPRD, var_name="PRD", & + var_description="Depositional growth of cloud ice, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRCI') + iPRCI = k + + call stat_assign( var_index=iPRCI, var_name="PRCI", & + var_description="Autoconversion of cloud ice to snow, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRAI') + iPRAI = k + + call stat_assign( var_index=iPRAI, var_name="PRAI", & + var_description="Collection of cloud ice by snow, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTR') + iQMULTR = k + + call stat_assign( var_index=iQMULTR, var_name="QMULTR", & + var_description="Splintering from rain droplets accreted onto snow, +rim, -rrm & + &[(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QMULTRG') + iQMULTRG = k + + call stat_assign( var_index=iQMULTRG, var_name="QMULTRG", & + var_description="Splintering from rain droplets accreted onto graupel, +rim, -rrm& + & [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCD') + iMNUCCD = k + + call stat_assign( var_index=iMNUCCD, var_name="MNUCCD", & + var_description="Freezing of aerosol, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACI') + iPRACI = k + + call stat_assign( var_index=iPRACI, var_name="PRACI", & + var_description="Collection of cloud ice by rain, +rgm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRACIS') + iPRACIS = k + + call stat_assign( var_index=iPRACIS, var_name="PRACIS", & + var_description="Collection of cloud ice by rain, +rsm, -rim [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRD') + iEPRD = k + + call stat_assign( var_index=iEPRD, var_name="EPRD", & + var_description="Negative of sublimation of cloud ice, +rim, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('MNUCCR') + iMNUCCR = k + + call stat_assign( var_index=iMNUCCR, var_name="MNUCCR", & + var_description="Contact freezing of rain droplets, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PIACR') + iPIACR = k + + call stat_assign( var_index=iPIACR, var_name="PIACR", & + var_description="Collection of cloud ice by rain, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PIACRS') + iPIACRS = k + + call stat_assign( var_index=iPIACRS, var_name="PIACRS", & + var_description="Collection of cloud ice by rain, +rsm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PGRACS') + iPGRACS = k + + call stat_assign( var_index=iPGRACS, var_name="PGRACS", & + var_description="Collection of rain by snow, +rgm, -rrm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRDS') + iPRDS = k + + call stat_assign( var_index=iPRDS, var_name="PRDS", & + var_description="Depositional growth of snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRDS') + iEPRDS = k + + call stat_assign( var_index=iEPRDS, var_name="EPRDS", & + var_description="Negative of sublimation of snow, +rsm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PSACR') + iPSACR = k + + call stat_assign( var_index=iPSACR, var_name="PSACR", & + var_description="Collection of snow by rain, +rgm, -rsm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRDG') + iPRDG = k + + call stat_assign( var_index=iPRDG, var_name="PRDG", & + var_description="Depositional growth of graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('EPRDG') + iEPRDG = k + + call stat_assign( var_index=iEPRDG, var_name="EPRDG", & + var_description="Negative of sublimation of graupel, +rgm, -rvm [(kg/kg)/s]", & + var_units="(kg/kg)/s", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGSTEN') + iNGSTEN = k + + call stat_assign( var_index=iNGSTEN, var_name="NGSTEN", & + var_description="Graupel sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NRSTEN') + iNRSTEN = k + + call stat_assign( var_index=iNRSTEN, var_name="NRSTEN", & + var_description="Rain sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NISTEN') + iNISTEN = k + + call stat_assign( var_index=iNISTEN, var_name="NISTEN", & + var_description="Cloud ice sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSSTEN') + iNSSTEN = k + + call stat_assign( var_index=iNSSTEN, var_name="NSSTEN", & + var_description="Snow sedimentation tendency [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NCSTEN') + iNCSTEN = k + + call stat_assign( var_index=iNCSTEN, var_name="NCSTEN", & + var_description="Cloud water sedimentation tendency [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRC1') + iNPRC1 = k + + call stat_assign( var_index=iNPRC1, var_name="NPRC1", & + var_description="Change in Nrm due to autoconversion of droplets, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NRAGG') + iNRAGG = k + + call stat_assign( var_index=iNRAGG, var_name="NRAGG", & + var_description="Change in Nrm due to self-collection of raindrops, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRACG') + iNPRACG = k + + call stat_assign( var_index=iNPRACG, var_name="NPRACG", & + var_description="Collection of rainwater by graupel, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBR') + iNSUBR = k + + call stat_assign( var_index=iNSUBR, var_name="NSUBR", & + var_description="Loss of Nrm by evaporation, +Nrm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSMLTR') + iNSMLTR = k + + call stat_assign( var_index=iNSMLTR, var_name="NSMLTR", & + var_description="Melting of snow to form rain, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGMLTR') + iNGMLTR = k + + call stat_assign( var_index=iNGMLTR, var_name="NGMLTR", & + var_description="Melting of graupel to form rain, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRACS') + iNPRACS = k + + call stat_assign( var_index=iNPRACS, var_name="NPRACS", & + var_description="Collection of rainwater by snow, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCR') + iNNUCCR = k + + call stat_assign( var_index=iNNUCCR, var_name="NNUCCR", & + var_description="Contact freezing of rain, +Ngm, -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIACR') + iNIACR = k + + call stat_assign( var_index=iNIACR, var_name="NIACR", & + var_description="Collection of cloud ice by rain, +Ngm, -Nrm, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIACRS') + iNIACRS = k + + call stat_assign( var_index=iNIACRS, var_name="NIACRS", & + var_description="Collection of cloud ice by rain, +Nsm, -Nrm, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGRACS') + iNGRACS = k + + call stat_assign( var_index=iNGRACS, var_name="NGRACS", & + var_description="Collection of rain by snow, +Ngm, -Nrm, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSMLTS') + iNSMLTS= k + + call stat_assign( var_index=iNSMLTS, var_name="NSMLTS", & + var_description="Melting of snow, +Nsm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSAGG') + iNSAGG= k + + call stat_assign( var_index=iNSAGG, var_name="NSAGG", & + var_description="Self collection of snow, +Nsm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + + k = k + 1 + + case ('NPRCI') + iNPRCI= k + + call stat_assign( var_index=iNPRCI, var_name="NPRCI", & + var_description="Autoconversion of cloud ice to snow, -Nim, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSCNG') + iNSCNG= k + + call stat_assign( var_index=iNSCNG, var_name="NSCNG", & + var_description="Conversion of snow to graupel, +Ngm, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBS') + iNSUBS= k + + call stat_assign( var_index=iNSUBS, var_name="NSUBS", & + var_description="Loss of snow due to sublimation, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRC') + iPRC= k + + call stat_assign( var_index=iPRC, var_name="PRC", & + var_description="Autoconversion +rrm -rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRA') + iPRA= k + + call stat_assign( var_index=iPRA, var_name="PRA", & + var_description="Accretion +rrm -rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PRE') + iPRE= k + + call stat_assign( var_index=iPRE, var_name="PRE", & + var_description="Evaporation of rain -rrm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('PCC') + iPCC= k + + call stat_assign( var_index=iPCC, var_name="PCC", & + var_description="Satuation adjustment -rvm +rcm [(kg/kg/s)]", var_units="(kg/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCC') + iNNUCCC= k + + call stat_assign( var_index=iNNUCCC, var_name="NNUCCC", & + var_description="Contact freezing of drops, -Ncm + Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWS') + iNPSACWS= k + + call stat_assign( var_index=iNPSACWS, var_name="NPSACWS", & + var_description="Droplet accretion by snow, -Ncm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRA') + iNPRA= k + + call stat_assign( var_index=iNPRA, var_name="NPRA", & + var_description="Droplet accretion by rain, -Ncm [(#/kg/s)]", var_units="(#/kg/s)", & + l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRC') + iNPRC= k + + call stat_assign( var_index=iNPRC, var_name="NPRC", & + var_description="Autoconversion of cloud drops, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWI') + iNPSACWI= k + + call stat_assign( var_index=iNPSACWI, var_name="NPSACWI", & + var_description="Droplet accretion by cloud ice, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPSACWG') + iNPSACWG= k + + call stat_assign( var_index=iNPSACWG, var_name="NPSACWG", & + var_description="Collection of cloud droplets by graupel, -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NPRAI') + iNPRAI= k + + call stat_assign( var_index=iNPRAI, var_name="NPRAI", & + var_description="Accretion of cloud ice by snow, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTS') + iNMULTS= k + + call stat_assign( var_index=iNMULTS, var_name="NMULTS", & + var_description="Ice multiplication due to riming of cloud droplets by snow, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTG') + iNMULTG= k + + call stat_assign( var_index=iNMULTG, var_name="NMULTG", & + var_description="Ice multiplication due to accretion of droplets by graupel, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTR') + iNMULTR= k + + call stat_assign( var_index=iNMULTR, var_name="NMULTR", & + var_description="Ice multiplication due to riming of rain by snow, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NMULTRG') + iNMULTRG= k + + call stat_assign( var_index=iNMULTRG, var_name="NMULTRG", & + var_description="Ice multiplication due to accretion of rain by graupel, +Nim & + &[(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NNUCCD') + iNNUCCD= k + + call stat_assign( var_index=iNNUCCD, var_name="NNUCCD", & + var_description="Primary ice nucleation, freezing of aerosol, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBI') + iNSUBI= k + + call stat_assign( var_index=iNSUBI, var_name="NSUBI", & + var_description="Loss of ice due to sublimation, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NGMLTG') + iNGMLTG= k + + call stat_assign( var_index=iNGMLTG, var_name="NGMLTG", & + var_description="Loss of graupel due to melting, -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NSUBG') + iNSUBG= k + + call stat_assign( var_index=iNSUBG, var_name="NSUBG", & + var_description="Loss of graupel due to sublimation, -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NACT') + iNACT= k + + call stat_assign( var_index=iNACT, var_name="NACT", & + var_description="Cloud drop formation by aerosol activation, +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NR') + iSIZEFIX_NR= k + + call stat_assign( var_index=iSIZEFIX_NR, var_name="SIZEFIX_NR", & + var_description="Adjust rain # conc. for large/small drops, +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NC') + iSIZEFIX_NC= k + + call stat_assign( var_index=iSIZEFIX_NC, var_name="SIZEFIX_NC", & + var_description="Adjust cloud # conc. for large/small drops, +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NI') + iSIZEFIX_NI= k + + call stat_assign( var_index=iSIZEFIX_NI, var_name="SIZEFIX_NI", & + var_description="Adjust ice # conc. for large/small drops, +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NS') + iSIZEFIX_NS= k + + call stat_assign( var_index=iSIZEFIX_NS, var_name="SIZEFIX_NS", & + var_description="Adjust snow # conc. for large/small drops, +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('SIZEFIX_NG') + iSIZEFIX_NG= k + + call stat_assign( var_index=iSIZEFIX_NG, var_name="SIZEFIX_NG", & + var_description="Adjust graupel # conc. for large/small drops,+Ngm [(#/kg/s)]",& + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NR') + iNEGFIX_NR= k + + call stat_assign( var_index=iNEGFIX_NR, var_name="NEGFIX_NR", & + var_description="Removal of negative rain drop number conc., -Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NC') + iNEGFIX_NC= k + + call stat_assign( var_index=iNEGFIX_NC, var_name="NEGFIX_NC", & + var_description="Removal of negative cloud drop number conc., -Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NI') + iNEGFIX_NI= k + + call stat_assign( var_index=iNEGFIX_NI, var_name="NEGFIX_NI", & + var_description="Removal of negative ice number conc., -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NS') + iNEGFIX_NS= k + + call stat_assign( var_index=iNEGFIX_NS, var_name="NEGFIX_NS", & + var_description="Removal of negative snow number conc,, -Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NEGFIX_NG') + iNEGFIX_NG= k + + call stat_assign( var_index=iNEGFIX_NG, var_name="NEGFIX_NG", & + var_description="Removal of negative graupel number conc., -Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NIM_MORR_CL') + iNIM_MORR_CL= k + + call stat_assign( var_index=iNIM_MORR_CL, var_name="NIM_MORR_CL", & + var_description="Clipping of large ice concentrations, -Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QC_INST') + iQC_INST= k + + call stat_assign( var_index=iQC_INST, var_name="QC_INST", & + var_description="Change in mixing ratio due to instantaneous processes," // & + " +rcm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QR_INST') + iQR_INST= k + + call stat_assign( var_index=iQR_INST, var_name="QR_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rrm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QI_INST') + iQI_INST= k + + call stat_assign( var_index=iQI_INST, var_name="QI_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rim [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QS_INST') + iQS_INST= k + + call stat_assign( var_index=iQS_INST, var_name="QS_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rsm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('QG_INST') + iQG_INST= k + + call stat_assign( var_index=iQG_INST, var_name="QG_INST", & + var_description="Change in mixing ratio from instantaneous processes," // & + " +rgm [(kg/kg/s)]", & + var_units="(kg/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NC_INST') + iNC_INST= k + + call stat_assign( var_index=iNC_INST, var_name="NC_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Ncm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NR_INST') + iNR_INST= k + + call stat_assign( var_index=iNR_INST, var_name="NR_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nrm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NI_INST') + iNI_INST= k + + call stat_assign( var_index=iNI_INST, var_name="NI_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nim [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NS_INST') + iNS_INST= k + + call stat_assign( var_index=iNS_INST, var_name="NS_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Nsm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('NG_INST') + iNG_INST= k + + call stat_assign( var_index=iNG_INST, var_name="NG_INST", & + var_description="Change in # conc. from instantaneous processes," // & + " +Ngm [(#/kg/s)]", & + var_units="(#/kg/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + + case ('T_in_K_mc') + iT_in_K_mc= k + + call stat_assign( var_index=iT_in_K_mc, var_name="T_in_K_mc", & + var_description="Temperature tendency from Morrison microphysics [(K/s)]", & + var_units="(K/s)", l_silhs=.true., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_evap_covar_zt') + iw_KK_evap_covar_zt = k + + call stat_assign( var_index=iw_KK_evap_covar_zt, var_name="w_KK_evap_covar_zt", & + var_description="Covariance of w and KK evaporation rate", & + var_units="m*(kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_evap_covar_zt') + irt_KK_evap_covar_zt = k + + call stat_assign( var_index=irt_KK_evap_covar_zt, var_name="rt_KK_evap_covar_zt", & + var_description="Covariance of r_t and KK evaporation rate", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_evap_covar_zt') + ithl_KK_evap_covar_zt = k + + call stat_assign( var_index=ithl_KK_evap_covar_zt, var_name="thl_KK_evap_covar_zt", & + var_description="Covariance of theta_l and KK evaporation rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_auto_covar_zt') + iw_KK_auto_covar_zt = k + + call stat_assign( var_index=iw_KK_auto_covar_zt, var_name="w_KK_auto_covar_zt", & + var_description="Covariance of w and KK autoconversion rate", & + var_units="m*(kg/kg)/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_auto_covar_zt') + irt_KK_auto_covar_zt = k + + call stat_assign( var_index=irt_KK_auto_covar_zt, var_name="rt_KK_auto_covar_zt", & + var_description="Covariance of r_t and KK autoconversion rate", & + var_units="(kg/kg)^2/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_auto_covar_zt') + ithl_KK_auto_covar_zt = k + + call stat_assign( var_index=ithl_KK_auto_covar_zt, var_name="thl_KK_auto_covar_zt", & + var_description="Covariance of theta_l and KK autoconversion rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_KK_accr_covar_zt') + iw_KK_accr_covar_zt = k + + call stat_assign( var_index=iw_KK_accr_covar_zt, var_name="w_KK_accr_covar_zt", & + var_description="Covariance of w and KK accretion rate", var_units="m*(kg/kg)/s^2", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rt_KK_accr_covar_zt') + irt_KK_accr_covar_zt = k + + call stat_assign( var_index=irt_KK_accr_covar_zt, var_name="rt_KK_accr_covar_zt", & + var_description="Covariance of r_t and KK accretion rate", var_units="(kg/kg)^2/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_KK_accr_covar_zt') + ithl_KK_accr_covar_zt = k + + call stat_assign( var_index=ithl_KK_accr_covar_zt, var_name="thl_KK_accr_covar_zt", & + var_description="Covariance of theta_l and KK accretion rate", & + var_units="K*(kg/kg)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rr_KK_mvr_covar_zt') + irr_KK_mvr_covar_zt = k + + call stat_assign( var_index=irr_KK_mvr_covar_zt, var_name="rr_KK_mvr_covar_zt", & + var_description="Covariance of r_r and KK rain drop mean volume radius [(kg/kg)m]", & + var_units="(kg/kg)m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Nr_KK_mvr_covar_zt') + iNr_KK_mvr_covar_zt = k + + call stat_assign( var_index=iNr_KK_mvr_covar_zt, var_name="Nr_KK_mvr_covar_zt", & + var_description="Covariance of N_r and KK rain drop mean volume radius [(num/kg)m]", & + var_units="(num/kg)m", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('KK_mvr_variance_zt') + iKK_mvr_variance_zt = k + + call stat_assign( var_index=iKK_mvr_variance_zt, var_name="KK_mvr_variance_zt", & + var_description="Variance of KK rain drop mean volume radius [m^2]", & + var_units="m^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_bt') + ivm_bt = k + + call stat_assign( var_index=ivm_bt, var_name="vm_bt", & + var_description="vm budget: vm time tendency [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ma') + ivm_ma = k + call stat_assign( var_index=ivm_ma, var_name="vm_ma", & + var_description="vm budget: vm vertical mean advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_gf') + ivm_gf = k + + call stat_assign( var_index=ivm_gf, var_name="vm_gf", & + var_description="vm budget: vm geostrophic forcing [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_cf') + ivm_cf = k + + call stat_assign( var_index=ivm_cf, var_name="vm_cf", & + var_description="vm budget: vm coriolis forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ta') + ivm_ta = k + + call stat_assign( var_index=ivm_ta, var_name="vm_ta", & + var_description="vm budget: vm turbulent transport [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_f') + ivm_f = k + call stat_assign( var_index=ivm_f, var_name="vm_f", & + var_description="vm budget: vm forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_sdmp') + ivm_sdmp = k + call stat_assign( var_index=ivm_sdmp, var_name="vm_sdmp", & + var_description="vm budget: vm sponge damping [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vm_ndg') + ivm_ndg = k + call stat_assign( var_index=ivm_ndg, var_name="vm_ndg", & + var_description="vm budget: vm nudging [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_bt') + ium_bt = k + + call stat_assign( var_index=ium_bt, var_name="um_bt", & + var_description="um budget: um time tendency [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ma') + ium_ma = k + + call stat_assign( var_index=ium_ma, var_name="um_ma", & + var_description="um budget: um vertical mean advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_gf') + ium_gf = k + call stat_assign( var_index=ium_gf, var_name="um_gf", & + var_description="um budget: um geostrophic forcing [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_cf') + ium_cf = k + call stat_assign( var_index=ium_cf, var_name="um_cf", & + var_description="um budget: um coriolis forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ta') + ium_ta = k + call stat_assign( var_index=ium_ta, var_name="um_ta", & + var_description="um budget: um turbulent advection [m s^{-2}]", & + var_units="m s^{-2}", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_f') + ium_f = k + call stat_assign( var_index=ium_f, var_name="um_f", & + var_description="um budget: um forcing [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_sdmp') + ium_sdmp = k + call stat_assign( var_index=ium_sdmp, var_name="um_sdmp", & + var_description="um budget: um sponge damping [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('um_ndg') + ium_ndg = k + call stat_assign( var_index=ium_ndg, var_name="um_ndg", & + var_description="um budget: um nudging [m s^{-2}]", var_units="m s^{-2}", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('mixt_frac') + imixt_frac = k + call stat_assign( var_index=imixt_frac, var_name="mixt_frac", & + var_description="pdf parameter: mixture fraction [count]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('w_1') + iw_1 = k + call stat_assign( var_index=iw_1, var_name="w_1", & + var_description="pdf parameter: mean w of component 1 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('w_2') + iw_2 = k + + call stat_assign( var_index=iw_2, var_name="w_2", & + var_description="pdf paramete: mean w of component 2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_w_1') + ivarnce_w_1 = k + call stat_assign( var_index=ivarnce_w_1, var_name="varnce_w_1", & + var_description="pdf parameter: w variance of component 1 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('varnce_w_2') + ivarnce_w_2 = k + + call stat_assign( var_index=ivarnce_w_2, var_name="varnce_w_2", & + var_description="pdf parameter: w variance of component 2 [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('thl_1') + ithl_1 = k + + call stat_assign( var_index=ithl_1, var_name="thl_1", & + var_description="pdf parameter: mean thl of component 1 [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('thl_2') + ithl_2 = k + + call stat_assign( var_index=ithl_2, var_name="thl_2", & + var_description="pdf parameter: mean thl of component 2 [K]", var_units="K", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_thl_1') + ivarnce_thl_1 = k + + call stat_assign( var_index=ivarnce_thl_1, var_name="varnce_thl_1", & + var_description="pdf parameter: thl variance of component 1 [K^2]", var_units="K^2", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('varnce_thl_2') + ivarnce_thl_2 = k + call stat_assign( var_index=ivarnce_thl_2, var_name="varnce_thl_2", & + var_description="pdf parameter: thl variance of component 2 [K^2]", var_units="K^2", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rt_1') + irt_1 = k + call stat_assign( var_index=irt_1, var_name="rt_1", & + var_description="pdf parameter: mean rt of component 1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('rt_2') + irt_2 = k + + call stat_assign( var_index=irt_2, var_name="rt_2", & + var_description="pdf parameter: mean rt of component 2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_rt_1') + ivarnce_rt_1 = k + call stat_assign( var_index=ivarnce_rt_1, var_name="varnce_rt_1", & + var_description="pdf parameter: rt variance of component 1 [(kg^2)/(kg^2)]", & + var_units="(kg^2)/(kg^2)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('varnce_rt_2') + ivarnce_rt_2 = k + + call stat_assign( var_index=ivarnce_rt_2, var_name="varnce_rt_2", & + var_description="pdf parameter: rt variance of component 2 [(kg^2)/(kg^2)]", & + var_units="(kg^2)/(kg^2)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rc_1') + irc_1 = k + + call stat_assign( var_index=irc_1, var_name="rc_1", & + var_description="pdf parameter: mean rc of component 1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rc_2') + irc_2 = k + + call stat_assign( var_index=irc_2, var_name="rc_2", & + var_description="pdf parameter: mean rc of component 2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsatl_1') + irsatl_1 = k + + call stat_assign( var_index=irsatl_1, var_name="rsatl_1", & + var_description="pdf parameter: sat mix rat based on tl1 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rsatl_2') + irsatl_2 = k + + call stat_assign( var_index=irsatl_2, var_name="rsatl_2", & + var_description="pdf parameter: sat mix rat based on tl2 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_frac_1') + icloud_frac_1 = k + call stat_assign( var_index=icloud_frac_1, var_name="cloud_frac_1", & + var_description="pdf parameter cloud_frac_1 [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cloud_frac_2') + icloud_frac_2 = k + + call stat_assign( var_index=icloud_frac_2, var_name="cloud_frac_2", & + var_description="pdf parameter cloud_frac_2 [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi_1') + ichi_1 = k + + call stat_assign( var_index=ichi_1, var_name="chi_1", & + var_description="pdf parameter: Mellor's s (extended liq) for component 1 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi_2') + ichi_2 = k + + call stat_assign( var_index=ichi_2, var_name="chi_2", & + var_description="pdf parameter: Mellor's s (extended liq) for component 2 [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_chi_1') + istdev_chi_1 = k + + call stat_assign( var_index=istdev_chi_1, var_name="stdev_chi_1", & + var_description="pdf parameter: Std dev of chi_1 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_chi_2') + istdev_chi_2 = k + + call stat_assign( var_index=istdev_chi_2, var_name="stdev_chi_2", & + var_description="pdf parameter: Std dev of chi_2 [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chip2') + ichip2 = k + call stat_assign( var_index=ichip2, var_name="chip2", & + var_description="Variance of chi(s) (overall) [(kg/kg)^2]", var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_eta_1') + istdev_eta_1 = k + + call stat_assign( var_index=istdev_eta_1, var_name="stdev_eta_1", & + var_description="Standard dev. of eta(t) (1st PDF component) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('stdev_eta_2') + istdev_eta_2 = k + + call stat_assign( var_index=istdev_eta_2, var_name="stdev_eta_2", & + var_description="Standard dev. of eta(t) (2nd PDF component) [kg/kg]", & + var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('covar_chi_eta_1') + icovar_chi_eta_1 = k + + call stat_assign( var_index=icovar_chi_eta_1, var_name="covar_chi_eta_1", & + var_description="Covariance of chi(s) and eta(t) (1st PDF component) [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('covar_chi_eta_2') + icovar_chi_eta_2 = k + + call stat_assign( var_index=icovar_chi_eta_2, var_name="covar_chi_eta_2", & + var_description="Covariance of chi(s) and eta(t) (2nd PDF component) [kg^2/kg^2]", & + var_units="kg^2/kg^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_1') + icorr_chi_eta_1 = k + + call stat_assign( var_index=icorr_chi_eta_1, & + var_name="corr_chi_eta_1", & + var_description="Correlation of chi (s) and" & + // " eta (t) (1st PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_2') + icorr_chi_eta_2 = k + + call stat_assign( var_index=icorr_chi_eta_2, & + var_name="corr_chi_eta_2", & + var_description="Correlation of chi (s) and" & + // " eta (t) (2nd PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rrtthl') + irrtthl = k + + call stat_assign( var_index=irrtthl, var_name="rrtthl", & + var_description="Correlation of rt and thl" & + // " (both PDF components) [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('crt_1') + icrt_1 = k + + call stat_assign( var_index=icrt_1, var_name="crt_1", & + var_description="Coefficient on rt in chi/eta" & + // " equations (1st PDF comp.) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('crt_2') + icrt_2 = k + + call stat_assign( var_index=icrt_2, var_name="crt_2", & + var_description="Coefficient on rt in chi/eta" & + // " equations (2nd PDF comp.) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cthl_1') + icthl_1 = k + + call stat_assign( var_index=icthl_1, var_name="cthl_1", & + var_description="Coefficient on theta-l in chi/eta" & + // " equations (1st PDF comp.) [kg/kg/K]", & + var_units="kg/kg/K", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('cthl_2') + icthl_2 = k + + call stat_assign( var_index=icthl_2, var_name="cthl_2", & + var_description="Coefficient on theta-l in chi/eta" & + // " equations (2nd PDF comp.) [kg/kg/K]", & + var_units="kg/kg/K", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + + case('wp2_zt') + iwp2_zt = k + + call stat_assign( var_index=iwp2_zt, var_name="wp2_zt", & + var_description="w'^2 interpolated to thermodyamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('thlp2_zt') + ithlp2_zt = k + + call stat_assign( var_index=ithlp2_zt, var_name="thlp2_zt", & + var_description="thl'^2 interpolated to thermodynamic levels [K^2]", & + var_units="K^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('wpthlp_zt') + iwpthlp_zt = k + + call stat_assign( var_index=iwpthlp_zt, var_name="wpthlp_zt", & + var_description="w'thl' interpolated to thermodynamic levels [(m K)/s]", & + var_units="(m K)/s", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('wprtp_zt') + iwprtp_zt = k + + call stat_assign( var_index=iwprtp_zt, var_name="wprtp_zt", & + var_description="w'rt' interpolated to thermodynamic levels [(m kg)/(s kg)]", & + var_units="(m kg)/(s kg)", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('rtp2_zt') + irtp2_zt = k + + call stat_assign( var_index=irtp2_zt, var_name="rtp2_zt", & + var_description="rt'^2 interpolated to thermodynamic levels [(kg/kg)^2]", & + var_units="(kg/kg)^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case('rtpthlp_zt') + irtpthlp_zt = k + + call stat_assign( var_index=irtpthlp_zt, var_name="rtpthlp_zt", & + var_description="rt'thl' interpolated to thermodynamic levels [(kg K)/kg]", & + var_units="(kg K)/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('up2_zt') + iup2_zt = k + call stat_assign( var_index=iup2_zt, var_name="up2_zt", & + var_description="u'^2 interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vp2_zt') + ivp2_zt = k + call stat_assign( var_index=ivp2_zt, var_name="vp2_zt", & + var_description="v'^2 interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('upwp_zt') + iupwp_zt = k + call stat_assign( var_index=iupwp_zt, var_name="upwp_zt", & + var_description="u'w' interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('vpwp_zt') + ivpwp_zt = k + call stat_assign( var_index=ivpwp_zt, var_name="vpwp_zt", & + var_description="v'w' interpolated to thermodynamic levels [m^2/s^2]", & + var_units="m^2/s^2", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Skw_zt') + iSkw_zt = k + call stat_assign( var_index=iSkw_zt, var_name="Skw_zt", & + var_description="Skewness of w on thermodynamic levels [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Skthl_zt') + iSkthl_zt = k + call stat_assign( var_index=iSkthl_zt, var_name="Skthl_zt", & + var_description="Skewness of thl on thermodynamic levels [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('Skrt_zt') + iSkrt_zt = k + call stat_assign( var_index=iSkrt_zt, var_name="Skrt_zt", & + var_description="Skewness of rt on thermodynamic levels [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Hydrometeor overall variances for each hydrometeor type. + case('hmp2_zt') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The overall variance of the hydrometeor. + ihmp2_zt(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihmp2_zt(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2_zt", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> on thermodyamic levels (from " & + // "integration over PDF) [(kg/kg)^2]", & + var_units="(kg/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihmp2_zt(hm_idx), & + var_name=trim( hm_type(1:2) )//"p2_zt", & + var_description="<" & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "'^2> on thermodyamic levels (from " & + // "integration over PDF) [(num/kg)^2]", & + var_units="(num/kg)^2", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('C11_Skw_fnc') + iC11_Skw_fnc = k + + call stat_assign( var_index=iC11_Skw_fnc, var_name="C11_Skw_fnc", & + var_description="C_11 parameter with Sk_w applied [-]", var_units="count", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('chi') + ichi = k + + call stat_assign( var_index=ichi, var_name="chi", & + var_description="Mellor's s (extended liq) [kg/kg]", var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'a3_coef_zt' ) + ia3_coef_zt = k + call stat_assign( var_index=ia3_coef_zt, var_name="a3_coef_zt", & + var_description="The a3 coefficient interpolated the the zt grid [-]", & + var_units="count", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'wp3_on_wp2_zt' ) + iwp3_on_wp2_zt = k + call stat_assign( var_index=iwp3_on_wp2_zt, var_name="wp3_on_wp2_zt", & + var_description="Smoothed version of wp3 / wp2 [m/s]", var_units="m/s", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Hydrometeor component mean values for each PDF component and hydrometeor + ! type. + case ( "hm_i" ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The mean of the hydrometeor in the 1st PDF component. + ihm_1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihm_1(hm_idx), & + var_name=trim( hm_type(1:2) )//"_1", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihm_1(hm_idx), & + var_name=trim( hm_type(1:2) )//"_1", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The mean of the hydrometeor in the 2nd PDF component. + ihm_2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=ihm_2(hm_idx), & + var_name=trim( hm_type(1:2) )//"_2", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=ihm_2(hm_idx), & + var_name=trim( hm_type(1:2) )//"_2", & + var_description="Mean of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'precip_frac' ) + iprecip_frac = k + call stat_assign( var_index=iprecip_frac, var_name="precip_frac", & + var_description="Precipitation Fraction [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'precip_frac_1' ) + iprecip_frac_1 = k + call stat_assign( var_index=iprecip_frac_1, var_name="precip_frac_1", & + var_description="Precipitation Fraction (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'precip_frac_2' ) + iprecip_frac_2 = k + call stat_assign( var_index=iprecip_frac_2, var_name="precip_frac_2", & + var_description="Precipitation Fraction (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ( 'Ncnm' ) + iNcnm = k + call stat_assign( var_index=iNcnm, var_name="Ncnm", & + var_description="Cloud nuclei concentration (PDF) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Hydrometeor component mean values (in-precip) for each PDF component and + ! hydrometeor type. + case ( 'mu_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip mean of the hydrometeor in the 1st PDF component. + imu_hm_1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_1(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_1(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip mean of the hydrometeor in the 2nd PDF component. + imu_hm_2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_2(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_2(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2", & + var_description="Mean (in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'mu_Ncn_i' ) + + imu_Ncn_1 = k + + call stat_assign( var_index=imu_Ncn_1, & + var_name="mu_Ncn_1", & + var_description="Mean of N_cn (1st PDF component) " & + // "[num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + imu_Ncn_2 = k + + call stat_assign( var_index=imu_Ncn_2, & + var_name="mu_Ncn_2", & + var_description="Mean of N_cn (2nd PDF component) " & + // "[num/kg]", var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component mean values (in-precip) for ln hm for each PDF + ! component and hydrometeor type. + case ( 'mu_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip mean of ln hm in the 1st PDF component. + imu_hm_1_n(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_1_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [ln(kg/kg)]", & + var_units="ln(kg/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_1_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_1_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip mean of ln hm in the 2nd PDF component. + imu_hm_2_n(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=imu_hm_2_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [ln(kg/kg)]", & + var_units="ln(kg/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=imu_hm_2_n(hm_idx), & + var_name="mu_"//trim( hm_type(1:2) )//"_2_n", & + var_description="Mean (in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'mu_Ncn_i_n' ) + + imu_Ncn_1_n = k + + call stat_assign( var_index=imu_Ncn_1_n, & + var_name="mu_Ncn_1_n", & + var_description="Mean of ln N_cn " & + // "(1st PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + imu_Ncn_2_n = k + + call stat_assign( var_index=imu_Ncn_2_n, & + var_name="mu_Ncn_2_n", & + var_description="Mean of ln N_cn " & + // "(2nd PDF component) [ln(num/kg)]", & + var_units="ln(num/kg)", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component standard deviations (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'sigma_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip standard deviation of the hydrometeor in the 1st PDF + ! component. + isigma_hm_1(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=isigma_hm_1(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=isigma_hm_1(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + ! The in-precip standard deviation of the hydrometeor in the 2nd PDF + ! component. + isigma_hm_2(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=isigma_hm_2(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [kg/kg]", & + var_units="kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=isigma_hm_2(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2", & + var_description="Standard deviation " & + // "(in-precip) of " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [num/kg]", & + var_units="num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'sigma_Ncn_i' ) + + isigma_Ncn_1 = k + + call stat_assign( var_index=isigma_Ncn_1, & + var_name="sigma_Ncn_1", & + var_description="Standard deviation of N_cn " & + // "(1st PDF component) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + isigma_Ncn_2 = k + + call stat_assign( var_index=isigma_Ncn_2, & + var_name="sigma_Ncn_2", & + var_description="Standard deviation of N_cn " & + // "(2nd PDF component) [num/kg]", & + var_units="num/kg", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Hydrometeor component standard deviations (in-precip) for ln hm for each + ! PDF component and hydrometeor type. + case ( 'sigma_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip standard deviation of ln hm in the 1st PDF + ! component. + isigma_hm_1_n(hm_idx) = k + + call stat_assign( var_index=isigma_hm_1_n(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_1_n", & + var_description="Standard deviation " & + // "(in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip standard deviation of ln hm in the 2nd PDF + ! component. + isigma_hm_2_n(hm_idx) = k + + call stat_assign( var_index=isigma_hm_2_n(hm_idx), & + var_name="sigma_" & + // trim( hm_type(1:2) )//"_2_n", & + var_description="Standard deviation " & + // "(in-precip) of ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'sigma_Ncn_i_n' ) + + isigma_Ncn_1_n = k + + call stat_assign( var_index=isigma_Ncn_1_n, & + var_name="sigma_Ncn_1_n", & + var_description="Standard deviation of ln N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + isigma_Ncn_2_n = k + + call stat_assign( var_index=isigma_Ncn_2_n, & + var_name="sigma_Ncn_2_n", & + var_description="Standard deviation of ln N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('corr_w_chi_1') + icorr_w_chi_1 = k + + call stat_assign( var_index=icorr_w_chi_1, var_name="corr_w_chi_1", & + var_description="Correlation of w and chi" & + // " (1st PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_chi_2') + icorr_w_chi_2 = k + + call stat_assign( var_index=icorr_w_chi_2, var_name="corr_w_chi_2", & + var_description="Correlation of w and chi" & + // " (2nd PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_eta_1') + icorr_w_eta_1 = k + + call stat_assign( var_index=icorr_w_eta_1, var_name="corr_w_eta_1", & + var_description="Correlation of w and eta" & + // " (1st PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_w_eta_2') + icorr_w_eta_2 = k + + call stat_assign( var_index=icorr_w_eta_2, var_name="corr_w_eta_2", & + var_description="Correlation of w and eta" & + // " (2nd PDF component) -- should be 0 by" & + // " CLUBB standards [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Correlation of w and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_w_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of w and the hydrometeor in the + ! 1st PDF component. + icorr_w_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_1(hm_idx), & + var_name="corr_w_"//trim( hm_type(1:2) )//"_1", & + var_description="Correlation (in-precip) " & + // "of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of w and the hydrometeor in the + ! 2nd PDF component. + icorr_w_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_2(hm_idx), & + var_name="corr_w_"//trim( hm_type(1:2) )//"_2", & + var_description="Correlation (in-precip) " & + // "of w and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_w_Ncn_i' ) + + icorr_w_Ncn_1 = k + + call stat_assign( var_index=icorr_w_Ncn_1, & + var_name="corr_w_Ncn_1", & + var_description="Correlation of w and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_w_Ncn_2 = k + + call stat_assign( var_index=icorr_w_Ncn_2, & + var_name="corr_w_Ncn_2", & + var_description="Correlation of w and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + case ('corr_chi_eta_1_ca') + icorr_chi_eta_1_ca = k + + call stat_assign( var_index=icorr_chi_eta_1_ca, & + var_name="corr_chi_eta_1_ca", & + var_description="Correlation of chi (s) and" & + // " eta (t) (1st PDF component) found in the" & + // " correlation array [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('corr_chi_eta_2_ca') + icorr_chi_eta_2_ca = k + + call stat_assign( var_index=icorr_chi_eta_2_ca, & + var_name="corr_chi_eta_2_ca", & + var_description="Correlation of chi (s) and" & + // " eta (t) (2nd PDF component) found in the" & + // " correlation array [-]", var_units="-", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + ! Correlation of chi(s) and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_chi_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of chi and the hydrometeor in the + ! 1st PDF component. + icorr_chi_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_1(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of chi (s) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of chi and the hydrometeor in the + ! 2nd PDF component. + icorr_chi_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_2(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of chi (s) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_chi_Ncn_i' ) + + icorr_chi_Ncn_1 = k + + call stat_assign( var_index=icorr_chi_Ncn_1, & + var_name="corr_chi_Ncn_1", & + var_description="Correlation of chi and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_chi_Ncn_2 = k + + call stat_assign( var_index=icorr_chi_Ncn_2, & + var_name="corr_chi_Ncn_2", & + var_description="Correlation of chi and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation of eta(t) and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_eta_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of eta and the hydrometeor in the + ! 1st PDF component. + icorr_eta_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_1(hm_idx), & + var_name="corr_eta_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of eta (t) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of eta and the hydrometeor in the + ! 2nd PDF component. + icorr_eta_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_2(hm_idx), & + var_name="corr_eta_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of eta (t) and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_eta_Ncn_i' ) + + icorr_eta_Ncn_1 = k + + call stat_assign( var_index=icorr_eta_Ncn_1, & + var_name="corr_eta_Ncn_1", & + var_description="Correlation of eta and N_cn " & + // "(1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_eta_Ncn_2 = k + + call stat_assign( var_index=icorr_eta_Ncn_2, & + var_name="corr_eta_Ncn_2", & + var_description="Correlation of eta and N_cn " & + // "(2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation of Ncn and a hydrometeor (in-precip) for each PDF + ! component and hydrometeor type. + case ( 'corr_Ncn_hm_i' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of Ncn and the hydrometeor in the + ! 1st PDF component. + icorr_Ncn_hm_1(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_1(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2))//"_1", & + var_description="Correlation (in-precip) " & + // "of N_cn and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of Ncn and the hydrometeor in the + ! 2nd PDF component. + icorr_Ncn_hm_2(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_2(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2))//"_2", & + var_description="Correlation (in-precip) " & + // "of N_cn and " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of two different hydrometeors (hmx and hmy) + ! for each PDF component and hydrometeor type. + case ( 'corr_hmx_hmy_i' ) + + do hmx_idx = 1, hydromet_dim, 1 + + hmx_type = hydromet_list(hmx_idx) + + do hmy_idx = hmx_idx+1, hydromet_dim, 1 + + hmy_type = hydromet_list(hmy_idx) + + ! The in-precip correlation of hmx and hmy in the 1st PDF + ! component. + icorr_hmx_hmy_1(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_1(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_1", & + var_description="Correlation (in-precip) " & + // "of " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of hmx and hmy in the 2nd PDF + ! component. + icorr_hmx_hmy_2(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_2(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_2", & + var_description="Correlation (in-precip) " & + // "of " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hmy_idx = hmx_idx+1, hydromet_dim, 1 + + enddo ! hmx_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of w and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_w_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of w and ln hm in the 1st PDF + ! component. + icorr_w_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_1_n(hm_idx), & + var_name="corr_w_"//trim(hm_type(1:2))//"_1_n", & + var_description="Correlation (in-precip) " & + // "of w and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of w and ln hm in the 2nd PDF + ! component. + icorr_w_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_w_hm_2_n(hm_idx), & + var_name="corr_w_"//trim(hm_type(1:2))//"_2_n", & + var_description="Correlation (in-precip) " & + // "of w and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_w_Ncn_i_n' ) + + icorr_w_Ncn_1_n = k + + call stat_assign( var_index=icorr_w_Ncn_1_n, & + var_name="corr_w_Ncn_1_n", & + var_description="Correlation of w and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_w_Ncn_2_n = k + + call stat_assign( var_index=icorr_w_Ncn_2_n, & + var_name="corr_w_Ncn_2_n", & + var_description="Correlation of w and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of chi and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_chi_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of chi and ln hm in the 1st PDF + ! component. + icorr_chi_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_1_n(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2)) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of chi (s) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of chi(s) and ln hm in the 2nd PDF + ! component. + icorr_chi_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_chi_hm_2_n(hm_idx), & + var_name="corr_chi_"//trim(hm_type(1:2)) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of chi (s) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_chi_Ncn_i_n' ) + + icorr_chi_Ncn_1_n = k + + call stat_assign( var_index=icorr_chi_Ncn_1_n, & + var_name="corr_chi_Ncn_1_n", & + var_description="Correlation of chi (s) and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_chi_Ncn_2_n = k + + call stat_assign( var_index=icorr_chi_Ncn_2_n, & + var_name="corr_chi_Ncn_2_n", & + var_description="Correlation of chi (s) and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of eta and ln hm for each PDF component and + ! hydrometeor type. + case ( 'corr_eta_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of eta and ln hm in the 1st PDF + ! component. + icorr_eta_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_1_n(hm_idx), & + var_name="corr_eta_"//trim( hm_type(1:2) ) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of eta (t) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of eta and ln hm in the 2nd PDF + ! component. + icorr_eta_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_eta_hm_2_n(hm_idx), & + var_name="corr_eta_"//trim( hm_type(1:2) ) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of eta(t) and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ( 'corr_eta_Ncn_i_n' ) + + icorr_eta_Ncn_1_n = k + + call stat_assign( var_index=icorr_eta_Ncn_1_n, & + var_name="corr_eta_Ncn_1_n", & + var_description="Correlation of eta (t) and " & + // "ln N_cn (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + icorr_eta_Ncn_2_n = k + + call stat_assign( var_index=icorr_eta_Ncn_2_n, & + var_name="corr_eta_Ncn_2_n", & + var_description="Correlation of eta (t) and " & + // "ln N_cn (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! Correlation (in-precip) of ln Ncn and ln hm for each PDF component + ! and hydrometeor type. + case ( 'corr_Ncn_hm_i_n' ) + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + ! The in-precip correlation of ln Ncn and ln hm in the 1st PDF + ! component. + icorr_Ncn_hm_1_n(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_1_n(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2)) & + // "_1_n", & + var_description="Correlation (in-precip) " & + // "of ln N_cn and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of ln Ncn and ln hm in the 2nd PDF + ! component. + icorr_Ncn_hm_2_n(hm_idx) = k + + call stat_assign( var_index=icorr_Ncn_hm_2_n(hm_idx), & + var_name="corr_Ncn_"//trim(hm_type(1:2)) & + // "_2_n", & + var_description="Correlation (in-precip) " & + // "of ln N_cn and ln " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + ! Correlation (in-precip) of ln hmx and ln hmy (hmx and hmy are two + ! different hydrometeors) for each PDF component and hydrometeor type. + case ( 'corr_hmx_hmy_i_n' ) + + do hmx_idx = 1, hydromet_dim, 1 + + hmx_type = hydromet_list(hmx_idx) + + do hmy_idx = hmx_idx+1, hydromet_dim, 1 + + hmy_type = hydromet_list(hmy_idx) + + ! The in-precip correlation of ln hmx and ln hmy in the 1st + ! PDF component. + icorr_hmx_hmy_1_n(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_1_n(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_1_n", & + var_description="Correlation (in-precip) " & + // "of ln " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and ln " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (1st PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + ! The in-precip correlation of ln hmx and ln hmy in the 2nd + ! PDF component. + icorr_hmx_hmy_2_n(hmy_idx,hmx_idx) = k + + call stat_assign( var_index=icorr_hmx_hmy_2_n(hmy_idx,hmx_idx), & + var_name="corr_"//trim( hmx_type(1:2) )//"_" & + // trim( hmy_type(1:2) )//"_2_n", & + var_description="Correlation (in-precip) " & + // "of ln " & + // hmx_type(1:1)//"_"//trim( hmx_type(2:2) ) & + // " and ln " & + // hmy_type(1:1)//"_"//trim( hmy_type(2:2) ) & + // " (2nd PDF component) [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + + k = k + 1 + + enddo ! hmy_idx = hmx_idx+1, hydromet_dim, 1 + + enddo ! hmx_idx = 1, hydromet_dim, 1 + + ! Third-order mixed moment < w'^2 hm' >, where hm is a hydrometeor. + case ('wp2hmp') + + do hm_idx = 1, hydromet_dim, 1 + + hm_type = hydromet_list(hm_idx) + + iwp2hmp(hm_idx) = k + + if ( l_mix_rat_hm(hm_idx) ) then + + call stat_assign( var_index=iwp2hmp(hm_idx), & + var_name="wp2"//trim( hm_type(1:2) )//"p", & + var_description="Third-order moment < w'^2 " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "' > [(m/s)^2 kg/kg]", & + var_units="(m/s)^2 kg/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + else ! Concentration + + call stat_assign( var_index=iwp2hmp(hm_idx), & + var_name="wp2"//trim( hm_type(1:2) )//"p", & + var_description="Third-order moment < w'^2 " & + // hm_type(1:1)//"_"//trim( hm_type(2:2) ) & + // "' > [(m/s)^2 num/kg]", & + var_units="(m/s)^2 num/kg", & + l_silhs=.false., grid_kind=stats_zt ) + + endif ! l_mix_rat_hm(hm_idx) + + k = k + 1 + + enddo ! hm_idx = 1, hydromet_dim, 1 + + case ('cloud_frac_refined') + icloud_frac_refined = k + call stat_assign( var_index=icloud_frac_refined, var_name="cloud_frac_refined", & + var_description="Cloud fraction computed on refined grid [-]", & + var_units="-", l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + + case ('rcm_refined') + ircm_refined = k + call stat_assign( var_index=ircm_refined, var_name="rcm_refined", & + var_description="Cloud water mixing ratio computed on refined grid & + &[kg/kg]", var_units="kg/kg", l_silhs=.false., grid_kind=stats_zt) + k = k + 1 + + case ('hl_on_Cp_residual') + ihl_on_Cp_residual = k + call stat_assign( var_index=ihl_on_Cp_residual, var_name="hl_on_Cp_residual", & + var_description="Residual change in HL/Cp from Morrison microphysics & + ¬ due to sedimentation [K]", & + var_units="K", l_silhs=.true., grid_kind=stats_zt) + k = k + 1 + + case ('qto_residual') + iqto_residual = k + call stat_assign( var_index=iqto_residual, var_name="qto_residual", & + var_description="Residual change in total water from Morrison & + µphysics not due to sedimentation [kg/kg]", & + var_units="kg/kg", l_silhs=.true., grid_kind=stats_zt) + k = k + 1 + + case ( 'sclrm' ) + do j = 1, sclr_dim, 1 + write(sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrm(j) = k + call stat_assign( var_index=isclrm(j), var_name="sclr"//trim(sclr_idx)//"m", & + var_description="passive scalar "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + end do + + case ( 'sclrm_f' ) + do j = 1, sclr_dim, 1 + write(sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + isclrm_f(j) = k + call stat_assign( var_index=isclrm_f(j), var_name="sclr"//trim(sclr_idx)//"m_f", & + var_description="passive scalar forcing "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + end do + + case ( 'edsclrm' ) + do j = 1, edsclr_dim, 1 + write(sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iedsclrm(j) = k + call stat_assign( var_index=iedsclrm(j), var_name="edsclr"//trim(sclr_idx)//"m", & + var_description="passive scalar "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + end do + + case ( 'edsclrm_f' ) + do j = 1, edsclr_dim, 1 + write(sclr_idx, * ) j + sclr_idx = adjustl(sclr_idx) + iedsclrm_f(j) = k + call stat_assign( var_index=iedsclrm_f(j), var_name="edsclr"//trim(sclr_idx)//"m_f", & + var_description="passive scalar forcing "//trim(sclr_idx), var_units="unknown", & + l_silhs=.false., grid_kind=stats_zt ) + k = k + 1 + end do + + case default + + write(fstderr,*) 'Error: unrecognized variable in vars_zt: ', trim( vars_zt(i) ) + l_error = .true. ! This will stop the run. + + end select ! trim( vars_zt ) + + + end do ! i=1,stats_zt%num_output_fields + + + return + + end subroutine stats_init_zt + +!=============================================================================== + +end module stats_zt_module diff --git a/src/physics/clubb/surface_varnce_module.F90 b/src/physics/clubb/surface_varnce_module.F90 new file mode 100644 index 0000000000..a55e46e09d --- /dev/null +++ b/src/physics/clubb/surface_varnce_module.F90 @@ -0,0 +1,461 @@ +!------------------------------------------------------------------------- +! $Id: surface_varnce_module.F90 6952 2014-06-17 15:59:47Z schemena@uwm.edu $ +!=============================================================================== +module surface_varnce_module + + implicit none + + private ! Default to private + + public :: surface_varnce + + contains + + !============================================================================= + subroutine surface_varnce( upwp_sfc, vpwp_sfc, wpthlp_sfc, wprtp_sfc, & + um_sfc, vm_sfc, Lscale_up_sfc, wpsclrp_sfc, & + wp2_sfc, up2_sfc, vp2_sfc, & + thlp2_sfc, rtp2_sfc, rtpthlp_sfc, err_code, & + sclrp2_sfc, & + sclrprtp_sfc, & + sclrpthlp_sfc ) + + ! Description: + ! This subroutine computes estimate of the surface thermodynamic and wind + ! component second order moments. + + ! References: + ! Andre, J. C., G. De Moor, P. Lacarrere, G. Therry, and R. Du Vachat, 1978. + ! Modeling the 24-Hour Evolution of the Mean and Turbulent Structures of + ! the Planetary Boundary Layer. J. Atmos. Sci., 35, 1861 -- 1883. + !----------------------------------------------------------------------- + + use parameters_model, only: & + T0 ! Variable(s) + + use constants_clubb, only: & + four, & ! Variable(s) + two, & + one, & + two_thirds, & + one_third, & + one_fourth, & + zero, & + grav, & + eps, & + fstderr + + use parameters_model, only: & + sclr_dim ! Variable(s) + + use numerical_check, only: & + surface_varnce_check ! Procedure + + use error_code, only: & + clubb_var_equals_NaN, & ! Variable(s) + clubb_at_least_debug_level, & + clubb_no_error ! Constant + + use array_index, only: & + iisclr_rt, & ! Index for a scalar emulating rt + iisclr_thl ! Index for a scalar emulating thetal + + use stats_type_utilities, only: & + stat_end_update_pt, & ! Procedure(s) + stat_update_var_pt + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! External + intrinsic :: sqrt, max + + ! Constant Parameters + + ! Logical for Andre et al., 1978 parameterization. + logical, parameter :: l_andre_1978 = .false. + + real( kind = core_rknd ), parameter :: & + a_const = 1.8_core_rknd, & + z_const = one, & ! Defined height of 1 meter [m] + ! Vince Larson increased ufmin to stabilize arm_97. 24 Jul 2007 +! ufmin = 0.0001_core_rknd, & + ufmin = 0.01_core_rknd, & ! Minimum allowable value of u* [m/s] + ! End Vince Larson's change. + ! Vince Larson changed in order to make correlations between [-1,1]. 31 Jan 2008. +! sclr_var_coef = 0.25_core_rknd, & ! This value is made up! - Vince Larson 12 Jul 2005 + sclr_var_coef = 0.4_core_rknd, & ! This value is made up! - Vince Larson 12 Jul 2005 + ! End Vince Larson's change + ! Vince Larson reduced surface spike in scalar variances associated + ! w/ Andre et al. 1978 scheme + reduce_coef = 0.2_core_rknd + + ! Input Variables + real( kind = core_rknd ), intent(in) :: & + upwp_sfc, & ! Surface u momentum flux, |_sfc [m^2/s^2] + vpwp_sfc, & ! Surface v momentum flux, |_sfc [m^2/s^2] + wpthlp_sfc, & ! Surface thetal flux, |_sfc [K m/s] + wprtp_sfc, & ! Surface moisture flux, |_sfc [kg/kg m/s] + um_sfc, & ! Surface u wind component, [m/s] + vm_sfc, & ! Surface v wind component, [m/s] + Lscale_up_sfc ! Upward component of Lscale at surface [m] + + real( kind = core_rknd ), intent(in), dimension(sclr_dim) :: & + wpsclrp_sfc ! Passive scalar flux, |_sfc [units m/s] + + ! Output Variables + real( kind = core_rknd ), intent(out) :: & + wp2_sfc, & ! Surface variance of w, |_sfc [m^2/s^2] + up2_sfc, & ! Surface variance of u, |_sfc [m^2/s^2] + vp2_sfc, & ! Surface variance of v, |_sfc [m^2/s^2] + thlp2_sfc, & ! Surface variance of theta-l, |_sfc [K^2] + rtp2_sfc, & ! Surface variance of rt, |_sfc [(kg/kg)^2] + rtpthlp_sfc ! Surface covariance of rt and theta-l [kg K/kg] + + integer, intent(out) :: & + err_code ! Error code + + real( kind = core_rknd ), intent(out), dimension(sclr_dim) :: & + sclrp2_sfc, & ! Surface variance of passive scalar [units^2] + sclrprtp_sfc, & ! Surface covariance of pssv scalar and rt [units kg/kg] + sclrpthlp_sfc ! Surface covariance of pssv scalar and theta-l [units K] + + ! Local Variables + real( kind = core_rknd ) :: & + ustar2, & ! Square of surface friction velocity, u* [m^2/s^2] + wstar, & ! Convective velocity, w* [m/s] + uf ! Surface friction vel., u*, in older version [m/s] + + ! Variables for Andre et al., 1978 parameterization. + real( kind = core_rknd ) :: & + um_sfc_sqd, & ! Surface value of ^2 [m^2/s^2] + vm_sfc_sqd, & ! Surface value of ^2 [m^2/s^2] + usp2_sfc, & ! u_s (vector oriented w/ mean sfc. wind) variance [m^2/s^2] + vsp2_sfc ! v_s (vector perpen. to mean sfc. wind) variance [m^2/s^2] + + real( kind = core_rknd ) :: & + ustar, & ! Surface friction velocity, u* [m/s] + Lngth, & ! Monin-Obukhov length [m] + zeta ! Dimensionless height z_const/Lngth, where z_const = 1 m. [-] + + integer :: i ! Loop index + + + err_code = clubb_no_error + + if ( l_andre_1978 ) then + + ! Calculate ^2 and ^2. + um_sfc_sqd = um_sfc**2 + vm_sfc_sqd = vm_sfc**2 + + ! Calculate surface friction velocity, u*. + ustar = max( ( upwp_sfc**2 + vpwp_sfc**2 )**(one_fourth), ufmin ) + + if ( wpthlp_sfc /= zero ) then + + ! Find Monin-Obukhov Length (Andre et al., 1978, p. 1866). + Lngth = - ( ustar**3 ) & + / ( 0.35_core_rknd * (one/T0) * grav * wpthlp_sfc ) + + ! Find the value of dimensionless height zeta + ! (Andre et al., 1978, p. 1866). + zeta = z_const / Lngth + + else ! wpthlp_sfc = 0 + + ! The value of Monin-Obukhov length is +inf when ustar < 0 and -inf + ! when ustar > 0. Either way, zeta = 0. + zeta = zero + + endif ! wpthlp_sfc /= 0 + + ! Andre et al, 1978, Eq. 29. + ! Notes: 1) "reduce_coef" is a reduction coefficient intended to make + ! the values of rtp2, thlp2, and rtpthlp smaller at the + ! surface. + ! 2) With the reduction coefficient having a value of 0.2, the + ! surface correlations of both w & rt and w & thl have a value + ! of about 0.845. These correlations are greater if zeta < 0. + ! The correlations have a value greater than 1 if + ! zeta <= -0.212. + ! 3) The surface correlation of rt & thl is 1. + ! Brian Griffin; February 2, 2008. + if ( zeta < zero ) then + + thlp2_sfc = reduce_coef & + * ( wpthlp_sfc**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + rtp2_sfc = reduce_coef & + * ( wprtp_sfc**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + rtpthlp_sfc = reduce_coef & + * ( wprtp_sfc * wpthlp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + wp2_sfc = ( ustar**2 ) & + * ( 1.75_core_rknd + two * (-zeta)**(two_thirds) ) + + else + + thlp2_sfc = reduce_coef & + * four * ( wpthlp_sfc**2 / ustar**2 ) + + rtp2_sfc = reduce_coef & + * four * ( wprtp_sfc**2 / ustar**2 ) + + rtpthlp_sfc = reduce_coef & + * four * ( wprtp_sfc * wpthlp_sfc / ustar**2 ) + + wp2_sfc = 1.75_core_rknd * ustar**2 + + endif + + ! Calculate wstar following Andre et al., 1978, p. 1866. + ! w* = ( ( 1 / T0 ) * g * |_sfc * z_i )^(1/3); + ! where z_i is the height of the mixed layer. The value of CLUBB's + ! upward component of mixing length, Lscale_up, at the surface will be + ! used as z_i. + wstar = ( (one/T0) * grav * wpthlp_sfc * Lscale_up_sfc )**(one_third) + + ! Andre et al., 1978, Eq. 29. + ! Andre et al. (1978) defines horizontal wind surface variances in terms + ! of orientation with the mean surface wind. The vector u_s is the wind + ! vector oriented with the mean surface wind. The vector v_s is the wind + ! vector oriented perpendicular to the mean surface wind. Thus, is + ! equal to the mean surface wind (both in speed and direction), and + ! is 0. Equation 29 gives the formula for the variance of u_s, which is + ! (usp2_sfc in the code), and the formula for the variance of + ! v_s, which is (vsp2_sfc in the code). + if ( wpthlp_sfc > zero ) then + + usp2_sfc = four * ustar**2 + 0.3_core_rknd * wstar**2 + + vsp2_sfc = 1.75_core_rknd * ustar**2 + 0.3_core_rknd * wstar**2 + + else + + usp2_sfc = four * ustar**2 + + vsp2_sfc = 1.75_core_rknd * ustar**2 + + endif + + ! Variance of u, , at the surface can be found from , + ! , and mean winds (at the surface) and , such that: + ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] + ! + * [ ^2 / ( ^2 + ^2 ) ]; + ! where ^2 + ^2 /= 0. + up2_sfc & + = usp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & + + vsp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) + + ! Variance of v, , at the surface can be found from , + ! , and mean winds (at the surface) and , such that: + ! |_sfc = * [ ^2 / ( ^2 + ^2 ) ] + ! + * [ ^2 / ( ^2 + ^2 ) ]; + ! where ^2 + ^2 /= 0. + vp2_sfc & + = vsp2_sfc * ( um_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) & + + usp2_sfc * ( vm_sfc_sqd / max( um_sfc_sqd + vm_sfc_sqd , eps ) ) + + ! Passive scalars + if ( sclr_dim > 0 ) then + do i = 1, sclr_dim + ! Notes: 1) "reduce_coef" is a reduction coefficient intended to + ! make the values of sclrprtp, sclrpthlp, and sclrp2 + ! smaller at the surface. + ! 2) With the reduction coefficient having a value of 0.2, + ! the surface correlation of w & sclr has a value of + ! about 0.845. The correlation is greater if zeta < 0. + ! The correlation has a value greater than 1 if + ! zeta <= -0.212. + ! 3) The surface correlations of both rt & sclr and + ! thl & sclr are 1. + ! Brian Griffin; February 2, 2008. + if ( zeta < zero ) then + + sclrprtp_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i) * wprtp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + sclrpthlp_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i) * wpthlp_sfc / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + sclrp2_sfc(i) & + = reduce_coef & + * ( wpsclrp_sfc(i)**2 / ustar**2 ) & + * four * ( one - 8.3_core_rknd * zeta )**(-two_thirds) + + else + + sclrprtp_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i) * wprtp_sfc / ustar**2 ) + + sclrpthlp_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i) * wpthlp_sfc / ustar**2 ) + + sclrp2_sfc(i) & + = reduce_coef & + * four * ( wpsclrp_sfc(i)**2 / ustar**2 ) + + endif + + enddo ! i = 1, sclr_dim + + endif + + + else ! Previous code. + + ! Compute ustar^2 + ustar2 = sqrt( upwp_sfc * upwp_sfc + vpwp_sfc * vpwp_sfc ) + + ! Compute wstar following Andre et al., 1976 + if ( wpthlp_sfc > zero ) then + wstar = ( one/T0 * grav * wpthlp_sfc * z_const )**(one_third) + else + wstar = zero + endif + + ! Surface friction velocity following Andre et al. 1978 + uf = sqrt( ustar2 + 0.3_core_rknd * wstar * wstar ) + uf = max( ufmin, uf ) + + ! Compute estimate for surface second order moments + wp2_sfc = a_const * uf**2 + up2_sfc = 2.0_core_rknd * a_const * uf**2 ! From Andre, et al. 1978 + vp2_sfc = 2.0_core_rknd * a_const * uf**2 ! " " + + ! Vince Larson changed to make correlations between [-1,1] 31 Jan 2008 +! thlp2_sfc = 0.1 * a * ( wpthlp_sfc / uf )**2 +! rtp2_sfc = 0.4 * a * ( wprtp_sfc / uf )**2 +! rtpthlp_sfc = a * ( wpthlp_sfc / uf ) * ( wprtp_sfc / uf ) + ! Notes: 1) With "a" having a value of 1.8, the surface correlations of + ! both w & rt and w & thl have a value of about 0.878. + ! 2) The surface correlation of rt & thl is 0.5. + ! Brian Griffin; February 2, 2008. + + thlp2_sfc = 0.4_core_rknd * a_const * ( wpthlp_sfc / uf )**2 + + rtp2_sfc = 0.4_core_rknd * a_const * ( wprtp_sfc / uf )**2 + + rtpthlp_sfc = 0.2_core_rknd * a_const & + * ( wpthlp_sfc / uf ) * ( wprtp_sfc / uf ) + + ! End Vince Larson's change. + + ! Passive scalars + if ( sclr_dim > 0 ) then + do i = 1, sclr_dim + ! Vince Larson changed coeffs to make correlations between [-1,1]. + ! 31 Jan 2008 +! sclrprtp_sfc(i) & +! = a * (wprtp_sfc / uf) * (wpsclrp_sfc(i) / uf) +! sclrpthlp_sfc(i) & +! = a * (wpthlp_sfc / uf) * (wpsclrp_sfc(i) / uf) +! sclrp2_sfc(i) & +! = sclr_var_coef * a * ( wpsclrp_sfc(i) / uf )**2 + ! Notes: 1) With "a" having a value of 1.8 and "sclr_var_coef" + ! having a value of 0.4, the surface correlation of + ! w & sclr has a value of about 0.878. + ! 2) With "sclr_var_coef" having a value of 0.4, the + ! surface correlations of both rt & sclr and + ! thl & sclr are 0.5. + ! Brian Griffin; February 2, 2008. + + ! We use the following if..then's to make sclr_rt and sclr_thl + ! close to the actual thlp2/rtp2 at the surface. + ! -dschanen 25 Sep 08 + if ( i == iisclr_rt ) then + ! If we are trying to emulate rt with the scalar, then we + ! use the variance coefficient from above + sclrprtp_sfc(i) = 0.4_core_rknd * a_const & + * ( wprtp_sfc / uf ) * ( wpsclrp_sfc(i) / uf ) + else + sclrprtp_sfc(i) = 0.2_core_rknd * a_const & + * ( wprtp_sfc / uf ) * ( wpsclrp_sfc(i) / uf ) + endif + + if ( i == iisclr_thl ) then + ! As above, but for thetal + sclrpthlp_sfc(i) = 0.4_core_rknd * a_const & + * ( wpthlp_sfc / uf ) & + * ( wpsclrp_sfc(i) / uf ) + else + sclrpthlp_sfc(i) = 0.2_core_rknd * a_const & + * ( wpthlp_sfc / uf ) & + * ( wpsclrp_sfc(i) / uf ) + endif + + sclrp2_sfc(i) = sclr_var_coef * a_const & + * ( wpsclrp_sfc(i) / uf )**2 + + ! End Vince Larson's change. + + enddo ! 1,...sclr_dim + endif ! sclr_dim > 0 + + + endif ! l_andre_1978 + + + if ( clubb_at_least_debug_level( 2 ) ) then + + call surface_varnce_check( wp2_sfc, up2_sfc, vp2_sfc, & + thlp2_sfc, rtp2_sfc, rtpthlp_sfc, & + sclrp2_sfc, sclrprtp_sfc, sclrpthlp_sfc, & + err_code ) + +! Error reporting +! Joshua Fasching February 2008 + if ( err_code == clubb_var_equals_NaN ) then + + write(fstderr,*) "Error in surface_varnce" + write(fstderr,*) "Intent(in)" + + write(fstderr,*) "upwp_sfc = ", upwp_sfc + write(fstderr,*) "vpwp_sfc = ", vpwp_sfc + write(fstderr,*) "wpthlp_sfc = ", wpthlp_sfc + write(fstderr,*) "wprtp_sfc = ", wprtp_sfc + + if ( sclr_dim > 0 ) then + write(fstderr,*) "wpsclrp_sfc = ", wpsclrp_sfc + endif + + write(fstderr,*) "Intent(out)" + + write(fstderr,*) "wp2_sfc = ", wp2_sfc + write(fstderr,*) "up2_sfc = ", up2_sfc + write(fstderr,*) "vp2_sfc = ", vp2_sfc + write(fstderr,*) "thlp2_sfc = ", thlp2_sfc + write(fstderr,*) "rtp2_sfc = ", rtp2_sfc + write(fstderr,*) "rtpthlp_sfc = ", rtpthlp_sfc + + if ( sclr_dim > 0 ) then + write(fstderr,*) "sclrp2_sfc = ", sclrp2_sfc + write(fstderr,*) "sclrprtp_sfc = ", sclrprtp_sfc + write(fstderr,*) "sclrpthlp_sfc = ", sclrpthlp_sfc + endif + + endif ! err_code == clubb_var_equals_NaN + + endif ! clubb_at_least_debug_level ( 2 ) + + + return + + end subroutine surface_varnce + +!=============================================================================== + +end module surface_varnce_module diff --git a/src/physics/clubb/variables_diagnostic_module.F90 b/src/physics/clubb/variables_diagnostic_module.F90 new file mode 100644 index 0000000000..874e324af9 --- /dev/null +++ b/src/physics/clubb/variables_diagnostic_module.F90 @@ -0,0 +1,729 @@ +!------------------------------------------------------------------------- +! $Id: variables_diagnostic_module.F90 7376 2014-11-09 02:55:23Z bmg2@uwm.edu $ +!=============================================================================== +module variables_diagnostic_module + +! Description: +! This module contains definitions of all diagnostic +! arrays used in the single column model, as well as subroutines +! to allocate, deallocate and initialize them. + +! Note that while these are all same dimension, there is a +! thermodynamic and momentum grid and they have different levels +!----------------------------------------------------------------------- + + use pdf_parameter_module, only: & + pdf_parameter ! derived type + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Set default scope + + public :: setup_diagnostic_variables, & + cleanup_diagnostic_variables + + + ! Diagnostic variables + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + sigma_sqd_w_zt, & ! PDF width parameter interpolated to t-levs. [-] + Skw_zm, & ! Skewness of w on momentum levels [-] + Skw_zt, & ! Skewness of w on thermodynamic levels [-] + Skthl_zm, & ! Skewness of w on momentum levels [-] + Skthl_zt, & ! Skewness of w on thermodynamic levels [-] + Skrt_zm, & ! Skewness of w on momentum levels [-] + Skrt_zt, & ! Skewness of w on thermodynamic levels [-] + ug, & ! u geostrophic wind [m/s] + vg, & ! v geostrophic wind [m/s] + um_ref, & ! Initial u wind; Michael Falk [m/s] + vm_ref, & ! Initial v wind; Michael Falk [m/s] + thlm_ref, & ! Initial liquid water potential temperature [K] + rtm_ref, & ! Initial total water mixing ratio [kg/kg] + thvm ! Virtual potential temperature [K] + +!!! Important Note !!! +! Do not indent the omp comments, they need to be in the first 4 columns +!!! End Important Note !!! +!$omp threadprivate(sigma_sqd_w_zt, Skw_zm, Skw_zt, Skthl_zm, Skthl_zt, Skrt_zm, & +!$omp Skrt_zt, ug, vg, um_ref, vm_ref, thlm_ref, rtm_ref, thvm ) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + rsat ! Saturation mixing ratio ! Brian + +!$omp threadprivate(rsat) + + type(pdf_parameter), allocatable, dimension(:), target, public :: & + pdf_params_zm, & ! pdf_params on momentum levels [units vary] + pdf_params_zm_frz !used when l_use_ice_latent = .true. + +!$omp threadprivate(pdf_params_zm, pdf_params_zm_frz) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + Frad, & ! Radiative flux (momentum point) [W/m^2] + radht, & ! SW + LW heating rate [K/s] + Frad_SW_up, & ! SW radiative upwelling flux [W/m^2] + Frad_LW_up, & ! LW radiative upwelling flux [W/m^2] + Frad_SW_down, & ! SW radiative downwelling flux [W/m^2] + Frad_LW_down ! LW radiative downwelling flux [W/m^2] + +!$omp threadprivate(Frad, radht, Frad_SW_up, Frad_SW_down, Frad_LW_up, Frad_LW_down) + +! Second order moments + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + thlprcp, & ! thl'rc' [K kg/kg] + rtprcp, & ! rt'rc' [kg^2/kg^2] + rcp2 ! rc'^2 [kg^2/kg^2] + +!$omp threadprivate(thlprcp, rtprcp, rcp2) + +! Third order moments + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + wpthlp2, & ! w'thl'^2 [m K^2/s] + wp2thlp, & ! w'^2 thl' [m^2 K/s^2] + wprtp2, & ! w'rt'^2 [m kg^2/kg^2] + wp2rtp, & ! w'^2rt' [m^2 kg/kg] + wprtpthlp, & ! w'rt'thl' [m kg K/kg s] + wp2rcp, & ! w'^2 rc' [m^2 kg/kg s^2] + wp3_zm, & ! w'^3 [m^3/s^3] + thlp3, & ! thl'^3 [K^3] + thlp3_zm, & ! thl'^3 [K^3] + rtp3, & ! rt'^3 [kg^3/kg^3] + rtp3_zm ! rt'^3 [kg^3/kg^3] + +!$omp threadprivate(wpthlp2, wp2thlp, wprtp2, wp2rtp, & +!$omp wprtpthlp, wp2rcp, wp3_zm, thlp3, thlp3_zm, rtp3, rtp3_zm ) + +! Fourth order moments + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + wp4 ! w'^4 [m^4/s^4] + +!$omp threadprivate(wp4) + +! Buoyancy related moments + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + rtpthvp, & ! rt'thv' [K kg/kg] + thlpthvp, & ! thl'thv' [K^2] + wpthvp, & ! w'thv' [K m/s] + wp2thvp ! w'^2thv' [K m^2/s^2] + +!$omp threadprivate(rtpthvp, thlpthvp, wpthvp, wp2thvp) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + Kh_zt, & ! Eddy diffusivity coefficient on thermodynamic levels [m^2/s] + Kh_zm ! Eddy diffusivity coefficient on momentum levels [m^2/s] + +!$omp threadprivate(Kh_zt, Kh_zm) + + real( kind = core_rknd ), allocatable, dimension(:,:), public :: & + K_hm ! Eddy diffusivity coefficient for hydrometeors on momentum levels [m^2 s^-1] + +!$omp threadprivate(K_hm) + +! Mixing lengths + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + Lscale, Lscale_up, Lscale_down ! [m] + +!$omp threadprivate(Lscale, Lscale_up, Lscale_down) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + em, & ! Turbulent Kinetic Energy (TKE) [m^2/s^2] + tau_zm, & ! Eddy dissipation time scale on momentum levels [s] + tau_zt ! Eddy dissipation time scale on thermodynamic levels [s] + +!$omp threadprivate(em, tau_zm, tau_zt) + +! hydrometeors variable arrays + real( kind = core_rknd ), allocatable, dimension(:,:), public :: & + hydromet, & ! Mean hydrometeor (thermodynamic levels) [units] + hydrometp2, & ! Variance of a hydrometeor (overall) (m-levs.) [units^2] + wphydrometp ! Covariance of w and hydrometeor (momentum levels) [(m/s)un] +!$omp threadprivate( hydromet, hydrometp2, wphydrometp ) + +! Cloud droplet concentration arrays + real( kind = core_rknd ), allocatable, dimension(:), public :: & + Ncm, & ! Mean cloud droplet concentration, (thermo. levels) [num/kg] + wpNcp ! Covariance of w and N_c, (momentum levels) [(m/s)(#/kg)] +!$omp threadprivate(Ncm,wpNcp) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + Nccnm ! Cloud condensation nuclei concentration (COAMPS/MG) [num/kg] +!$omp threadprivate(Nccnm) + + +! Surface data + real( kind = core_rknd ), public :: ustar ! Average value of friction velocity [m/s] + + real( kind = core_rknd ), public :: soil_heat_flux ! Soil Heat Flux [W/m^2] +!$omp threadprivate(ustar, soil_heat_flux) + +! Passive scalar variables + + real( kind = core_rknd ), target, allocatable, dimension(:,:), public :: & + wpedsclrp ! w'edsclr' +!$omp threadprivate(wpedsclrp) + + real( kind = core_rknd ), target, allocatable, dimension(:,:), public :: & + sclrpthvp, & ! sclr'th_v' + sclrprcp, & ! sclr'rc' + wp2sclrp, & ! w'^2 sclr' + wpsclrp2, & ! w'sclr'^2 + wpsclrprtp, & ! w'sclr'rt' + wpsclrpthlp ! w'sclr'thl' + +!$omp threadprivate(sclrpthvp, sclrprcp, & +!$omp wp2sclrp, wpsclrp2, wpsclrprtp, wpsclrpthlp ) + +! Interpolated variables for tuning +! + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + wp2_zt, & ! w'^2 on thermo. grid [m^2/s^2] + thlp2_zt, & ! thl'^2 on thermo. grid [K^2] + wpthlp_zt, & ! w'thl' on thermo. grid [m K/s] + wprtp_zt, & ! w'rt' on thermo. grid [m kg/(kg s)] + rtp2_zt, & ! rt'^2 on therm. grid [(kg/kg)^2] + rtpthlp_zt, & ! rt'thl' on thermo. grid [kg K/kg] + up2_zt, & ! u'^2 on thermo. grid [m^2/s^2] + vp2_zt, & ! v'^2 on thermo. grid [m^2/s^2] + upwp_zt, & ! u'w' on thermo. grid [m^2/s^2] + vpwp_zt ! v'w' on thermo. grid [m^2/s^2] + +!$omp threadprivate(wp2_zt, thlp2_zt, wpthlp_zt, wprtp_zt, & +!$omp rtp2_zt, rtpthlp_zt, & +!$omp up2_zt, vp2_zt, upwp_zt, vpwp_zt) + + +! Latin Hypercube arrays. Vince Larson 22 May 2005 + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + lh_AKm, & ! Kessler ac estimate [kg/kg/s] + AKm, & ! Exact Kessler ac [kg/kg/s] + AKstd, & ! St dev of exact Kessler ac [kg/kg/s] + AKstd_cld, & ! Stdev of exact w/in cloud ac [kg/kg/s] + lh_rcm_avg, & ! Monte Carlo rcm estimate [kg/kg] + AKm_rcm, & ! Kessler ac based on rcm [kg/kg/s] + AKm_rcc ! Kessler ac based on rcm/cloud_frac [kg/kg/s] + +!$omp threadprivate(lh_AKm, AKm, AKstd, AKstd_cld, lh_rcm_avg, AKm_rcm, & +!$omp AKm_rcc) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + Skw_velocity, & ! Skewness velocity [m/s] + a3_coef, & ! The a3 coefficient from CLUBB eqns [-] + a3_coef_zt ! The a3 coefficient interpolated to the zt grid [-] + +!$omp threadprivate(Skw_velocity, a3_coef, a3_coef_zt) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + wp3_on_wp2, & ! w'^3 / w'^2 on the zm grid [m/s] + wp3_on_wp2_zt ! w'^3 / w'^2 on the zt grid [m/s] + +!$omp threadprivate(wp3_on_wp2, wp3_on_wp2_zt) + + contains + +!----------------------------------------------------------------------- + subroutine setup_diagnostic_variables( nz ) +! Description: +! Allocates and initializes prognostic scalar and array variables +! for the CLUBB model code +!----------------------------------------------------------------------- + + use constants_clubb, only: & + em_min, & ! Constant(s) + zero + + use parameters_model, only: & + hydromet_dim, & ! Variables + sclr_dim, & + edsclr_dim + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + ! Input Variables + integer, intent(in) :: nz ! Nunber of grid levels [-] + + ! Local Variables + integer :: i + +! --- Allocation --- + + ! Diagnostic variables + + allocate( sigma_sqd_w_zt(1:nz) ) ! PDF width parameter interp. to t-levs. + allocate( Skw_zm(1:nz) ) ! Skewness of w on momentum levels + allocate( Skw_zt(1:nz) ) ! Skewness of w on thermodynamic levels + allocate( Skthl_zm(1:nz) ) ! Skewness of thl on momentum levels + allocate( Skthl_zt(1:nz) ) ! Skewness of thl on thermodynamic levels + allocate( Skrt_zm(1:nz) ) ! Skewness of rt on momentum levels + allocate( Skrt_zt(1:nz) ) ! Skewness of rt on thermodynamic levels + allocate( ug(1:nz) ) ! u geostrophic wind + allocate( vg(1:nz) ) ! v geostrophic wind + allocate( um_ref(1:nz) ) ! Reference u wind for nudging; Michael Falk, 17 Oct 2007 + allocate( vm_ref(1:nz) ) ! Reference v wind for nudging; Michael Falk, 17 Oct 2007 + allocate( thlm_ref(1:nz) ) ! Reference liquid water potential for nudging + allocate( rtm_ref(1:nz) ) ! Reference total water mixing ratio for nudging + allocate( thvm(1:nz) ) ! Virtual potential temperature + + allocate( rsat(1:nz) ) ! Saturation mixing ratio ! Brian + + allocate( Frad(1:nz) ) ! radiative flux (momentum point) + allocate( Frad_SW_up(1:nz) ) + allocate( Frad_LW_up(1:nz) ) + allocate( Frad_SW_down(1:nz) ) + allocate( Frad_LW_down(1:nz) ) + + allocate( radht(1:nz) ) ! SW + LW heating rate + + ! pdf_params on momentum levels + allocate( pdf_params_zm(1:nz) ) + allocate( pdf_params_zm_frz(1:nz) ) + + ! Second order moments + + allocate( thlprcp(1:nz) ) ! thl'rc' + allocate( rtprcp(1:nz) ) ! rt'rc' + allocate( rcp2(1:nz) ) ! rc'^2 + + ! Third order moments + + allocate( wpthlp2(1:nz) ) ! w'thl'^2 + allocate( wp2thlp(1:nz) ) ! w'^2thl' + allocate( wprtp2(1:nz) ) ! w'rt'^2 + allocate( wp2rtp(1:nz) ) ! w'^2rt' + allocate( wprtpthlp(1:nz) ) ! w'rt'thl' + allocate( wp2rcp(1:nz) ) ! w'^2rc' + + allocate( wp3_zm(1:nz) ) ! w'^3 + + allocate( thlp3(1:nz) ) ! thl'^3 + allocate( thlp3_zm(1:nz) ) ! thl'^3 + + allocate( rtp3(1:nz) ) ! rt'^3 + allocate( rtp3_zm(1:nz) ) ! rt'^3 + + ! Fourth order moments + + allocate( wp4(1:nz) ) + + ! Buoyancy related moments + + allocate( rtpthvp(1:nz) ) ! rt'thv' + allocate( thlpthvp(1:nz) ) ! thl'thv' + allocate( wpthvp(1:nz) ) ! w'thv' + allocate( wp2thvp(1:nz) ) ! w'^2thv' + + allocate( Kh_zt(1:nz) ) ! Eddy diffusivity coefficient: thermo. levels + allocate( Kh_zm(1:nz) ) ! Eddy diffusivity coefficient: momentum levels + allocate( K_hm(1:nz,1:hydromet_dim) ) ! Eddy diff. coef. for hydromets.: mom. levs. + + allocate( em(1:nz) ) + allocate( Lscale(1:nz) ) + allocate( Lscale_up(1:nz) ) + allocate( Lscale_down(1:nz) ) + + allocate( tau_zm(1:nz) ) ! Eddy dissipation time scale: momentum levels + allocate( tau_zt(1:nz) ) ! Eddy dissipation time scale: thermo. levels + + + ! Interpolated Variables + allocate( wp2_zt(1:nz) ) ! w'^2 on thermo. grid + allocate( thlp2_zt(1:nz) ) ! thl'^2 on thermo. grid + allocate( wpthlp_zt(1:nz) ) ! w'thl' on thermo. grid + allocate( wprtp_zt(1:nz) ) ! w'rt' on thermo. grid + allocate( rtp2_zt(1:nz) ) ! rt'^2 on thermo. grid + allocate( rtpthlp_zt(1:nz) ) ! rt'thl' on thermo. grid + allocate( up2_zt(1:nz) ) ! u'^2 on thermo. grid + allocate( vp2_zt(1:nz) ) ! v'^2 on thermo. grid + allocate( upwp_zt(1:nz) ) ! u'w' on thermo. grid + allocate( vpwp_zt(1:nz) ) ! v'w' on thermo. grid + + + ! Microphysics Variables + allocate( Nccnm(1:nz) ) + allocate( hydromet(1:nz,1:hydromet_dim) ) ! All hydrometeor mean fields + allocate( hydrometp2(1:nz,1:hydromet_dim) ) ! All < h_m'^2 > fields + allocate( wphydrometp(1:nz,1:hydromet_dim) ) ! All < w'h_m' > fields + allocate( Ncm(1:nz) ) ! Mean cloud droplet concentration, < N_c > + allocate( wpNcp(1:nz) ) ! < w'N_c' > + + ! Variables for Latin hypercube microphysics. Vince Larson 22 May 2005 + allocate( lh_AKm(1:nz) ) ! Kessler ac estimate + allocate( AKm(1:nz) ) ! Exact Kessler ac + allocate( AKstd(1:nz) ) ! St dev of exact Kessler ac + allocate( AKstd_cld(1:nz) ) ! St dev of exact w/in cloud Kessler ac + allocate( lh_rcm_avg(1:nz) ) ! Monte Carlo rcm estimate + allocate( AKm_rcm(1:nz) ) ! Kessler ac based on rcm + allocate( AKm_rcc(1:nz) ) ! Kessler ac based on rcm/cloud_frac + ! End of variables for Latin hypercube. + + ! High-order passive scalars + allocate( sclrpthvp(1:nz, 1:sclr_dim) ) + allocate( sclrprcp(1:nz, 1:sclr_dim) ) + + allocate( wp2sclrp(1:nz, 1:sclr_dim) ) + allocate( wpsclrp2(1:nz, 1:sclr_dim) ) + allocate( wpsclrprtp(1:nz, 1:sclr_dim) ) + allocate( wpsclrpthlp(1:nz, 1:sclr_dim) ) + + ! Eddy Diff. Scalars + allocate( wpedsclrp(1:nz, 1:edsclr_dim) ) + + allocate( Skw_velocity(1:nz) ) + + allocate( a3_coef(1:nz) ) + allocate( a3_coef_zt(1:nz) ) + + allocate( wp3_on_wp2(1:nz) ) + allocate( wp3_on_wp2_zt(1:nz) ) + + ! --- Initializaton --- + + ! Diagnostic variables + + sigma_sqd_w_zt = 0.0_core_rknd ! PDF width parameter interp. to t-levs. + Skw_zm = 0.0_core_rknd ! Skewness of w on momentum levels + Skw_zt = 0.0_core_rknd ! Skewness of w on thermodynamic levels + Skthl_zm = 0.0_core_rknd ! Skewness of thl on momentum levels + Skthl_zt = 0.0_core_rknd ! Skewness of thl on thermodynamic levels + Skrt_zm = 0.0_core_rknd ! Skewness of rt on momentum levels + Skrt_zt = 0.0_core_rknd ! Skewness of rt on thermodynamic levels + ug = 0.0_core_rknd ! u geostrophic wind + vg = 0.0_core_rknd ! v geostrophic wind + um_ref = 0.0_core_rknd + vm_ref = 0.0_core_rknd + thlm_ref = 0.0_core_rknd + rtm_ref = 0.0_core_rknd + + thvm = 0.0_core_rknd ! Virtual potential temperature + rsat = 0.0_core_rknd ! Saturation mixing ratio ! Brian + + radht = 0.0_core_rknd ! Heating rate + Frad = 0.0_core_rknd ! Radiative flux + Frad_SW_up = 0.0_core_rknd + Frad_LW_up = 0.0_core_rknd + Frad_SW_down = 0.0_core_rknd + Frad_LW_down = 0.0_core_rknd + + + ! pdf_params on momentum levels + pdf_params_zm(:)%w_1 = zero + pdf_params_zm(:)%w_2 = zero + pdf_params_zm(:)%varnce_w_1 = zero + pdf_params_zm(:)%varnce_w_2 = zero + pdf_params_zm(:)%rt_1 = zero + pdf_params_zm(:)%rt_2 = zero + pdf_params_zm(:)%varnce_rt_1 = zero + pdf_params_zm(:)%varnce_rt_2 = zero + pdf_params_zm(:)%thl_1 = zero + pdf_params_zm(:)%thl_2 = zero + pdf_params_zm(:)%varnce_thl_1 = zero + pdf_params_zm(:)%varnce_thl_2 = zero + pdf_params_zm(:)%rrtthl = zero + pdf_params_zm(:)%alpha_thl = zero + pdf_params_zm(:)%alpha_rt = zero + pdf_params_zm(:)%crt_1 = zero + pdf_params_zm(:)%crt_2 = zero + pdf_params_zm(:)%cthl_1 = zero + pdf_params_zm(:)%cthl_2 = zero + pdf_params_zm(:)%chi_1 = zero + pdf_params_zm(:)%chi_2 = zero + pdf_params_zm(:)%stdev_chi_1 = zero + pdf_params_zm(:)%stdev_chi_2 = zero + pdf_params_zm(:)%stdev_eta_1 = zero + pdf_params_zm(:)%stdev_eta_2 = zero + pdf_params_zm(:)%covar_chi_eta_1 = zero + pdf_params_zm(:)%covar_chi_eta_2 = zero + pdf_params_zm(:)%corr_chi_eta_1 = zero + pdf_params_zm(:)%corr_chi_eta_2 = zero + pdf_params_zm(:)%rsatl_1 = zero + pdf_params_zm(:)%rsatl_2 = zero + pdf_params_zm(:)%rc_1 = zero + pdf_params_zm(:)%rc_2 = zero + pdf_params_zm(:)%cloud_frac_1 = zero + pdf_params_zm(:)%cloud_frac_2 = zero + pdf_params_zm(:)%mixt_frac = zero + + pdf_params_zm_frz(:)%w_1 = zero + pdf_params_zm_frz(:)%w_2 = zero + pdf_params_zm_frz(:)%varnce_w_1 = zero + pdf_params_zm_frz(:)%varnce_w_2 = zero + pdf_params_zm_frz(:)%rt_1 = zero + pdf_params_zm_frz(:)%rt_2 = zero + pdf_params_zm_frz(:)%varnce_rt_1 = zero + pdf_params_zm_frz(:)%varnce_rt_2 = zero + pdf_params_zm_frz(:)%thl_1 = zero + pdf_params_zm_frz(:)%thl_2 = zero + pdf_params_zm_frz(:)%varnce_thl_1 = zero + pdf_params_zm_frz(:)%varnce_thl_2 = zero + pdf_params_zm_frz(:)%rrtthl = zero + pdf_params_zm_frz(:)%alpha_thl = zero + pdf_params_zm_frz(:)%alpha_rt = zero + pdf_params_zm_frz(:)%crt_1 = zero + pdf_params_zm_frz(:)%crt_2 = zero + pdf_params_zm_frz(:)%cthl_1 = zero + pdf_params_zm_frz(:)%cthl_2 = zero + pdf_params_zm_frz(:)%chi_1 = zero + pdf_params_zm_frz(:)%chi_2 = zero + pdf_params_zm_frz(:)%stdev_chi_1 = zero + pdf_params_zm_frz(:)%stdev_chi_2 = zero + pdf_params_zm_frz(:)%stdev_eta_1 = zero + pdf_params_zm_frz(:)%stdev_eta_2 = zero + pdf_params_zm_frz(:)%covar_chi_eta_1 = zero + pdf_params_zm_frz(:)%covar_chi_eta_2 = zero + pdf_params_zm_frz(:)%corr_chi_eta_1 = zero + pdf_params_zm_frz(:)%corr_chi_eta_2 = zero + pdf_params_zm_frz(:)%rsatl_1 = zero + pdf_params_zm_frz(:)%rsatl_2 = zero + pdf_params_zm_frz(:)%rc_1 = zero + pdf_params_zm_frz(:)%rc_2 = zero + pdf_params_zm_frz(:)%cloud_frac_1 = zero + pdf_params_zm_frz(:)%cloud_frac_2 = zero + pdf_params_zm_frz(:)%mixt_frac = zero + + ! Second order moments + thlprcp = 0.0_core_rknd + rtprcp = 0.0_core_rknd + rcp2 = 0.0_core_rknd + + ! Third order moments + wpthlp2 = 0.0_core_rknd + wp2thlp = 0.0_core_rknd + wprtp2 = 0.0_core_rknd + wp2rtp = 0.0_core_rknd + wp2rcp = 0.0_core_rknd + wprtpthlp = 0.0_core_rknd + + wp3_zm = 0.0_core_rknd + + thlp3 = 0.0_core_rknd + thlp3_zm = 0.0_core_rknd + + rtp3 = 0.0_core_rknd + rtp3_zm = 0.0_core_rknd + + ! Fourth order moments + wp4 = 0.0_core_rknd + + ! Buoyancy related moments + rtpthvp = 0.0_core_rknd ! rt'thv' + thlpthvp = 0.0_core_rknd ! thl'thv' + wpthvp = 0.0_core_rknd ! w'thv' + wp2thvp = 0.0_core_rknd ! w'^2thv' + + ! Eddy diffusivity + Kh_zt = 0.0_core_rknd ! Eddy diffusivity coefficient: thermo. levels + Kh_zm = 0.0_core_rknd ! Eddy diffusivity coefficient: momentum levels + + do i = 1, hydromet_dim, 1 + K_hm(1:nz,i) = 0.0_core_rknd ! Eddy diff. coef. for hydromets.: mom. levs. + end do + + ! TKE + em = em_min + + ! Length scale + Lscale = 0.0_core_rknd + Lscale_up = 0.0_core_rknd + Lscale_down = 0.0_core_rknd + + ! Dissipation time + tau_zm = 0.0_core_rknd ! Eddy dissipation time scale: momentum levels + tau_zt = 0.0_core_rknd ! Eddy dissipation time scale: thermo. levels + + ! Hydrometer types + Nccnm(1:nz) = 0.0_core_rknd ! CCN concentration (COAMPS/MG) + + do i = 1, hydromet_dim, 1 + hydromet(1:nz,i) = 0.0_core_rknd + hydrometp2(1:nz,i) = 0.0_core_rknd + wphydrometp(1:nz,i) = 0.0_core_rknd + enddo + + ! Cloud droplet concentration + Ncm(1:nz) = 0.0_core_rknd + wpNcp(1:nz) = 0.0_core_rknd + + + ! Variables for Latin hypercube microphysics. Vince Larson 22 May 2005 + lh_AKm = 0.0_core_rknd ! Kessler ac estimate + AKm = 0.0_core_rknd ! Exact Kessler ac + AKstd = 0.0_core_rknd ! St dev of exact Kessler ac + AKstd_cld = 0.0_core_rknd ! St dev of exact w/in cloud Kessler ac + lh_rcm_avg = 0.0_core_rknd ! Monte Carlo rcm estimate + AKm_rcm = 0.0_core_rknd ! Kessler ac based on rcm + AKm_rcc = 0.0_core_rknd ! Kessler ac based on rcm/cloud_frac + + ! Passive scalars + if ( sclr_dim > 0 ) then + sclrpthvp(:,:) = 0.0_core_rknd + sclrprcp(:,:) = 0.0_core_rknd + + wp2sclrp(:,:) = 0.0_core_rknd + wpsclrp2(:,:) = 0.0_core_rknd + wpsclrprtp(:,:) = 0.0_core_rknd + wpsclrpthlp(:,:) = 0.0_core_rknd + + end if + + if ( edsclr_dim > 0 ) then + wpedsclrp(:,:) = 0.0_core_rknd + end if + + Skw_velocity = 0.0_core_rknd + + a3_coef = 0.0_core_rknd + a3_coef_zt = 0.0_core_rknd + + wp3_on_wp2 = 0.0_core_rknd + wp3_on_wp2_zt = 0.0_core_rknd + + return + end subroutine setup_diagnostic_variables + +!------------------------------------------------------------------------ + subroutine cleanup_diagnostic_variables( ) + +! Description: +! Subroutine to deallocate variables defined in module global +!------------------------------------------------------------------------ + + implicit none + + + ! --- Deallocate --- + ! TODO: use more appropriate condition here + if (allocated(sigma_sqd_w_zt)) then + deallocate( sigma_sqd_w_zt ) ! PDF width parameter interp. to t-levs. + deallocate( Skw_zm ) ! Skewness of w on momentum levels + deallocate( Skw_zt ) ! Skewness of w on thermodynamic levels + deallocate( Skthl_zm ) ! Skewness of thl on momentum levels + deallocate( Skthl_zt ) ! Skewness of thl on thermodynamic levels + deallocate( Skrt_zm ) ! Skewness of rt on momentum levels + deallocate( Skrt_zt ) ! Skewness of rt on thermodynamic levels + deallocate( ug ) ! u geostrophic wind + deallocate( vg ) ! v geostrophic wind + deallocate( um_ref ) ! u initial + deallocate( vm_ref ) ! v initial + deallocate( thlm_ref ) + deallocate( rtm_ref ) + + deallocate( thvm ) ! virtual potential temperature + deallocate( rsat ) ! saturation mixing ratio ! Brian + + deallocate( Frad ) ! radiative flux (momentum point) + + deallocate( Frad_SW_up ) ! upwelling shortwave radiative flux + deallocate( Frad_LW_up ) ! upwelling longwave radiative flux + deallocate( Frad_SW_down ) ! downwelling shortwave radiative flux + deallocate( Frad_LW_down ) ! downwelling longwave radiative flux + + deallocate( radht ) ! SW + LW heating rate + + deallocate( pdf_params_zm ) + deallocate( pdf_params_zm_frz ) + + ! Second order moments + + deallocate( thlprcp ) ! thl'rc' + deallocate( rtprcp ) ! rt'rc' + deallocate( rcp2 ) ! rc'^2 + + ! Third order moments + + deallocate( wpthlp2 ) ! w'thl'^2 + deallocate( wp2thlp ) ! w'^2thl' + deallocate( wprtp2 ) ! w'rt'^2 + deallocate( wp2rtp ) ! w'^2rt' + deallocate( wprtpthlp ) ! w'rt'thl' + deallocate( wp2rcp ) ! w'^2rc' + + deallocate( wp3_zm ) + + deallocate( thlp3 ) ! thl'^3 + deallocate( thlp3_zm ) ! thl'^3 + + deallocate( rtp3 ) ! rt'^3 + deallocate( rtp3_zm ) ! rt'^3 + + ! Fourth order moments + + deallocate( wp4 ) + + ! Buoyancy related moments + + deallocate( rtpthvp ) ! rt'thv' + deallocate( thlpthvp ) ! thl'thv' + deallocate( wpthvp ) ! w'thv' + deallocate( wp2thvp ) ! w'^2thv' + + deallocate( Kh_zt ) ! Eddy diffusivity coefficient: thermo. levels + deallocate( Kh_zm ) ! Eddy diffusivity coefficient: momentum levels + deallocate( K_hm ) ! Eddy diff. coef. for hydromets.: mom. levs. + + deallocate( em ) + deallocate( Lscale ) + deallocate( Lscale_up ) + deallocate( Lscale_down ) + deallocate( tau_zm ) ! Eddy dissipation time scale: momentum levels + deallocate( tau_zt ) ! Eddy dissipation time scale: thermo. levels + + ! Cloud water variables + + deallocate( Nccnm ) + + deallocate( hydromet ) ! Hydrometeor mean fields + deallocate( hydrometp2 ) ! < h_m'^2 > fields + deallocate( wphydrometp ) ! < w'h_m' > fields + deallocate( Ncm ) ! Mean cloud droplet concentration, < N_c > + deallocate( wpNcp ) ! < w'N_c' > + + ! Interpolated variables for tuning + deallocate( wp2_zt ) ! w'^2 on thermo. grid + deallocate( thlp2_zt ) ! th_l'^2 on thermo. grid + deallocate( wpthlp_zt ) ! w'th_l' on thermo. grid + deallocate( wprtp_zt ) ! w'rt' on thermo. grid + deallocate( rtp2_zt ) ! rt'^2 on thermo. grid + deallocate( rtpthlp_zt ) ! rt'th_l' on thermo. grid + deallocate( up2_zt ) ! u'^2 on thermo. grid + deallocate( vp2_zt ) ! v'^2 on thermo. grid + deallocate( upwp_zt ) ! u'w' on thermo. grid + deallocate( vpwp_zt ) ! v'w' on thermo. grid + + ! Variables for Latin hypercube microphysics. Vince Larson 22 May 2005 + deallocate( lh_AKm ) ! Kessler ac estimate + deallocate( AKm ) ! Exact Kessler ac + deallocate( AKstd ) ! St dev of exact Kessler ac + deallocate( AKstd_cld ) ! St dev of exact w/in cloud Kessler ac + deallocate( lh_rcm_avg ) ! Monte Carlo rcm estimate + deallocate( AKm_rcm ) ! Kessler ac based on rcm + deallocate( AKm_rcc ) ! Kessler ac based on rcm/cloud_frac + + ! Passive scalars + deallocate( sclrpthvp ) + deallocate( sclrprcp ) + + deallocate( wp2sclrp ) + deallocate( wpsclrp2 ) + deallocate( wpsclrprtp ) + deallocate( wpsclrpthlp ) + + deallocate( wpedsclrp ) + + deallocate( Skw_velocity ) + + deallocate( a3_coef ) + deallocate( a3_coef_zt ) + + deallocate( wp3_on_wp2 ) + deallocate( wp3_on_wp2_zt ) + end if + + return + end subroutine cleanup_diagnostic_variables + +end module variables_diagnostic_module diff --git a/src/physics/clubb/variables_prognostic_module.F90 b/src/physics/clubb/variables_prognostic_module.F90 new file mode 100644 index 0000000000..c460fc13b4 --- /dev/null +++ b/src/physics/clubb/variables_prognostic_module.F90 @@ -0,0 +1,569 @@ +!----------------------------------------------------------------------- +! $Id: variables_prognostic_module.F90 7309 2014-09-20 17:06:28Z betlej@uwm.edu $ +!=============================================================================== +module variables_prognostic_module + +! This module contains definitions of all prognostic +! arrays used in the single column model, as well as subroutines +! to allocate, deallocate and initialize them. + +! Note that while these are all same dimension, there is a +! thermodynamic grid and a momentum grid, and the grids have +! different points. +!----------------------------------------------------------------------- + use pdf_parameter_module, only: & + pdf_parameter ! Derived type + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + private ! Set Default Scoping + + public :: & + setup_prognostic_variables, & + cleanup_prognostic_variables + + ! Prognostic variables +! ---> h1g, 2010-06-16 +#ifdef GFDL + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + um, & ! u wind [m/s] + vm, & ! v wind [m/s] + upwp, & ! vertical u momentum flux [m^2/s^2] + vpwp, & ! vertical v momentum flux [m^2/s^2] + up2, & ! u'^2 [m^2/s^2] + vp2, & ! v'^2 [m^2/s^2] + thlm, & ! liquid potential temperature [K] +!---> h1g + temp_clubb, & ! air temperature [K] +!<--- h1g + rtm, & ! total water mixing ratio [kg/kg] + wprtp, & ! w'rt' [(kg/kg) m/s] + wpthlp, & ! w'thl' [m K/s] + wprcp, & ! w'rc' [(kg/kg) m/s] + wp2, & ! w'^2 [m^2/s^2] + wp3, & ! w'^3 [m^3/s^3] + rtp2, & ! rt'^2 [(kg/kg)^2] + thlp2, & ! thl'^2 [K^2] + rtpthlp ! rt'thl' [kg/kg K] +!$omp threadprivate( temp_clubb ) +#else + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + um, & ! u wind [m/s] + vm, & ! v wind [m/s] + upwp, & ! vertical u momentum flux [m^2/s^2] + vpwp, & ! vertical v momentum flux [m^2/s^2] + up2, & ! u'^2 [m^2/s^2] + vp2, & ! v'^2 [m^2/s^2] + thlm, & ! liquid potential temperature [K] + rtm, & ! total water mixing ratio [kg/kg] + wprtp, & ! w'rt' [(kg/kg) m/s] + wpthlp, & ! w'thl' [m K/s] + wprcp, & ! w'rc' [(kg/kg) m/s] + wp2, & ! w'^2 [m^2/s^2] + wp3, & ! w'^3 [m^3/s^3] + rtp2, & ! rt'^2 [(kg/kg)^2] + thlp2, & ! thl'^2 [K^2] + rtpthlp ! rt'thl' [kg/kg K] +#endif +! <--- h1g, 2010-06-16 + +!$omp threadprivate(um, vm, upwp, vpwp, up2, vp2) +!$omp threadprivate(thlm, rtm, wprtp, wpthlp, wprcp) +!$omp threadprivate(wp2, wp3, rtp2, thlp2, rtpthlp) + + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + p_in_Pa, & ! Pressure (Pa) (thermodynamic levels) [Pa] + exner, & ! Exner function = ( p / p0 ) ** kappa [-] + rho, & ! Density (thermodynamic levels) [kg/m^3] + rho_zm, & ! Density on momentum levels [kg/m^3] + rho_ds_zm, & ! Dry, static density (momentum levels) [kg/m^3] + rho_ds_zt, & ! Dry, static density (thermodynamic levels) [kg/m^3] + invrs_rho_ds_zm, & ! Inverse dry, static density (momentum levs.) [m^3/kg] + invrs_rho_ds_zt, & ! Inverse dry, static density (thermo. levs.) [m^3/kg] + thv_ds_zm, & ! Dry, base-state theta_v (momentum levels) [K] + thv_ds_zt, & ! Dry, base-state theta_v (thermodynamic levs.) [K] + thlm_forcing, & ! thlm large-scale forcing [K/s] + rtm_forcing, & ! rtm large-scale forcing [kg/kg/s] + um_forcing, & ! u wind forcing [m/s/s] + vm_forcing, & ! v wind forcing [m/s/s] + wprtp_forcing, & ! forcing (momentum levels) [m*K/s^2] + wpthlp_forcing, & ! forcing (momentum levels) [m*(kg/kg)/s^2] + rtp2_forcing, & ! forcing (momentum levels) [(kg/kg)^2/s] + thlp2_forcing, & ! forcing (momentum levels) [K^2/s] + rtpthlp_forcing ! forcing (momentum levels) [K*(kg/kg)/s] + +!$omp threadprivate( p_in_Pa, exner, rho, rho_zm, rho_ds_zm, rho_ds_zt, & +!$omp invrs_rho_ds_zm, invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & +!$omp thlm_forcing, rtm_forcing, um_forcing, vm_forcing, wprtp_forcing, & +!$omp wpthlp_forcing, rtp2_forcing, thlp2_forcing, rtpthlp_forcing ) + + ! Imposed large scale w + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + wm_zm, & ! w on momentum levels [m/s] + wm_zt ! w on thermodynamic levels [m/s] + +!$omp threadprivate(wm_zm, wm_zt) + + ! Cloud water variables + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + rcm, & ! Cloud water mixing ratio [kg/kg] + cloud_frac, & ! Cloud fraction [-] + ice_supersat_frac, & ! Ice cloud fraction [-] + rcm_in_layer, & ! Cloud water mixing ratio in cloud layer [kg/kg] + cloud_cover ! Cloud cover [-] + +!$omp threadprivate(rcm, cloud_frac, ice_supersat_frac, rcm_in_layer, cloud_cover) + + ! Surface fluxes + real( kind = core_rknd ), public :: & + wpthlp_sfc, & ! w'thl' [m K/s] + wprtp_sfc, & ! w'rt' [m kg/(kg s)] + upwp_sfc, vpwp_sfc ! u'w' & v'w' [m^2/s^2] + +!$omp threadprivate(wpthlp_sfc, wprtp_sfc, upwp_sfc, vpwp_sfc) + + ! Surface fluxes for passive scalars + real( kind = core_rknd ), dimension(:), allocatable, public :: & + wpsclrp_sfc, & ! w'sclr' at surface [units m/s] + wpedsclrp_sfc ! w'edsclr' at surface [units m/s] + +!$omp threadprivate(wpsclrp_sfc, wpedsclrp_sfc) + + ! More surface data + real( kind = core_rknd ), public :: & + T_sfc, & ! surface temperature [K] + p_sfc, & ! surface pressure [Pa] + sens_ht, & ! sensible heat flux [K m/s] + latent_ht ! latent heat flux [m/s] + +!$omp threadprivate(T_sfc, p_sfc, sens_ht, latent_ht) + + ! Passive scalars + real( kind = core_rknd ), target, allocatable, dimension(:,:), public :: & + sclrm, & ! Mean passive scalars [units vary] + sclrp2, & ! sclr'^2 [units^2] + sclrprtp, & ! sclr'rt' [units kg/kg] + sclrpthlp, & ! sclr'th_l' [units K] + sclrm_forcing, & ! Scalars' forcing [units/s] + edsclrm, & ! Mean eddy-diffusivity scalars [units vary] + edsclrm_forcing, & ! Eddy-diff. scalars forcing [units/s] + wpsclrp ! w'sclr' [units vary m/s] + +!---> h1g, 2010-06-16 +#ifdef GFDL + real( kind = core_rknd ), target, allocatable, dimension( : , : , : ), public :: & + RH_crit ! critical relative humidity for droplet and ice nucleation +!$omp threadprivate( RH_crit ) +#endif +!<--- h1g, 2010-06-16 + +!$omp threadprivate(sclrm, sclrp2, sclrprtp, sclrpthlp, sclrm_forcing, & +!$omp edsclrm, edsclrm_forcing, wpsclrp) + + ! PDF parameters + real( kind = core_rknd ), target, allocatable, dimension(:), public :: & + sigma_sqd_w ! PDF width parameter (momentum levels) [-] + +!$omp threadprivate(sigma_sqd_w) + + type(pdf_parameter), target, allocatable, dimension(:), public :: & + pdf_params, & + pdf_params_frz !for use when l_use_ice_latent = .true. + +!$omp threadprivate(pdf_params, pdf_params_frz) + + contains +!----------------------------------------------------------------------- + subroutine setup_prognostic_variables( nz ) + +! Description: +! Allocates and Initializes prognostic scalar and array variables +! for the CLUBB parameterization. Variables contained within this module +! will be arguments to the advance_clubb_core subroutine rather than brought +! in through a use statement. + +! References: +! None +!----------------------------------------------------------------------- + use constants_clubb, only: & + rt_tol, & ! Constant(s) + thl_tol, & + w_tol_sqd, & + zero + + use parameters_model, only: & + sclr_dim, & ! Variable(s) + edsclr_dim + + use clubb_precision, only: & + core_rknd ! Variable(s) + + implicit none + + integer, intent(in) :: nz ! Number of grid levels [-] + + integer :: i + +! --- Allocation --- + +! Prognostic variables + + allocate( um(1:nz) ) ! u wind + allocate( vm(1:nz) ) ! v wind + + allocate( upwp(1:nz) ) ! vertical u momentum flux + allocate( vpwp(1:nz) ) ! vertical v momentum flux + + allocate( up2(1:nz) ) + allocate( vp2(1:nz) ) + + allocate( thlm(1:nz) ) ! liquid potential temperature +!---> h1g, 2010-06-16 +#ifdef GFDL + allocate( temp_clubb(1:nz) ) ! air temperature +#endif +!<--- h1g, 2010-06-16 + + allocate( rtm(1:nz) ) ! total water mixing ratio + allocate( wprtp(1:nz) ) ! w'rt' + allocate( wpthlp(1:nz) ) ! w'thl' + allocate( wprcp(1:nz) ) ! w'rc' + allocate( wp2(1:nz) ) ! w'^2 + allocate( wp3(1:nz) ) ! w'^3 + allocate( rtp2(1:nz) ) ! rt'^2 + allocate( thlp2(1:nz) ) ! thl'^2 + allocate( rtpthlp(1:nz) ) ! rt'thlp' + + allocate( p_in_Pa(1:nz) ) ! pressure (pascals) + allocate( exner(1:nz) ) ! exner function + allocate( rho(1:nz) ) ! density: t points + allocate( rho_zm(1:nz) ) ! density: m points + allocate( rho_ds_zm(1:nz) ) ! dry, static density: m-levs + allocate( rho_ds_zt(1:nz) ) ! dry, static density: t-levs + allocate( invrs_rho_ds_zm(1:nz) ) ! inv. dry, static density: m-levs + allocate( invrs_rho_ds_zt(1:nz) ) ! inv. dry, static density: t-levs + allocate( thv_ds_zm(1:nz) ) ! dry, base-state theta_v: m-levs + allocate( thv_ds_zt(1:nz) ) ! dry, base-state theta_v: t-levs + + allocate( thlm_forcing(1:nz) ) ! thlm ls forcing + allocate( rtm_forcing(1:nz) ) ! rtm ls forcing + allocate( um_forcing(1:nz) ) ! u forcing + allocate( vm_forcing(1:nz) ) ! v forcing + allocate( wprtp_forcing(1:nz) ) ! forcing (microphysics) + allocate( wpthlp_forcing(1:nz) ) ! forcing (microphysics) + allocate( rtp2_forcing(1:nz) ) ! forcing (microphysics) + allocate( thlp2_forcing(1:nz) ) ! forcing (microphysics) + allocate( rtpthlp_forcing(1:nz) ) ! forcing (microphysics) + + ! Imposed large scale w + + allocate( wm_zm(1:nz) ) ! momentum levels + allocate( wm_zt(1:nz) ) ! thermodynamic levels + + ! Cloud water variables + + allocate( rcm(1:nz) ) + allocate( cloud_frac(1:nz) ) + allocate( ice_supersat_frac(1:nz) ) + allocate( rcm_in_layer(1:nz) ) + allocate( cloud_cover(1:nz) ) + + ! Passive scalar variables + ! Note that sclr_dim can be 0 + allocate( wpsclrp_sfc(1:sclr_dim) ) + allocate( sclrm(1:nz, 1:sclr_dim) ) + allocate( sclrp2(1:nz, 1:sclr_dim) ) + allocate( sclrm_forcing(1:nz, 1:sclr_dim) ) + allocate( sclrprtp(1:nz, 1:sclr_dim) ) + allocate( sclrpthlp(1:nz, 1:sclr_dim) ) + + allocate( wpedsclrp_sfc(1:edsclr_dim) ) + allocate( edsclrm_forcing(1:nz, 1:edsclr_dim) ) + + allocate( edsclrm(1:nz, 1:edsclr_dim) ) + allocate( wpsclrp(1:nz, 1:sclr_dim) ) + +!---> h1g, 2010-06-16 +#ifdef GFDL + allocate( RH_crit(1:nz, 1:min(1,sclr_dim), 2) ) +#endif +!<--- h1g, 2010-06-16 + + allocate( sigma_sqd_w(1:nz) ) ! PDF width parameter (momentum levels) + + ! Variables for pdf closure scheme + allocate( pdf_params(1:nz) ) + allocate( pdf_params_frz(1:nz) ) + +!--------- Set initial values for array variables --------- + + ! Prognostic variables + + um(1:nz) = 0.0_core_rknd ! u wind + vm (1:nz) = 0.0_core_rknd ! v wind + + upwp(1:nz) = 0.0_core_rknd ! vertical u momentum flux + vpwp(1:nz) = 0.0_core_rknd ! vertical v momentum flux + + up2(1:nz) = w_tol_sqd ! u'^2 + vp2(1:nz) = w_tol_sqd ! v'^2 + wp2(1:nz) = w_tol_sqd ! w'^2 + + thlm(1:nz) = 0.0_core_rknd ! liquid potential temperature + rtm(1:nz) = 0.0_core_rknd ! total water mixing ratio + wprtp(1:nz) = 0.0_core_rknd ! w'rt' + wpthlp(1:nz) = 0.0_core_rknd ! w'thl' + wprcp(1:nz) = 0.0_core_rknd ! w'rc' + wp3(1:nz) = 0.0_core_rknd ! w'^3 + rtp2(1:nz) = rt_tol**2 ! rt'^2 + thlp2(1:nz) = thl_tol**2 ! thl'^2 + rtpthlp(1:nz) = 0.0_core_rknd ! rt'thl' + + p_in_Pa(1:nz)= 0.0_core_rknd ! pressure (Pa) + exner(1:nz) = 0.0_core_rknd ! exner + rho(1:nz) = 0.0_core_rknd ! density on thermo. levels + rho_zm(1:nz) = 0.0_core_rknd ! density on moment. levels + rho_ds_zm(1:nz) = 0.0_core_rknd ! dry, static density: m-levs + rho_ds_zt(1:nz) = 0.0_core_rknd ! dry, static density: t-levs + invrs_rho_ds_zm(1:nz) = 0.0_core_rknd ! inv. dry, static density: m-levs + invrs_rho_ds_zt(1:nz) = 0.0_core_rknd ! inv. dry, static density: t-levs + thv_ds_zm(1:nz) = 0.0_core_rknd ! dry, base-state theta_v: m-levs + thv_ds_zt(1:nz) = 0.0_core_rknd ! dry, base-state theta_v: t-levs + + thlm_forcing(1:nz) = zero ! thlm large-scale forcing + rtm_forcing(1:nz) = zero ! rtm large-scale forcing + um_forcing(1:nz) = zero ! u forcing + vm_forcing(1:nz) = zero ! v forcing + wprtp_forcing(1:nz) = zero ! forcing (microphysics) + wpthlp_forcing(1:nz) = zero ! forcing (microphysics) + rtp2_forcing(1:nz) = zero ! forcing (microphysics) + thlp2_forcing(1:nz) = zero ! forcing (microphysics) + rtpthlp_forcing(1:nz) = zero ! forcing (microphysics) + + ! Imposed large scale w + + wm_zm(1:nz) = 0.0_core_rknd ! Momentum levels + wm_zt(1:nz) = 0.0_core_rknd ! Thermodynamic levels + + ! Cloud water variables + + rcm(1:nz) = 0.0_core_rknd + cloud_frac(1:nz) = 0.0_core_rknd + ice_supersat_frac(1:nz) = 0.0_core_rknd + rcm_in_layer(1:nz) = 0.0_core_rknd + cloud_cover(1:nz) = 0.0_core_rknd + + sigma_sqd_w = 0.0_core_rknd ! PDF width parameter (momentum levels) + + ! Variables for PDF closure scheme + pdf_params(:)%w_1 = zero + pdf_params(:)%w_2 = zero + pdf_params(:)%varnce_w_1 = zero + pdf_params(:)%varnce_w_2 = zero + pdf_params(:)%rt_1 = zero + pdf_params(:)%rt_2 = zero + pdf_params(:)%varnce_rt_1 = zero + pdf_params(:)%varnce_rt_2 = zero + pdf_params(:)%thl_1 = zero + pdf_params(:)%thl_2 = zero + pdf_params(:)%varnce_thl_1 = zero + pdf_params(:)%varnce_thl_2 = zero + pdf_params(:)%rrtthl = zero + pdf_params(:)%alpha_thl = zero + pdf_params(:)%alpha_rt = zero + pdf_params(:)%crt_1 = zero + pdf_params(:)%crt_2 = zero + pdf_params(:)%cthl_1 = zero + pdf_params(:)%cthl_2 = zero + pdf_params(:)%chi_1 = zero + pdf_params(:)%chi_2 = zero + pdf_params(:)%stdev_chi_1 = zero + pdf_params(:)%stdev_chi_2 = zero + pdf_params(:)%stdev_eta_1 = zero + pdf_params(:)%stdev_eta_2 = zero + pdf_params(:)%covar_chi_eta_1 = zero + pdf_params(:)%covar_chi_eta_2 = zero + pdf_params(:)%corr_chi_eta_1 = zero + pdf_params(:)%corr_chi_eta_2 = zero + pdf_params(:)%rsatl_1 = zero + pdf_params(:)%rsatl_2 = zero + pdf_params(:)%rc_1 = zero + pdf_params(:)%rc_2 = zero + pdf_params(:)%cloud_frac_1 = zero + pdf_params(:)%cloud_frac_2 = zero + pdf_params(:)%mixt_frac = zero + pdf_params(:)%ice_supersat_frac_1 = zero + pdf_params(:)%ice_supersat_frac_2 = zero + + pdf_params_frz(:)%w_1 = zero + pdf_params_frz(:)%w_2 = zero + pdf_params_frz(:)%varnce_w_1 = zero + pdf_params_frz(:)%varnce_w_2 = zero + pdf_params_frz(:)%rt_1 = zero + pdf_params_frz(:)%rt_2 = zero + pdf_params_frz(:)%varnce_rt_1 = zero + pdf_params_frz(:)%varnce_rt_2 = zero + pdf_params_frz(:)%thl_1 = zero + pdf_params_frz(:)%thl_2 = zero + pdf_params_frz(:)%varnce_thl_1 = zero + pdf_params_frz(:)%varnce_thl_2 = zero + pdf_params_frz(:)%rrtthl = zero + pdf_params_frz(:)%alpha_thl = zero + pdf_params_frz(:)%alpha_rt = zero + pdf_params_frz(:)%crt_1 = zero + pdf_params_frz(:)%crt_2 = zero + pdf_params_frz(:)%cthl_1 = zero + pdf_params_frz(:)%cthl_2 = zero + pdf_params_frz(:)%chi_1 = zero + pdf_params_frz(:)%chi_2 = zero + pdf_params_frz(:)%stdev_chi_1 = zero + pdf_params_frz(:)%stdev_chi_2 = zero + pdf_params_frz(:)%stdev_eta_1 = zero + pdf_params_frz(:)%stdev_eta_2 = zero + pdf_params_frz(:)%covar_chi_eta_1 = zero + pdf_params_frz(:)%covar_chi_eta_2 = zero + pdf_params_frz(:)%corr_chi_eta_1 = zero + pdf_params_frz(:)%corr_chi_eta_2 = zero + pdf_params_frz(:)%rsatl_1 = zero + pdf_params_frz(:)%rsatl_2 = zero + pdf_params_frz(:)%rc_1 = zero + pdf_params_frz(:)%rc_2 = zero + pdf_params_frz(:)%cloud_frac_1 = zero + pdf_params_frz(:)%cloud_frac_2 = zero + pdf_params_frz(:)%mixt_frac = zero + pdf_params_frz(:)%ice_supersat_frac_1 = zero + pdf_params_frz(:)%ice_supersat_frac_2 = zero + + ! Surface fluxes + wpthlp_sfc = 0.0_core_rknd + wprtp_sfc = 0.0_core_rknd + upwp_sfc = 0.0_core_rknd + vpwp_sfc = 0.0_core_rknd + +! ---> h1g, 2010-06-16 +! initialize critical relative humidity for liquid and ice nucleation +#ifdef GFDL + RH_crit = 1.0_core_rknd +#endif +!<--- h1g, 2010-06-16 + + ! Passive scalars + do i = 1, sclr_dim, 1 + wpsclrp_sfc(i) = 0.0_core_rknd + + sclrm(1:nz,i) = 0.0_core_rknd + sclrp2(1:nz,i) = 0.0_core_rknd + sclrprtp(1:nz,i) = 0.0_core_rknd + sclrpthlp(1:nz,i) = 0.0_core_rknd + sclrm_forcing(1:nz,i) = 0.0_core_rknd + wpsclrp(1:nz,i) = 0.0_core_rknd + end do + + do i = 1, edsclr_dim, 1 + wpedsclrp_sfc(i) = 0.0_core_rknd + + edsclrm(1:nz,i) = 0.0_core_rknd + edsclrm_forcing(1:nz,i) = 0.0_core_rknd + end do + + return + end subroutine setup_prognostic_variables +!----------------------------------------------------------------------- + subroutine cleanup_prognostic_variables + implicit none + + ! Prognostic variables + ! TODO: use a more appropriate condition + if (allocated(um)) then + deallocate( um ) ! u wind + deallocate( vm ) ! v wind + + deallocate( upwp ) ! vertical u momentum flux + deallocate( vpwp ) ! vertical v momentum flux + + deallocate( up2, vp2 ) + + deallocate( thlm ) ! liquid potential temperature + +!---> h1g, 2010-06-16 +#ifdef GFDL + deallocate( temp_clubb ) +#endif +!<--- h1g, 2010-06-16 + + deallocate( rtm ) ! total water mixing ratio + deallocate( wprtp ) ! w'rt' + deallocate( wpthlp ) ! w'thl' + deallocate( wprcp ) ! w'rc' + deallocate( wp2 ) ! w'^2 + deallocate( wp3 ) ! w'^3 + deallocate( rtp2 ) ! rt'^2 + deallocate( thlp2 ) ! thl'^2 + deallocate( rtpthlp ) ! rt'thl' + + deallocate( p_in_Pa ) ! pressure + deallocate( exner ) ! exner + deallocate( rho ) ! density: t points + deallocate( rho_zm ) ! density: m points + deallocate( rho_ds_zm ) ! dry, static density: m-levs + deallocate( rho_ds_zt ) ! dry, static density: t-levs + deallocate( invrs_rho_ds_zm ) ! inv. dry, static density: m-levs + deallocate( invrs_rho_ds_zt ) ! inv. dry, static density: t-levs + deallocate( thv_ds_zm ) ! dry, base-state theta_v: m-levs + deallocate( thv_ds_zt ) ! dry, base-state theta_v: t-levs + + deallocate( thlm_forcing ) ! thlm large-scale forcing + deallocate( rtm_forcing ) ! rtm large-scale forcing + deallocate( um_forcing ) ! u forcing + deallocate( vm_forcing ) ! v forcing + deallocate( wprtp_forcing ) ! forcing (microphysics) + deallocate( wpthlp_forcing ) ! forcing (microphysics) + deallocate( rtp2_forcing ) ! forcing (microphysics) + deallocate( thlp2_forcing ) ! forcing (microphysics) + deallocate( rtpthlp_forcing ) ! forcing (microphysics) + + ! Imposed large scale w + + deallocate( wm_zm ) ! momentum levels + deallocate( wm_zt ) ! thermodynamic levels + + ! Cloud water variables + + deallocate( rcm ) + deallocate( cloud_frac ) + deallocate( ice_supersat_frac ) + deallocate( rcm_in_layer ) + deallocate( cloud_cover ) + + deallocate( sigma_sqd_w ) ! PDF width parameter (momentum levels) + + ! Variable for pdf closure scheme + deallocate( pdf_params ) + deallocate( pdf_params_frz ) + + ! Passive scalars + deallocate( wpsclrp_sfc, wpedsclrp_sfc ) + deallocate( sclrm ) + deallocate( sclrp2 ) + deallocate( sclrprtp ) + deallocate( sclrpthlp ) + deallocate( sclrm_forcing ) + deallocate( wpsclrp ) + + deallocate( edsclrm ) + deallocate( edsclrm_forcing ) + +!---> h1g, 2010-06-16 +#ifdef GFDL + deallocate( RH_crit ) +#endif +! <--- h1g, 2010-06-16 + end if + + return + end subroutine cleanup_prognostic_variables + +end module variables_prognostic_module diff --git a/src/physics/cosp2/src/README b/src/physics/cosp2/src/README new file mode 100644 index 0000000000..2f90b3b64e --- /dev/null +++ b/src/physics/cosp2/src/README @@ -0,0 +1,21 @@ +Overview: +This directory contains version 2 of the Cloud Feedback Model Intercomparison Project +Observational Simulator Package (COSP2). + +The code in this directory depends on +two model-specific files in ../model-interface which may be edited for +consistency with the host model. + +cosp.f90 contains + *) type(cosp_grid_inputs) - COSP inputs directly from model state + *) type(cosp_inputs) - COSP inputs derived from model state (optics) + *) type(cosp_outputs) - COSP outputs + *) cosp_simulator - Main cosp engine + *) cosp_init - COSP Initialization + *) cosp_errorCheck - Error checking for inputs +cosp_config.F90 include configuration information needed by the host model and COSP + (e.g. joint-histogram bin boundaries) +cosp_stats.F90 contains statistical subroutines used by multiple simulators + (e.g. Joint-histogram computation) + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/src/physics/cosp2/src/cosp.F90 b/src/physics/cosp2/src/cosp.F90 new file mode 100644 index 0000000000..c94aaf3fc0 --- /dev/null +++ b/src/physics/cosp2/src/cosp.F90 @@ -0,0 +1,2885 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +MODULE MOD_COSP + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,PARASOL_NREFL,LIDAR_NCAT,SR_BINS, & + N_HYDRO,RTTOV_MAX_CHANNELS,numMISRHgtBins, & + DBZE_BINS,LIDAR_NTEMP,calipso_histBsct, & + use_vgrid,Nlvgrid,vgrid_zu,vgrid_zl,vgrid_z, & + numMODISTauBins,numMODISPresBins, & + numMODISReffIceBins,numMODISReffLiqBins, & + numISCCPTauBins,numISCCPPresBins,numMISRTauBins,& + ntau,modis_histTau,tau_binBounds, & + modis_histTauEdges,tau_binEdges, & + modis_histTauCenters,tau_binCenters + USE MOD_COSP_MODIS_INTERFACE, ONLY: cosp_modis_init, modis_IN + USE MOD_COSP_RTTOV_INTERFACE, ONLY: cosp_rttov_init, rttov_IN + USE MOD_COSP_MISR_INTERFACE, ONLY: cosp_misr_init, misr_IN + USE MOD_COSP_ISCCP_INTERFACE, ONLY: cosp_isccp_init, isccp_IN + USE MOD_COSP_CALIPSO_INTERFACE, ONLY: cosp_calipso_init, calipso_IN + USE MOD_COSP_PARASOL_INTERFACE, ONLY: cosp_parasol_init, parasol_in + USE MOD_COSP_CLOUDSAT_INTERFACE, ONLY: cosp_cloudsat_init, cloudsat_IN + USE quickbeam, ONLY: quickbeam_subcolumn, quickbeam_column, radar_cfg + USE MOD_ICARUS, ONLY: icarus_subcolumn, icarus_column + USE MOD_MISR_SIMULATOR, ONLY: misr_subcolumn, misr_column + USE MOD_LIDAR_SIMULATOR, ONLY: lidar_subcolumn, lidar_column + USE MOD_MODIS_SIM, ONLY: modis_subcolumn, modis_column + USE MOD_PARASOL, ONLY: parasol_subcolumn, parasol_column + use mod_cosp_rttov, ONLY: rttov_column + USE MOD_COSP_STATS, ONLY: COSP_LIDAR_ONLY_CLOUD,COSP_CHANGE_VERTICAL_GRID + + IMPLICIT NONE + + logical :: linitialization ! Initialization flag + + ! ###################################################################################### + ! TYPE cosp_column_inputs + ! ###################################################################################### + type cosp_column_inputs + integer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + + integer,allocatable,dimension(:) :: & + sunlit ! Sunlit flag (0-1) + + real(wp),allocatable,dimension(:,:) :: & + at, & ! Temperature (K) + pfull, & ! Pressure (Pa) + phalf, & ! Pressure at half-levels (Pa) + qv, & ! Specific humidity (kg/kg) + hgt_matrix, & ! Height of hydrometeors (km) + hgt_matrix_half ! Height of hydrometeors at half levels (km) + + real(wp),allocatable,dimension(:) :: & + land, & ! Land/Sea mask (0-1) + skt ! Surface temperature (K) + ! Fields used ONLY by RTTOV + integer :: & + month ! Month for surface emissivty atlas (1-12) + real(wp) :: & + zenang, & ! Satellite zenith angle for RTTOV (deg) + co2, & ! CO2 (kg/kg) + ch4, & ! Methane (kg/kg) + n2o, & ! N2O (kg/kg) + co ! CO (kg/kg) + real(wp),allocatable,dimension(:) :: & + emis_sfc, & ! Surface emissivity (1) + u_sfc, & ! Surface u-wind (m/s) + v_sfc, & ! Surface v-wind (m/s) + seaice, & ! Sea-ice fraction (0-1) + lat, & ! Latitude (deg) + lon ! Longitude (deg) + real(wp),allocatable,dimension(:,:) :: & + o3, & ! Ozone (kg/kg) + tca, & ! Total column cloud fraction (0-1) + cloudIce, & ! Cloud ice water mixing ratio (kg/kg) + cloudLiq, & ! Cloud liquid water mixing ratio (kg/kg) + fl_rain, & ! Precipitation (rain) flux (kg/m2/s) + fl_snow ! Precipitation (snow) flux (kg/m2/s) + end type cosp_column_inputs + + ! ###################################################################################### + ! TYPE cosp_optical_inputs + ! ###################################################################################### + type cosp_optical_inputs + integer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels, & ! Number of levels. + Npart, & ! Number of cloud meteors for LIDAR simulator. + Nrefl ! Number of reflectances for PARASOL simulator + real(wp) :: & + emsfc_lw ! 11 micron surface emissivity + real(wp),allocatable,dimension(:,:,:) :: & + frac_out, & ! Cloud fraction + tau_067, & ! Optical depth + fracLiq, & ! Cloud fraction + emiss_11, & ! Emissivity + asym, & ! Assymetry parameter + ss_alb, & ! Single-scattering albedo + betatot, & ! Backscatter coefficient for polarized optics (total) + betatot_ice, & ! Backscatter coefficient for polarized optics (ice) + betatot_liq, & ! Backscatter coefficient for polarized optics (liquid) + tautot, & ! Optical thickess integrated from top (total) + tautot_ice, & ! Optical thickess integrated from top (ice) + tautot_liq, & ! Optical thickess integrated from top (liquid) + z_vol_cloudsat, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol_cloudsat, & ! Attenuation coefficient hydro (dB/km) + g_vol_cloudsat ! Attenuation coefficient gases (dB/km) + real(wp),allocatable,dimension(:,:) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol, & ! Molecular optical depth + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + type(radar_cfg) :: & + rcfg_cloudsat ! Radar comfiguration information (CLOUDSAT) + end type cosp_optical_inputs + + ! ###################################################################################### + ! TYPE cosp_outputs + ! ###################################################################################### + type cosp_outputs + + ! CALIPSO outputs + real(wp),dimension(:,:,:),pointer :: & + calipso_betaperp_tot => null(), & ! Total backscattered signal + calipso_beta_tot => null(), & ! Total backscattered signal + calipso_tau_tot => null(), & ! Optical thickness integrated from top to level z + calipso_lidarcldphase => null(), & ! 3D "lidar" phase cloud fraction + calipso_cldlayerphase => null(), & ! low, mid, high-level lidar phase cloud cover + calipso_lidarcldtmp => null(), & ! 3D "lidar" phase cloud temperature + calipso_cfad_sr => null() ! CFAD of scattering ratio + real(wp), dimension(:,:),pointer :: & + calipso_lidarcld => null(), & ! 3D "lidar" cloud fraction + calipso_cldlayer => null(), & ! low, mid, high-level, total lidar cloud cover + calipso_beta_mol => null(), & ! Molecular backscatter + calipso_temp_tot => null() + real(wp), dimension(:),pointer :: & + calipso_srbval => null() ! SR bins in cfad_sr + + ! PARASOL outputs + real(wp),dimension(:,:,:),pointer :: & + parasolPix_refl => null() ! PARASOL reflectances (subcolumn) + real(wp),dimension(:,:),pointer :: & + parasolGrid_refl => null() ! PARASOOL reflectances (column) + + ! CLOUDSAT outputs + real(wp),dimension(:,:,:),pointer :: & + cloudsat_Ze_tot => null(), & ! Effective reflectivity factor (Npoints,Ncolumns,Nlevels) + cloudsat_cfad_ze => null() ! Ze CFAD(Npoints,dBZe_bins,Nlevels) + real(wp), dimension(:,:),pointer :: & + lidar_only_freq_cloud => null() ! (Npoints,Nlevels) + real(wp),dimension(:),pointer :: & + radar_lidar_tcc => null() ! Radar&lidar total cloud amount, grid-box scale (Npoints) + + ! ISCCP outputs + real(wp),dimension(:),pointer :: & + isccp_totalcldarea => null(), & ! The fraction of model grid box columns with cloud + ! somewhere in them. (%) + isccp_meantb => null(), & ! Mean all-sky 10.5 micron brightness temperature. (K) + isccp_meantbclr => null(), & ! Mean clear-sky 10.5 micron brightness temperature. (K) + isccp_meanptop => null(), & ! Mean cloud top pressure (mb). + isccp_meantaucld => null(), & ! Mean optical thickness. (1) + isccp_meanalbedocld => null() ! Mean cloud albedo. (1) + real(wp),dimension(:,:),pointer ::& + isccp_boxtau => null(), & ! Optical thickness in each column. (1) + isccp_boxptop => null() ! Cloud top pressure in each column. (mb) + real(wp),dimension(:,:,:),pointer :: & + isccp_fq => null() ! The fraction of the model grid box covered by each of + ! the 49 ISCCP D level cloud types. (%) + + ! MISR outptus + real(wp),dimension(:,:,:),pointer :: & ! + misr_fq => null() ! Fraction of the model grid box covered by each of the MISR + ! cloud types + real(wp),dimension(:,:),pointer :: & ! + misr_dist_model_layertops => null() ! + real(wp),dimension(:),pointer :: & ! + misr_meanztop => null(), & ! Mean MISR cloud top height + misr_cldarea => null() ! Mean MISR cloud cover area + + ! MODIS outptus + real(wp),pointer,dimension(:) :: & ! + modis_Cloud_Fraction_Total_Mean => null(), & ! L3 MODIS retrieved cloud fraction (total) + modis_Cloud_Fraction_Water_Mean => null(), & ! L3 MODIS retrieved cloud fraction (liq) + modis_Cloud_Fraction_Ice_Mean => null(), & ! L3 MODIS retrieved cloud fraction (ice) + modis_Cloud_Fraction_High_Mean => null(), & ! L3 MODIS retrieved cloud fraction (high) + modis_Cloud_Fraction_Mid_Mean => null(), & ! L3 MODIS retrieved cloud fraction (middle) + modis_Cloud_Fraction_Low_Mean => null(), & ! L3 MODIS retrieved cloud fraction (low ) + modis_Optical_Thickness_Total_Mean => null(), & ! L3 MODIS retrieved optical thickness (tot) + modis_Optical_Thickness_Water_Mean => null(), & ! L3 MODIS retrieved optical thickness (liq) + modis_Optical_Thickness_Ice_Mean => null(), & ! L3 MODIS retrieved optical thickness (ice) + modis_Optical_Thickness_Total_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Optical_Thickness_Water_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Optical_Thickness_Ice_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Cloud_Particle_Size_Water_Mean => null(), & ! L3 MODIS retrieved particle size (liquid) + modis_Cloud_Particle_Size_Ice_Mean => null(), & ! L3 MODIS retrieved particle size (ice) + modis_Cloud_Top_Pressure_Total_Mean => null(), & ! L3 MODIS retrieved cloud top pressure + modis_Liquid_Water_Path_Mean => null(), & ! L3 MODIS retrieved liquid water path + modis_Ice_Water_Path_Mean => null() ! L3 MODIS retrieved ice water path + real(wp),pointer,dimension(:,:,:) :: & + modis_Optical_Thickness_vs_Cloud_Top_Pressure => null(), & ! Tau/Pressure joint histogram + modis_Optical_Thickness_vs_ReffICE => null(), & ! Tau/ReffICE joint histogram + modis_Optical_Thickness_vs_ReffLIQ => null() ! Tau/ReffLIQ joint histogram + + ! RTTOV outputs + real(wp),pointer :: & + rttov_tbs(:,:) => null() ! Brightness Temperature + + end type cosp_outputs + +CONTAINS + ! ###################################################################################### + ! FUNCTION cosp_simulator + ! ###################################################################################### + function COSP_SIMULATOR(cospIN,cospgridIN,cospOUT,start_idx,stop_idx,debug) + type(cosp_optical_inputs),intent(in),target :: cospIN ! Optical inputs to COSP simulator + type(cosp_column_inputs), intent(in),target :: cospgridIN ! Host model inputs to COSP + + ! Inputs into the simulators + type(isccp_IN) :: isccpIN ! Input to the ISCCP simulator + type(misr_IN) :: misrIN ! Input to the LIDAR simulator + type(calipso_IN) :: calipsoIN ! Input to the LIDAR simulator + type(parasol_IN) :: parasolIN ! Input to the PARASOL simulator + type(cloudsat_IN) :: cloudsatIN ! Input to the CLOUDSAT radar simulator + type(modis_IN) :: modisIN ! Input to the MODIS simulator + type(rttov_IN) :: rttovIN ! Input to the RTTOV simulator + integer,optional :: start_idx,stop_idx + logical,optional :: debug + + ! Outputs from the simulators (nested simulator output structure) + type(cosp_outputs), intent(inout) :: cospOUT + character(len=256),dimension(100) :: cosp_simulator + + ! Local variables + integer :: & + i,icol,ij,ik,nError + integer,target :: & + Npoints + logical :: & + Lisccp_subcolumn, & ! On/Off switch for subcolumn ISCCP simulator + Lmisr_subcolumn, & ! On/Off switch for subcolumn MISR simulator + Lcalipso_subcolumn, & ! On/Off switch for subcolumn CALIPSO simulator + Lparasol_subcolumn, & ! On/Off switch for subcolumn PARASOL simulator + Lcloudsat_subcolumn, & ! On/Off switch for subcolumn CLOUDSAT simulator + Lmodis_subcolumn, & ! On/Off switch for subcolumn MODIS simulator + Lrttov_subcolumn, & ! On/Off switch for subcolumn RTTOV simulator + Lisccp_column, & ! On/Off switch for column ISCCP simulator + Lmisr_column, & ! On/Off switch for column MISR simulator + Lcalipso_column, & ! On/Off switch for column CALIPSO simulator + Lparasol_column, & ! On/Off switch for column PARASOL simulator + Lcloudsat_column, & ! On/Off switch for column CLOUDSAT simulator + Lmodis_column, & ! On/Off switch for column MODIS simulator + Lrttov_column, & ! On/Off switch for column RTTOV simulator (not used) + Lradar_lidar_tcc, & ! On/Off switch from joint Calipso/Cloudsat product + Llidar_only_freq_cloud ! On/Off switch from joint Calipso/Cloudsat product + logical :: & + ok_lidar_cfad = .false., & + lrttov_cleanUp = .false. + + integer, dimension(:,:),allocatable :: & + modisRetrievedPhase,isccpLEVMATCH + real(wp), dimension(:), allocatable :: & + modisCfTotal,modisCfLiquid,modisMeanIceWaterPath, isccp_meantbclr, & + modisCfIce, modisCfHigh, modisCfMid, modisCfLow,modisMeanTauTotal, & + modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal, & + modisMeanLogTauLiquid, modisMeanLogTauIce, modisMeanSizeLiquid, & + modisMeanSizeIce, modisMeanCloudTopPressure, modisMeanLiquidWaterPath, & + radar_lidar_tcc + REAL(WP), dimension(:,:),allocatable :: & + modisRetrievedCloudTopPressure,modisRetrievedTau,modisRetrievedSize, & + misr_boxtau,misr_boxztop,misr_dist_model_layertops,isccp_boxtau, & + isccp_boxttop,isccp_boxptop,calipso_beta_mol,lidar_only_freq_cloud + REAL(WP), dimension(:,:,:),allocatable :: & + modisJointHistogram,modisJointHistogramIce,modisJointHistogramLiq, & + calipso_beta_tot,calipso_betaperp_tot, cloudsatDBZe,parasolPix_refl + real(wp),dimension(:),allocatable,target :: & + out1D_1,out1D_2,out1D_3,out1D_4,out1D_5,out1D_6 + real(wp),dimension(:,:,:),allocatable :: & + betamol_in,betamolFlip,pnormFlip,ze_totFlip + + ! Initialize error reporting for output + cosp_simulator(:)='' + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 1) Determine if using full inputs or subset + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (present(start_idx) .and. present(stop_idx)) then + ij=start_idx + ik=stop_idx + else + ij=1 + ik=cospIN%Npoints + endif + Npoints = ik-ij+1 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 2a) Determine which simulators to run and which statistics to compute + ! - If any of the subcolumn fields are allocated, then run the subcolumn simulators. + ! - If any of the column fields are allocated, then compute the statistics for that + ! simulator, but only save the requested fields. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Start with all simulators and joint-diagnostics off + Lisccp_subcolumn = .false. + Lmisr_subcolumn = .false. + Lcalipso_subcolumn = .false. + Lparasol_subcolumn = .false. + Lcloudsat_subcolumn = .false. + Lmodis_subcolumn = .false. + Lrttov_subcolumn = .false. + Lisccp_column = .false. + Lmisr_column = .false. + Lcalipso_column = .false. + Lparasol_column = .false. + Lcloudsat_column = .false. + Lmodis_column = .false. + Lrttov_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + + ! CLOUDSAT subcolumn + if (associated(cospOUT%cloudsat_Ze_tot)) Lcloudsat_subcolumn = .true. + + ! MODIS subcolumn + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Total_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_High_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Mid_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Low_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_LogMean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean) .or. & + associated(cospOUT%modis_Liquid_Water_Path_Mean) .or. & + associated(cospOUT%modis_Ice_Water_Path_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + Lmodis_subcolumn = .true. + + ! ISCCP subcolumn + if (associated(cospOUT%isccp_boxtau) .or. & + associated(cospOUT%isccp_boxptop)) & + Lisccp_subcolumn = .true. + + ! MISR subcolumn + if (associated(cospOUT%misr_dist_model_layertops)) & + Lmisr_subcolumn = .true. + + ! CALIPOSO subcolumn + if (associated(cospOUT%calipso_tau_tot) .or. & + associated(cospOUT%calipso_beta_mol) .or. & + associated(cospOUT%calipso_temp_tot) .or. & + associated(cospOUT%calipso_betaperp_tot) .or. & + associated(cospOUT%calipso_beta_tot)) & + Lcalipso_subcolumn = .true. + + ! PARASOL subcolumn + if (associated(cospOUT%parasolPix_refl)) & + Lparasol_subcolumn = .true. + + ! RTTOV column + if (associated(cospOUT%rttov_tbs)) & + Lrttov_column = .true. + + ! Set flag to deallocate rttov types (only done on final call to simulator) + if (size(cospOUT%isccp_meantb) .eq. stop_idx) lrttov_cleanUp = .true. + + ! ISCCP column + if (associated(cospOUT%isccp_fq) .or. & + associated(cospOUT%isccp_meanalbedocld) .or. & + associated(cospOUT%isccp_meanptop) .or. & + associated(cospOUT%isccp_meantaucld) .or. & + associated(cospOUT%isccp_totalcldarea) .or. & + associated(cospOUT%isccp_meantb)) then + Lisccp_column = .true. + Lisccp_subcolumn = .true. + endif + + ! MISR column + if (associated(cospOUT%misr_cldarea) .or. & + associated(cospOUT%misr_meanztop) .or. & + associated(cospOUT%misr_fq)) then + Lmisr_column = .true. + Lmisr_subcolumn = .true. + endif + + ! CALIPSO column + if (associated(cospOUT%calipso_cfad_sr) .or. & + associated(cospOUT%calipso_lidarcld) .or. & + associated(cospOUT%calipso_lidarcldphase) .or. & + associated(cospOUT%calipso_cldlayer) .or. & + associated(cospOUT%calipso_cldlayerphase) .or. & + associated(cospOUT%calipso_lidarcldtmp)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + endif + + ! PARASOL column + if (associated(cospOUT%parasolGrid_refl)) then + Lparasol_column = .true. + Lparasol_subcolumn = .true. + endif + + ! CLOUDSAT column + if (associated(cospOUT%cloudsat_cfad_ze)) then + Lcloudsat_column = .true. + Lcloudsat_subcolumn = .true. + endif + + ! MODIS column + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_High_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Mid_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Low_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_LogMean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean) .or. & + associated(cospOUT%modis_Liquid_Water_Path_Mean) .or. & + associated(cospOUT%modis_Ice_Water_Path_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then + Lmodis_column = .true. + Lmodis_subcolumn = .true. + endif + + ! Joint simulator products + if (associated(cospOUT%lidar_only_freq_cloud) .or. associated(cospOUT%radar_lidar_tcc)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + Lcloudsat_column = .true. + Lcloudsat_subcolumn = .true. + Lradar_lidar_tcc = .true. + Llidar_only_freq_cloud = .true. + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 2b) Error Checking + ! Enforce bounds on input fields. If input field is out-of-bounds, report error + ! and turn off simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call cosp_errorCheck(cospgridIN,cospIN,Lisccp_subcolumn,Lisccp_column, & + Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column, & + Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_subcolumn, & + Lcalipso_column,Lrttov_subcolumn,Lrttov_column, & + Lparasol_subcolumn,Lparasol_column,Lradar_lidar_tcc, & + Llidar_only_freq_cloud,cospOUT,cosp_simulator,nError) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 3) Populate instrument simulator inputs + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + isccpIN%Npoints => Npoints + isccpIN%Ncolumns => cospIN%Ncolumns + isccpIN%Nlevels => cospIN%Nlevels + isccpIN%emsfc_lw => cospIN%emsfc_lw + isccpIN%skt => cospgridIN%skt + isccpIN%qv => cospgridIN%qv + isccpIN%at => cospgridIN%at + isccpIN%frac_out => cospIN%frac_out + isccpIN%dtau => cospIN%tau_067 + isccpIN%dem => cospIN%emiss_11 + isccpIN%phalf => cospgridIN%phalf + isccpIN%sunlit => cospgridIN%sunlit + isccpIN%pfull => cospgridIN%pfull + endif + + if (Lmisr_subcolumn) then + misrIN%Npoints => Npoints + misrIN%Ncolumns => cospIN%Ncolumns + misrIN%Nlevels => cospIN%Nlevels + misrIN%dtau => cospIN%tau_067 + misrIN%sunlit => cospgridIN%sunlit + misrIN%zfull => cospgridIN%hgt_matrix + misrIN%at => cospgridIN%at + endif + + if (Lcalipso_subcolumn) then + calipsoIN%Npoints => Npoints + calipsoIN%Ncolumns => cospIN%Ncolumns + calipsoIN%Nlevels => cospIN%Nlevels + calipsoIN%beta_mol => cospIN%beta_mol + calipsoIN%betatot => cospIN%betatot + calipsoIN%betatot_liq => cospIN%betatot_liq + calipsoIN%betatot_ice => cospIN%betatot_ice + calipsoIN%tau_mol => cospIN%tau_mol + calipsoIN%tautot => cospIN%tautot + calipsoIN%tautot_liq => cospIN%tautot_liq + calipsoIN%tautot_ice => cospIN%tautot_ice + endif + + if (Lparasol_subcolumn) then + parasolIN%Npoints => Npoints + parasolIN%Nlevels => cospIN%Nlevels + parasolIN%Ncolumns => cospIN%Ncolumns + parasolIN%Nrefl => cospIN%Nrefl + parasolIN%tautot_S_liq => cospIN%tautot_S_liq + parasolIN%tautot_S_ice => cospIN%tautot_S_ice + endif + + if (Lcloudsat_subcolumn) then + cloudsatIN%Npoints => Npoints + cloudsatIN%Nlevels => cospIN%Nlevels + cloudsatIN%Ncolumns => cospIN%Ncolumns + cloudsatIN%z_vol => cospIN%z_vol_cloudsat + cloudsatIN%kr_vol => cospIN%kr_vol_cloudsat + cloudsatIN%g_vol => cospIN%g_vol_cloudsat + cloudsatIN%rcfg => cospIN%rcfg_cloudsat + cloudsatIN%hgt_matrix => cospgridIN%hgt_matrix + endif + + if (Lmodis_subcolumn) then + modisIN%Ncolumns => cospIN%Ncolumns + modisIN%Nlevels => cospIN%Nlevels + modisIN%Npoints => Npoints + modisIN%liqFrac => cospIN%fracLiq + modisIN%tau => cospIN%tau_067 + modisIN%g => cospIN%asym + modisIN%w0 => cospIN%ss_alb + modisIN%Nsunlit = count(cospgridIN%sunlit > 0) + if (modisIN%Nsunlit .gt. 0) then + allocate(modisIN%sunlit(modisIN%Nsunlit),modisIN%pres(modisIN%Nsunlit,cospIN%Nlevels+1)) + modisIN%sunlit = pack((/ (i, i = 1, Npoints ) /),mask = cospgridIN%sunlit > 0) + modisIN%pres = cospgridIN%phalf(int(modisIN%sunlit(:)),:) + endif + if (count(cospgridIN%sunlit <= 0) .gt. 0) then + allocate(modisIN%notSunlit(count(cospgridIN%sunlit <= 0))) + modisIN%notSunlit = pack((/ (i, i = 1, Npoints ) /),mask = .not. cospgridIN%sunlit > 0) + endif + endif + + if (Lrttov_column) then + rttovIN%nPoints => Npoints + rttovIN%nLevels => cospIN%nLevels + rttovIN%nSubCols => cospIN%nColumns + rttovIN%zenang => cospgridIN%zenang + rttovIN%co2 => cospgridIN%co2 + rttovIN%ch4 => cospgridIN%ch4 + rttovIN%n2o => cospgridIN%n2o + rttovIN%co => cospgridIN%co + rttovIN%surfem => cospgridIN%emis_sfc + rttovIN%h_surf => cospgridIN%hgt_matrix_half(:,cospIN%Nlevels+1) + rttovIN%u_surf => cospgridIN%u_sfc + rttovIN%v_surf => cospgridIN%v_sfc + rttovIN%t_skin => cospgridIN%skt + rttovIN%p_surf => cospgridIN%phalf(:,cospIN%Nlevels+1) + rttovIN%q2m => cospgridIN%qv(:,cospIN%Nlevels) + rttovIN%t2m => cospgridIN%at(:,cospIN%Nlevels) + rttovIN%lsmask => cospgridIN%land + rttovIN%latitude => cospgridIN%lat + rttovIN%longitude => cospgridIN%lon + rttovIN%seaice => cospgridIN%seaice + rttovIN%p => cospgridIN%pfull + rttovIN%ph => cospgridIN%phalf + rttovIN%t => cospgridIN%at + rttovIN%q => cospgridIN%qv + rttovIN%o3 => cospgridIN%o3 + ! Below only needed for all-sky RTTOV calculation + rttovIN%month => cospgridIN%month + rttovIN%tca => cospgridIN%tca + rttovIN%cldIce => cospgridIN%cloudIce + rttovIN%cldLiq => cospgridIN%cloudLiq + rttovIN%fl_rain => cospgridIN%fl_rain + rttovIN%fl_snow => cospgridIN%fl_snow + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 4) Call subcolumn simulators + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! ISCCP (icarus) subcolumn simulator + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + ! Allocate space for local variables + allocate(isccpLEVMATCH(Npoints,isccpIN%Ncolumns), & + isccp_boxttop(Npoints,isccpIN%Ncolumns), & + isccp_boxptop(Npoints,isccpIN%Ncolumns), & + isccp_boxtau(Npoints,isccpIN%Ncolumns), isccp_meantbclr(Npoints)) + ! Call simulator + call icarus_subcolumn(isccpIN%npoints,isccpIN%ncolumns,isccpIN%nlevels, & + isccpIN%sunlit,isccpIN%dtau,isccpIN%dem,isccpIN%skt, & + isccpIN%emsfc_lw,isccpIN%qv,isccpIN%at,isccpIN%pfull, & + isccpIN%phalf,isccpIN%frac_out,isccpLEVMATCH, & + isccp_boxtau(:,:),isccp_boxptop(:,:), & + isccp_boxttop(:,:),isccp_meantbclr(:)) + ! Store output (if requested) + if (associated(cospOUT%isccp_boxtau)) then + cospOUT%isccp_boxtau(ij:ik,:) = isccp_boxtau + endif + if (associated(cospOUT%isccp_boxptop)) then + cospOUT%isccp_boxptop(ij:ik,:) = isccp_boxptop + endif + if (associated(cospOUT%isccp_meantbclr)) then + cospOUT%isccp_meantbclr(ij:ik) = isccp_meantbclr + endif + endif + + ! MISR subcolumn simulator + if (Lmisr_subcolumn) then + ! Allocate space for local variables + allocate(misr_boxztop(Npoints,misrIN%Ncolumns), & + misr_boxtau(Npoints,misrIN%Ncolumns), & + misr_dist_model_layertops(Npoints,numMISRHgtBins)) + ! Call simulator + call misr_subcolumn(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau, & + misrIN%zfull,misrIN%at,misrIN%sunlit,misr_boxtau, & + misr_dist_model_layertops,misr_boxztop) + ! Store output (if requested) + if (associated(cospOUT%misr_dist_model_layertops)) then + cospOUT%misr_dist_model_layertops(ij:ik,:) = misr_dist_model_layertops + endif + endif + + ! Calipso subcolumn simulator + if (Lcalipso_subcolumn) then + ! Allocate space for local variables + allocate(calipso_beta_mol(calipsoIN%Npoints,calipsoIN%Nlevels), & + calipso_beta_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels),& + calipso_betaperp_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels)) + ! Call simulator + call lidar_subcolumn(calipsoIN%npoints,calipsoIN%ncolumns,calipsoIN%nlevels, & + calipsoIN%beta_mol,calipsoIN%tau_mol, & + calipsoIN%betatot,calipsoIN%tautot,calipsoIN%betatot_ice, & + calipsoIN%tautot_ice,calipsoIN%betatot_liq, & + calipsoIN%tautot_liq,calipso_beta_mol(:,:), & + calipso_beta_tot(:,:,:),calipso_betaperp_tot(:,:,:)) + ! Store output (if requested) + if (associated(cospOUT%calipso_beta_mol)) & + cospOUT%calipso_beta_mol(ij:ik,calipsoIN%Nlevels:1:-1) = calipso_beta_mol + if (associated(cospOUT%calipso_beta_tot)) & + cospOUT%calipso_beta_tot(ij:ik,:,calipsoIN%Nlevels:1:-1) = calipso_beta_tot + if (associated(cospOUT%calipso_betaperp_tot)) & + cospOUT%calipso_betaperp_tot(ij:ik,:,:) = calipso_betaperp_tot + + endif + + ! PARASOL subcolumn simulator + if (Lparasol_subcolumn) then + ! Allocate space for local variables + allocate(parasolPix_refl(parasolIN%Npoints,parasolIN%Ncolumns,PARASOL_NREFL)) + ! Call simulator + do icol=1,parasolIN%Ncolumns + call parasol_subcolumn(parasolIN%npoints, PARASOL_NREFL, & + parasolIN%tautot_S_liq(1:parasolIN%Npoints,icol), & + parasolIN%tautot_S_ice(1:parasolIN%Npoints,icol), & + parasolPix_refl(:,icol,1:PARASOL_NREFL)) + ! Store output (if requested) + if (associated(cospOUT%parasolPix_refl)) then + cospOUT%parasolPix_refl(ij:ik,icol,1:PARASOL_NREFL) = & + parasolPix_refl(:,icol,1:PARASOL_NREFL) + endif + enddo + endif + + ! Cloudsat (quickbeam) subcolumn simulator + if (Lcloudsat_subcolumn) then + ! Allocate space for local variables + allocate(cloudsatDBZe(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels)) + do icol=1,cloudsatIN%ncolumns + call quickbeam_subcolumn(cloudsatIN%rcfg,cloudsatIN%Npoints,cloudsatIN%Nlevels,& + cloudsatIN%hgt_matrix/1000._wp, & + cloudsatIN%z_vol(:,icol,:), & + cloudsatIN%kr_vol(:,icol,:), & + cloudsatIN%g_vol(:,1,:),cloudsatDBze(:,icol,:)) + enddo + ! Store output (if requested) + if (associated(cospOUT%cloudsat_Ze_tot)) then + cospOUT%cloudsat_Ze_tot(ij:ik,:,:) = cloudsatDBZe(:,:,1:cloudsatIN%Nlevels) + endif + endif + + if (Lmodis_subcolumn) then + if(modisiN%nSunlit > 0) then + ! Allocate space for local variables + allocate(modisRetrievedTau(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedSize(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedPhase(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedCloudTopPressure(modisIN%nSunlit,modisIN%nColumns)) + ! Call simulator + do i = 1, modisIN%nSunlit + call modis_subcolumn(modisIN%Ncolumns,modisIN%Nlevels,modisIN%pres(i,:), & + modisIN%tau(int(modisIN%sunlit(i)),:,:), & + modisIN%liqFrac(int(modisIN%sunlit(i)),:,:), & + modisIN%g(int(modisIN%sunlit(i)),:,:), & + modisIN%w0(int(modisIN%sunlit(i)),:,:), & + isccp_boxptop(int(modisIN%sunlit(i)),:), & + modisRetrievedPhase(i,:), & + modisRetrievedCloudTopPressure(i,:), & + modisRetrievedTau(i,:),modisRetrievedSize(i,:)) + end do + endif + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 5) Call column simulators + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! ISCCP + if (Lisccp_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if(.not. associated(cospOUT%isccp_meanalbedocld)) then + allocate(out1D_1(Npoints)) + cospOUT%isccp_meanalbedocld(ij:ik) => out1D_1 + endif + if(.not. associated(cospOUT%isccp_meanptop)) then + allocate(out1D_2(Npoints)) + cospOUT%isccp_meanptop(ij:ik) => out1D_2 + endif + if(.not. associated(cospOUT%isccp_meantaucld)) then + allocate(out1D_3(Npoints)) + cospOUT%isccp_meantaucld(ij:ik) => out1D_3 + endif + if(.not. associated(cospOUT%isccp_totalcldarea)) then + allocate(out1D_4(Npoints)) + cospOUT%isccp_totalcldarea(ij:ik) => out1D_4 + endif + if(.not. associated(cospOUT%isccp_meantb)) then + allocate(out1D_5(Npoints)) + cospOUT%isccp_meantb(ij:ik) => out1D_5 + endif + if(.not. associated(cospOUT%isccp_fq)) then + allocate(out1D_6(Npoints*numISCCPTauBins*numISCCPPresBins)) + cospOUT%isccp_fq(ij:ik,1:numISCCPTauBins,1:numISCCPPresBins) => out1D_6 + endif + + ! Call simulator + call icarus_column(isccpIN%npoints, isccpIN%ncolumns,isccp_boxtau(:,:), & + isccp_boxptop(:,:)/100._wp, isccpIN%sunlit,isccp_boxttop, & + cospOUT%isccp_fq(ij:ik,:,:), & + cospOUT%isccp_meanalbedocld(ij:ik), & + cospOUT%isccp_meanptop(ij:ik),cospOUT%isccp_meantaucld(ij:ik), & + cospOUT%isccp_totalcldarea(ij:ik),cospOUT%isccp_meantb(ij:ik)) + cospOUT%isccp_fq(ij:ik,:,:) = cospOUT%isccp_fq(ij:ik,:,7:1:-1) + + ! Check if there is any value slightly greater than 1 + where ((cospOUT%isccp_totalcldarea > 1.0-1.e-5) .and. & + (cospOUT%isccp_totalcldarea < 1.0+1.e-5)) + cospOUT%isccp_totalcldarea = 1.0 + endwhere + + ! Clear up memory (if necessary) + if (allocated(isccp_boxttop)) deallocate(isccp_boxttop) + if (allocated(isccp_boxptop)) deallocate(isccp_boxptop) + if (allocated(isccp_boxtau)) deallocate(isccp_boxtau) + if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr) + if (allocated(isccpLEVMATCH)) deallocate(isccpLEVMATCH) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%isccp_meanalbedocld) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%isccp_meanptop) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%isccp_meantaucld) + endif + if (allocated(out1D_4)) then + deallocate(out1D_4) + nullify(cospOUT%isccp_totalcldarea) + endif + if (allocated(out1D_5)) then + deallocate(out1D_5) + nullify(cospOUT%isccp_meantb) + endif + if (allocated(out1D_6)) then + deallocate(out1D_6) + nullify(cospOUT%isccp_fq) + endif + endif + + ! MISR + if (Lmisr_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%misr_cldarea)) then + allocate(out1D_1(Npoints)) + cospOUT%misr_cldarea(ij:ik) => out1D_1 + endif + if (.not. associated(cospOUT%misr_meanztop)) then + allocate(out1D_2(Npoints)) + cospOUT%misr_meanztop(ij:ik) => out1D_2 + endif + if (.not. associated(cospOUT%misr_fq)) then + allocate(out1D_3(Npoints*numMISRTauBins*numMISRHgtBins)) + cospOUT%misr_fq(ij:ik,1:numMISRTauBins,1:numMISRHgtBins) => out1D_3 + endif + + ! Call simulator + call misr_column(misrIN%Npoints,misrIN%Ncolumns,misr_boxztop,misrIN%sunlit,& + misr_boxtau,cospOUT%misr_cldarea(ij:ik), & + cospOUT%misr_meanztop(ij:ik),cospOUT%misr_fq(ij:ik,:,:)) + + ! Clear up memory + if (allocated(misr_boxtau)) deallocate(misr_boxtau) + if (allocated(misr_boxztop)) deallocate(misr_boxztop) + if (allocated(misr_dist_model_layertops)) deallocate(misr_dist_model_layertops) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%misr_cldarea) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%misr_meanztop) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%misr_fq) + endif + endif + + ! CALIPSO LIDAR Simulator + if (Lcalipso_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%calipso_cfad_sr)) then + allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) + cospOUT%calipso_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1 + endif + if (.not. associated(cospOUT%calipso_lidarcld)) then + allocate(out1D_2(Npoints*Nlvgrid)) + cospOUT%calipso_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 + endif + if (.not. associated(cospOUT%calipso_lidarcldphase)) then + allocate(out1D_3(Npoints*Nlvgrid*6)) + cospOUT%calipso_lidarcldphase(ij:ik,1:Nlvgrid,1:6) => out1D_3 + endif + if (.not. associated(cospOUT%calipso_cldlayer)) then + allocate(out1D_4(Npoints*LIDAR_NCAT)) + cospOUT%calipso_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_4 + endif + if (.not. associated(cospOUT%calipso_cldlayerphase)) then + allocate(out1D_5(Npoints*LIDAR_NCAT*6)) + cospOUT%calipso_cldlayerphase(ij:ik,1:LIDAR_NCAT,1:6) => out1D_5 + endif + if (.not. associated(cospOUT%calipso_lidarcldtmp)) then + allocate(out1D_6(Npoints*40*5)) + cospOUT%calipso_lidarcldtmp(ij:ik,1:40,1:5) => out1D_6 + endif + + ! Call simulator + ok_lidar_cfad=.true. + call lidar_column(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels, & + Nlvgrid,SR_BINS,cospgridIN%at(:,:), & + calipso_beta_tot(:,:,:),calipso_betaperp_tot(:,:,:), & + calipso_beta_mol(:,:), & + cospgridIN%phalf(:,2:calipsoIN%Nlevels+1),ok_lidar_cfad, & + LIDAR_NCAT,cospOUT%calipso_cfad_sr(ij:ik,:,:), & + cospOUT%calipso_lidarcld(ij:ik,:), & + cospOUT%calipso_lidarcldphase(ij:ik,:,:), & + cospOUT%calipso_cldlayer(ij:ik,:), & + cospgridIN%hgt_matrix,cospgridIN%hgt_matrix_half, & + cospOUT%calipso_cldlayerphase(ij:ik,:,:), & + cospOUT%calipso_lidarcldtmp(ij:ik,:,:)) + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval = calipso_histBsct + + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%calipso_cfad_sr) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%calipso_lidarcld) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%calipso_lidarcldphase) + endif + if (allocated(out1D_4)) then + deallocate(out1D_4) + nullify(cospOUT%calipso_cldlayer) + endif + if (allocated(out1D_5)) then + deallocate(out1D_5) + nullify(cospOUT%calipso_cldlayerphase) + endif + if (allocated(out1D_6)) then + deallocate(out1D_6) + nullify(cospOUT%calipso_lidarcldtmp) + endif + endif + + ! PARASOL + if (Lparasol_column) then + call parasol_column(parasolIN%Npoints,PARASOL_NREFL,parasolIN%Ncolumns, & + cospgridIN%land(:),parasolPix_refl(:,:,:), & + cospOUT%parasolGrid_refl(ij:ik,:)) + if (allocated(parasolPix_refl)) deallocate(parasolPix_refl) + endif + + ! CLOUDSAT + if (Lcloudsat_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%cloudsat_cfad_ze)) then + allocate(out1D_1(Npoints*DBZE_BINS*Nlvgrid)) + cospOUT%cloudsat_cfad_ze(ij:ik,1:DBZE_BINS,1:Nlvgrid) => out1D_1 + endif + + ! Call simulator + call quickbeam_column(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels, & + Nlvgrid,cloudsatDBZe,cospgridIN%hgt_matrix, & + cospgridIN%hgt_matrix_half,cospOUT%cloudsat_cfad_ze(ij:ik,:,:)) + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%cloudsat_cfad_ze) + endif + endif + + ! MODIS + if (Lmodis_column) then + if(modisiN%nSunlit > 0) then + ! Allocate space for local variables + allocate(modisCftotal(modisIN%nSunlit), modisCfLiquid(modisIN%nSunlit), & + modisCfIce(modisIN%nSunlit),modisCfHigh(modisIN%nSunlit), & + modisCfMid(modisIN%nSunlit),modisCfLow(modisIN%nSunlit), & + modisMeanTauTotal(modisIN%nSunlit), & + modisMeanTauLiquid(modisIN%nSunlit),modisMeanTauIce(modisIN%nSunlit), & + modisMeanLogTauTotal(modisIN%nSunlit), & + modisMeanLogTauLiquid(modisIN%nSunlit), & + modisMeanLogTauIce(modisIN%nSunlit), & + modisMeanSizeLiquid(modisIN%nSunlit), & + modisMeanSizeIce(modisIN%nSunlit), & + modisMeanCloudTopPressure(modisIN%nSunlit), & + modisMeanLiquidWaterPath(modisIN%nSunlit), & + modisMeanIceWaterPath(modisIN%nSunlit), & + modisJointHistogram(modisIN%nSunlit,numMODISTauBins,numMODISPresBins),& + modisJointHistogramIce(modisIN%nSunlit,numModisTauBins,numMODISReffIceBins),& + modisJointHistogramLiq(modisIN%nSunlit,numModisTauBins,numMODISReffLiqBins)) + ! Call simulator + call modis_column(modisIN%nSunlit, modisIN%Ncolumns,modisRetrievedPhase, & + modisRetrievedCloudTopPressure,modisRetrievedTau, & + modisRetrievedSize, modisCfTotal, modisCfLiquid, modisCfIce,& + modisCfHigh, modisCfMid, modisCfLow, modisMeanTauTotal, & + modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal, & + modisMeanLogTauLiquid, modisMeanLogTauIce, & + modisMeanSizeLiquid, modisMeanSizeIce, & + modisMeanCloudTopPressure, modisMeanLiquidWaterPath, & + modisMeanIceWaterPath, modisJointHistogram, & + modisJointHistogramIce,modisJointHistogramLiq) + ! Store data (if requested) + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) then + cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfTotal + endif + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) then + cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfLiquid + endif + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) then + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfIce + endif + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) then + cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfHigh + endif + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) then + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfMid + endif + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) then + cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfLow + endif + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) then + cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauTotal + endif + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) then + cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauLiquid + endif + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) then + cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauIce + endif + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) then + cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%sunlit(:))-1)= & + modisMeanLogTauTotal + endif + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) then + cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLogTauLiquid + endif + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) then + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLogTauIce + endif + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) then + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanSizeLiquid + endif + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) then + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanSizeIce + endif + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) then + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanCloudTopPressure + endif + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) then + cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLiquidWaterPath + endif + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) then + cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanIceWaterPath + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+ & + int(modisIN%sunlit(:))-1, 1:numModisTauBins, :) = modisJointHistogram(:, :, :) + ! Reorder pressure bins in joint histogram to go from surface to TOA + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,:) = & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,numMODISPresBins:1:-1) + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffIce)) then + cospOUT%modis_Optical_Thickness_vs_ReffIce(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = & + modisJointHistogramIce(:,:,:) + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLiq)) then + cospOUT%modis_Optical_Thickness_vs_ReffLiq(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = & + modisJointHistogramLiq(:,:,:) + endif + + if(modisIN%nSunlit < modisIN%Npoints) then + ! Where it's night and we haven't done the retrievals the values are undefined + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+int(modisIN%notSunlit(:))-1, :, :) = R_UNDEF + end if + else + ! It's nightime everywhere - everything is undefined + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik, :, :) = R_UNDEF + endif + ! Free up memory (if necessary) + if (allocated(modisRetrievedTau)) deallocate(modisRetrievedTau) + if (allocated(modisRetrievedSize)) deallocate(modisRetrievedSize) + if (allocated(modisRetrievedPhase)) deallocate(modisRetrievedPhase) + if (allocated(modisRetrievedCloudTopPressure)) deallocate(modisRetrievedCloudTopPressure) + if (allocated(modisCftotal)) deallocate(modisCftotal) + if (allocated(modisCfLiquid)) deallocate(modisCfLiquid) + if (allocated(modisCfIce)) deallocate(modisCfIce) + if (allocated(modisCfHigh)) deallocate(modisCfHigh) + if (allocated(modisCfMid)) deallocate(modisCfMid) + if (allocated(modisCfLow)) deallocate(modisCfLow) + if (allocated(modisMeanTauTotal)) deallocate(modisMeanTauTotal) + if (allocated(modisMeanTauLiquid)) deallocate(modisMeanTauLiquid) + if (allocated(modisMeanTauIce)) deallocate(modisMeanTauIce) + if (allocated(modisMeanLogTauTotal)) deallocate(modisMeanLogTauTotal) + if (allocated(modisMeanLogTauLiquid)) deallocate(modisMeanLogTauLiquid) + if (allocated(modisMeanLogTauIce)) deallocate(modisMeanLogTauIce) + if (allocated(modisMeanSizeLiquid)) deallocate(modisMeanSizeLiquid) + if (allocated(modisMeanSizeIce)) deallocate(modisMeanSizeIce) + if (allocated(modisMeanCloudTopPressure)) deallocate(modisMeanCloudTopPressure) + if (allocated(modisMeanLiquidWaterPath)) deallocate(modisMeanLiquidWaterPath) + if (allocated(modisMeanIceWaterPath)) deallocate(modisMeanIceWaterPath) + if (allocated(modisJointHistogram)) deallocate(modisJointHistogram) + if (allocated(modisJointHistogramIce)) deallocate(modisJointHistogramIce) + if (allocated(modisJointHistogramLiq)) deallocate(modisJointHistogramLiq) + if (allocated(isccp_boxttop)) deallocate(isccp_boxttop) + if (allocated(isccp_boxptop)) deallocate(isccp_boxptop) + if (allocated(isccp_boxtau)) deallocate(isccp_boxtau) + if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr) + if (allocated(isccpLEVMATCH)) deallocate(isccpLEVMATCH) + endif + + ! RTTOV + if (lrttov_column) then + call rttov_column(rttovIN%nPoints,rttovIN%nLevels,rttovIN%nSubCols,rttovIN%q, & + rttovIN%p,rttovIN%t,rttovIN%o3,rttovIN%ph,rttovIN%h_surf, & + rttovIN%u_surf,rttovIN%v_surf,rttovIN%p_surf,rttovIN%t_skin, & + rttovIN%t2m,rttovIN%q2m,rttovIN%lsmask,rttovIN%longitude, & + rttovIN%latitude,rttovIN%seaice,rttovIN%co2,rttovIN%ch4, & + rttovIN%n2o,rttovIN%co,rttovIN%zenang,lrttov_cleanUp, & + cospOUT%rttov_tbs(ij:ik,:),cosp_simulator(nError+1), & + ! Optional arguments for surface emissivity calculation + month=rttovIN%month) + ! Optional arguments to rttov for all-sky calculation + ! rttovIN%month, rttovIN%tca,rttovIN%cldIce,rttovIN%cldLiq, & + ! rttovIN%fl_rain,rttovIN%fl_snow) + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 6) Compute multi-instrument products + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! CLOUDSAT/CALIPSO products + if (Lradar_lidar_tcc .or. Llidar_only_freq_cloud) then + + if (use_vgrid) then + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,Nlvgrid), & + radar_lidar_tcc(cloudsatIN%Npoints)) + allocate(betamol_in(cloudsatIN%Npoints,1,cloudsatIN%Nlevels), & + betamolFlip(cloudsatIN%Npoints,1,Nlvgrid), & + pnormFlip(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid), & + Ze_totFlip(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid)) + + betamol_in(:,1,:) = calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1) + call cosp_change_vertical_grid(cloudsatIN%Npoints,1,cloudsatIN%Nlevels, & + cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),betamol_in, & + Nlvgrid,vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1), & + betamolFlip(:,1,Nlvgrid:1:-1)) + + call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1), & + calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid, & + vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),pnormFlip(:,:,Nlvgrid:1:-1)) + + call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1), & + cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,vgrid_zl(Nlvgrid:1:-1), & + vgrid_zu(Nlvgrid:1:-1),Ze_totFlip(:,:,Nlvgrid:1:-1),log_units=.true.) + + call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + Nlvgrid,pnormFlip,betamolFlip,Ze_totFlip, & + lidar_only_freq_cloud,radar_lidar_tcc) + + deallocate(betamol_in,betamolFlip,pnormFlip,ze_totFlip) + else + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,cloudsatIN%Nlevels), & + radar_lidar_tcc(cloudsatIN%Npoints)) + call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cospIN%Nlevels,calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1), & + calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1), & + cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),lidar_only_freq_cloud, & + radar_lidar_tcc) + endif + + ! Store, when necessary + if (associated(cospOUT%lidar_only_freq_cloud)) then + cospOUT%lidar_only_freq_cloud(ij:ik,:) = lidar_only_freq_cloud + endif + if (associated(cospOUT%radar_lidar_tcc)) then + cospOUT%radar_lidar_tcc(ij:ik) = radar_lidar_tcc + endif + + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 7) Cleanup + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + nullify(isccpIN%Npoints,isccpIN%Ncolumns,isccpIN%Nlevels,isccpIN%emsfc_lw, & + isccpIN%skt,isccpIN%qv,isccpIN%at,isccpIN%frac_out,isccpIN%dtau, & + isccpIN%dem,isccpIN%phalf,isccpIN%sunlit,isccpIN%pfull) + endif + + if (Lmisr_subcolumn) then + nullify(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,misrIN%sunlit, & + misrIN%zfull,misrIN%at) + endif + + if (Lcalipso_subcolumn) then + nullify(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels,calipsoIN%beta_mol,& + calipsoIN%betatot,calipsoIN%betatot_liq,calipsoIN%betatot_ice, & + calipsoIN%tau_mol,calipsoIN%tautot,calipsoIN%tautot_liq,calipsoIN%tautot_ice) + endif + + if (Lparasol_subcolumn) then + nullify(parasolIN%Npoints,parasolIN%Nlevels,parasolIN%Ncolumns,parasolIN%Nrefl, & + parasolIN%tautot_S_liq,parasolIN%tautot_S_ice) + endif + + if (Lcloudsat_subcolumn) then + nullify(cloudsatIN%Npoints,cloudsatIN%Nlevels,cloudsatIN%Ncolumns,cloudsatIN%rcfg,& + cloudsatIN%kr_vol,cloudsatIN%g_vol,cloudsatIN%z_vol,cloudsatIN%hgt_matrix) + endif + + if (Lmodis_subcolumn) then + nullify(modisIN%Npoints,modisIN%Ncolumns,modisIN%Nlevels,modisIN%tau,modisIN%g, & + modisIN%liqFrac,modisIN%w0) + if (allocated(modisIN%sunlit)) deallocate(modisIN%sunlit) + if (allocated(modisIN%notSunlit)) deallocate(modisIN%notSunlit) + if (allocated(modisIN%pres)) deallocate(modisIN%pres) + endif + + if (allocated(calipso_beta_tot)) deallocate(calipso_beta_tot) + if (allocated(calipso_beta_mol)) deallocate(calipso_beta_mol) + if (allocated(calipso_betaperp_tot)) deallocate(calipso_betaperp_tot) + if (allocated(cloudsatDBZe)) deallocate(cloudsatDBZe) + if (allocated(lidar_only_freq_cloud)) deallocate(lidar_only_freq_cloud) + if (allocated(radar_lidar_tcc)) deallocate(radar_lidar_tcc) + + end function COSP_SIMULATOR + ! ###################################################################################### + ! SUBROUTINE cosp_init + ! ###################################################################################### + SUBROUTINE COSP_INIT(Lisccp, Lmodis, Lmisr, Lcloudsat, Lcalipso, Lparasol, Lrttov, & + cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, cloudsat_do_ray, & + isccp_top_height, isccp_top_height_direction, surface_radar, rcfg, lusevgrid, & + luseCSATvgrid, Nvgrid, Nlevels, cloudsat_micro_scheme) + + ! INPUTS + logical,intent(in) :: Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,Lparasol,Lrttov + integer,intent(in) :: & + cloudsat_use_gas_abs, & ! + cloudsat_do_ray, & ! + isccp_top_height, & ! + isccp_top_height_direction, & ! + Nlevels, & ! + Nvgrid, & ! Number of levels for new L3 grid + surface_radar ! + real(wp),intent(in) :: & + cloudsat_radar_freq, & ! + cloudsat_k2 ! + logical,intent(in) :: & + lusevgrid, & ! Switch to use different vertical grid + luseCSATvgrid ! Switch to use CLOUDSAT grid spacing for new + ! vertical grid + character(len=64),intent(in) :: & + cloudsat_micro_scheme ! Microphysical scheme used by CLOUDSAT + + ! OUTPUTS + type(radar_cfg) :: rcfg + + ! Local variables + integer :: i + real(wp) :: zstep + + ! Initialize MODIS optical-depth bin boundaries for joint-histogram. (defined in cosp_config.F90) + if (.not. allocated(modis_histTau)) then + allocate(modis_histTau(ntau+1),modis_histTauEdges(2,ntau),modis_histTauCenters(ntau)) + numMODISTauBins = ntau + modis_histTau = tau_binBounds + modis_histTauEdges = tau_binEdges + modis_histTauCenters = tau_binCenters + endif + + ! Set up vertical grid used by CALIPSO and CLOUDSAT L3 + use_vgrid = lusevgrid + + if (use_vgrid) then + Nlvgrid = Nvgrid + allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid)) + ! CloudSat grid requested + if (luseCSATvgrid) zstep = 480._wp + ! Other grid requested. Constant vertical spacing with top at 20 km + if (.not. luseCSATvgrid) zstep = 20000._wp/Nvgrid + do i=1,Nvgrid + vgrid_zl(Nlvgrid-i+1) = (i-1)*zstep + vgrid_zu(Nlvgrid-i+1) = i*zstep + enddo + vgrid_z = (vgrid_zl+vgrid_zu)/2._wp + else + Nlvgrid = Nlevels + allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid)) + endif + + ! Initialize simulators + if (Lisccp) call cosp_isccp_init(isccp_top_height,isccp_top_height_direction) + if (Lmodis) call cosp_modis_init() + if (Lmisr) call cosp_misr_init() + if (Lrttov) call cosp_rttov_init() + if (Lcloudsat) call cosp_cloudsat_init(cloudsat_radar_freq,cloudsat_k2, & + cloudsat_use_gas_abs,cloudsat_do_ray,R_UNDEF,N_HYDRO, surface_radar, & + rcfg,cloudsat_micro_scheme) + if (Lcalipso) call cosp_calipso_init() + if (Lparasol) call cosp_parasol_init() + + linitialization = .FALSE. + END SUBROUTINE COSP_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_cleanUp + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_cleanUp() + deallocate(vgrid_zl,vgrid_zu,vgrid_z) + end subroutine cosp_cleanUp + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_errorCheck + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_errorCheck(cospgridIN, cospIN, Lisccp_subcolumn, Lisccp_column, & + Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column, Lcloudsat_subcolumn, & + Lcloudsat_column, Lcalipso_subcolumn, Lcalipso_column, Lrttov_subcolumn, & + Lrttov_column, Lparasol_subcolumn, Lparasol_column, Lradar_lidar_tcc, & + Llidar_only_freq_cloud, cospOUT, errorMessage, nError) + + ! Inputs + type(cosp_column_inputs),intent(in) :: & + cospgridIN ! Model grid inputs to COSP + type(cosp_optical_inputs),intent(in) :: & + cospIN ! Derived (optical) input to COSP + + ! Outputs + logical,intent(inout) :: & + Lisccp_subcolumn, & ! ISCCP subcolumn simulator on/off switch + Lisccp_column, & ! ISCCP column simulator on/off switch + Lmisr_subcolumn, & ! MISR subcolumn simulator on/off switch + Lmisr_column, & ! MISR column simulator on/off switch + Lmodis_subcolumn, & ! MODIS subcolumn simulator on/off switch + Lmodis_column, & ! MODIS column simulator on/off switch + Lcloudsat_subcolumn, & ! CLOUDSAT subcolumn simulator on/off switch + Lcloudsat_column, & ! CLOUDSAT column simulator on/off switch + Lcalipso_subcolumn, & ! CALIPSO subcolumn simulator on/off switch + Lcalipso_column, & ! CALIPSO column simulator on/off switch + Lparasol_subcolumn, & ! PARASOL subcolumn simulator on/off switch + Lparasol_column, & ! PARASOL column simulator on/off switch + Lrttov_subcolumn, & ! RTTOV subcolumn simulator on/off switch + Lrttov_column, & ! RTTOV column simulator on/off switch + Lradar_lidar_tcc, & ! On/Off switch for joint Calipso/Cloudsat product + Llidar_only_freq_cloud ! On/Off switch for joint Calipso/Cloudsat product + type(cosp_outputs),intent(inout) :: & + cospOUT ! COSP Outputs + character(len=256),dimension(100) :: errorMessage + integer,intent(out) :: nError + + ! Local variables + character(len=100) :: parasolErrorMessage + logical :: alloc_status + + nError = 0 + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! PART 0: Ensure that the inputs needed by the requested simulators are allocated. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ISCCP simulator + if (Lisccp_subcolumn .or. Lisccp_column) then + alloc_status = .true. + if (.not. allocated(cospgridIN%skt)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%skt has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%frac_out)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%frac_out has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%emiss_11)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%emiss_11 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%pfull)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%pfull has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + + ! MISR simulator + if (Lmisr_subcolumn .or. Lmisr_column) then + alloc_status = .true. + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + endif + endif + + ! Calipso Lidar simulator + if (Lcalipso_subcolumn .or. Lcalipso_column) then + alloc_status = .true. + if (.not. allocated(cospIN%beta_mol)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%beta_mol has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%betatot has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_liq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%betatot_liq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_ice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%betatot_ice has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_mol)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%tau_mol has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%tautot has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_liq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%tautot_liq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_ice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%tautot_ice has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_beta_mol)) cospOUT%calipso_beta_mol(:,:) = R_UNDEF + if (associated(cospOUT%calipso_beta_tot)) cospOUT%calipso_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_betaperp_tot)) cospOUT%calipso_betaperp_tot(:,:,:) = R_UNDEF + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + + ! Calipso column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + endif + + ! PARASOL simulator + if (Lparasol_subcolumn .or. Lparasol_column) then + alloc_status = .true. + if (.not. allocated(cospIN%tautot_S_liq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_liq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_S_ice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_ice has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lparasol_subcolumn = .false. + Lparasol_column = .false. + if (associated(cospOUT%parasolPix_refl)) cospOUT%parasolPix_refl(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + + ! PARASOL column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%land)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospgridIN%land has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lparasol_column = .false. + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + endif + + ! Cloudsat radar simulator + if (Lcloudsat_subcolumn .or. Lcloudsat_column) then + alloc_status = .true. + if (.not. allocated(cospIN%z_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%z_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%kr_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%kr_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%g_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%g_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + + ! Cloudsat column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcloudsat_column = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + endif + + ! MODIS simulator + if (Lmodis_subcolumn .or. Lmodis_column) then + alloc_status = .true. + if (.not. allocated(cospIN%fracLiq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%fracLiq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%asym)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%asym has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%ss_alb)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%ss_alb has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + endif + + ! RTTOV + if (Lrttov_column) then + alloc_status = .true. + if (.not. allocated(cospgridIN%emis_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%u_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%u_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%v_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%v_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%skt)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%skt has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%land)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%land has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%lat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%lon)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lon has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%seaice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%seaice has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%pfull)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%pfull has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%o3)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%o3 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%tca)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%tca has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%cloudIce)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudIce has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%cloudLiq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudLiq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%fl_rain)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_rain has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%fl_snow)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_snow has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! PART 1: Check input array values for out-of-bounds values. When an out-of-bound value + ! is encountered, COSP outputs that are dependent on that input are filled with + ! an undefined value (set in cosp_config.f90) and if necessary, that simulator + ! is turned off. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column])) then + if (any(cospgridIN%sunlit .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%sunlit contains values out of range (0 or 1)' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lrttov_column,& + Lcalipso_column, Lcloudsat_column, Lradar_lidar_tcc,Llidar_only_freq_cloud])) then + if (any(cospgridIN%at .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%at contains values out of range (at<0), expected units (K)' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lrttov_column = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn, Lisccp_column, Lrttov_column])) then + if (any(cospgridIN%pfull .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%pfull contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lmodis_subcolumn,Lmodis_column,Lcalipso_column,Lrttov_column])) then + if (any(cospgridIN%phalf .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%phalf contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + Lcalipso_column = .false. + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then + if (any(cospgridIN%qv .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%qv contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + if (any([Lmisr_subcolumn,Lmisr_column,Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,& + Llidar_only_freq_cloud])) then + if (any(cospgridIN%hgt_matrix .lt. -300)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix contains values out of range' + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lcalipso_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + endif + if (any([Lrttov_column,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,Llidar_only_freq_cloud])) then + if (any(cospgridIN%hgt_matrix_half .lt. -300)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix_half contains values out of range' + Lrttov_column = .false. + Lcloudsat_column = .false. + Lcalipso_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + endif + if (any([Lrttov_column,Lcalipso_column,Lparasol_column])) then + if (any(cospgridIN%land .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%land contains values out of range' + Lrttov_column = .false. + Lcalipso_column = .false. + Lparasol_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then + if (any(cospgridIN%skt .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%skt contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + + ! RTTOV Inputs + if (Lrttov_column) then + if (cospgridIN%zenang .lt. -90. .OR. cospgridIN%zenang .gt. 90) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%zenang contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%co2 .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co2 contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%ch4 .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%ch4 contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%n2o .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%n2o contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%co.lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%o3 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%o3 contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%emis_sfc .lt. 0. .OR. cospgridIN%emis_sfc .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%emis_sfc contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%u_sfc .lt. -100. .OR. cospgridIN%u_sfc .gt. 100.)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%u_sfc contains values out of range' + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + Lrttov_column = .false. + endif + if (any(cospgridIN%v_sfc .lt. -100. .OR. cospgridIN%v_sfc .gt. 100.)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%v_sfc contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%lat .lt. -90 .OR. cospgridIN%lat .gt. 90)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%lat contains values out of range' + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + endif + + ! COSP_INPUTS + if (any([Lisccp_subcolumn,Lisccp_column])) then + if (cospIN%emsfc_lw .lt. 0. .OR. cospIN%emsfc_lw .gt. 1.) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emsfc_lw contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column])) then + if (any(cospIN%tau_067 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_067 contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column])) then + if (any(cospIN%emiss_11 .lt. 0. .OR. cospIN%emiss_11 .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emiss_11 contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + endif + if (any([Lmodis_subcolumn,Lmodis_column])) then + if (any(cospIN%asym .lt. -1. .OR. cospIN%asym .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%asym contains values out of range' + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + if (any(cospIN%ss_alb .lt. 0 .OR. cospIN%ss_alb .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%ss_alb contains values out of range' + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + endif + if (any([Lcalipso_subcolumn,Lcalipso_column])) then + if (any(cospIN%betatot .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%betatot_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%betatot_liq contains values out of range') + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%betatot_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_ice contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%tautot_liq contains values out of range') + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_ice contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tau_mol .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + endif + if (any([Lcalipso_subcolumn,Lcalipso_column,Lcloudsat_column,Lradar_lidar_tcc,Llidar_only_freq_cloud])) then + if (any(cospIN%beta_mol .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + endif + if (any([Lparasol_subcolumn,Lparasol_column])) then + if (any(cospIN%tautot_S_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_liq contains values out of range' + Lparasol_subcolumn = .false. + Lparasol_column = .false. + if (associated(cospOUT%parasolPix_refl)) cospOUT%parasolPix_refl(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + if (any(cospIN%tautot_S_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_ice contains values out of range' + Lparasol_subcolumn = .false. + Lparasol_column = .false. + if (associated(cospOUT%parasolPix_refl)) cospOUT%parasolPix_refl(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + endif + if (any([Lcloudsat_subcolumn,Lcloudsat_column,Lradar_lidar_tcc,Llidar_only_freq_cloud])) then + if (any(cospIN%z_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%z_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospIN%kr_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%kr_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospIN%g_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%g_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Part 2: Check input fields array size for consistency. This needs to be done for each + ! simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ISCCP + if (Lisccp_subcolumn .or. Lisccp_column) then + if (size(cospIN%frac_out,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospIN%emiss_11,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%skt) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%sunlit) .ne. cospIN%Npoints .OR. & + size(cospgridIN%pfull,1) .ne. cospIN%Npoints) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%frac_out,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%emiss_11,2) .ne. cospIN%Ncolumns) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%frac_out,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%emiss_11,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! MISR + if (Lmisr_subcolumn .or. Lmisr_column) then + if (size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%sunlit) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%tau_067,2) .ne. cospIN%Ncolumns) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! MODIS + if (Lmodis_subcolumn .or. Lmodis_column) then + if (size(cospIN%fracLiq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospIN%asym,1) .ne. cospIN%Npoints .OR. & + size(cospIN%ss_alb,1) .ne. cospIN%Npoints) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%fracLiq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%asym,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%ss_alb,2) .ne. cospIN%Ncolumns) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%fracLiq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%asym,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%ss_alb,3) .ne. cospIN%Nlevels) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! CLOUDSAT + if (Lcloudsat_subcolumn .or. Lcloudsat_column) then + if (size(cospIN%z_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospIN%kr_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospIN%g_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%z_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%kr_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%g_vol_cloudsat,2) .ne. cospIN%Ncolumns) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%z_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%kr_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%g_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! CALIPSO + if (Lcalipso_subcolumn .or. Lcalipso_column) then + if (size(cospIN%beta_mol,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_ice,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_mol,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_ice,1) .ne. cospIN%Npoints) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%betatot,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_ice,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_ice,2) .ne. cospIN%Ncolumns) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%beta_mol,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_liq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_ice,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_mol,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_liq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_ice,3) .ne. cospIN%Nlevels) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! PARASOL + if (Lparasol_subcolumn .or. Lparasol_column) then + if (size(cospIN%tautot_S_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_S_ice,1) .ne. cospIN%Npoints) then + Lparasol_subcolumn = .false. + Lparasol_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(parasol_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%tautot_S_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_S_ice,2) .ne. cospIN%Ncolumns) then + Lparasol_subcolumn = .false. + Lparasol_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(parasol_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! RTTOV + if (Lrttov_column) then + if (size(cospgridIN%pfull,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix_half,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%u_sfc) .ne. cospIN%Npoints .OR. & + size(cospgridIN%v_sfc) .ne. cospIN%Npoints .OR. & + size(cospgridIN%skt) .ne. cospIN%Npoints .OR. & + size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%land) .ne. cospIN%Npoints .OR. & + size(cospgridIN%lat) .ne. cospIN%Npoints) then + Lrttov_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(rttov_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix_half,2) .ne. cospIN%Nlevels+1 .OR. & + size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1 .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels) then + Lrttov_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(rttov_simulator): The number of levels in the input fields are inconsistent' + endif + endif + end subroutine cosp_errorCheck + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP diff --git a/src/physics/cosp2/src/cosp_config.F90 b/src/physics/cosp2/src/cosp_config.F90 new file mode 100644 index 0000000000..4fd18a69da --- /dev/null +++ b/src/physics/cosp2/src/cosp_config.F90 @@ -0,0 +1,339 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes +! Oct 2008 - H. Chepfer - Added PARASOL_NREFL +! Jun 2010 - R. Marchand - Modified to support quickbeam V3, added ifdef for +! hydrometeor definitions +! May 2015 - D. Swales - Tidied up. Set up appropriate fields during initialization. +! June 2015- D. Swales - Moved hydrometeor class variables to hydro_class_init in +! the module quickbeam_optics. +! Mar 2016 - D. Swales - Added scops_ccfrac. Was previously hardcoded in prec_scops.f90. +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE MOD_COSP_CONFIG + USE COSP_KINDS, ONLY: wp,dp + IMPLICIT NONE + + ! ##################################################################################### + ! Common COSP information + ! ##################################################################################### + character(len=32) :: & + COSP_VERSION ! COSP Version ID (set in cosp_interface_init) + real(wp),parameter :: & + R_UNDEF = -1.0E30, & ! Missing value + R_GROUND = -1.0E20, & ! Flag for below ground results + scops_ccfrac = 0.05 ! Fraction of column (or subcolumn) covered with convective + ! precipitation (default is 5%). *NOTE* This quantity may vary + ! between modeling centers. + logical :: & + use_vgrid ! True=Use new grid for L3 CLOUDAT and CALIPSO + integer,parameter :: & + SR_BINS = 15, & ! Number of bins (backscattering coefficient) in CALOPSO LIDAR simulator. + N_HYDRO = 9 ! Number of hydrometeor classes used by quickbeam radar simulator. + + ! #################################################################################### + ! Joint histogram bin-boundaries + ! tau is used by ISCCP and MISR + ! pres is used by ISCCP + ! hgt is used by MISR + ! ReffLiq is used by MODIS + ! ReffIce is used by MODIS + ! *NOTE* ALL JOINT-HISTOGRAM BIN BOUNDARIES ARE DECLARED AND DEFINED HERE IN + ! COSP_CONFIG, WITH THE EXCEPTION OF THE TAU AXIS USED BY THE MODIS SIMULATOR, + ! WHICH IS SET DURING INITIALIZATION IN COSP_INTERFACE_INIT. + ! #################################################################################### + ! Optical depth bin axis + integer,parameter :: & + ntau=7 + real(wp),parameter,dimension(ntau+1) :: & + tau_binBounds = (/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60., 10000./) + real(wp),parameter,dimension(ntau) :: & + tau_binCenters = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/) + real(wp),parameter,dimension(2,ntau) :: & + tau_binEdges = reshape(source=(/0.0, 0.3, 0.3, 1.3, 1.3, 3.6, 3.6, & + 9.4, 9.4, 23.0, 23.0, 60.0, 60.0, 100000.0/), & + shape=(/2,ntau/)) + + ! Optical depth bin axes (ONLY USED BY MODIS SIMULATOR IN v1.4) + integer :: l,k + integer,parameter :: & + ntauV1p4 = 6 + real(wp),parameter,dimension(ntauV1p4+1) :: & + tau_binBoundsV1p4 = (/0.3, 1.3, 3.6, 9.4, 23., 60., 10000./) + real(wp),parameter,dimension(2,ntauV1p4) :: & + tau_binEdgesV1p4 = reshape(source =(/tau_binBoundsV1p4(1),((tau_binBoundsV1p4(k),l=1,2), & + k=2,ntauV1p4),100000._wp/),shape = (/2,ntauV1p4/)) + real(wp),parameter,dimension(ntauV1p4) :: & + tau_binCentersV1p4 = (tau_binEdgesV1p4(1,:)+tau_binEdgesV1p4(2,:))/2._wp + + ! Cloud-top height pressure bin axis + integer,parameter :: & + npres = 7 + real(wp),parameter,dimension(npres+1) :: & + pres_binBounds = (/0., 180., 310., 440., 560., 680., 800., 10000./) + real(wp),parameter,dimension(npres) :: & + pres_binCenters = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) + real(wp),parameter,dimension(2,npres) :: & + pres_binEdges = reshape(source=(/100000.0, 80000.0, 80000.0, 68000.0, 68000.0, & + 56000.0, 56000.0, 44000.0, 44000.0, 31000.0, & + 31000.0, 18000.0, 18000.0, 0.0/), & + shape=(/2,npres/)) + + ! Cloud-top height bin axis #1 + integer,parameter :: & + nhgt = 16 + real(wp),parameter,dimension(nhgt+1) :: & + hgt_binBounds = (/-.99,0.,0.5,1.,1.5,2.,2.5,3.,4.,5.,7.,9.,11.,13.,15.,17.,99./) + real(wp),parameter,dimension(nhgt) :: & + hgt_binCenters = 1000*(/0.,0.25,0.75,1.25,1.75,2.25,2.75,3.5,4.5,6.,8.,10.,12., & + 14.5,16.,18./) + real(wp),parameter,dimension(2,nhgt) :: & + hgt_binEdges = 1000.0*reshape(source=(/-99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5, & + 1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0, & + 4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0,11.0, & + 11.0,13.0,13.0,15.0,15.0,17.0,17.0,99.0/),& + shape=(/2,nhgt/)) + + ! Liquid and Ice particle bins for MODIS joint histogram of optical-depth and particle + ! size + integer :: i,j + integer,parameter :: & + nReffLiq = 6, & ! Number of bins for tau/ReffLiq joint-histogram + nReffIce = 6 ! Number of bins for tau/ReffICE joint-histogram + real(wp),parameter,dimension(nReffLiq+1) :: & + reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/) + real(wp),parameter,dimension(nReffIce+1) :: & + reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/) + real(wp),parameter,dimension(2,nReffICE) :: & + reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k), & + l=1,2),k=2,nReffICE),reffICE_binBounds(nReffICE+1)/), & + shape = (/2,nReffICE/)) + real(wp),parameter,dimension(2,nReffLIQ) :: & + reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k), & + l=1,2),k=2,nReffLIQ),reffLIQ_binBounds(nReffICE+1)/), & + shape = (/2,nReffLIQ/)) + real(wp),parameter,dimension(nReffICE) :: & + reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2._wp + real(wp),parameter,dimension(nReffLIQ) :: & + reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2._wp + + ! #################################################################################### + ! Constants used by RTTOV. + ! #################################################################################### + integer,parameter :: & + RTTOV_MAX_CHANNELS = 20 + character(len=256),parameter :: & + rttovDir = '/Projects/Clouds/dswales/RTTOV/rttov_11.3/' + + ! #################################################################################### + ! Constants used by the PARASOL simulator. + ! #################################################################################### + integer,parameter :: & + PARASOL_NREFL = 5, & ! Number of angles in LUT + PARASOL_NTAU = 7 ! Number of optical depths in LUT + real(wp),parameter,dimension(PARASOL_NREFL) :: & + PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/) + REAL(WP),parameter,dimension(PARASOL_NTAU) :: & + PARASOL_TAU = (/0., 1., 5., 10., 20., 50., 100./) + + ! LUTs + REAL(WP),parameter,dimension(PARASOL_NREFL,PARASOL_NTAU) :: & + ! LUT for liquid particles + rlumA = reshape(source=(/ 0.03, 0.03, 0.03, 0.03, 0.03, & + 0.090886, 0.072185, 0.058410, 0.052498, 0.034730, & + 0.283965, 0.252596, 0.224707, 0.175844, 0.064488, & + 0.480587, 0.436401, 0.367451, 0.252916, 0.081667, & + 0.695235, 0.631352, 0.509180, 0.326551, 0.098215, & + 0.908229, 0.823924, 0.648152, 0.398581, 0.114411, & + 1.0, 0.909013, 0.709554, 0.430405, 0.121567/), & + shape=(/PARASOL_NREFL,PARASOL_NTAU/)), & + ! LUT for ice particles + rlumB = reshape(source=(/ 0.03, 0.03, 0.03, 0.03, 0.03, & + 0.092170, 0.087082, 0.083325, 0.084935, 0.054157, & + 0.311941, 0.304293, 0.285193, 0.233450, 0.089911, & + 0.511298, 0.490879, 0.430266, 0.312280, 0.107854, & + 0.712079, 0.673565, 0.563747, 0.382376, 0.124127, & + 0.898243, 0.842026, 0.685773, 0.446371, 0.139004, & + 0.976646, 0.912966, 0.737154, 0.473317, 0.145269/), & + shape=(/PARASOL_NREFL,PARASOL_NTAU/)) + + ! #################################################################################### + ! ISCCP simulator tau/CTP joint histogram information + ! #################################################################################### + integer,parameter :: & + numISCCPTauBins = ntau, & ! Number of optical depth bins + numISCCPPresBins = npres ! Number of pressure bins + real(wp),parameter,dimension(ntau+1) :: & + isccp_histTau = tau_binBounds ! Joint-histogram boundaries (optical depth) + real(wp),parameter,dimension(npres+1) :: & + isccp_histPres = pres_binBounds ! Joint-histogram boundaries (cloud pressure) + real(wp),parameter,dimension(ntau) :: & + isccp_histTauCenters = tau_binCenters ! Joint histogram bin centers (optical depth) + real(wp),parameter,dimension(npres) :: & + isccp_histPresCenters = pres_binCenters ! Joint histogram bin centers (cloud pressure) + real(wp),parameter,dimension(2,ntau) :: & + isccp_histTauEdges = tau_binEdges ! Joint histogram bin edges (optical depth) + real(wp),parameter,dimension(2,npres) :: & + isccp_histPresEdges = pres_binEdges ! Joint histogram bin edges (cloud pressure) + + ! #################################################################################### + ! MISR simulator tau/CTH joint histogram information + ! #################################################################################### + integer,parameter :: & + numMISRHgtBins = nhgt, & ! Number of cloud-top height bins + numMISRTauBins = ntau ! Number of optical depth bins + ! Joint histogram boundaries + real(wp),parameter,dimension(numMISRHgtBins+1) :: & + misr_histHgt = hgt_binBounds ! Joint-histogram boundaries (cloud height) + real(wp),parameter,dimension(numMISRTauBins+1) :: & + misr_histTau = tau_binBounds ! Joint-histogram boundaries (optical-depth) + real(wp),parameter,dimension(numMISRHgtBins) :: & + misr_histHgtCenters = hgt_binCenters ! Joint-histogram bin centers (cloud height) + real(wp),parameter,dimension(2,numMISRHgtBins) :: & + misr_histHgtEdges = hgt_BinEdges ! Joint-histogram bin edges (cloud height) + + ! #################################################################################### + ! MODIS simulator tau/CTP joint histogram information + ! #################################################################################### + integer,parameter :: & + numMODISPresBins = npres ! Number of pressure bins for joint-histogram + real(wp),parameter,dimension(numMODISPresBins + 1) :: & + modis_histPres = 100*pres_binBounds ! Joint-histogram boundaries (cloud pressure) + real(wp),parameter,dimension(2, numMODISPresBins) :: & + modis_histPresEdges = 100*pres_binEdges ! Joint-histogram bin edges (cloud pressure) + real(wp),parameter,dimension(numMODISPresBins) :: & + modis_histPresCenters = 100*pres_binCenters ! Joint-histogram bin centers (cloud pressure) + + ! For the MODIS simulator we want to preserve the ability for cospV1.4.0 to use the + ! old histogram bin boundaries for optical depth, so these are set up in initialization. + integer :: & + numMODISTauBins ! Number of tau bins for joint-histogram + real(wp),allocatable,dimension(:) :: & + modis_histTau ! Joint-histogram boundaries (optical depth) + real(wp),allocatable,dimension(:,:) :: & + modis_histTauEdges ! Joint-histogram bin edges (optical depth) + real(wp),allocatable,dimension(:) :: & + modis_histTauCenters ! Joint-histogram bin centers (optical depth) + + ! #################################################################################### + ! MODIS simulator tau/ReffICE and tau/ReffLIQ joint-histogram information + ! #################################################################################### + ! Ice + integer,parameter :: & + numMODISReffIceBins = nReffIce ! Number of bins for joint-histogram + real(wp),parameter,dimension(nReffIce+1) :: & + modis_histReffIce = reffICE_binBounds ! Effective radius bin boundaries + real(wp),parameter,dimension(nReffIce) :: & + modis_histReffIceCenters = reffICE_binCenters ! Effective radius bin centers + real(wp),parameter,dimension(2,nReffICE) :: & + modis_histReffIceEdges = reffICE_binEdges ! Effective radius bin edges + + ! Liquid + integer,parameter :: & + numMODISReffLiqBins = nReffLiq ! Number of bins for joint-histogram + real(wp),parameter,dimension(nReffLiq+1) :: & + modis_histReffLiq = reffLIQ_binBounds ! Effective radius bin boundaries + real(wp),parameter,dimension(nReffLiq) :: & + modis_histReffLiqCenters = reffICE_binCenters ! Effective radius bin centers + real(wp),parameter,dimension(2,nReffICE) :: & + modis_histReffLiqEdges = reffLIQ_binEdges ! Effective radius bin edges + + ! #################################################################################### + ! CLOUDSAT reflectivity histogram information + ! #################################################################################### + integer,parameter :: & + DBZE_BINS = 15, & ! Number of dBZe bins in histogram (cfad) + DBZE_MIN = -100, & ! Minimum value for radar reflectivity + DBZE_MAX = 80, & ! Maximum value for radar reflectivity + CFAD_ZE_MIN = -50, & ! Lower value of the first CFAD Ze bin + CFAD_ZE_WIDTH = 5 ! Bin width (dBZe) + + real(wp),parameter,dimension(DBZE_BINS+1) :: & + cloudsat_histRef = (/DBZE_MIN,(/(i, i=int(CFAD_ZE_MIN+CFAD_ZE_WIDTH), & + int(CFAD_ZE_MIN+(DBZE_BINS-1)*CFAD_ZE_WIDTH), & + int(CFAD_ZE_WIDTH))/),DBZE_MAX/) + real(wp),parameter,dimension(2,DBZE_BINS) :: & + cloudsat_binEdges = reshape(source=(/cloudsat_histRef(1),((cloudsat_histRef(k), & + l=1,2),k=2,DBZE_BINS),cloudsat_histRef(DBZE_BINS+1)/),& + shape = (/2,DBZE_BINS/)) + real(wp),parameter,dimension(DBZE_BINS) :: & + cloudsat_binCenters = (cloudsat_binEdges(1,:)+cloudsat_binEdges(2,:))/2._wp + + ! #################################################################################### + ! Parameters used by the CALIPSO LIDAR simulator + ! #################################################################################### + ! CALISPO backscatter histogram bins + real(wp),parameter :: & + S_cld = 5.0, & ! Threshold for cloud detection + S_att = 0.01, & ! + S_cld_att = 30. ! Threshold for undefined cloud phase detection + real(wp),parameter,dimension(SR_BINS+1) :: & + calipso_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0, & + 60.0,80.0,999./) ! Backscatter histogram bins + real(wp),parameter,dimension(2,SR_BINS) :: & + calipso_binEdges = reshape(source=(/calipso_histBsct(1),((calipso_histBsct(k), & + l=1,2),k=2,SR_BINS),calipso_histBsct(SR_BINS+1)/), & + shape = (/2,SR_BINS/)) + real(wp),parameter,dimension(SR_BINS) :: & + calipso_binCenters = (calipso_binEdges(1,:)+calipso_binEdges(2,:))/2._wp + + integer,parameter :: & + LIDAR_NTEMP = 40, & + LIDAR_NCAT = 4 ! Number of categories for cloudtop heights (high/mid/low/tot) + real(wp),parameter,dimension(LIDAR_NTEMP) :: & + LIDAR_PHASE_TEMP= & + (/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5, & + -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5, & + -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5, & + -1.5, 1.5, 4.5, 7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/) + real(wp),parameter,dimension(2,LIDAR_NTEMP) :: & + LIDAR_PHASE_TEMP_BNDS=reshape(source= & + (/-273.15, -90., -90., -87., -87., -84., -84., -81., -81., -78., & + -78., -75., -75., -72., -72., -69., -69., -66., -66., -63., & + -63., -60., -60., -57., -57., -54., -54., -51., -51., -48., & + -48., -45., -45., -42., -42., -39., -39., -36., -36., -33., & + -33., -30., -30., -27., -27., -24., -24., -21., -21., -18., & + -18., -15., -15., -12., -12., -9., -9., -6., -6., -3., & + -3., 0., 0., 3., 3., 6., 6., 9., 9., 12., & + 12., 15., 15., 18., 18., 21., 21., 24., 24., 100. /), & + shape=(/2,40/)) + + ! #################################################################################### + ! New vertical grid used by CALIPSO and CLOUDSAT L3 (set up during initialization) + ! #################################################################################### + integer :: & + Nlvgrid ! Number of levels in New grid + real(wp),dimension(:),allocatable :: & + vgrid_zl, & ! New grid bottoms + vgrid_zu, & ! New grid tops + vgrid_z ! New grid center + +END MODULE MOD_COSP_CONFIG diff --git a/src/physics/cosp2/src/cosp_constants.F90 b/src/physics/cosp2/src/cosp_constants.F90 new file mode 100644 index 0000000000..8fbdba50f5 --- /dev/null +++ b/src/physics/cosp2/src/cosp_constants.F90 @@ -0,0 +1,72 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE cosp_math_constants + USE cosp_kinds, only: wp + IMPLICIT NONE + REAL(wp), PARAMETER :: pi = acos(-1.0_wp) + +END MODULE cosp_math_constants + +MODULE cosp_phys_constants + USE cosp_kinds, only: wp + IMPLICIT NONE + + REAL(wp), PARAMETER :: & + tmelt = 273.15_wp, & ! Melting temperature of ice/snow [K] + rhoice = 917._wp, & ! Density of ice [kg/m3] + rholiq = 1000._wp ! Density of liquid water [kg/m3] + + ! Molecular weights + REAL(wp), PARAMETER :: & + amw = 18.01534_wp, & ! Water [g/mol] + amd = 28.9644_wp, & ! Dry air [g/mol] + amO3 = 47.9983_wp, & ! Ozone [g/mol] + amCO2 = 44.0096_wp, & ! CO2 [g/mol] + amCH4 = 16.0426_wp, & ! Methane [g/mol] + amN2O = 44.0129_wp, & ! N2O [g/mol] + amCO = 28.0102_wp ! CO [g/mol] + + ! WMO/SI value + REAL(wp), PARAMETER :: & + avo = 6.023E23_wp, & ! Avogadro constant used by ISCCP simulator [1/mol] + grav = 9.806650_wp ! Av. gravitational acceleration used by ISCCP simulator [m/s2] + + ! Thermodynamic constants for the dry and moist atmosphere + REAL(wp), PARAMETER :: & + rd = 287.04_wp, & ! Gas constant for dry air [J/K/Kg] + cpd = 1004.64_wp, & ! Specific heat at constant pressure for dry air [J/K/Kg] + rv = 461.51_wp, & ! Gas constant for water vapor [J/K/Kg] + cpv = 1869.46_wp, & ! Specific heat at constant pressure for water vapor [J/K/Kg] + km = 1.38e-23_wp ! Boltzmann constant [J/K] + +END MODULE cosp_phys_constants diff --git a/src/physics/cosp2/src/cosp_stats.F90 b/src/physics/cosp2/src/cosp_stats.F90 new file mode 100644 index 0000000000..be76ddd343 --- /dev/null +++ b/src/physics/cosp2/src/cosp_stats.F90 @@ -0,0 +1,285 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid +! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns +! in COSP_STATS +! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments +! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations +! Jan 2013 - G. Cesana - Added betaperp and temperature arguments +! - Added phase 3D/3Dtemperature/Map output variables in diag_lidar +! May 2015 - D. Swales - Modified for cosp2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_STATS + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,R_GROUND + IMPLICIT NONE +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units) + implicit none + ! Input arguments + integer,intent(in) :: Npoints !# of grid points + integer,intent(in) :: Nlevels !# of levels + integer,intent(in) :: Ncolumns !# of columns + real(wp),dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real(wp),dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid + integer,intent(in) :: Nglevels !# levels in the new grid + real(wp),dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] + real(wp),dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels [m] + logical,optional,intent(in) :: log_units ! log units, need to convert to linear units + ! Output + real(wp),dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + integer :: l + real(wp) :: w ! Weight + real(wp) :: dbb, dtb, dbt, dtt ! Distances between edges of both grids + integer :: Nw ! Number of weights + real(wp) :: wt ! Sum of weights + real(wp),dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid + real(wp) :: yp ! Local copy of y at a particular point. + ! This allows for change of units. + + lunits=.false. + if (present(log_units)) lunits=log_units + + r = 0._wp + + do i=1,Npoints + ! Calculate tops and bottoms of new and old grids + oldgrid_bot = zhalf(i,:) + oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels) + oldgrid_top(Nlevels) = zfull(i,Nlevels) + zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric + l = 0 ! Index of level in the old grid + ! Loop over levels in the new grid + do k = 1,Nglevels + Nw = 0 ! Number of weigths + wt = 0._wp ! Sum of weights + ! Loop over levels in the old grid and accumulate total for weighted average + do + l = l + 1 + w = 0.0 ! Initialise weight to 0 + ! Distances between edges of both grids + dbb = oldgrid_bot(l) - newgrid_bot(k) + dtb = oldgrid_top(l) - newgrid_bot(k) + dbt = oldgrid_bot(l) - newgrid_top(k) + dtt = oldgrid_top(l) - newgrid_top(k) + if (dbt >= 0.0) exit ! Do next level in the new grid + if (dtb > 0.0) then + if (dbb <= 0.0) then + if (dtt <= 0) then + w = dtb + else + w = newgrid_top(k) - newgrid_bot(k) + endif + else + if (dtt <= 0) then + w = oldgrid_top(l) - oldgrid_bot(l) + else + w = -dbt + endif + endif + ! If layers overlap (w/=0), then accumulate + if (w /= 0.0) then + Nw = Nw + 1 + wt = wt + w + do j=1,Ncolumns + if (lunits) then + if (y(i,j,l) /= R_UNDEF) then + yp = 10._wp**(y(i,j,l)/10._wp) + else + yp = 0._wp + endif + else + yp = y(i,j,l) + endif + r(i,j,k) = r(i,j,k) + w*yp + enddo + endif + endif + enddo + l = l - 2 + if (l < 1) l = 0 + ! Calculate average in new grid + if (Nw > 0) then + do j=1,Ncolumns + r(i,j,k) = r(i,j,k)/wt + enddo + endif + enddo + enddo + + ! Set points under surface to R_UNDEF, and change to dBZ if necessary + do k=1,Nglevels + do j=1,Ncolumns + do i=1,Npoints + if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level + if (lunits) then + if (r(i,j,k) <= 0.0) then + r(i,j,k) = R_UNDEF + else + r(i,j,k) = 10._wp*log10(r(i,j,k)) + endif + endif + else ! Level below surface + r(i,j,k) = R_GROUND + endif + enddo + enddo + enddo + +END SUBROUTINE COSP_CHANGE_VERTICAL_GRID + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- + ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. + ! All rights reserved. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot, & + beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of horizontal gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels ! Number of vertical layers + real(wp),dimension(Npoints,Nlevels),intent(in) :: & + beta_mol ! Molecular backscatter + real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: & + beta_tot, & ! Total backscattered signal + Ze_tot ! Radar reflectivity + ! Outputs + real(wp),dimension(Npoints,Nlevels),intent(out) :: & + lidar_only_freq_cloud + real(wp),dimension(Npoints),intent(out) ::& + tcc + + ! local variables + real(wp) :: sc_ratio + real(wp),parameter :: & + s_cld=5.0, & + s_att=0.01 + integer :: flag_sat,flag_cld,pr,i,j + + lidar_only_freq_cloud = 0._wp + tcc = 0._wp + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + do j=1,Nlevels + sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) + if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j + if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud + if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud + lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf + flag_cld=1 + endif + else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) + flag_cld=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp + enddo !columns + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + + ! Unit conversion + where(lidar_only_freq_cloud /= R_UNDEF) & + lidar_only_freq_cloud = lidar_only_freq_cloud*100._wp + where(tcc /= R_UNDEF) tcc = tcc*100._wp + + END SUBROUTINE COSP_LIDAR_ONLY_CLOUD + + ! ###################################################################################### + ! FUNCTION hist1D + ! ###################################################################################### + function hist1d(Npoints,var,nbins,bins) + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of points in input array + Nbins ! Number of bins for sorting + real(wp),intent(in),dimension(Npoints) :: & + var ! Input variable to be sorted + real(wp),intent(in),dimension(Nbins+1) :: & + bins ! Histogram bins [lowest,binTops] + ! Outputs + real(wp),dimension(Nbins) :: & + hist1d ! Output histogram + ! Local variables + integer :: ij + + do ij=2,Nbins+1 + hist1D(ij-1) = count(var .ge. bins(ij-1) .and. var .lt. bins(ij)) + if (count(var .eq. R_GROUND) .ge. 1) hist1D(ij-1)=R_UNDEF + enddo + + end function hist1D + + ! ###################################################################################### + ! SUBROUTINE hist2D + ! ###################################################################################### + subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist) + implicit none + + ! INPUTS + integer, intent(in) :: & + npts, & ! Number of data points to be sorted + nbin1, & ! Number of bins in histogram direction 1 + nbin2 ! Number of bins in histogram direction 2 + real(wp),intent(in),dimension(npts) :: & + var1, & ! Variable 1 to be sorted into bins + var2 ! variable 2 to be sorted into bins + real(wp),intent(in),dimension(nbin1+1) :: & + bin1 ! Histogram bin 1 boundaries + real(wp),intent(in),dimension(nbin2+1) :: & + bin2 ! Histogram bin 2 boundaries + ! OUTPUTS + real(wp),intent(out),dimension(nbin1,nbin2) :: & + jointHist + + ! LOCAL VARIABLES + integer :: ij,ik + + do ij=2,nbin1+1 + do ik=2,nbin2+1 + jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. & + var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik)) + enddo + enddo + end subroutine hist2D +END MODULE MOD_COSP_STATS diff --git a/src/physics/cosp2/src/simulator/MISR_simulator/MISR_simulator.F90 b/src/physics/cosp2/src/simulator/MISR_simulator/MISR_simulator.F90 new file mode 100644 index 0000000000..7a65917bee --- /dev/null +++ b/src/physics/cosp2/src/simulator/MISR_simulator/MISR_simulator.F90 @@ -0,0 +1,292 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Roger Marchand, version 1.2 +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_MISR_SIMULATOR + use cosp_kinds, only: wp + use MOD_COSP_STATS, ONLY: hist2D + use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt, & + misr_histTau + implicit none + + ! Parameters + real(wp),parameter :: & + misr_taumin = 0.3_wp, & ! Minimum optical depth for joint-histogram + tauchk = -1.*log(0.9999999) ! Lower limit on optical depth + +contains + + ! ###################################################################################### + ! SUBROUTINE misr_subcolumn + ! ###################################################################################### + SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT, & + dist_model_layertops,box_MISR_ztop) + ! INPUTS + INTEGER, intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncol, & ! Number of subcolumns + nlev ! Number of vertical layers + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & + dtau ! Optical thickness + REAL(WP),intent(in),dimension(npoints,nlev) :: & + zfull, & ! Height of full model levels (i.e. midpoints), [nlev] is bottom + at ! Temperature (K) + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,ncol) :: & + box_MISR_ztop, & ! Cloud-top height in each column + tauOUT ! Optical depth in each column + REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: & + dist_model_layertops ! + + ! INTERNAL VARIABLES + INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR + INTEGER :: iMISR_ztop + REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest + + ! ############################################################################ + ! Initialize + box_MISR_ztop(1:npoints,1:ncol) = 0._wp + + do j=1,npoints + + ! Estimate distribution of Model layer tops + dist_model_layertops(j,:)=0 + do ilev=1,nlev + ! Define location of "layer top" + if(ilev.eq.1 .or. ilev.eq.nlev) then + ztest=zfull(j,ilev) + else + ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) + endif + + ! Find MISR layer that contains this level + ! *NOTE* the first MISR level is "no height" level + iMISR_ztop=2 + do loop=2,numMISRHgtBins + if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then + iMISR_ztop=loop+1 + endif + enddo + + dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1 + enddo + + ! For each GCM cell or horizontal model grid point + do ibox=1,ncol + ! Compute optical depth as a cummulative distribution in the vertical (nlev). + tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev)) + + thres_crossed_MISR=0 + do ilev=1,nlev + ! If there a cloud, start the counter and store this height + if(thres_crossed_MISR .eq. 0 .and. dtau(j,ibox,ilev) .gt. 0.) then + ! First encountered a "cloud" + thres_crossed_MISR = 1 + cloud_dtau = 0 + endif + + if( thres_crossed_MISR .lt. 99 .and. thres_crossed_MISR .gt. 0 ) then + if( dtau(j,ibox,ilev) .eq. 0.) then + ! We have come to the end of the current cloud layer without yet + ! selecting a CTH boundary. Restart cloud tau counter + cloud_dtau=0 + else + ! Add current optical depth to count for the current cloud layer + cloud_dtau=cloud_dtau+dtau(j,ibox,ilev) + endif + + ! If the cloud is continuous but optically thin (< 1) from above the + ! current layer cloud top to the current level then MISR will like + ! see a top below the top of the current layer. + if( dtau(j,ibox,ilev).gt.0 .and. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then + if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then + ! MISR will likely penetrate to some point within this layer ... the middle + MISR_penetration_height=zfull(j,ilev) + else + ! Take the OD = 1.0 level into this layer + MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - & + 0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev) + endif + box_MISR_ztop(j,ibox)=MISR_penetration_height + endif + + ! Check for a distinctive water layer + if(dtau(j,ibox,ilev) .gt. 1 .and. at(j,ilev) .gt. 273 ) then + ! Must be a water cloud, take this as CTH level + thres_crossed_MISR=99 + endif + + ! If the total column optical depth is "large" than MISR can't see + ! anything else. Set current point as CTH level + if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then + thres_crossed_MISR=99 + endif + endif + enddo + + ! Check to see if there was a cloud for which we didn't + ! set a MISR cloud top boundary + if( thres_crossed_MISR .eq. 1) then + ! If the cloud has a total optical depth of greater + ! than ~ 0.5 MISR will still likely pick up this cloud + ! with a height near the true cloud top + ! otherwise there should be no CTH + if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then + ! keep MISR detected CTH + elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then + ! MISR may detect but wont likley have a good height + box_MISR_ztop(j,ibox)=-1 + else + ! MISR not likely to even detect. + ! so set as not cloudy + box_MISR_ztop(j,ibox)=0 + endif + endif + enddo ! loop of subcolumns + + enddo ! loop of gridpoints + + ! Modify MISR CTH for satellite spatial / pattern matcher effects + ! Code in this region added by roj 5/2006 to account + ! for spatial effect of the MISR pattern matcher. + ! Basically, if a column is found between two neighbors + ! at the same CTH, and that column has no hieght or + ! a lower CTH, THEN misr will tend to but place the + ! odd column at the same height as it neighbors. + + ! This setup assumes the columns represent a about a 1 to 4 km scale + ! it will need to be modified significantly, otherwise +! ! DS2015: Add loop over gridpoints and index accordingly. +! if(ncol.eq.1) then +! ! Adjust based on neightboring points. +! do j=2,npoints-1 +! if(box_MISR_ztop(j-1,1) .gt. 0 .and. & +! box_MISR_ztop(j+1,1) .gt. 0 .and. & +! abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .and. & +! box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then +! box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1) +! endif +! enddo +! else +! ! Adjust based on neighboring subcolumns. +! do j=1,npoints +! do ibox=2,ncol-1 +! if(box_MISR_ztop(j,ibox-1) .gt. 0 .and. & +! box_MISR_ztop(j,ibox+1) .gt. 0 .and. & +! abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .and. & +! box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then +! box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1) +! endif +! enddo +! enddo +! endif +! ! DS2015 END + + ! Fill dark scenes + do j=1,numMISRHgtBins + where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF + enddo + + end SUBROUTINE MISR_SUBCOLUMN + + ! ###################################################################################### + ! SUBROUTINE misr_column + ! ###################################################################################### + SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH) + + ! INPUTS + INTEGER, intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncol ! Number of subcolumns + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in),dimension(npoints,ncol) :: & + box_MISR_ztop, & ! Cloud-top height in each column + tau ! Column optical thickness + + ! OUTPUTS + REAL(WP),intent(inout),dimension(npoints) :: & + MISR_cldarea, & ! Fraction area covered by clouds + MISR_mean_ztop ! Mean cloud top height MISR would observe + REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: & + fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau + + ! INTERNAL VARIABLES + INTEGER :: j + LOGICAL,dimension(ncol) :: box_cloudy + real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK + ! ############################################################################ + + ! Compute column quantities and joint-histogram + MISR_cldarea(1:npoints) = 0._wp + MISR_mean_ztop(1:npoints) = 0._wp + fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp + tauWRK(1:npoints,1:ncol) = tau(1:npoints,1:ncol) + box_MISR_ztopWRK(1:npoints,1:ncol) = box_MISR_ztop(1:npoints,1:ncol) + do j=1,npoints + + ! Subcolumns that are cloudy(true) and not(false) + box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk) + + ! Fill optically thin clouds with fill value + where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol) = -999._wp + where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp + + ! Compute joint histogram and column quantities for points that are sunlit and cloudy + if (sunlit(j) .eq. 1) then + ! Joint histogram + call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,& + 1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)) + fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) = & + 100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol + + ! Column cloud area + MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol + + ! Column cloud-top height + if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then + MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ & + count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) + else + MISR_mean_ztop(j) = R_UNDEF + endif + + else + MISR_cldarea(j) = R_UNDEF + MISR_mean_ztop(npoints) = R_UNDEF + endif + enddo + + end SUBROUTINE MISR_COLUMN + +end MODULE MOD_MISR_SIMULATOR diff --git a/src/physics/cosp2/src/simulator/MODIS_simulator/modis_simulator.F90 b/src/physics/cosp2/src/simulator/MODIS_simulator/modis_simulator.F90 new file mode 100644 index 0000000000..684c5897ac --- /dev/null +++ b/src/physics/cosp2/src/simulator/MODIS_simulator/modis_simulator.F90 @@ -0,0 +1,906 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2009: Robert Pincus - Initial version +! June 2009: Steve Platnick and Robert Pincus - Simple radiative transfer for size +! retrievals +! August 2009: Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) +! November 2009: Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler +! using AM2 (GFDL) +! January 2010: Robert Pincus - Added high, middle, low cloud fractions +! May 2015: Dustin Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Notes on using the MODIS simulator: +! *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1 +! microns, or optical thickness at 0.67 microns and ice- and liquid-water contents +! (in consistent units of your choosing) +! *) Required input also includes the optical thickness and cloud top pressure +! derived from the ISCCP simulator run with parameter top_height = 1. +! *) Cloud particle sizes are specified as radii, measured in meters, though within the +! module we use units of microns. Where particle sizes are outside the bounds used in +! the MODIS retrieval libraries (parameters re_water_min, re_ice_min, etc.) the +! simulator returns missing values (re_fill) +! +! When error conditions are encountered this code calls the function complain_and_die, +! supplied at the bottom of this module. Users probably want to replace this with +! something more graceful. +! +module mod_modis_sim + USE MOD_COSP_CONFIG, only: R_UNDEF,modis_histTau,modis_histPres,numMODISTauBins, & + numMODISPresBins,numMODISReffIceBins,numMODISReffLiqBins, & + modis_histReffIce,modis_histReffLiq + USE COSP_KINDS, ONLY: wp + use MOD_COSP_STATS, ONLY: hist2D + + implicit none + ! ########################################################################## + ! Retrieval parameters + integer, parameter :: & + num_trial_res = 15 ! Increase to make the linear pseudo-retrieval of size more accurate + + real(wp) :: & + min_OpticalThickness, & ! Minimum detectable optical thickness + CO2Slicing_PressureLimit, & ! Cloud with higher pressures use thermal methods, units Pa + CO2Slicing_TauLimit, & ! How deep into the cloud does CO2 slicing see? + phase_TauLimit, & ! How deep into the cloud does the phase detection see? + size_TauLimit, & ! Depth of the re retreivals + phaseDiscrimination_Threshold, & ! What fraction of total extincton needs to be in a single + ! category to make phase discrim. work? + re_fill, & ! + re_water_min, & ! Minimum effective radius (liquid) + re_water_max, & ! Maximum effective radius (liquid) + re_ice_min, & ! Minimum effective radius (ice) + re_ice_max, & ! Minimum effective radius (ice) + highCloudPressureLimit, & ! High cloud pressure limit (Pa) + lowCloudPressureLimit ! Low cloud pressure limit (Pa) + integer :: & + phaseIsNone, & ! + phaseIsLiquid, & ! + phaseIsIce, & ! + phaseIsUndetermined ! + + real(wp),dimension(num_trial_res) :: & + trial_re_w, & ! Near-IR optical params vs size for retrieval scheme (liquid) + trial_re_i ! Near-IR optical params vs size for retrieval scheme (ice) + real(wp),dimension(num_trial_res) :: & + g_w, & ! Assymettry parameter for size retrieval (liquid) + g_i, & ! Assymettry parameter for size retrieval (ice) + w0_w, & ! Single-scattering albedo for size retrieval (liquid) + w0_i ! Single-scattering albedo for size retrieval (ice) + ! Algorithmic parameters + real(wp),parameter :: & + ice_density = 0.93_wp ! Liquid density is 1. + +contains + ! ######################################################################################## + ! MODIS simulator using specified liquid and ice optical thickness in each layer + ! + ! Note: this simulator operates on all points; to match MODIS itself night-time + ! points should be excluded + ! + ! Note: the simulator requires as input the optical thickness and cloud top pressure + ! derived from the ISCCP simulator run with parameter top_height = 1. + ! If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing + ! and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that + ! alogrithm in this simulator we simply report the values from the ISCCP simulator. + ! ######################################################################################## + subroutine modis_subcolumn(nSubCols, nLevels, pressureLevels, optical_thickness, & + tauLiquidFraction, g, w0,isccpCloudTopPressure, & + retrievedPhase, retrievedCloudTopPressure, & + retrievedTau, retrievedSize) + + ! INPUTS + integer,intent(in) :: & + nSubCols, & ! Number of subcolumns + nLevels ! Number of levels + real(wp),dimension(nLevels+1),intent(in) :: & + pressureLevels ! Gridmean pressure at layer edges (Pa) + real(wp),dimension(nSubCols,nLevels),intent(in) :: & + optical_thickness, & ! Subcolumn optical thickness @ 0.67 microns. + tauLiquidFraction, & ! Liquid water fraction + g, & ! Subcolumn assymetry parameter + w0 ! Subcolumn single-scattering albedo + real(wp),dimension(nSubCols),intent(in) :: & + isccpCloudTopPressure ! ISCCP retrieved cloud top pressure (Pa) + + ! OUTPUTS + integer, dimension(nSubCols), intent(inout) :: & + retrievedPhase ! MODIS retrieved phase (liquid/ice/other) + real(wp),dimension(nSubCols), intent(inout) :: & + retrievedCloudTopPressure, & ! MODIS retrieved CTP (Pa) + retrievedTau, & ! MODIS retrieved optical depth (unitless) + retrievedSize ! MODIS retrieved particle size (microns) + + ! LOCAL VARIABLES + logical, dimension(nSubCols) :: & + cloudMask + real(wp) :: & + integratedLiquidFraction, & + obs_Refl_nir + real(wp),dimension(num_trial_res) :: & + predicted_Refl_nir + integer :: & + i + + ! ######################################################################################## + ! Optical depth retrieval + ! This is simply a sum over the optical thickness in each layer. + ! It should agree with the ISCCP values after min values have been excluded. + ! ######################################################################################## + retrievedTau(1:nSubCols) = sum(optical_thickness(1:nSubCols,1:nLevels), dim = 2) + + ! ######################################################################################## + ! Cloud detection + ! does optical thickness exceed detection threshold? + ! ######################################################################################## + cloudMask = retrievedTau(1:nSubCols) >= min_OpticalThickness + + do i = 1, nSubCols + if(cloudMask(i)) then + ! ################################################################################## + ! Cloud top pressure determination + ! MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal + ! methods for clouds lower than that. For CO2 slicing we report the optical-depth + ! weighted pressure, integrating to a specified optical depth. + ! This assumes linear variation in p between levels. Linear in ln(p) is probably + ! better, though we'd need to deal with the lowest pressure gracefully. + ! ################################################################################## + retrievedCloudTopPressure(i) = cloud_top_pressure(nLevels,(/ 0._wp, optical_thickness(i,1:nLevels) /), & + pressureLevels(1:nLevels),CO2Slicing_TauLimit) + + ! ################################################################################## + ! Phase determination + ! Determine fraction of total tau that's liquid when ice and water contribute about + ! equally to the extinction we can't tell what the phase is. + ! ################################################################################## + integratedLiquidFraction = weight_by_extinction(nLevels,optical_thickness(i,1:nLevels), & + tauLiquidFraction(i, 1:nLevels), & + phase_TauLimit) + if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsLiquid + else if (integratedLiquidFraction <= 1._wp- phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsIce + else + retrievedPhase(i) = phaseIsUndetermined + end if + + ! ################################################################################## + ! Size determination + ! ################################################################################## + + ! Compute observed reflectance + obs_Refl_nir = compute_toa_reflectace(nLevels,optical_thickness(i,1:nLevels), g(i,1:nLevels), w0(i,1:nLevels)) + + ! Compute predicted reflectance + if(any(retrievedPhase(i) == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then + if (retrievedPhase(i) == phaseIsLiquid .OR. retrievedPhase(i) == phaseIsUndetermined) then + predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), & + g_w(1:num_trial_res), w0_w(1:num_trial_res)) + retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_w(1:num_trial_res), & + predicted_Refl_nir(1:num_trial_res), obs_Refl_nir) + else + predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), & + g_i(1:num_trial_res), w0_i(1:num_trial_res)) + retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_i(1:num_trial_res), & + predicted_Refl_nir(1:num_trial_res), obs_Refl_nir) + endif + else + retrievedSize(i) = re_fill + endif + else + ! Values when we don't think there's a cloud. + retrievedCloudTopPressure(i) = R_UNDEF + retrievedPhase(i) = phaseIsNone + retrievedSize(i) = R_UNDEF + retrievedTau(i) = R_UNDEF + end if + end do + where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) & + retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill + + ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS + ! mimics what MODIS does to first order. + ! Of course, ISCCP cloud top pressures are in mb. + where(cloudMask(1:nSubCols) .and. retrievedCloudTopPressure(1:nSubCols) > CO2Slicing_PressureLimit) & + retrievedCloudTopPressure(1:nSubCols) = isccpCloudTopPressure! * 100._wp + + end subroutine modis_subcolumn + + ! ######################################################################################## + subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size, & + Cloud_Fraction_Total_Mean, Cloud_Fraction_Water_Mean, Cloud_Fraction_Ice_Mean, & + Cloud_Fraction_High_Mean, Cloud_Fraction_Mid_Mean, Cloud_Fraction_Low_Mean, & + Optical_Thickness_Total_Mean, Optical_Thickness_Water_Mean, Optical_Thickness_Ice_Mean, & + Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,& + Cloud_Particle_Size_Water_Mean, Cloud_Particle_Size_Ice_Mean, Cloud_Top_Pressure_Total_Mean, & + Liquid_Water_Path_Mean, Ice_Water_Path_Mean, & + Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq) + + ! INPUTS + integer,intent(in) :: & + nPoints, & ! Number of horizontal gridpoints + nSubCols ! Number of subcolumns + integer,intent(in), dimension(nPoints, nSubCols) :: & + phase + real(wp),intent(in),dimension(nPoints, nSubCols) :: & + cloud_top_pressure, & + optical_thickness, & + particle_size + + ! OUTPUTS + real(wp),intent(inout),dimension(nPoints) :: & ! + Cloud_Fraction_Total_Mean, & ! + Cloud_Fraction_Water_Mean, & ! + Cloud_Fraction_Ice_Mean, & ! + Cloud_Fraction_High_Mean, & ! + Cloud_Fraction_Mid_Mean, & ! + Cloud_Fraction_Low_Mean, & ! + Optical_Thickness_Total_Mean, & ! + Optical_Thickness_Water_Mean, & ! + Optical_Thickness_Ice_Mean, & ! + Optical_Thickness_Total_MeanLog10, & ! + Optical_Thickness_Water_MeanLog10, & ! + Optical_Thickness_Ice_MeanLog10, & ! + Cloud_Particle_Size_Water_Mean, & ! + Cloud_Particle_Size_Ice_Mean, & ! + Cloud_Top_Pressure_Total_Mean, & ! + Liquid_Water_Path_Mean, & ! + Ice_Water_Path_Mean ! + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISPresBins) :: & + Optical_Thickness_vs_Cloud_Top_Pressure + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffIceBins) :: & + Optical_Thickness_vs_ReffIce + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffLiqBins) :: & + Optical_Thickness_vs_ReffLiq + + ! LOCAL VARIABLES + real(wp), parameter :: & + LWP_conversion = 2._wp/3._wp * 1000._wp ! MKS units + integer :: j + logical, dimension(nPoints,nSubCols) :: & + cloudMask, & + waterCloudMask, & + iceCloudMask, & + validRetrievalMask + real(wp),dimension(nPoints,nSubCols) :: & + tauWRK,ctpWRK,reffIceWRK,reffLiqWRK + + ! ######################################################################################## + ! Include only those pixels with successful retrievals in the statistics + ! ######################################################################################## + validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0. + cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + iceCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsIce .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + + ! ######################################################################################## + ! Use these as pixel counts at first + ! ######################################################################################## + Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask, dim = 2)) + Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2)) + Cloud_Fraction_Ice_Mean(1:nPoints) = real(count(iceCloudMask, dim = 2)) + Cloud_Fraction_High_Mean(1:nPoints) = real(count(cloudMask .and. cloud_top_pressure <= & + highCloudPressureLimit, dim = 2)) + Cloud_Fraction_Low_Mean(1:nPoints) = real(count(cloudMask .and. cloud_top_pressure > & + lowCloudPressureLimit, dim = 2)) + Cloud_Fraction_Mid_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)& + - Cloud_Fraction_Low_Mean(1:nPoints) + + ! ######################################################################################## + ! Compute column amounts. + ! ######################################################################################## + where(Cloud_Fraction_Total_Mean(1:nPoints) > 0) + Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask, dim = 2) / & + Cloud_Fraction_Total_Mean(1:nPoints) + Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, & + dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints) + elsewhere + Optical_Thickness_Total_Mean = R_UNDEF + Optical_Thickness_Total_MeanLog10 = R_UNDEF + endwhere + where(Cloud_Fraction_Water_Mean(1:nPoints) > 0) + Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, & + mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints) + Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,& + dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints) + Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + elsewhere + Optical_Thickness_Water_Mean = R_UNDEF + Optical_Thickness_Water_MeanLog10 = R_UNDEF + Cloud_Particle_Size_Water_Mean = R_UNDEF + Liquid_Water_Path_Mean = R_UNDEF + endwhere + where(Cloud_Fraction_Ice_Mean(1:nPoints) > 0) + Optical_Thickness_Ice_Mean(1:nPoints) = sum(optical_thickness, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,& + mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints) + Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,& + dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints) + Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + elsewhere + Optical_Thickness_Ice_Mean = R_UNDEF + Optical_Thickness_Ice_MeanLog10 = R_UNDEF + Cloud_Particle_Size_Ice_Mean = R_UNDEF + Ice_Water_Path_Mean = R_UNDEF + endwhere + Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / & + max(1, count(cloudMask, dim = 2)) + + ! ######################################################################################## + ! Normalize pixel counts to fraction. + ! ######################################################################################## + Cloud_Fraction_High_Mean(1:nPoints) = Cloud_Fraction_High_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Mid_Mean(1:nPoints) = Cloud_Fraction_Mid_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Low_Mean(1:nPoints) = Cloud_Fraction_Low_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Ice_Mean(1:nPoints) = Cloud_Fraction_Ice_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols + + ! ######################################################################################## + ! Joint histograms + ! ######################################################################################## + ! Loop over all points + tauWRK(1:nPoints,1:nSubCols) = optical_thickness(1:nPoints,1:nSubCols) + ctpWRK(1:nPoints,1:nSubCols) = cloud_top_pressure(1:nPoints,1:nSubCols) + reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask) + reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask) + do j=1,nPoints + + ! Fill clear and optically thin subcolumns with fill + where(.not. cloudMask(j,1:nSubCols)) + tauWRK(j,1:nSubCols) = -999._wp + ctpWRK(j,1:nSubCols) = -999._wp + endwhere + ! Joint histogram of tau/CTP + call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,& + modis_histTau,numMODISTauBins,& + modis_histPres,numMODISPresBins,& + Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numMODISTauBins,1:numMODISPresBins)) + ! Joint histogram of tau/ReffICE + call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols, & + modis_histTau,numMODISTauBins,modis_histReffIce, & + numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numMODISTauBins,1:numMODISReffIceBins)) + ! Joint histogram of tau/ReffLIQ + call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols, & + modis_histTau,numMODISTauBins,modis_histReffLiq, & + numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numMODISTauBins,1:numMODISReffLiqBins)) + + enddo + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins) = & + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins)/nSubCols + Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins) = & + Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins)/nSubCols + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins) = & + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins)/nSubCols + + + ! Unit conversion + where(Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) & + Optical_Thickness_vs_Cloud_Top_Pressure = Optical_Thickness_vs_Cloud_Top_Pressure*100._wp + where(Optical_Thickness_vs_ReffIce /= R_UNDEF) Optical_Thickness_vs_ReffIce = Optical_Thickness_vs_ReffIce*100._wp + where(Optical_Thickness_vs_ReffLiq /= R_UNDEF) Optical_Thickness_vs_ReffLiq = Optical_Thickness_vs_ReffLiq*100._wp + where(Cloud_Fraction_Total_Mean /= R_UNDEF) Cloud_Fraction_Total_Mean = Cloud_Fraction_Total_Mean*100._wp + where(Cloud_Fraction_Water_Mean /= R_UNDEF) Cloud_Fraction_Water_Mean = Cloud_Fraction_Water_Mean*100._wp + where(Cloud_Fraction_Ice_Mean /= R_UNDEF) Cloud_Fraction_Ice_Mean = Cloud_Fraction_Ice_Mean*100._wp + where(Cloud_Fraction_High_Mean /= R_UNDEF) Cloud_Fraction_High_Mean = Cloud_Fraction_High_Mean*100._wp + where(Cloud_Fraction_Mid_Mean /= R_UNDEF) Cloud_Fraction_Mid_Mean = Cloud_Fraction_Mid_Mean*100._wp + where(Cloud_Fraction_Low_Mean /= R_UNDEF) Cloud_Fraction_Low_Mean = Cloud_Fraction_Low_Mean*100._wp + + end subroutine modis_column + + ! ######################################################################################## + function cloud_top_pressure(nLevels,tauIncrement, pressure, tauLimit) + ! INPUTS + integer, intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tauIncrement, pressure + real(wp),intent(in) :: tauLimit + ! OUTPUTS + real(wp) :: cloud_top_pressure + ! LOCAL VARIABLES + real(wp) :: deltaX, totalTau, totalProduct + integer :: i + + ! Find the extinction-weighted pressure. Assume that pressure varies linearly between + ! layers and use the trapezoidal rule. + totalTau = 0._wp; totalProduct = 0._wp + do i = 2, size(tauIncrement) + if(totalTau + tauIncrement(i) > tauLimit) then + deltaX = tauLimit - totalTau + totalTau = totalTau + deltaX + ! + ! Result for trapezoidal rule when you take less than a full step + ! tauIncrement is a layer-integrated value + ! + totalProduct = totalProduct & + + pressure(i-1) * deltaX & + + (pressure(i) - pressure(i-1)) * deltaX**2/(2._wp * tauIncrement(i)) + else + totalTau = totalTau + tauIncrement(i) + totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2._wp + end if + if(totalTau >= tauLimit) exit + end do + + if (totalTau > 0._wp) then + cloud_top_pressure = totalProduct/totalTau + else + cloud_top_pressure = 0._wp + endif + + end function cloud_top_pressure + + ! ######################################################################################## + function weight_by_extinction(nLevels,tauIncrement, f, tauLimit) + ! INPUTS + integer, intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tauIncrement, f + real(wp),intent(in) :: tauLimit + ! OUTPUTS + real(wp) :: weight_by_extinction + ! LOCAL VARIABLES + real(wp) :: deltaX, totalTau, totalProduct + integer :: i + + ! Find the extinction-weighted value of f(tau), assuming constant f within each layer + totalTau = 0._wp; totalProduct = 0._wp + do i = 1, size(tauIncrement) + if(totalTau + tauIncrement(i) > tauLimit) then + deltaX = tauLimit - totalTau + totalTau = totalTau + deltaX + totalProduct = totalProduct + deltaX * f(i) + else + totalTau = totalTau + tauIncrement(i) + totalProduct = totalProduct + tauIncrement(i) * f(i) + end if + if(totalTau >= tauLimit) exit + end do + + if (totalTau > 0._wp) then + weight_by_extinction = totalProduct/totalTau + else + weight_by_extinction = 0._wp + endif + + end function weight_by_extinction + + ! ######################################################################################## + pure function interpolate_to_min(x, y, yobs) + ! INPUTS + real(wp),intent(in),dimension(num_trial_res) :: x, y + real(wp),intent(in) :: yobs + ! OUTPUTS + real(wp) :: interpolate_to_min + ! LOCAL VARIABLES + real(wp), dimension(num_trial_res) :: diff + integer :: nPoints, minDiffLoc, lowerBound, upperBound + + ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs) + ! y must be monotonic in x + + nPoints = size(y) + diff(1:num_trial_res) = y(1:num_trial_res) - yobs + minDiffLoc = minloc(abs(diff), dim = 1) + + if(minDiffLoc == 1) then + lowerBound = minDiffLoc + upperBound = minDiffLoc + 1 + else if(minDiffLoc == nPoints) then + lowerBound = minDiffLoc - 1 + upperBound = minDiffLoc + else + if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then + lowerBound = minDiffLoc-1 + upperBound = minDiffLoc + else + lowerBound = minDiffLoc + upperBound = minDiffLoc + 1 + end if + end if + + if(diff(lowerBound) * diff(upperBound) < 0) then + ! + ! Interpolate the root position linearly if we bracket the root + ! + interpolate_to_min = x(upperBound) - & + diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound)) + else + interpolate_to_min = re_fill + end if + + + end function interpolate_to_min + + ! ######################################################################################## + ! Optical properties + ! ######################################################################################## + elemental function get_g_nir_old (phase, re) + ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + + ! INPUTS + integer, intent(in) :: phase + real(wp),intent(in) :: re + ! OUTPUTS + real(wp) :: get_g_nir_old + ! LOCAL VARIABLES(parameters) + real(wp), dimension(3), parameter :: & + ice_coefficients = (/ 0.7432, 4.5563e-3, -2.8697e-5 /), & + small_water_coefficients = (/ 0.8027, -1.0496e-2, 1.7071e-3 /), & + big_water_coefficients = (/ 0.7931, 5.3087e-3, -7.4995e-5 /) + + ! approx. fits from MODIS Collection 5 LUT scattering calculations + if(phase == phaseIsLiquid) then + if(re < 8.) then + get_g_nir_old = fit_to_quadratic(re, small_water_coefficients) + if(re < re_water_min) get_g_nir_old = fit_to_quadratic(re_water_min, small_water_coefficients) + else + get_g_nir_old = fit_to_quadratic(re, big_water_coefficients) + if(re > re_water_max) get_g_nir_old = fit_to_quadratic(re_water_max, big_water_coefficients) + end if + else + get_g_nir_old = fit_to_quadratic(re, ice_coefficients) + if(re < re_ice_min) get_g_nir_old = fit_to_quadratic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_g_nir_old = fit_to_quadratic(re_ice_max, ice_coefficients) + end if + + end function get_g_nir_old + + ! ######################################################################################## + elemental function get_ssa_nir_old (phase, re) + ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + + ! INPUTS + integer, intent(in) :: phase + real(wp),intent(in) :: re + ! OUTPUTS + real(wp) :: get_ssa_nir_old + ! LOCAL VARIABLES (parameters) + real(wp), dimension(4), parameter :: ice_coefficients = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /) + real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) + + ! approx. fits from MODIS Collection 5 LUT scattering calculations + if(phase == phaseIsLiquid) then + get_ssa_nir_old = fit_to_quadratic(re, water_coefficients) + if(re < re_water_min) get_ssa_nir_old = fit_to_quadratic(re_water_min, water_coefficients) + if(re > re_water_max) get_ssa_nir_old = fit_to_quadratic(re_water_max, water_coefficients) + else + get_ssa_nir_old = fit_to_cubic(re, ice_coefficients) + if(re < re_ice_min) get_ssa_nir_old = fit_to_cubic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_ssa_nir_old = fit_to_cubic(re_ice_max, ice_coefficients) + end if + + end function get_ssa_nir_old + + elemental function get_g_nir (phase, re) + ! + ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + ! + + integer, intent(in) :: phase + real(wp), intent(in) :: re + real(wp) :: get_g_nir + + real(wp), dimension(3), parameter :: ice_coefficients = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), & + small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /) + real(wp), dimension(4), parameter :: big_water_coefficients = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /) + + ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals + if(phase == phaseIsLiquid) then + if(re < 7.) then + get_g_nir = fit_to_quadratic(re, small_water_coefficients) + if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients) + else + get_g_nir = fit_to_cubic(re, big_water_coefficients) + if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients) + end if + else + get_g_nir = fit_to_quadratic(re, ice_coefficients) + if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients) + end if + + end function get_g_nir + + ! -------------------------------------------- + elemental function get_ssa_nir (phase, re) + integer, intent(in) :: phase + real(wp), intent(in) :: re + real(wp) :: get_ssa_nir + ! + ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + ! + real(wp), dimension(4), parameter :: ice_coefficients = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/) + real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /) + + ! approx. fits from MODIS Collection 6 LUT scattering calculations + if(phase == phaseIsLiquid) then + get_ssa_nir = fit_to_quadratic(re, water_coefficients) + if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients) + if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients) + else + get_ssa_nir = fit_to_cubic(re, ice_coefficients) + if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients) + end if + + end function get_ssa_nir + + + + ! ######################################################################################## + pure function fit_to_cubic(x, coefficients) + ! INPUTS + real(wp), intent(in) :: x + real(wp), dimension(4), intent(in) :: coefficients + ! OUTPUTS + real(wp) :: fit_to_cubic + + fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4))) + end function fit_to_cubic + + ! ######################################################################################## + pure function fit_to_quadratic(x, coefficients) + ! INPUTS + real(wp), intent(in) :: x + real(wp), dimension(3), intent(in) :: coefficients + ! OUTPUTS + real(wp) :: fit_to_quadratic + + fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3))) + end function fit_to_quadratic + + ! ######################################################################################## + ! Radiative transfer + ! ######################################################################################## + pure function compute_toa_reflectace(nLevels,tau, g, w0) + ! This wrapper reports reflectance only and strips out non-cloudy elements from the + ! calculation + + ! INPUTS + integer,intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tau, g, w0 + ! OUTPUTS + real(wp) :: compute_toa_reflectace + ! LOCAL VARIABLES + logical, dimension(nLevels) :: cloudMask + integer, dimension(count(tau(1:nLevels) > 0)) :: cloudIndicies + real(wp),dimension(count(tau(1:nLevels) > 0)) :: Refl,Trans + real(wp) :: Refl_tot, Trans_tot + integer :: i + + cloudMask(1:nLevels) = tau(1:nLevels) > 0. + cloudIndicies = pack((/ (i, i = 1, nLevels) /), mask = cloudMask) + do i = 1, size(cloudIndicies) + call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i)) + end do + + call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot) + + compute_toa_reflectace = Refl_tot + + end function compute_toa_reflectace + + ! ######################################################################################## + pure subroutine two_stream(tauint, gint, w0int, ref, tra) + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + ! INPUTS + real(wp), intent(in) :: tauint, gint, w0int + ! OUTPUTS + real(wp), intent(out) :: ref, tra + ! LOCAL VARIABLES + ! for delta Eddington code + ! xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1) + integer, parameter :: beam = 2 + real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, & + rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th + + ! Compute reflectance and transmittance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + f = gint**2 + tau = (1._wp - w0int * f) * tauint + w0 = (1._wp - f) * w0int / (1._wp - w0int * f) + g = (gint - f) / (1._wp - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp + gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp + gamma3 = (2._wp - 3._wp*g*xmu) / 4._wp + gamma4 = 1._wp - gamma3 + + if (w0int > minConservativeW0) then + ! Conservative scattering + if (beam == 1) then + rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) + + ref = rh / (1._wp + gamma1 * tau) + tra = 1._wp - ref + else if(beam == 2) then + ref = gamma1*tau/(1._wp + gamma1*tau) + tra = 1._wp - ref + endif + else + ! Non-conservative scattering + a1 = gamma1 * gamma4 + gamma2 * gamma3 + a2 = gamma1 * gamma3 + gamma2 * gamma4 + + rk = sqrt(gamma1**2 - gamma2**2) + + r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3) + r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3) + r3 = 2._wp * rk *(gamma3 - a2 * xmu) + r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1) + r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4) + t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4) + t3 = 2._wp * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500._wp) + e2 = min(tau / xmu, 500._wp) + + if (beam == 1) then + den = r4 * exp(e1) + r5 * exp(-e1) + ref = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den + den = t4 * exp(e1) + t5 * exp(-e1) + th = exp(-e2) + tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den + elseif (beam == 2) then + ef1 = exp(-e1) + ef2 = exp(-2*e1) + ref = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2)) + tra = (2._wp*rk*ef1)/((rk+gamma1)*(1._wp-beta*ef2)) + endif + end if + end subroutine two_stream + + ! ######################################################################################## + elemental function two_stream_reflectance(tauint, gint, w0int) + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + + ! INPUTS + real(wp), intent(in) :: tauint, gint, w0int + ! OUTPUTS + real(wp) :: two_stream_reflectance + ! LOCAL VARIABLES + ! for delta Eddington code + ! xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1) + integer, parameter :: beam = 2 + real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, & + rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den + + f = gint**2 + tau = (1._wp - w0int * f) * tauint + w0 = (1._wp - f) * w0int / (1._wp - w0int * f) + g = (gint - f) / (1._wp - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp + gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp + gamma3 = (2._wp - 3._wp*g*xmu) / 4._wp + gamma4 = 1._wp - gamma3 + + if (w0int > minConservativeW0) then + ! Conservative scattering + if (beam == 1) then + rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) + two_stream_reflectance = rh / (1._wp + gamma1 * tau) + elseif (beam == 2) then + two_stream_reflectance = gamma1*tau/(1._wp + gamma1*tau) + endif + + else ! + + ! Non-conservative scattering + a1 = gamma1 * gamma4 + gamma2 * gamma3 + a2 = gamma1 * gamma3 + gamma2 * gamma4 + + rk = sqrt(gamma1**2 - gamma2**2) + + r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3) + r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3) + r3 = 2._wp * rk *(gamma3 - a2 * xmu) + r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1) + r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4) + t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4) + t3 = 2._wp * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500._wp) + e2 = min(tau / xmu, 500._wp) + + if (beam == 1) then + den = r4 * exp(e1) + r5 * exp(-e1) + two_stream_reflectance = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den + elseif (beam == 2) then + ef1 = exp(-e1) + ef2 = exp(-2*e1) + two_stream_reflectance = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2)) + endif + + end if + end function two_stream_reflectance + + ! ######################################################################################## + pure subroutine adding_doubling (npts,Refl, Tran, Refl_tot, Tran_tot) + ! Use adding/doubling formulas to compute total reflectance and transmittance from + ! layer values + + ! INPUTS + integer,intent(in) :: npts + real(wp),intent(in),dimension(npts) :: Refl,Tran + ! OUTPUTS + real(wp),intent(out) :: Refl_tot, Tran_tot + ! LOCAL VARIABLES + integer :: i + real(wp), dimension(npts) :: Refl_cumulative, Tran_cumulative + + Refl_cumulative(1) = Refl(1) + Tran_cumulative(1) = Tran(1) + + do i=2, npts + ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface): + Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i)) + Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i)) + end do + + Refl_tot = Refl_cumulative(size(Refl)) + Tran_tot = Tran_cumulative(size(Refl)) + + end subroutine adding_doubling + +end module mod_modis_sim diff --git a/src/physics/cosp2/src/simulator/README b/src/physics/cosp2/src/simulator/README new file mode 100644 index 0000000000..733c2188d9 --- /dev/null +++ b/src/physics/cosp2/src/simulator/README @@ -0,0 +1,14 @@ +Overview: This directory contains codes that interface between COSP and +the instrument simulators. + +Subdirectories hold the core of each simulator, as listed below. The interface +between COSP and each simulator is in this directory. + +Subdirectories: +actsim/: LIDAR simulator source code +icarus/: ISCCP simulator source code +MISR_simulator/: MISR simulator source code +MODIS_simulator/: MODIS simulator source code +parasol/: PARASOL simulator source code +quickbeam/: RADAR simulator source code +rttov/: RTTOV simulator interface (RTTOV source is NOT distributed with COSP!) diff --git a/src/physics/cosp2/src/simulator/actsim/lidar_simulator.F90 b/src/physics/cosp2/src/simulator/actsim/lidar_simulator.F90 new file mode 100644 index 0000000000..51f381e706 --- /dev/null +++ b/src/physics/cosp2/src/simulator/actsim/lidar_simulator.F90 @@ -0,0 +1,1025 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony +! +! May 2008, H. Chepfer: +! - Units of pressure inputs: Pa +! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients +! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical) +! +! June 2008, A. Bodas-Salcedo: +! - Ported to Fortran 90 and optimisation changes +! +! August 2008, J-L Dufresne: +! - Optimisation changes (sum instructions suppressed) +! +! October 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Interface with COSP v2.0: +! cloud fraction removed from inputs +! in-cloud condensed water now in input (instead of grid-averaged value) +! depolarisation diagnostic removed +! parasol (polder) reflectances (for 5 different solar zenith angles) added +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Modification of the integration of the lidar equation. +! - change the cloud detection threshold +! +! April 2008, A. Bodas-Salcedo: +! - Bug fix in computation of pmol and pnorm of upper layer +! +! April 2008, J-L. Dufresne +! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 +! was missing. This affects the ATB values but not the cloud fraction. +! +! January 2013, G. Cesana and H. Chepfer: +! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments +! - Add the temperature for each levels (temp) in the arguments +! - Add the computation of the perpendicular component of the backscattered lidar signal +! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase +! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376 +! +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_lidar_simulator + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: SR_BINS,S_CLD,S_ATT,S_CLD_ATT,R_UNDEF,calipso_histBsct, & + use_vgrid,vgrid_zl,vgrid_zu + USE MOD_COSP_STATS, ONLY: COSP_CHANGE_VERTICAL_GRID,hist1d + implicit none + + ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the + ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles + ! derived from CALIPSO-GOCCP observations at 120m vertical grid + ! (Cesana and Chepfer, JGR, 2013). + ! + ! Relationship between ATBice and ATBperp,ice for ice particles: + ! ATBperp,ice = Alpha*ATBice + ! Relationship between ATBice and ATBperp,ice for liquid particles: + ! ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice + real(wp) :: & + alpha,beta,gamma + +contains + ! ###################################################################################### + ! SUBROUTINE lidar_subcolumn + ! Inputs with a vertical dimensions (nlev) should ordered in along the vertical + ! dimension from TOA-2-SFC, for example: varIN(nlev) is varIN @ SFC. + ! ###################################################################################### + subroutine lidar_subcolumn(npoints,ncolumns,nlev,beta_mol,tau_mol,betatot,tautot, & + betatot_ice,tautot_ice,betatot_liq,tautot_liq, & + pmol,pnorm,pnorm_perp_tot) + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of gridpoints + ncolumns, & ! Number of subcolumns + nlev ! Number of levels + REAL(WP),intent(in),dimension(npoints,nlev) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + + REAL(WP),intent(in),dimension(npoints,ncolumns,nlev) :: & + betatot, & ! + tautot, & ! Optical thickess integrated from top + betatot_ice, & ! Backscatter coefficient for ice particles + betatot_liq, & ! Backscatter coefficient for liquid particles + tautot_ice, & ! Total optical thickness of ice + tautot_liq ! Total optical thickness of liq + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,nlev) :: & + pmol ! Molecular attenuated backscatter lidar signal power(m^-1.sr^-1) + REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: & + pnorm, & ! Molecular backscatter signal power (m^-1.sr^-1) + pnorm_perp_tot ! Perpendicular lidar backscattered signal power + + ! LOCAL VARIABLES + INTEGER :: k,icol + REAL(WP),dimension(npoints) :: & + tautot_lay ! + REAL(WP),dimension(npoints,ncolumns,nlev) :: & + pnorm_liq, & ! Lidar backscattered signal power for liquid + pnorm_ice, & ! Lidar backscattered signal power for ice + pnorm_perp_ice, & ! Perpendicular lidar backscattered signal power for ice + pnorm_perp_liq, & ! Perpendicular lidar backscattered signal power for liq + beta_perp_ice, & ! Perpendicular backscatter coefficient for ice + beta_perp_liq ! Perpendicular backscatter coefficient for liquid + + ! #################################################################################### + ! *) Molecular signal + ! #################################################################################### + call cmp_backsignal(nlev,npoints,beta_mol(1:npoints,1:nlev),& + tau_mol(1:npoints,1:nlev),pmol(1:npoints,1:nlev)) + + ! #################################################################################### + ! PLANE PARRALLEL FIELDS + ! #################################################################################### + do icol=1,ncolumns + ! ################################################################################# + ! *) Total Backscatter signal + ! ################################################################################# + call cmp_backsignal(nlev,npoints,betatot(1:npoints,icol,1:nlev),& + tautot(1:npoints,icol,1:nlev),pnorm(1:npoints,icol,1:nlev)) + ! ################################################################################# + ! *) Ice/Liq Backscatter signal + ! ################################################################################# + ! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq) + ! Ice only + call cmp_backsignal(nlev,npoints,betatot_ice(1:npoints,icol,1:nlev),& + tautot_ice(1:npoints,icol,1:nlev),& + pnorm_ice(1:npoints,icol,1:nlev)) + ! Liquid only + call cmp_backsignal(nlev,npoints,betatot_liq(1:npoints,icol,1:nlev),& + tautot_liq(1:npoints,icol,1:nlev),& + pnorm_liq(1:npoints,icol,1:nlev)) + enddo + + ! #################################################################################### + ! PERDENDICULAR FIELDS + ! #################################################################################### + do icol=1,ncolumns + + ! ################################################################################# + ! *) Ice/Liq Perpendicular Backscatter signal + ! ################################################################################# + ! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering + ! contribution (Cesana and Chepfer 2013, JGR) + do k=1,nlev + ! Ice particles + pnorm_perp_ice(1:npoints,icol,k) = Alpha * pnorm_ice(1:npoints,icol,k) + + ! Liquid particles + pnorm_perp_liq(1:npoints,icol,k) = 1000._wp*Beta*pnorm_liq(1:npoints,icol,k)**2+& + Gamma*pnorm_liq(1:npoints,icol,k) + enddo + + ! ################################################################################# + ! *) Computation of beta_perp_ice/liq using the lidar equation + ! ################################################################################# + ! Ice only + call cmp_beta(nlev,npoints,pnorm_perp_ice(1:npoints,icol,1:nlev),& + tautot_ice(1:npoints,icol,1:nlev),beta_perp_ice(1:npoints,icol,1:nlev)) + + ! Liquid only + call cmp_beta(nlev,npoints,pnorm_perp_liq(1:npoints,icol,1:nlev),& + tautot_liq(1:npoints,icol,1:nlev),beta_perp_liq(1:npoints,icol,1:nlev)) + + ! ################################################################################# + ! *) Perpendicular Backscatter signal + ! ################################################################################# + ! Computation of the total perpendicular lidar signal (ATBperp for liq+ice) + ! Upper layer + WHERE(tautot(1:npoints,icol,1) .gt. 0) + pnorm_perp_tot(1:npoints,icol,1) = (beta_perp_ice(1:npoints,icol,1)+ & + beta_perp_liq(1:npoints,icol,1)- & + (beta_mol(1:npoints,1)/(1._wp+1._wp/0.0284_wp))) / & + (2._wp*tautot(1:npoints,icol,1))* & + (1._wp-exp(-2._wp*tautot(1:npoints,icol,1))) + ELSEWHERE + pnorm_perp_tot(1:npoints,icol,1) = 0._wp + ENDWHERE + + ! Other layers + do k=2,nlev + ! Optical thickness of layer k + tautot_lay(1:npoints) = tautot(1:npoints,icol,k)-tautot(1:npoints,icol,k-1) + + ! The perpendicular component of the molecular backscattered signal (Betaperp) + ! has been taken into account two times (once for liquid and once for ice). + ! We remove one contribution using + ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following + ! equations: + WHERE (pnorm(1:npoints,icol,k) .eq. 0) + pnorm_perp_tot(1:npoints,icol,k)=0._wp + ELSEWHERE + where(tautot_lay(1:npoints) .gt. 0.) + pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+ & + beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/ & + 0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))/ & + (2._wp*tautot_lay(1:npoints))* (1._wp-EXP(-2._wp*tautot_lay(1:npoints))) + elsewhere + pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+ & + beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/ & + 0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1)) + endwhere + ENDWHERE + END DO + enddo + end subroutine lidar_subcolumn + + ! ###################################################################################### + ! SUBROUTINE lidar_column + ! ###################################################################################### + subroutine lidar_column(npoints,ncol,nlevels,llm,max_bin,tmp, pnorm, & + pnorm_perp, pmol, pplay, ok_lidar_cfad, ncat, cfad2, & + lidarcld, lidarcldphase, cldlayer, zlev, zlev_half, & + cldlayerphase, lidarcldtmp) + integer,parameter :: & + nphase = 6 ! Number of cloud layer phase types + + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncol, & ! Number of subcolumns + nlevels, & ! Number of vertical layers (OLD grid) + llm, & ! Number of vertical layers (NEW grid) + max_bin, & ! Number of bins for SR CFADs + ncat ! Number of cloud layer types (low,mid,high,total) + real(wp),intent(in),dimension(npoints,ncol,Nlevels) :: & + pnorm, & ! Lidar ATB + pnorm_perp ! Lidar perpendicular ATB + real(wp),intent(in),dimension(npoints,Nlevels) :: & + pmol, & ! Molecular ATB + pplay, & ! Pressure on model levels (Pa) + tmp ! Temperature at each levels + logical,intent(in) :: & + ok_lidar_cfad ! True if lidar CFAD diagnostics need to be computed + real(wp),intent(in),dimension(npoints,nlevels) :: & + zlev ! Model full levels + real(wp),intent(in),dimension(npoints,nlevels+1) :: & + zlev_half ! Model half levels + + ! Outputs + real(wp),intent(inout),dimension(npoints,llm) :: & + lidarcld ! 3D "lidar" cloud fraction + real(wp),intent(inout),dimension(npoints,ncat) :: & + cldlayer ! "lidar" cloud layer fraction (low, mid, high, total) + real(wp),intent(inout),dimension(npoints,llm,nphase) :: & + lidarcldphase ! 3D "lidar" phase cloud fraction + real(wp),intent(inout),dimension(npoints,40,5) :: & + lidarcldtmp ! 3D "lidar" phase cloud fraction as a function of temp + real(wp),intent(inout),dimension(npoints,ncat,nphase) :: & + cldlayerphase ! "lidar" phase low mid high cloud fraction + real(wp),intent(inout),dimension(npoints,max_bin,llm) :: & + cfad2 ! CFADs of SR + + ! Local Variables + integer :: ic,i,j + real(wp),dimension(npoints,ncol,llm) :: & + x3d + real(wp),dimension(npoints,llm) :: & + x3d_c,pnorm_c + real(wp) :: & + xmax + real(wp),dimension(npoints,1,Nlevels) :: t_in,ph_in,betamol_in + real(wp),dimension(npoints,ncol,llm) :: pnormFlip,pnorm_perpFlip + real(wp),dimension(npoints,1,llm) :: tmpFlip,pplayFlip,betamolFlip + + ! Vertically regrid input data + if (use_vgrid) then + t_in(:,1,:)=tmp(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + t_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),tmpFlip(:,1,llm:1:-1)) + ph_in(:,1,:) = pplay(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + ph_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pplayFlip(:,1,llm:1:-1)) + betamol_in(:,1,:) = pmol(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + betamol_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),betamolFlip(:,1,llm:1:-1)) + call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + pnorm(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnormFlip(:,:,llm:1:-1)) + call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + pnorm_perp(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnorm_perpFlip(:,:,llm:1:-1)) + endif + + ! Initialization (The histogram bins, are set up during initialization and the + ! maximum value is used as the upper bounds.) + xmax = maxval(calipso_histBsct) + + ! Compute LIDAR scattering ratio + if (use_vgrid) then + do ic = 1, ncol + pnorm_c = pnormFlip(:,ic,:) + where ((pnorm_c .lt. xmax) .and. (betamolFlip(:,1,:) .lt. xmax) .and. & + (betamolFlip(:,1,:) .gt. 0.0 )) + x3d_c = pnorm_c/betamolFlip(:,1,:) + elsewhere + x3d_c = R_UNDEF + end where + x3d(:,ic,:) = x3d_c + enddo + ! Diagnose cloud fractions for subcolumn lidar scattering ratios + CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,tmpFlip,x3d,pnormFlip, & + pnorm_perpFlip,pplayFlip,S_att,S_cld,S_cld_att,R_UNDEF, & + lidarcld,cldlayer,lidarcldphase,cldlayerphase,lidarcldtmp) + else + do ic = 1, ncol + pnorm_c = pnorm(:,ic,:) + where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) + x3d_c = pnorm_c/pmol + elsewhere + x3d_c = R_UNDEF + end where + x3d(:,ic,:) = x3d_c + enddo + ! Diagnose cloud fractions for subcolumn lidar scattering ratios + CALL COSP_CLDFRAC(npoints,ncol,nlevels,ncat,nphase,tmp,x3d,pnorm,pnorm_perp,pplay,& + S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase, & + cldlayerphase,lidarcldtmp) + endif + + ! CFADs + if (ok_lidar_cfad) then + ! CFADs of subgrid-scale lidar scattering ratios + do i=1,Npoints + do j=1,llm + cfad2(i,:,j) = hist1D(ncol,x3d(i,:,j),SR_BINS,calipso_histBsct) + enddo + enddo + where(cfad2 .ne. R_UNDEF) cfad2=cfad2/ncol + + endif + + ! Unit conversions + where(lidarcld /= R_UNDEF) lidarcld = lidarcld*100._wp + where(cldlayer /= R_UNDEF) cldlayer = cldlayer*100._wp + where(cldlayerphase /= R_UNDEF) cldlayerphase = cldlayerphase*100._wp + where(lidarcldphase /= R_UNDEF) lidarcldphase = lidarcldphase*100._wp + where(lidarcldtmp /= R_UNDEF) lidarcldtmp = lidarcldtmp*100._wp + + end subroutine lidar_column + + ! ###################################################################################### + ! The subroutines below compute the attenuated backscatter signal and the lidar + ! backscatter coefficients using eq (1) from doi:0094-8276/08/2008GL034207 + ! ###################################################################################### + subroutine cmp_backsignal(nlev,npoints,beta,tau,pnorm) + ! INPUTS + integer, intent(in) :: nlev,npoints + real(wp),intent(in),dimension(npoints,nlev) :: beta,tau + + ! OUTPUTS + real(wp),intent(out),dimension(npoints,nlev) :: pnorm + + ! Internal Variables + real(wp), dimension(npoints) :: tautot_lay + integer :: k + + ! Uppermost layer + pnorm(:,1) = beta(:,1) / (2._wp*tau(:,1)) * (1._wp-exp(-2._wp*tau(:,1))) + + ! Other layers + do k=2,nlev + tautot_lay(:) = tau(:,k)-tau(:,k-1) + WHERE (tautot_lay(:) .gt. 0.) + pnorm(:,k) = beta(:,k)*EXP(-2._wp*tau(:,k-1)) /& + (2._wp*tautot_lay(:))*(1._wp-EXP(-2._wp*tautot_lay(:))) + ELSEWHERE + ! This must never happen, but just in case, to avoid div. by 0 + pnorm(:,k) = beta(:,k) * EXP(-2._wp*tau(:,k-1)) + END WHERE + + END DO + end subroutine cmp_backsignal + + subroutine cmp_beta(nlev,npoints,pnorm,tau,beta) + ! INPUTS + integer, intent(in) :: nlev,npoints + real(wp),intent(in),dimension(npoints,nlev) :: pnorm,tau + + ! OUTPUTS + real(wp),intent(out),dimension(npoints,nlev) :: beta + + ! Internal Variables + real(wp), dimension(npoints) :: tautot_lay + integer :: k + real(wp) :: epsrealwp + + epsrealwp = epsilon(1._wp) + beta(:,1) = pnorm(:,1) * (2._wp*tau(:,1))/(1._wp-exp(-2._wp*tau(:,1))) + do k=2,nlev + tautot_lay(:) = tau(:,k)-tau(:,k-1) + WHERE ( EXP(-2._wp*tau(:,k-1)) .gt. epsrealwp ) + WHERE (tautot_lay(:) .gt. 0.) + beta(:,k) = pnorm(:,k)/ EXP(-2._wp*tau(:,k-1))* & + (2._wp*tautot_lay(:))/(1._wp-exp(-2._wp*tautot_lay(:))) + ELSEWHERE + beta(:,k)=pnorm(:,k)/EXP(-2._wp*tau(:,k-1)) + END WHERE + ELSEWHERE + beta(:,k)=pnorm(:,k)/epsrealwp + END WHERE + ENDDO + + end subroutine cmp_beta + ! #################################################################################### + ! SUBROUTINE cosp_cldfrac + ! Conventions: Ncat must be equal to 4 + ! #################################################################################### + SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase,tmp,x,ATB,ATBperp, & + pplay,S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer, & + lidarcldphase,cldlayerphase,lidarcldtemp) + ! Parameters + integer,parameter :: Ntemp=40 ! indice of the temperature vector + real(wp),parameter,dimension(Ntemp+1) :: & + tempmod = [0.0, 183.15,186.15,189.15,192.15,195.15,198.15,201.15,204.15,207.15, & + 210.15,213.15,216.15,219.15,222.15,225.15,228.15,231.15,234.15,237.15, & + 240.15,243.15,246.15,249.15,252.15,255.15,258.15,261.15,264.15,267.15, & + 270.15,273.15,276.15,279.15,282.15,285.15,288.15,291.15,294.15,297.15, & + 473.15] + + ! Polynomial coefficient of the phase discrimination line used to separate liquid from ice + ! (Cesana and Chepfer, JGR, 2013) + ! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50 + real(wp),parameter :: & + alpha50 = 9.0322e+15_wp, & ! + beta50 = -2.1358e+12_wp, & ! + gamma50 = 173.3963e06_wp, & ! + delta50 = -3.9514e03_wp, & ! + epsilon50 = 0.2559_wp, & ! + zeta50 = -9.4776e-07_wp ! + + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels, & ! Number of vertical levels + Ncat, & ! Number of cloud layer types + Nphase ! Number of cloud layer phase types + ! [ice,liquid,undefined,false ice,false liquid,Percent of ice] + real(wp),intent(in) :: & + S_att, & ! + S_cld, & ! + S_cld_att,& ! New threshold for undefine cloud phase detection + undef ! Undefined value + real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: & + x, & ! + ATB, & ! 3D attenuated backscatter + ATBperp ! 3D attenuated backscatter (perpendicular) + real(wp),intent(in),dimension(Npoints,Nlevels) :: & + tmp, & ! Temperature + pplay ! Pressure + + ! Outputs + real(wp),intent(out),dimension(Npoints,Ntemp,5) :: & + lidarcldtemp ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq + real(wp),intent(out),dimension(Npoints,Nlevels,Nphase) :: & + lidarcldphase ! 3D cloud phase fraction + real(wp),intent(out),dimension(Npoints,Nlevels) :: & + lidarcld ! 3D cloud fraction + real(wp),intent(out),dimension(Npoints,Ncat) :: & + cldlayer ! Low, middle, high, total cloud fractions + real(wp),intent(out),dimension(Npoints,Ncat,Nphase) :: & + cldlayerphase ! Low, middle, high, total cloud fractions for ice liquid and undefine phase + + ! Local variables + integer :: & + ip, k, iz, ic, ncol, nlev, i, itemp, toplvlsat + real(wp) :: & + p1,checktemp, ATBperp_tmp,checkcldlayerphase, checkcldlayerphase2 + real(wp),dimension(Npoints,Nlevels) :: & + nsub,lidarcldphasetmp + real(wp),dimension(Npoints,Ntemp) :: & + sumlidarcldtemp,lidarcldtempind + real(wp),dimension(Npoints,Ncolumns,Ncat) :: & + cldlay,nsublay + real(wp),dimension(Npoints,Ncat) :: & + nsublayer,cldlayerphasetmp,cldlayerphasesum + real(wp),dimension(Npoints,Ncolumns,Nlevels) :: & + tmpi, & ! Temperature of ice cld + tmpl, & ! Temperature of liquid cld + tmpu, & ! Temperature of undef cld + cldy, & ! + srok ! + real(wp),dimension(Npoints,Ncolumns,Ncat,Nphase) :: & + cldlayphase ! subgrided low mid high phase cloud fraction + + ! #################################################################################### + ! 1) Initialize + ! #################################################################################### + lidarcld = 0._wp + nsub = 0._wp + cldlay = 0._wp + nsublay = 0._wp + ATBperp_tmp = 0._wp + lidarcldphase(:,:,:) = 0._wp + cldlayphase(:,:,:,:) = 0._wp + cldlayerphase(:,:,:) = 0._wp + tmpi(:,:,:) = 0._wp + tmpl(:,:,:) = 0._wp + tmpu(:,:,:) = 0._wp + cldlayerphasesum(:,:) = 0._wp + lidarcldtemp(:,:,:) = 0._wp + lidarcldtempind(:,:) = 0._wp + sumlidarcldtemp(:,:) = 0._wp + lidarcldphasetmp(:,:) = 0._wp + toplvlsat = 0 + + ! #################################################################################### + ! 2) Cloud detection + ! #################################################################################### + do k=1,Nlevels + ! Cloud detection at subgrid-scale: + where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) ) + cldy(:,:,k)=1._wp + elsewhere + cldy(:,:,k)=0._wp + endwhere + + ! Number of usefull sub-columns: + where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) ) + srok(:,:,k)=1._wp + elsewhere + srok(:,:,k)=0._wp + endwhere + enddo + + ! #################################################################################### + ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories) + ! #################################################################################### + lidarcld = 0._wp + nsub = 0._wp + cldlay = 0._wp + nsublay = 0._wp + do k=1,Nlevels + do ic = 1, Ncolumns + do ip = 1, Npoints + + ! Computation of the cloud fraction as a function of the temperature instead + ! of height, for ice,liquid and all clouds + if(srok(ip,ic,k).gt.0.)then + do itemp=1,Ntemp + if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then + lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1._wp + endif + enddo + endif + + if(cldy(ip,ic,k).eq.1.)then + do itemp=1,Ntemp + if( (tmp(ip,k) .ge. tempmod(itemp)).and.(tmp(ip,k) .lt. tempmod(itemp+1)) )then + lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1._wp + endif + enddo + endif + + iz=1 + p1 = pplay(ip,k) + if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds + iz=3 + else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds + iz=2 + endif + + cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k)) + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) + lidarcld(ip,k) = lidarcld(ip,k) + cldy(ip,ic,k) + + nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k)) + nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) + nsub(ip,k) = nsub(ip,k) + srok(ip,ic,k) + + enddo + enddo + enddo + + ! Grid-box 3D cloud fraction + where ( nsub(:,:).gt.0.0 ) + lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) + elsewhere + lidarcld(:,:) = undef + endwhere + + ! Layered cloud fractions + cldlayer = 0._wp + nsublayer = 0._wp + do iz = 1, Ncat + do ic = 1, Ncolumns + cldlayer(:,iz) = cldlayer(:,iz) + cldlay(:,ic,iz) + nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz) + enddo + enddo + where (nsublayer(:,:) .gt. 0.0) + cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:) + elsewhere + cldlayer(:,:) = undef + endwhere + + ! #################################################################################### + ! 4) Grid-box 3D cloud Phase + ! #################################################################################### + + ! #################################################################################### + ! 4.1) For Cloudy pixels with 8.16km < z < 19.2km + ! #################################################################################### + do ncol=1,Ncolumns + do i=1,Npoints + do nlev=1,23 ! from 19.2km until 8.16km + p1 = pplay(1,nlev) + + ! Avoid zero values + if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then + ! Computation of the ATBperp along the phase discrimination line + ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + & + (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + & + ATB(i,ncol,nlev)*epsilon50 + zeta50 + ! ######################################################################## + ! 4.1.a) Ice: ATBperp above the phase discrimination line + ! ######################################################################## + if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds + + ! ICE with temperature above 273,15°K = Liquid (false ice) + if(tmp(i,nlev) .gt. 273.15) then ! Temperature above 273,15 K + ! Liquid: False ice corrected by the temperature to Liquid + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! False ice detection ==> added to Liquid + + tmpl(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp ! Keep the information "temperature criterium used" + ! to classify the phase cloud + cldlayphase(i,ncol,4,2) = 1. ! tot cloud + if (p1 .gt. 0. .and. p1.lt.(440._wp*100._wp)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1._wp + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1._wp + else ! low cloud + cldlayphase(i,ncol,1,2) = 1._wp + endif + cldlayphase(i,ncol,4,5) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,5) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,5) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,5) = 1._wp + endif + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp + tmpi(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + ! ######################################################################## + ! 4.1.b) Liquid: ATBperp below the phase discrimination line + ! ######################################################################## + else + ! Liquid with temperature above 231,15°K + if(tmp(i,nlev) .gt. 231.15_wp) then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp + tmpl(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + else + ! Liquid with temperature below 231,15°K = Ice (false liquid) + tmpi(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liquid detection ==> added to ice + lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp + cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,4) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,4) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,4) = 1._wp + endif + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + endif ! end of discrimination condition + endif ! end of cloud condition + enddo ! end of altitude loop + + ! ############################################################################## + ! 4.2) For Cloudy pixels with 0km < z < 8.16km + ! ############################################################################## + toplvlsat = 0 + do nlev=24,Nlevels! from 8.16km until 0km + p1 = pplay(i,nlev) + + if((cldy(i,ncol,nlev) .eq. 1.) .and. (ATBperp(i,ncol,nlev) .gt. 0.) )then + ! Computation of the ATBperp of the phase discrimination line + ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + & + (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + & + ATB(i,ncol,nlev)*epsilon50 + zeta50 + ! ######################################################################## + ! 4.2.a) Ice: ATBperp above the phase discrimination line + ! ######################################################################## + ! ICE with temperature above 273,15°K = Liquid (false ice) + if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds + if(tmp(i,nlev) .gt. 273.15)then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! false ice ==> liq + tmpl(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + + cldlayphase(i,ncol,4,5) = 1. ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,5) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,5) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,5) = 1._wp + endif + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp + tmpi(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt.(680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + + ! ######################################################################## + ! 4.2.b) Liquid: ATBperp below the phase discrimination line + ! ######################################################################## + else + ! Liquid with temperature above 231,15°K + if(tmp(i,nlev) .gt. 231.15)then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp + tmpl(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + else + ! Liquid with temperature below 231,15°K = Ice (false liquid) + tmpi(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liq ==> ice + lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp ! false liq ==> ice + cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,4) = 1._wp + ! Middle + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,4) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,4) = 1._wp + endif + + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + endif ! end of discrimination condition + + toplvlsat=0 + + ! Find the level of the highest cloud with SR>30 + if(x(i,ncol,nlev) .gt. S_cld_att) then ! SR > 30. + toplvlsat = nlev+1 + goto 99 + endif + endif ! end of cloud condition + enddo ! end of altitude loop +99 continue + + ! ############################################################################## + ! Undefined phase: For a cloud located below another cloud with SR>30 + ! see Cesana and Chepfer 2013 Sect.III.2 + ! ############################################################################## + if(toplvlsat.ne.0) then + do nlev = toplvlsat,Nlevels + p1 = pplay(i,nlev) + if(cldy(i,ncol,nlev).eq.1.)then + lidarcldphase(i,nlev,3) = lidarcldphase(i,nlev,3)+1._wp + tmpu(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,3) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,3) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,3) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,3) = 1._wp + endif + endif + enddo + endif + toplvlsat=0 + enddo + enddo + + ! #################################################################################### + ! Computation of final cloud phase diagnosis + ! #################################################################################### + + ! Compute the Ice percentage in cloud = ice/(ice+liq) as a function of the occurrences + lidarcldphasetmp(:,:) = lidarcldphase(:,:,1)+lidarcldphase(:,:,2); + WHERE (lidarcldphasetmp(:,:) .gt. 0.) + lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:) + ELSEWHERE + lidarcldphase(:,:,6) = undef + ENDWHERE + + ! Compute Phase 3D Cloud Fraction + !WHERE (nsub(:,Nlevels:1:-1) .gt. 0.0 ) + WHERE (nsub(:,:) .gt. 0.0 ) + lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:) + lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:) + lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:) + lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:) + lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:) + ELSEWHERE + lidarcldphase(:,:,1) = undef + lidarcldphase(:,:,2) = undef + lidarcldphase(:,:,3) = undef + lidarcldphase(:,:,4) = undef + lidarcldphase(:,:,5) = undef + ENDWHERE + + ! Compute Phase low mid high cloud fractions + do iz = 1, Ncat + do i=1,Nphase-3 + do ic = 1, Ncolumns + cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i) + cldlayerphasesum(:,iz) = cldlayerphasesum(:,iz) + cldlayphase(:,ic,iz,i) + enddo + enddo + enddo + do iz = 1, Ncat + do i=4,5 + do ic = 1, Ncolumns + cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i) + enddo + enddo + enddo + + ! Compute the Ice percentage in cloud = ice/(ice+liq) + cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2) + WHERE (cldlayerphasetmp(:,:).gt. 0.) + cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:) + ELSEWHERE + cldlayerphase(:,:,6) = undef + ENDWHERE + + do i=1,Nphase-1 + WHERE ( cldlayerphasesum(:,:).gt.0.0 ) + cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:) + ENDWHERE + enddo + + do i=1,Npoints + do iz=1,Ncat + checkcldlayerphase=0. + checkcldlayerphase2=0. + if (cldlayerphasesum(i,iz) .gt. 0.0 )then + do ic=1,Nphase-3 + checkcldlayerphase = checkcldlayerphase+cldlayerphase(i,iz,ic) + enddo + checkcldlayerphase2 = cldlayer(i,iz)-checkcldlayerphase + if((checkcldlayerphase2 .gt. 0.01) .or. (checkcldlayerphase2 .lt. -0.01) ) print *, checkcldlayerphase,cldlayer(i,iz) + endif + enddo + enddo + + do i=1,Nphase-1 + WHERE (nsublayer(:,:) .eq. 0.0) + cldlayerphase(:,:,i) = undef + ENDWHERE + enddo + + ! Compute Phase 3D as a function of temperature + do nlev=1,Nlevels + do ncol=1,Ncolumns + do i=1,Npoints + do itemp=1,Ntemp + if(tmpi(i,ncol,nlev).gt.0.)then + if((tmpi(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpi(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1._wp + endif + elseif(tmpl(i,ncol,nlev) .gt. 0.)then + if((tmpl(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpl(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1._wp + endif + elseif(tmpu(i,ncol,nlev) .gt. 0.)then + if((tmpu(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpu(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1._wp + endif + endif + enddo + enddo + enddo + enddo + + ! Check temperature cloud fraction + do i=1,Npoints + do itemp=1,Ntemp + checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4) + !if(checktemp .NE. lidarcldtemp(i,itemp,1))then + ! print *, i,itemp + ! print *, lidarcldtemp(i,itemp,1:4) + !endif + + enddo + enddo + + ! Compute the Ice percentage in cloud = ice/(ice+liq) + sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3) + WHERE(sumlidarcldtemp(:,:) .gt. 0.) + lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:) + ELSEWHERE + lidarcldtemp(:,:,5)=undef + ENDWHERE + + do i=1,4 + WHERE(lidarcldtempind(:,:) .gt. 0.) + lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:) + ELSEWHERE + lidarcldtemp(:,:,i) = undef + ENDWHERE + enddo + + RETURN + END SUBROUTINE COSP_CLDFRAC + +end module mod_lidar_simulator diff --git a/src/physics/cosp2/src/simulator/cosp_calipso_interface.F90 b/src/physics/cosp2/src/simulator/cosp_calipso_interface.F90 new file mode 100644 index 0000000000..e0d630d1d1 --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_calipso_interface.F90 @@ -0,0 +1,84 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_CALIPSO_INTERFACE + USE COSP_KINDS, ONLY: wp + USE MOD_LIDAR_SIMULATOR, ONLY: alpha,beta,gamma + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE calipso_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type calipso_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + + real(wp),dimension(:,:),pointer :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + real(wp),dimension(:,:,:),pointer :: & + betatot, & ! + tautot, & ! Optical thickess integrated from top + betatot_ice, & ! Backscatter coefficient for ice particles + betatot_liq, & ! Backscatter coefficient for liquid particles + tautot_ice, & ! Total optical thickness of ice + tautot_liq ! Total optical thickness of liq + real(wp),dimension(:,:,:,:),pointer :: & + taupart + end type calipso_IN + +CONTAINS + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_calipso_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_calipso_init() + + ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the + ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles + ! derived from CALIPSO-GOCCP observations at 120m vertical grid + ! (Cesana and Chepfer, JGR, 2013). + ! + ! Relationship between ATBice and ATBperp,ice for ice particles: + ! ATBperp,ice = Alpha*ATBice + ! Relationship between ATBice and ATBperp,ice for liquid particles: + ! ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice + Alpha = 0.2904_wp + Beta = 0.4099_wp + Gamma = 0.009_wp + + end subroutine cosp_calipso_init + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_CALIPSO_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_cloudsat_interface.F90 b/src/physics/cosp2/src/simulator/cosp_cloudsat_interface.F90 new file mode 100644 index 0000000000..b17fd5c498 --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_cloudsat_interface.F90 @@ -0,0 +1,144 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_CLOUDSAT_INTERFACE + USE MOD_COSP_CONFIG, ONLY: DBZE_BINS,CFAD_ZE_MIN,CFAD_ZE_WIDTH,SR_BINS,DBZE_MAX, & + DBZE_MIN + USE COSP_KINDS, ONLY: wp + USE quickbeam, ONLY: quickbeam_init,radar_cfg,Re_MAX_BIN,Re_BIN_LENGTH + IMPLICIT NONE + + ! Directory where LUTs will be stored + character(len=120) :: RADAR_SIM_LUT_DIRECTORY = './' + logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. + logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cloudsat_IN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cloudsat_IN + integer,pointer :: & + Npoints, & ! Number of horizontal grid-points + Nlevels, & ! Number of vertical levels + Ncolumns ! Number of subcolumns + real(wp),pointer :: & + hgt_matrix(:,:), & ! Height of hydrometeors (km) + z_vol(:,:,:), & ! Effective reflectivity factor (mm^6/m^3) + kr_vol(:,:,:), & ! Attenuation coefficient hydro (dB/km) + g_vol(:,:,:), & ! Attenuation coefficient gases (dB/km) + g_to_vol_in(:,:) ! Gaseous atteunation, radar to vol (dB) + type(radar_cfg),pointer :: rcfg ! Radar simulator configuration + end type cloudsat_IN + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_cloudsat_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CLOUDSAT_INIT(radar_freq,k2,use_gas_abs,do_ray,undef,nhydro, & + surface_radar,rcfg,cloudsat_micro_scheme,load_LUT) + ! INPUTS + real(wp),intent(in) :: & + radar_freq, & ! Radar frequency (GHz) + k2, & ! |K|^2, the dielectric constant + undef ! Undefined + integer,intent(in) :: & + use_gas_abs, & ! 1 = do gaseous abs calcs, 0=no gasesous absorbtion calculated, + ! 2 = calculate absorption for first profile on all profiles + do_ray, & ! + nhydro, & ! + surface_radar + logical,intent(in),optional :: & + load_LUT + character(len=64),intent(in) :: & + cloudsat_micro_scheme + + ! OUTPUTS + type(radar_cfg) :: & + rcfg ! + + ! LOCAL VARIABLES + character(len=240) :: LUT_file_name + logical :: local_load_LUT + integer :: j + + if (present(load_LUT)) then + local_load_LUT = load_LUT + else + local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag + endif + + ! LUT file name + LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // & + trim(cloudsat_micro_scheme) + + ! Initialize for NEW radar-configurarion derived type (radar_cfg) + rcfg%freq = radar_freq + rcfg%k2 = k2 + rcfg%use_gas_abs = use_gas_abs + rcfg%do_ray = do_ray + rcfg%nhclass = nhydro + rcfg%load_scale_LUTs = local_load_LUT + rcfg%update_scale_LUTs = .false. + rcfg%scale_LUT_file_name = LUT_file_name + rcfg%N_scale_flag = .false. + rcfg%fc = undef + rcfg%rho_eff = undef + rcfg%Z_scale_flag = .false. + rcfg%Ze_scaled = 0._wp + rcfg%Zr_scaled = 0._wp + rcfg%kr_scaled = 0._wp + + ! Set up Re bin "structure" for z_scaling + rcfg%base_list(1)=0 + do j=1,Re_MAX_BIN + rcfg%step_list(j)=0.1_wp+0.1_wp*((j-1)**1.5) + if(rcfg%step_list(j)>Re_BIN_LENGTH) then + rcfg%step_list(j)=Re_BIN_LENGTH + endif + if(j>1) then + rcfg%base_list(j)=rcfg%base_list(j-1)+floor(Re_BIN_LENGTH/rcfg%step_list(j-1)) + endif + enddo + + ! Set flag denoting position of radar + if (surface_radar == 1) then + rcfg%radar_at_layer_one = .false. + else + rcfg%radar_at_layer_one = .true. + endif + + END SUBROUTINE COSP_CLOUDSAT_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_CLOUDSAT_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_isccp_interface.F90 b/src/physics/cosp2/src/simulator/cosp_isccp_interface.F90 new file mode 100644 index 0000000000..70299aac43 --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_isccp_interface.F90 @@ -0,0 +1,85 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_ISCCP_INTERFACE + USE COSP_KINDS, ONLY: wp + USE mod_icarus, ONLY: isccp_top_height,isccp_top_height_direction + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE isccp_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Derived input type for ISCCP simulator + type isccp_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels, & ! Number of levels. + top_height, & ! + top_height_direction ! + integer,pointer :: & + sunlit(:) ! Sunlit points (npoints) + real(wp),pointer :: & + emsfc_lw + real(wp),pointer :: & + skt(:) ! Surface temperature (npoints) + real(wp),pointer :: & + at(:,:), & ! Temperature (npoint,nlev) + pfull(:,:), & ! Pressure (npoints,nlev) + qv(:,:) ! Specific humidity (npoints,nlev) + real(wp),pointer :: & + phalf(:,:) ! Pressure at half levels (npoints,nlev+1) + real(wp),pointer :: & + frac_out(:,:,:), & ! Cloud fraction (npoints,ncolumns,nlevels) + dtau(:,:,:), & ! Optical depth (npoints,ncolumns,nlevels) + dem(:,:,:) ! Emissivity (npoints,ncolumns,nlevels) + end type isccp_IN + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_isccp_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_ISCCP_INIT(top_height,top_height_direction) + integer,intent(in) :: & + top_height, & + top_height_direction + + ! Cloud-top height determination + isccp_top_height = top_height + isccp_top_height_direction = top_height_direction + + END SUBROUTINE COSP_ISCCP_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_ISCCP_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_misr_interface.F90 b/src/physics/cosp2/src/simulator/cosp_misr_interface.F90 new file mode 100644 index 0000000000..a2daa6ef7d --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_misr_interface.F90 @@ -0,0 +1,67 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_MISR_INTERFACE + USE COSP_KINDS, ONLY: wp + + IMPLICIT NONE + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE misr_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type misr_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + integer,pointer :: & + sunlit(:) ! Sunlit points (npoints). + real(wp),pointer :: & + zfull(:,:), & ! Height of full model levels (i.e. midpoints). (npoints,nlev) + at(:,:) ! Temperature. (npoints,nlev) + real(wp),pointer :: & + dtau(:,:,:) ! Optical depth. (npoints,ncolumns,nlev) + + end type misr_IN + +CONTAINS + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_misr_init + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_MISR_INIT() + + END SUBROUTINE COSP_MISR_INIT + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_MISR_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_modis_interface.F90 b/src/physics/cosp2/src/simulator/cosp_modis_interface.F90 new file mode 100644 index 0000000000..10944654fc --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_modis_interface.F90 @@ -0,0 +1,113 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_Modis_INTERFACE + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF + use mod_modis_sim, ONLY: num_trial_res,min_OpticalThickness,CO2Slicing_PressureLimit,& + CO2Slicing_TauLimit,phase_TauLimit,size_TauLimit,re_fill, & + phaseDiscrimination_Threshold,re_water_min, & + re_water_max,re_ice_min,re_ice_max, & + highCloudPressureLimit,lowCloudPressureLimit,phaseIsNone, & + phaseIsLiquid,phaseIsIce,phaseIsUndetermined,trial_re_w, & + trial_re_i,g_w,g_i,w0_w,w0_i, get_g_nir,get_ssa_nir + implicit none + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE modis_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type modis_IN + integer,pointer :: & + Npoints, & ! Number of horizontal gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels ! Number of vertical levels + integer :: & + Nsunlit ! Number of sunlit lit pixels + real(wp),allocatable,dimension(:) :: & + sunlit, & ! Sunlit scenes + notSunlit ! Dark scenes + real(wp),allocatable,dimension(:,:) :: & + pres ! Gridmean pressure at layer edges (Pa) + real(wp),pointer :: & + tau(:,:,:), & ! Subcolumn optical thickness @ 0.67 microns. + liqFrac(:,:,:), & ! Liquid water fraction + g(:,:,:), & ! Subcolumn assymetry parameter + w0(:,:,:) ! Subcolumn single-scattering albedo + end type modis_IN +contains + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROTUINE cosp_modis_init + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_MODIS_INIT() + integer :: i + + ! Retrieval parameters + min_OpticalThickness = 0.3_wp ! Minimum detectable optical thickness + CO2Slicing_PressureLimit = 70000._wp ! Cloud with higher pressures use thermal + ! methods, units Pa + CO2Slicing_TauLimit = 1._wp ! How deep into the cloud does CO2 slicing + ! see? + phase_TauLimit = 1._wp ! How deep into the cloud does the phase + ! detection see? + size_TauLimit = 2._wp ! Depth of the re retreivals + phaseDiscrimination_Threshold = 0.7_wp ! What fraction of total extincton needs to + ! be in a single category to make phase + ! discrim. work? + re_fill = -999._wp ! Fill value + re_water_min = 4._wp ! Minimum effective radius (liquid) + re_water_max = 30._wp ! Maximum effective radius (liquid) + re_ice_min = 5._wp ! Minimum effective radius (ice) + re_ice_max = 90._wp ! Minimum effective radius (ice) + highCloudPressureLimit = 44000._wp ! High cloud pressure limit (Pa) + lowCloudPressureLimit = 68000._wp ! Low cloud pressure limit (Pa) + phaseIsNone = 0 ! No cloud + phaseIsLiquid = 1 ! Liquid cloud + phaseIsIce = 2 ! Ice cloud + phaseIsUndetermined = 3 ! Undetermined cloud + + ! Precompute near-IR optical params vs size for retrieval scheme + trial_re_w(1:num_trial_res) = re_water_min + (re_water_max - re_water_min) / & + (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/) + trial_re_i(1:num_trial_res) = re_ice_min + (re_ice_max - re_ice_min) / & + (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/) + + ! Initialize estimates for size retrieval + g_w(1:num_trial_res) = get_g_nir(phaseIsLiquid,trial_re_w(1:num_trial_res)) + w0_w(1:num_trial_res) = get_ssa_nir(phaseIsLiquid,trial_re_w(1:num_trial_res)) + g_i(1:num_trial_res) = get_g_nir(phaseIsIce,trial_re_i(1:num_trial_res)) + w0_i(1:num_trial_res) = get_ssa_nir(phaseIsIce,trial_re_i(1:num_trial_res)) + + END SUBROUTINE COSP_MODIS_INIT + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE MOD_COSP_Modis_INTERFACE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_Modis_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_parasol_interface.F90 b/src/physics/cosp2/src/simulator/cosp_parasol_interface.F90 new file mode 100644 index 0000000000..21a2d8650e --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_parasol_interface.F90 @@ -0,0 +1,90 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_PARASOL_INTERFACE + USE COSP_KINDS, ONLY: WP + implicit none + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_parasol + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE PARASOL_SGX + ! Dimensions + integer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nrefl ! Number of parasol reflectances + + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + real(wp),dimension(:,:,:),pointer :: & + refl ! parasol reflectances + + END TYPE PARASOL_SGX + TYPE PARASOL_GBX + integer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nrefl ! Number of parasol reflectances + real(wp), dimension(:,:),pointer :: & + parasolrefl ! Mean parasol reflectance + + END TYPE PARASOL_GBX + TYPE COSP_PARASOL + type(PARASOL_SGX) :: PARASOL_SGX + type(PARASOL_GBX) :: PARASOL_GBX + END TYPE COSP_PARASOL + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE parasol_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE parasol_IN + integer,pointer :: & + Npoints, & ! Number of horizontal gridpoints + Nlevels, & ! Number of vertical levels + Ncolumns, & ! Number of columns + Nrefl ! Number of angles for which the reflectance is computed + real(wp),dimension(:,:),pointer :: & + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + END TYPE parasol_IN + +contains + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_parasol_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_PARASOL_INIT() + + end subroutine COSP_PARASOL_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +end module MOD_COSP_PARASOL_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_rttov_interface.F90 b/src/physics/cosp2/src/simulator/cosp_rttov_interface.F90 new file mode 100644 index 0000000000..b7a6ec65a6 --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_rttov_interface.F90 @@ -0,0 +1,143 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! Apr 2015 - D. Swales - Modified for RTTOVv11.3 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_RTTOV_INTERFACE + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: RTTOV_MAX_CHANNELS,rttovDir + use mod_cosp_rttov, only: platform,satellite,sensor,nChannels,iChannel,coef_rttov, & + coef_scatt,opts,opts_scatt,construct_rttov_coeffilename, & + construct_rttov_scatfilename + IMPLICIT NONE +#include "rttov_read_coefs.interface" +#include "rttov_read_scattcoeffs.interface" + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE rttov_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type rttov_in + integer,pointer :: & + nPoints, & ! Number of profiles to simulate + nLevels, & ! Number of levels + nSubCols, & ! Number of subcolumns + month ! Month (needed for surface emissivity calculation) + real(wp),pointer :: & + zenang, & ! Satellite zenith angle + co2, & ! Carbon dioxide + ch4, & ! Methane + n2o, & ! n2o + co ! Carbon monoxide + real(wp),dimension(:),pointer :: & + surfem ! Surface emissivities for the channels + real(wp),dimension(:),pointer :: & + h_surf, & ! Surface height + u_surf, & ! U component of surface wind + v_surf, & ! V component of surface wind + t_skin, & ! Surface skin temperature + p_surf, & ! Surface pressure + t2m, & ! 2 m Temperature + q2m, & ! 2 m Specific humidity + lsmask, & ! land-sea mask + latitude, & ! Latitude + longitude, & ! Longitude + seaice ! Sea-ice? + real(wp),dimension(:,:),pointer :: & + p, & ! Pressure @ model levels + ph, & ! Pressure @ model half levels + t, & ! Temperature + q, & ! Specific humidity + o3 ! Ozone + + ! These fields below are needed ONLY for the RTTOV all-sky brightness temperature + real(wp),dimension(:,:),pointer :: & + tca, & ! Cloud fraction + cldIce, & ! Cloud ice + cldLiq, & ! Cloud liquid + fl_rain, & ! Precipitation flux (startiform+convective rain) (kg/m2/s) + fl_snow ! Precipitation flux (stratiform+convective snow) + end type rttov_in +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_rttov_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_RTTOV_INIT(NchanIN,platformIN,satelliteIN,instrumentIN,channelsIN) + integer,intent(in) :: & + NchanIN, & ! Number of channels + platformIN, & ! Satellite platform + satelliteIN, & ! Satellite + instrumentIN ! Instrument + integer,intent(in),dimension(RTTOV_MAX_CHANNELS) :: & + channelsIN ! RTTOV channels + + ! Local variables + character(len=256) :: coef_file,scat_file + integer :: errorstatus + + ! Initialize fields in module memory (cosp_rttovXX.F90) + nChannels = NchanIN + platform = platformIN + satellite = satelliteIN + sensor = instrumentIN + iChannel = channelsIN + + ! Options common to RTTOV clear-sky Tb calculation + opts%interpolation%addinterp = .true. ! allow interpolation of input profile + opts%rt_all%use_q2m = .true. + opts%config%do_checkinput = .false. + opts%config%verbose = .false. + opts%rt_all%addrefrac = .true. ! include refraction in path calc + opts%interpolation%reg_limit_extrap = .true. + ! Options common to RTTOV clear-sky Tb calculation + opts_scatt%config%do_checkinput = .false. + opts_scatt%config%verbose = .false. + opts_scatt%config%apply_reg_limits = .true. + opts_scatt%interp_mode = 1 + opts_scatt%reg_limit_extrap = .true. + opts_scatt%use_q2m = .true. + opts%rt_mw%clw_data = .true. + + ! Read in scattering coefficient file. + coef_file = trim(rttovDir)//"rtcoef_rttov11/rttov7pred54L/"// & + trim(construct_rttov_coeffilename(platform,satellite,sensor)) + call rttov_read_coefs(errorstatus,coef_rttov, opts, file_coef=trim(coef_file)) + + ! Read in scattering (clouds+aerosol) coefficient file. *ONLY NEEDED IF DOING RTTOV ALL-SKY.* + !scat_file = trim(rttovDir)//"rtcoef_rttov11/cldaer/"//& + ! trim(construct_rttov_scatfilename(platform,satellite,sensor)) + ! Can't pass filename to rttov_read_scattcoeffs!!!!! + !call rttov_read_scattcoeffs (errorstatus, coef_rttov%coef, coef_scatt,) + + END SUBROUTINE COSP_RTTOV_INIT + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_RTTOV_INTERFACE diff --git a/src/physics/cosp2/src/simulator/cosp_rttov_interfaceSTUB.F90 b/src/physics/cosp2/src/simulator/cosp_rttov_interfaceSTUB.F90 new file mode 100644 index 0000000000..654a8df619 --- /dev/null +++ b/src/physics/cosp2/src/simulator/cosp_rttov_interfaceSTUB.F90 @@ -0,0 +1,91 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! Apr 2015 - D. Swales - Modified for RTTOVv11.3 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_RTTOV_INTERFACE + USE COSP_KINDS, ONLY: wp + IMPLICIT NONE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE rttov_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type rttov_in + integer,pointer :: & + nPoints, & ! Number of profiles to simulate + nLevels, & ! Number of levels + nSubCols, & ! Number of subcolumns + month ! Month (needed for surface emissivity calculation) + real(wp),pointer :: & + zenang, & ! Satellite zenith angle + co2, & ! Carbon dioxide + ch4, & ! Methane + n2o, & ! n2o + co ! Carbon monoxide + real(wp),dimension(:),pointer :: & + surfem ! Surface emissivities for the channels + real(wp),dimension(:),pointer :: & + h_surf, & ! Surface height + u_surf, & ! U component of surface wind + v_surf, & ! V component of surface wind + t_skin, & ! Surface skin temperature + p_surf, & ! Surface pressure + t2m, & ! 2 m Temperature + q2m, & ! 2 m Specific humidity + lsmask, & ! land-sea mask + latitude, & ! Latitude + longitude, & ! Longitude + seaice ! Sea-ice? + real(wp),dimension(:,:),pointer :: & + p, & ! Pressure @ model levels + ph, & ! Pressure @ model half levels + t, & ! Temperature + q, & ! Specific humidity + o3 ! Ozone + + ! These fields below are needed ONLY for the RTTOV all-sky brightness temperature + real(wp),dimension(:,:),pointer :: & + tca, & ! Cloud fraction + cldIce, & ! Cloud ice + cldLiq, & ! Cloud liquid + fl_rain, & ! Precipitation flux (startiform+convective rain) (kg/m2/s) + fl_snow ! Precipitation flux (stratiform+convective snow) + end type rttov_in +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_rttov_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_RTTOV_INIT() + + END SUBROUTINE COSP_RTTOV_INIT + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_RTTOV_INTERFACE diff --git a/src/physics/cosp2/src/simulator/icarus/README b/src/physics/cosp2/src/simulator/icarus/README new file mode 100644 index 0000000000..5a98e903f3 --- /dev/null +++ b/src/physics/cosp2/src/simulator/icarus/README @@ -0,0 +1,1351 @@ +Name: ISCCP Simulator ICARUS/SCOPS +What: Simulate ISCCP cloud products from GCM inputs +Version: 4.1 +Authors: Steve Klein + Mark Webb + +This README file is written by Mark, and so references to 'I' +or 'me' refer to Mark. + +************************************************************************ +This code is subject to copyright, according to a BSD licence + +(c) 2009, Lawrence Livermore National Security Limited Liability +Corporation. All rights reserved. ( icarus.f ) + +(c) British Crown Copyright 2009, the Met Office. All rights reserved. +(remaining code) + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the +following conditions are met: + + * Redistributions of source code must retain the above + copyright notice, this list of conditions and the following + disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the names of the above organisations nor the names of + their contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +********************************************************************** + +0. Contents +----------- + +0. Contents +1. About the code +2. Conditions of use +3. No warranty +4. Compilation and testing +5. Points to be aware of when using the code + 1) Are you running a correct version? + 2) Calling the code from within your model. + 3) Passing the cloud types in correctly. + 4) Setting NCOL. + 5) Setting the seed correctly. + 6) Memory usage + 7) Check the results against your total cloud amount. + 8) Set top_height=1 for best comparisons with ISCCP IR-VIS. + 9) Handling sunlit points. + A) Meaning of outputs from the ISCCP simulator. +6. Revision history of released versions +7. Some other issues to consider + +1. About the code +----------------- + +This is a code that can be used to take cloud and atmosphere +information from atmospheric models and convert it into something that is +comparable to data from the ISCCP. It has two parts. + +SCOPS - Subgrid Cloud Overlap Profile Sampler. + +This is the core of the code (written by Mark) which samples the subgrid +distibution of clouds within a model gridbox using a pseudo-random +sampling process. It takes vertical profiles of convective and large +scale cloud amount as input and applies a choice of cloud overlap +assumptions to provide a number of cloud profiles sampled from random +positions within the gridbox. + +ICARUS - ISCCP Clouds and Radiances Using SCOPS. + +This is the code (written by Steve) that emulates the ISCCP retrieval +using the profiles extracted from the GCM gridbox using SCOPS. + +For more information, see Klein and Jakob 1999; Webb et al. 2001. + +2. Conditions of use +-------------------- + +Version 4.0 is released under a BSD licence, to promote open +use of the code. Please refer to the copyright statements in the code. + +(c) 2009, Lawrence Livermore National Security Limited Liability +Corporation. ( icarus.f ) + +(c) British Crown Copyright 2009, the Met Office. (other code) + +Please email us to let us know if you are using the code so that +we can let you know about new releases. Please also acknowledge +us in anything you write up, and cite: + +Klein & Jakob (Monthly Weather Review 1999) and +Webb, Senior, Bony & Morcrette (Climate Dynamics 2001) + +3. Other sources of information. +------------------------------- + +Announcements regarding the code will be made on a mailing list - see +below for details on how to subscribe: + +Two mailing lists are available for news, updates and comments +on the ISCCP Simulator software: + + isccp-simulator@metoffice.com + +(for technical announcements and queries about the simulator) + + isccp-simulator-projects@metoffice.com + +(for projects using the simulator - e.g. CFMIP) + +To subscribe, send a message to majordomo@metoffice.com with the following +message body: + + subscribe isccp-simulator your.email@address.com + +The list is a closed one so only subscribers may post to the list. +Subscription requests may take up to two working days to process. + +See also www.cfmip.net + +4. Compilation and testing +-------------------------- + +How to compile me: + + gunzip icarus-scops-4.0-bsd.tar.gz + tar xvf icarus-scops-4.0-bsd.tar + cd icarus-scops-4.0-bsd + make clean + make + +You may need to change the name of the compiler in the Makefile, +e.g. + + F77=f90 ( T3E ) + F77=g77 ( GNU FORTRAN compiler ) + +How to test me: + + make test + +A successful test will look something like the following. + +$ make test +test_isccp_cloud_types.ksh +make[1]: Entering directory `/home/hc0300/hadmw/icarus-scops-3.4' +make[1]: `test_isccp_cloud_types' is up to date. +make[1]: Leaving directory `/home/hc0300/hadmw/icarus-scops-3.4' +tests passed ok. + +An unsuccessful test looks something like the following: + +e.g. + +t3ea> make test + test_isccp_cloud_types.ksh +`test_isccp_cloud_types' is up to date. + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' + STOP (PE 0) executed at line 92 in Fortran routine '$MAIN' +4225c4225 +< 0.17 0.30 0.00 0.00 0.15 0.00 0.00 +--- +> 0.18 0.30 0.00 0.00 0.15 0.00 0.00 +4912c4912 +< 0.30 0.17 0.00 0.00 0.15 0.00 0.00 +--- +> 0.30 0.18 0.00 0.00 0.15 0.00 0.00 +there may be a problem with the test - files stdout and stdout.expected do not match. +Make: "test_isccp_cloud_types.ksh": Error code 1 +cmd-2436 make: Stop. + +Minor differences like those seen in this case can be caused by +rounding characteristics in formatting on different platforms. +I'd be interested to see any test output that has more serious +differences than these. + +If you see something like this: + +[mark@sagan icarus-scops-3.4]$ make test +./test_isccp_cloud_types.ksh +make[1]: Entering directory `/home/mark/icarus-scops-3.4' +f77 -c test_isccp_cloud_types.f +f77 -c isccp_cloud_types.f +f77 -c ran0.f +f77 test_isccp_cloud_types.f isccp_cloud_types.o ran0.o -o test_isccp_cloud_types +make[1]: Leaving directory `/home/mark/icarus-scops-3.4' +916c916 +< meantaucld = 0.00000 +--- +> meantaucld = 3.25000 +1942c1942 +< meantaucld = 0.00000 +--- +> meantaucld = 1.67000 +2968c2968 +< meantaucld = 0.00000 +--- +> meantaucld = 1.89000 +3704c3704 +< meantaucld = 0.00000 +--- +> meantaucld = 3.25000 +4440c4440 +< meantaucld = 0.00000 +--- +> meantaucld = 1.67000 +5176c5176 +< meantaucld = 0.00000 +--- +> meantaucld = 1.89000 + +then you are most likely unable to read the unformatted files containing the +optical thickness weights - try setting readbinary=.false. near line +24 of test_isccp_cloud_types.f + +5. Points to be aware of when using the code +-------------------------------------------- + +1) Are you running a correct version? + +There are various versions of the code around. If you +didn't get the code directly from me, Steve, the GCSS +DIME website or www.cfmip.net, what you have may not be what is +described in the version history below. Just because +it says it's version x does not mean that it is. +A good way to check is to take what you have, run the tests +supplied with the latest version and see if the results +are as expected. + +If you have a version that doesn't look like one of the ones below, +please send me a copy so that I can incorporate any improvements +into a future release. + +In particular, if you are running with a version that says version 1.13 in +isccp_cloudtypes.f, the results may be incorrect. + +2) Calling the code from within your model. + +Before the vector version of the code was available, people +looped over model grid points, calling the code column by column, +either on all model points, or just those with daylight. Now +that the code accepts vector inputs, you have the choice of +continuing to do this, or of passing full model fields into the +code. The latter approach is likely to be more CPU efficient, +particularly on vector processors, but will use more memory. +See the section on memory usage if you run out of memory. + +Although the input arrays are mostly of the form (npoints,nlevs), +there is no problem passing in arrays of the form (nx,ny,nlevs) +if that is more convenient for you. As long as npoints=nx*ny, +this should be fine, although it is worth switching +the debug logical on occasionally to check that all of the +arguments are being passed correctly. + +3) Passing the cloud types in correctly. + +When running with convective cloud, cc represents the _total_ +cloud amount, which includes the convective fraction +conv. i.e. cc = conv + stratiform. It is a common mistake +to assume that cc = stratiform and conv = convective. +The treatment of convective cloud assumes that you can maximally +overlap the convective cloud first and then overlap the +stratiform cloud in the remaining cloud free space according +to the specified overlap type. This is consistent with the +overlap scheme in Edwards/Slingo (in the HadCM3) model +( convective cloud maximally overlapped within but may not +be true for schemes used for overlapping separate convective and +stratiform clouds in other models. + +4) Setting NCOL. + +The simulator uses a Monte Carlo method for sampling various columns +within each model gridbox. The number of columns is set by the value +of NCOL. The value that you want to set NCOL to depends on the +accuracy you want and amount of averaging you are doing on the outputs. + +The recommended rule of thumb recommended by the authors is that you +should aim for something like 2400 samples to keep statistical +noise to a reasonable level. + +For example, if you are doing no averaging, (i.e. you are +be calling the simulator once on instantaneous model variables +and looking directly at the results), you should set +might expect that you need to set NCOL to something around 2400. + +If you are looking at daily means, and are calculating this by +averaging 8 3-hourly calls to the simulator, NCOL should be set +to 300 ( = 2400/8 ) + +If, say, you are looking at monthly means, and are calling the +simulator, say, every 15 hours, NCOL should be set to +50 =2400/(24*30/15) + +If you are looking at monthly means, and are calculating this by +averaging 8 3-hourly calls per day to the simulator, NCOL should be set +to 10 ( = 2400/(8*30) ) + +*WARNING* Running with NCOL < 10 is not recommended even if you are +doing a lot of averaging on the results - I have experienced +systematic biases when doing this myself, although this might +not be a problem if the random number generator is seeded +properly. + +Finally, don't forget to set NCOLMAX to be at least as big +as NCOL, ( but not bigger than necessary as the amount +of memory used is proportional to NCOLMAX.) ( ** Note that +ncolmax is not required for versions 3.2 onwards. ) + +5) Setting the seed correctly. + +It is essential that the seed for the random number generator +is set to a different value for each model gridbox it is called on, +as it is possible that the choice of the same seed value every time +may introduce some statistical bias in the results, particularly +for low values of NCOL. + +In the simulations in Webb et al 2001, this was done by setting +seed=(pfull(nlev)-int(pfull(nlev)))*100+1, although this +may or may not work for you. I now recommend something more like: +seed=(pfull(nlev)-int(pfull(nlev)))*100000+1 +as always seeding with a small number could in theory +cause problems. + +From version 2.2 onwards, seed is passed as an argument to +isccp_cloudtypes. + +( Note that a seed value of 50 is required to get the correct +test output. ) + +6) Memory usage + +If you find that you run out of memory setting large values +on NCOL, try calling the simulator repeatedly and averaging the +results. If you do this, set the seed before the first call +but let subsequent calls use the value of the seed returned +by the previous call. If you set the seed to the +same value for each call, each call will give exactly the +same results, defeating the object of the repeated +call. + +7) Check the results against your total cloud amount. + +It is strongly recommended that you check that the code is +giving results consistent with the overlap scheme used in +your radiation code. This can be done by: + + a) setting the sample size to a large values, ideally 10000 + ( ncol=10000 or an average of 100 calls with ncol=100 ) + b) running the code on a varied selection of inputs from your + model + c) summing the output from all of the cloud classes (including the + ones representing points with tau < isccp_taumin ) and checking + that this is statistically equivalent to the total cloud amount + diagnosed in your radiation scheme for sunlit points. + +If you can't get this to agree, switch on the debug flag and +check that the values are being passed in properly. Look +at the code and see if you are using a value of overlap +that is consistent with the overaps used in your radiation +code. Failing that, I may be able to help, but can't guarantee +to be able to modify the code to match your overlap assumptions. + +8) Set top_height=1 for best comparisons with ISCCP IR-VIS. + +It is recommended that for best comparison with ISCCP IR-VIS +products the code be set to calculate effective rather than +actual cloud top pressures i.e. set top_height to 1 +for comparison with VIS/IR daytime products (consistent +with Webb et al 2001.) However if you want to examine +nighttime products from ISCCP, the option set top_height = 3 +would be the best one to compare to at night. Using top_height += 1 at night would be significantly worse in this case. + +9) Handling sunlit points. + +for top_height=(1 or 2) the input array sunlit should be set to 1 for +day points and 0 for nighttime points. + +The outputs are set as described below: +for the following values of top_height. These output +domains are set on the assumption that the outputs +will be compared with the ISCCP variables shown below +(documented at + +http://eosweb.larc.nasa.gov/PRODOCS/isccp/table_isccp.html + -> D1 parameters list. + -> DX parameters list +) + +all points (A), sunlit points only (S) or not diagnosed (0) + +top_height=1 +------------ + +diagnostic domain comparable ISCCP diagnostic + +fq_isccp, S D1 30d-71d +totalcldarea, A D1 12 Number of cloudy pixels +meanptop, S D1 78 Mean PC for cloudy pixels (VIS-adjusted day, unadjusted night) +meantaucld, S D1 92d Mean TAU for cloudy pixels +boxtau, S DX 26. VALBTA : VIS retrieved cloud tau or surface albedo + DX 30. VTAUIC : VIS retrieved ice cloud tau +boxptop S DX 29. VPRS : VIS adjusted cloud top pressure + +Please note that currently meanptop is not diagnosed in the IS for night-time +points if top_height=1, although ISCCP D1 item 78 is available for day and night +points. For top_height=1, meanptop should only be compared to +item 78 for sunlit points. + +top_height=2 +------------ + +as for top_height=1 + +top_height=3 +------------ + +diagnostic domain comparable ISCCP diagnostic + +fq_isccp, A d1 23-29 Cloud top pressure distribution (unadjusted PC) + ( although this is in 7 classes rather than 49, so + you need to sum over the different tau classes, excluding + the ones for tau below isccp_taumin) * +totalcldarea, A d1 13 Number of IR-cloudy pixels +meanptop, A d1 79 Mean PC for IR-cloudy pixels (unadjusted) +meantaucld, 0 not diagnosed +boxtau, 0 not diagnosed +boxptop A dx 18. IPRS : IR retrieved cloud top pressure + +* Note from Steve: + +Note that we have a problem here. One thing I didn't sort out was +that for the ir-only method what would be a minimum cloud emissivity for +which the ir-threshold method would not detect cloud. Probably the most +defensible method, which would not be hard to implement, would be to compare +the clear sky and cloudy sky brightness temperatures. If the difference is +less than the ir-thresholds then the cloud would not be seen by ISCCP. +The table of ir-thresholds is table 3.2.4 of ISCCP documentation. This +table is scene-type (e.g. ocean/land/coastal/high topography/snow covered) +dependent. Thus the simulator inputs would need to have this information +included. This will take time to build. + +For now probably the best thing is to do is to note that +the isccp_taumin thresholding is not the best but an interim measure until +a proper method (i.e. the last paragraph) can be implemented. + +A) Time averaging of outputs from the ISCCP simulator. + +It is important to be careful when time averaging the outputs from +the IS as some variables are set to a missing data indicator in certain +cases - e.g. for night points when top_height=(1 or 2) and for in-cloud +values where the cloud fraction is zero. + +The time averaging needs to be done outside the simulator, and from +version 3.6 onwards, this can be done in two ways. + +1/ Missing data indicator method + +This option may be preferred in models where the time averaging +system knows about missing data indicators. + +icarus.f now contains a data statement which sets +a real variable called "output_missing_value" to a value of +-1.E+30. This can be changed to match the value of the +missing data indicator in the model. + +Variables fq_isccp and totalcldarea will contain the missing +data indicator at night when top_height=(1 or 2). These should +be averaged only over the points which are not flagged by the +missing data indicator. + +Variables "meanptop", "meanalbedocld" and "meantaucld" will contain +the missing data indicator at night when top_height=(1 or 2), +and also when totalcldarea is zero. + +Time means for "meanptop", "meanalbedocld", "meantaucld" should +be made using cloud area weighted grid box mean values to +prevent, for example, very large optical depths over +small cloud fractions dominating the statistics - e.g. + +gridbox_meanalbedocld=meanalbedocld*totalcldarea for totalcldarea>0 + =0 for totalcldarea=0 + +These should be set zero when totalcldarea is zero, overwriting +the missing data indicator value present. Any missing data +indicators at night time points should remain, as for fq_isccp +and totalcldarea. + +At the analysis stage these should be divided by the mean cloud fraction +to produce cloud area weighted in-cloud values - e.g. + +avg(meanalbedocld) = avg(gridbox_meanalbedocld)/avg(totalcldarea). + +Points where avg(totalcldarea) is zero will need to be considered +'missing data' + +2/ Missing data mask method + +This option may be preferred in models where the time averaging +system does not use missing data indicators, and is based on +guidance for versions of the simulator prior to vn3.6. + +icarus.f now contains a data statement which sets +a real variable called "output_missing_value" to a value of +-1.E+30. This value should be set to zero. + +When top_height=(1 or 2), a sunlit points mask variable will be +required. This needs to be type REAL, taking a value of 1 for +lit points and a value of 0 for night points (essentially +a REAL version of the INTEGER sunlit variable.) A time +average should be made of this variable, which will be used +to 'unweight' the time mean outputs at the analysis stage. + +Variables fq_isccp and totalcldarea will contain zeros at night +when top_height=(1 or 2). These variables should be averaged over +all points. These averages can be divided by the time average +sunlit mask at the analysis stage. Points where the mask is +zero should be considered 'missing data'. + +Variables "meanptop", "meanalbedocld" and "meantaucld" will contain +zeros at night when top_height=(1 or 2), and also when totalcldarea +is zero. + +Time means for "meanptop", "meanalbedocld", "meantaucld" should +be made using cloud area weighted grid box mean values to +prevent, for example, very large optical depths over +small cloud fractions dominating the statistics - e.g. + +gridbox_meanalbedocld=meanalbedocld*totalcldarea + +In this case all points can be treated the same way in the +weighting process and in the time averaging. + +At the analysis stage these should be divided by the mean cloud fraction +to produce cloud area weighted in-cloud values - e.g. + +avg(meanalbedocld) = avg(gridbox_meanalbedocld)/avg(totalcldarea). + +Locations where avg(totalcldarea) (e.g. night points or cloud +free points) are zero should be considered 'missing data'. +Care should be taken to ensure that the numerator and demoninator +have had the sunlit mask applied consistently to both, or to +neither, which should give the same result. + +Mark Webb +________________________________________________________________________ + +6. Revision history of released versions +---------------------------------------- +_______________________________________________________________________________ + +Changes made by Steve Klein from version 4.0 to 4.1 + +1/ This is a bugfix for a bug found by Jason Cole (thanks, Jason!). +This is for *RARE* cases where the cloud temperature is greater than +any temperature in the troposphere, however, the maximum temperature +in the atmosphere is in the stratosphere. Under these cases, the cloud +top pressure variable, ptop, was not assigned, and (depending on +compiler) the model crashes because it couldn't evaluate the scalar +operations involving ptop. + +The fix is to assign the maximum and minimum temperatures used in the +cloud-top pressure detection to temperatures within the troposphere. +This will prevent any values of ptop remaining undefined. + +_______________________________________________________________________________ + +Changes made by Steve Klein and Mark Webb from version 3.8 to 4.0 + +1/ The experimental setting to top_height_direction (= 2) is now declared +to be the default setting for all ISCCP simulator uses. When implementing +version 4.0 into a model, please confirm that the setting of this +variable is correct. + +2/ BSD copyright is now applied to the simulator. +_______________________________________________________________________________ + +Changes made by Steve Klein and Mark Webb from version 3.7 to 3.8 + +Three changes have been made in this release. + +1/ isccp_cloud_types is now a wrapper routine which calls SCOPS and +ICARUS routines. This has been done to allow the ISCCP simulator to +be easily bundled along with COSP (CFMIP Observational Simulator +Package - see www.cfmip.net ) The ICARUS routine contains most +of the code that was in ISCCP_CLOUD_TYPES previously. + +The integer call_scops has been removed from the ISCCP_CLOUD_TYPES +argument list, as users who wish to bypass SCOPS can now do so by +calling the ICARUS routine directly. + +Users who call SCOPS directly should note that SCOPS now takes +slightly different arguments. Previously the cloud fraction +inputs cc(npoints,nlev) and conv(npoints,nlev) were copied into +tca(npoints,0:nlev) and cca(npoints,nlev) in ISCCP_CLOUD_TYPES, +which were then passed into SCOPS. SCOPS now takes cc(npoints,nlev) +and conv(npoints,nlev) as inputs, to be consistent with ISCCP_CLOUD_TYPES +and ICARUS. tca(npoints,0:nlev) is now an internal variable in SCOPS, +and the cca variable has been removed since it was an unnecessary copy +of the conv variable. + +2/ This version of the simulator adds the capability to output as +diagnostic variables the grid-box mean (i.e. average over sub-columns) +of the 10.5 micron infrared brightness temperature for all-sky and +clear-sky conditions. These variables are called "meantb" and "meantbclr + +3/ A minor bugfix has been made to some debugging code in icarus.f +to prevent an array bound error when setting the levmatch variable. +levmatch is a debugging variable and and fixing this bug does not +affect pc-tau counts or any other output variables of the +simulator. + +_______________________________________________________________________________ +Changes made by Steve Klein and Mark Webb from version 3.6 to 3.7 + +Two changes have been made in this release. + +1/ In all previous versions of the code, two input tables were used to +convert cloud optical thickness into cloud albedo and vice versa. These +tables, invtau and tautab, came from the original ISCCP software and +documentation. In this version of the code, these tables are removed +from the code and replaced with the following analytic functions which +are a reasonable fit to these tables. + +ALB = TAU**0.895 / ( TAU**0.895 + 6.82 ) + +TAU = ( 6.82 / ( ( 1. / ALB ) - 1. ) ) ** (1./0.895) + +where TAU is the cloud optical thickness and ALB is the cloud albedo. + +2/ Option to bypass call to SCOPS in ISCCP_CLOUD_TYPES + +This is to support integration into the CFMIP Observational Simulator +Package (COSP - see http://www.cfmip.net ) + +New input arguments for isccp_cloud_types: + +integer call_scops +real frac_out(npoints,ncol,nlev) + +Default behaviour when using the ISCCP simulator on its own is +to set the integer argument call_scops to 1. frac_out does +not need to be set in this case. + +If calling scops externally to isccp_cloud_types, call_scops should +be set to zero and overlap information passed in using frac_out. + +_______________________________________________________________________________ +Changes made by Steve Klein from versions 3.5.1 to 3.6 + +The modifications can be divided into three groups. Those involving +averages of cloud properties across the sub-columns (i.e. the +"Lightweight" diagnostics of total cloud area, mean cloud top pressure, +and mean cloud albedo), those involving the determination of +cloud-top pressure, and those to handle missing data issues. + +All modifications (except the missing data issues) change results, +although the differences in results should be relatively minor for +most situations. The most prominent differences will be: + +(a) the values of the lightweight diagnostics in grid-boxes that have a +lot of cloud with optical thickness less than the minimum that ISCCP can +detect ("isccp_taumin" = 0.3). + +(b) the values of cloud-top pressure for clouds under strong temperature +inversions (e.g. marine stratocumulus) when the experimental cloud-top +pressure assignment is used. Note that currently the experimental +cloud-top pressure assignment is not recommended but may be become +default if it is demonstrated to yield improved agreement with ISCCP +observations through ICARUS-assessment tests being performed by Jay Mace +and his colleagues (e.g. Mace et al. JGR 2005, doi: 10.1029/2005JD005921). + +Missing data handling +--------------------- + +1) In the case of dark points but "top_height" not equal to 3, the +output variables will now be equal to the value of a new real defined in the +code. This real is called "output_missing_value" and set to -1.E+30 in +a data statement in icarus.f. Note that the output variables include +"fq_isccp", "totalcldarea", "meanptop", "meanalbedocld", "meantaucld", +"boxptop", and "boxtau". + +2) In the case of "totalcldarea" = 0., "meanptop", "meanalbedocld" and +"meantaucld" will be equal to the "output_missing_value". + +3) For all sub-columns with no cloud, "boxptop" and "boxtau" now have +the "output_missing_value" and not the values of 0. as they did previously. + + +Lightweight diagnostics modifications +------------------------------------- + +1. Restrictions involving the reporting of totalcldarea + +In the original code, "totalcldarea", which is the diagnostic for the +total horizontal area of a grid box covered by clouds at any level, was +always calculated. This was done even though other diagnostics such as +"meanptop" and "meantaucld", which are the mean cloud-top pressure and +cloud optical thickness, were calculated only for sunlit gridpoints in +most circumstances. This modification restricts the calculation of +"totalcldarea" to the same situations used to calculate "meanptop" and +"meantaucld". + +To review, these diagnostics are calculated only if the grid-box is +sunlit in the case that "top_height" = 1 or 2, and at all times is +"top_height" = 3. The value of "top_height" equal to 1 corresponds to +the calculation of cloud-top pressure using algorithms appropriate to +compare to ISCCP daylight data (i.e. the pc-tau diagrams) and is the +value used in all CFMIP projects. The value of "top_height" equal to 2 +corresponds the assignment of cloud-top pressure at the model's actual +highest cloud-top pressure. The value of "top_height" equal to 3 +corresponds to the calculation of cloud-top pressure according the +methods that correspond to ISCCP IR-only retrievals which are performed +both at night and during the day. It should be used when comparing to +the ISCCP IR-only cloud data, but I haven't seen that ever done, +although it could be. + +2. Addition of "meanalbedocld" diagnostic + +Williams and Webb (2008, Climate Dynamics doi:10.1007/s00382-008-0443-1) +created the term "Lightweight diagnostics" to represent a much smaller +set of ISCCP simulator output quantities than the 49 pc-tau histograms. +These diagnostics are the total cloud area ("totalcldarea"), the mean +cloud-top pressure ("meanptop"), and the mean cloud albedo +("meanalbedocld"). These lightweight diagnostics were also used in an +earlier clustering study involving ISCCP observations (Gordon et al. JGR +2005 doi:10.1029/2004JD005027). + +The modification is to have the simulator compute and output the mean +cloud albedo ("meanalbedocld"). Previous versions of the ISCCP simulator +did not do this but output the mean cloud optical thickness +("meantaucld") which was internally calculated from the mean cloud +albedo. This modification results in the addition of "meanalbedocld" to +the isccp_cloud_types subroutine interface and will require users to +make appropriate modifications to their calling statements to ISCCP +simulator. + +3. Restriction of lightweight diagnostics to clouds with optical +thickness greater than the minimum ISCCP can detect ("isccp_taumin") + +If these lightweight diagnostics are to be compared to ISCCP +observations, they must be calculated using only the model clouds that +ISCCP can detect. In the case of the simulator, this condition is +determined by saying that clouds with optical thickness less than a +threshold ("isccp_taumin") are not detectable by ISCCP. The current +value of "isccp_taumin" is 0.3. The modification limits the calculation +of "totalcldarea", "meanptop", "meanalbedocld", and "meanptop", to +clouds in sub-columns with column cloud optical thicknesses greater than +"isccp_taumin". Previous versions of the simulator did not impose this +restriction. + +This will have a noticeable impact on the values of the lightweight +diagnostics in grid-boxes that have a lot of model clouds with optical +thickness less than "isccp_taumin". Relative to previous versions of the +ISCCP simulator, this will result in decreases of "totalcldarea" and +increases of "meanalbedocld" and "meantaucld". + + +Cloud-top pressure modifications +-------------------------------- + +1. Actual cloud-top pressures for "top_height" equal to 2. + +In the case that one wants to examine the cloud-top pressures actually +produced by a model, one selects "top_height" equal to 2. This +modification is to calculate the cloud-top pressure as the half-level +pressure corresponding to the top of the highest model level to contain +any cloud. Previous versions assigned the cloud-top pressure to the +full-level pressure of the highest model level to contain any cloud. +Note the terminology is that "full" level is the pressure corresponding +to somewhere in the middle of the model level and that "half" level is +the pressure corresponding to the boundaries of a model level. Thus, +half levels are staggered relative to full levels. This modification, +following a suggestion of Tony Del Genio, now obeys the common +parameterization assumption that where clouds occur, they fill the full +vertical extent of a model level. Under this assumption, the actual +cloud-top pressure is at the top of the model level. + +Note that "top_height" equal to 2 is not generally used. + +2. Interpolated cloud-top pressure + +In the case, "top_height" equals 1 or 3, the cloud-top pressure is +determined from an infrared brightness-temperature derived cloud-top +temperature. This involves a step of locating the pressure level on a +temperature profile which has the radiance-derived cloud-top +temperature. The modification now determines cloud-top pressure through +vertical interpolation in log-pressure space of the model's temperature +profile. Previous versions had determined the cloud-top pressure as the +full-level pressure of the model level which had a temperature nearest +the radiance-derived cloud-top temperature. The new method is more +accurate. + +As you might expect, this change has a very minor impact on the pc-tau +histogram for the generally true condition when model levels are more +finely spaced in pressure than the 7 cloud-top pressure bins. In some +applications though, users had examined the values of cloud-top pressure +directly and found that the default procedure was insufficient. This was +first noticed by Steve Krueger and Yali Luo (Luo et al. JAS 2005). This +change can also markedly impact the values of the mean cloud-top +pressure "meanptop". + +3. Experimental alternative radiance-derived cloud-top pressure + +In the case that there is only one tropospheric level in a temperature +profile with temperature equal to the radiance-derived cloud-top +temperature, the method to determine cloud-top pressure has a unique +solution. However, when temperature inversions occur, there are multiple +solutions for cloud-top pressures. Because many clouds are capped by +inversions (e.g. marine stratocumulus clouds), this situation arises +frequently in the atmosphere. + +All previous versions of the ISCCP simulator have set the cloud-top +pressure to be that corresponding to the highest pressure level (i.e. +lowest altitude level) which has the temperature closest to the +radiance-derived cloud-top temperature. In normal circumstances, this +cloud-top pressure would be very close to the actual cloud-top pressure +in the model. + +However, there is abundant evidence (from most recently the new Clousat +and Calipso data) that ISCCP (and other satellite retrievals involving +passive visible and infrared radiances) is more likely to set the +cloud-top pressure in this circumstance closer to the lowest pressure +level (i.e. highest altitude level) which has the temperature closest to +the radiance-determined cloud-top temperature. In the case of marine +stratocumulus clouds underneath at 10K inversion this difference can be +very large. For example, it might be the difference between a cloud-top +pressure of ~900 mb and ~750 mb. It is for this reason that Pat Minnis +(Minnis et al. J. Appl. Met. 1992) derived an alternative technique for +cloud-top height by scaling the difference between cloud-top and +sea-surface temperatures by an assumed lapse-rate for the marine +boundary layer. Indeed, one finds that in marine stratocumulus regions +that ISCCP reports a lot of cloud in the cloud-top pressure bin between +680 and 800 mb. Probably much of this cloud should properly be in the +800 mb to the surface cloud-top pressure bin. A recent article (Garay, M. +J., S. P. de Szoeke, and C. M. Moroney (2008), Comparison of marine +stratocumulus cloud top heights in the southeastern Pacific retrieved +from satellites with coincident ship-based observations, J. Geophys. +Res., 113, D18204, doi:10.1029/2008JD009975) shows that ISCCP seriously +underestimates the cloud-top pressure under these situations (see Garay +et al. Figure 2). + +However, the purpose of the simulator is to mimic ISCCP data and this an +important ISCCP error which probably should be mimicked. Thus, as an +experimental modification, a flag variable "top_height_direction" is +provided which allows one to choose whether or not to set the cloud-top +pressure as the highest or lowest pressure for which the interpolated +temperature profile matches the radiance-derived cloud-top temperature. + +The flag variable "top_height_direction" is a new interface variable to +the isccp_cloud_types subroutine. When "top_height_direction" equals 1, +the cloud-top pressure corresponds to the highest pressure (i.e. lowest +altitude) with temperature matching the radiance-derived cloud-top +temperature. When "top_height_direction" equals 2, the cloud-top +pressure corresponds to the lowest pressure (i.e. highest altitude) +level with the matching cloud-top temperature. + +All previous versions of the ISCCP simulator have been using the method +that corresponds to "top_height_direction" equal to 1. This remains the +recommended default setting. However, if further work (i.e. +ICARUS-assessment tests by Jay Mace) demonstrates that +"top_height_direction" equal to 2 would be a better match to the ISCCP +cloud-top pressures then in the future it may be recommended to use +"top_height_direction" equal to 2. + +_______________________________________________________________________________ + +Changes made by Mark Webb from version 3.5 to 3.5.1 + +SCOPS separated out into its own subroutine (8/11/06) + +_______________________________________________________________________________ +Changes made by Mark Webb from version 3.4.1 to 3.5 + +Version released under LGPL ( GNU Public License ) +Introduced a new random number generator to allow release +under LGPL. Results should be statistically equivalent to 3.4 +Minor changes to the README file on seeding. +Updated Steve's email address +_______________________________________________________________________________ +Changes made by Mark Webb from version 3.3 to 3.4. +Changes made by Mark Webb from version 3.4 to 3.4.1 + +Changes to the README file mainly on guidance for setting NCOL. +Code exactly as 3.4 +_______________________________________________________________________________ +Changes made by Mark Webb from version 3.3 to 3.4. + +Default value for attrop changed to 120K, on request from Steve. +Reference to nlevmax removed from isccp_cloud_types.f - this +caused a segfault when running the tests under Linux/g77. +Moved initialisation of tauchk to start of isccp_cloud_types.f +as it was not being initialised for top_height = 2. + +Various minor changes to the README file requested by Steve. +_______________________________________________________________________________ + +Changes made by Mark Webb and Steve Klein from version 3.2 to 3.3. + +Converted debug to be an integer value - 0 = no printing, +non-zero specifies the step with which the printout loops over j. + +Added debugcol allow separate activation of box printout. + +Modified tropopause diagnosis: + +Previously, the code worked by starting at the top of the atmosphere +and working down, setting the tropopause temperature to the layer +temperature as long as the layer temperature is greater than in +the layer below - i.e. the tropopause temperature was the +temperature of the lowest layer that is in or near to the +stratosphere. The problem with this is that if the atmosphere +is isothermal, or if temperature monotonically decreases with +height, attrop is never set, and the default value of ptrop +of 50mb is used. + +The main effect of this was (in the cases where a tropopause +was not found ) to set the cloud tops pressures +for pixels with optical thickness around .3 or less to 50mb. +This is not thought a serious problem, as most of the cloud +affected is below the detection threshold for ISCCP anyway. + +This version has been modified to diagnose the tropopause as +the coldest level between 400mb and 50mb. A tropopause will +always be diagnosed if the inputs have pressure levels +between these levels. Failing that, ptrop will be set +to 50Mb, and attrop will be set to 0K. This is safer +than setting attrop to, say, 200K as the emissivity correction +for optically thin clouds does not work properly if the +cloud temperature is lower than that of attrop. + +_______________________________________________________________________________ + +Changes made by Bryant McAvaney going from version 3.1 to 3.2. + +Bryant made the following changes: + +renamed: + +isccp_cloudtypes.f, test_isccp_cloudtypes.f, test_isccp_cloudtypes.f + +to + +isccp_cloud_types.f, test_isccp_cloud_types.f, test_isccp_cloud_types.f + +to avoid problems when using interactive debugger. + +itrop -> itrop(npoints) ( fix for bug in version 3.1 ) + +initialised attrop to 200K and itrop to 1 ( as were uninitialised on +occasions where tropopause code failed to find a tropopause. ) + +now only do emcld adjustment to fluxtop if tau(j,ibox) .gt. (tauchk) - +this aviods floating exceptions when ir inputs are passed with no or v. +small vis values e.g. at dawn/dusk + +removal of ncolmax, nlevmax + +added debugcol logical for column printout + +modified most of ncolprint loops to work in vector mode + +re-ordered write statements under 'debug' to match argument list + +initialised boxtau,boxptop,box_cloudy + +moved bb emission calc out of ibox loop + +added rec2p13 to hold reciprocal of 2.13 + +added tauchk to hold -1.*log(0.9999999) value + +moved btcmin calc out of ibox loop + +_______________________________________________________________________________ + +Changes made by Mark Webb in going from Version 3.0 to Version 3.1 + +( ** Please note that a bug has been found in this version. +The tropopause index itrop was not dimensioned over npoints. +This is corrected in version 3.3 ) + +This version is scientifically equivalent to version 3.0, but +is optimised to run more efficiently on vector processors +such as the NEC SX-6. It should be bit reproducible with version 3.0. +Please let me know if you find a situation where the two versions +give difference answers for consistent inputs. + +To do this I have had to modify isccp_cloudtypes.f to accept +vector inputs rather than single column inputs. This version +can still be called column by column, ( just set npoints to +1 ), but this is very inefficient on vector architectures. + +A few new arguments have been added - I have put these at +the start of the argument list to make them easier to spot. + +debug is a logical which, if set to true, tell isccp_cloudtypes +to print out lots of diagnostics to unit 6 and unit 9. debug +is set to true in test_isccp_cloudtypes.f, and is useful for +checking that you are passing all of the relevant arguments +in correctly. + +npoints is the number of grid points in the horizontal that you +want to process. Most of the input variables now have npoints +as their first array dimension, and most of the inner loops +in isccp_cloudtypes loop over this array dimension, (and do +vectorise on the sx-6). The larger the value of npoints, the +better the performance you are likely to get on a vector +processor. The code is not structured to vectorise over +loops over ncol/ibox, although a small number of these do. + +sunlit should be set to 1 for day points and 0 for nighttime +points. See the section below on handling sunlit points for a +discussion of the related issues. + +Added sections on setting NCOL, handling sunlit points, and +averaging to the 'things to bear in mind' section. +_______________________________________________________________________________ + +Changes made by Steve Klein in going from Version 2.2.1.1 to Version 3.0 + +*** Please note that moving to this version changes the results given +by the code *** + +1. Based upon e-mail correspondance with Bill Rossow, the minimum visible + optical thickness ISCCP is assumed to detect is set to 0.3. Previous + versions used 0.1. + +2. Provisions haven been made for an IR-only cloud top pressure adjustment. This + permits comparison to ISCCP data at night. This is done by adding a third + option to top_height which will be the IR-only adjusted top option. Note + that the previous adjusted option used the visible optical depth to adjust + the cloud emissivity. NOTE that one must still pass the visible optical + depth to the code even if one wishes IR-only calculations. This is done + primarily to count the abundance of cloud types in different visible optical + thickness categories. Comparison to IR-only ISCCP data is accomplished by + summing over all categories of optical thickness for a given cloud top + pressure interval. + +3. Previous versions of the code assumed that tau-ir = tau_vis / 2.13 . + Note that 2.13 is the ice microphysics conversion factor. An error comes + from using this factor for liquid phase clouds where the appropriate factor + is 2.56. This has been accomodated by a small iteration loop after the + calculation of the cloud brightness temperature. If the cloud brightness + temperature is greater than 260K (ISCCP's ice cloud threshold) then the + calculation of cloud brightness temperature is repeated using 2.56 instead + of 2.13. + +The next minor correction is based upon a more careful reading of page 86 of +the ISCCP documentation (available from the ISCCP web site): + +Rossow, W.B., A.W. Walker, D.E. Beuschel, and M.D. Roiter, 1996: International +Satellite Cloud Climatology Project (ISCCP) Documentation of New Cloud Datasets. WMO/TD-No. 737, World Meteorological +Organization, 115 pp. + +4. Following the calculation of TRANS-MAX described towards the bottom of page + 86, cloud top pressure is set to the tropopause pressure if tau < taumin + based upon transmax. In previous versions though, conversion of taumin from + IR-tau to VIS-tau before comparison to tau(ibox) was overlooked. Also at + this point, the cloud top temperature is assumed to be 5 K colder than + the tropopause temperature. Note that the documentation says the "cloud top + pressure equals tropopause pressure". + + +============================================================================ + +Changes made by Mark Webb in going from Version 2.2 to Version 2.2.1.1 + +A very minor change was applied to test_isccp_cloudtypes.f to +avoid a problem with some stricter compilers which do not allow +constants arguments to be overwritten in the called routine. This +was happening because I was passing a constant 50 into the seed +argument of isccp_cloudtypes instead of the variable seed. + +Minor changes also made to Makefile and test_isccp_cloudtypes.ksh +to remove the need for . in $PATH. + +Mark Webb 2/7/2002 + +============================================================================ + +Changes made by Mark Webb in going from Version 2.1 to Version 2.2 + +1) seed is now passed in as an argument. This makes it + easier for the user to follow the advice in the README + file wrt setting different seed values for subsequent calls. +2) a couple of lines were > 72 chars long, which gave errors + with my compiler. +3) use of formatted write statements to print out values of + totalcldarea, meanptop, meantaucld ( unformatted writes + make the tests fail with different compilers as they + output different white space characters. I can't ignore + white space in the comparison because this could mask + errors in the overlap output. ) +4) changes to the formats of some other write statements + to reduce false errors with different rounding characteristics + in formatting on different platforms. +5) the binary files containing the enery weightings only work on + some platforms - I have added formatted versions that can be used + as alternatives - specify readbinary=.false. in test_isccp_cloudtypes.f. + +Mark Webb 26/6/2002 + +============================================================================ + +Changes made by Steve Klein in going from Version 2.0 to Version 2.1 + +The code was modified so that the primary subroutine, ISCCP_CLOUD_TYPES, +now returns the fraction of columns that contain cloud ('totalcldarea'), +the mean cloud top pressure in the cloudy portion of the grid box ('meanptop'), +and the energy-weighted mean optical thickness ('meantaucld'). Note that +if the grid box contains no clouds whatsoever that meanptop and meantaucld +are both zero. + +In addition, the code now returns the output on a column by column basis +of the cloud top pressure ('boxptop') and optical depth ('boxtau'). If +no cloud exists in the column then both these variables are zero. + +In computing the energy-weighted mean optical thickness, the tables +used by ISCCP are applied. These tables are in binary files 'tautab.bin' +and 'invtau.bin' supplied in the tar file. Note that the size of the +invtau vector is 45021, rather large. These binary files are read by +the test_isccp_cloudtypes.f and passed as new input arguments to +ISCCP_CLOUD_TYPES. + +The 'stdout.expected' file is modified from that of version 2.0 in that +the additional fields output by ISCCP_CLOUD_TYPES (totalcldarea, meanptop, +meantaucld, boxtau, boxptop) are added. Apart from the additions the +stdout.expected file is identical to that in version 2.0. + +============================================================================ + +What's new in 2.0 since 1.17.1.1: + + o No functional changes + o The tests can now be run using 'make test' + o There is now a README file + o All write statements in the tests should use formatted I/O, + which makes it easier to check whether the tests have passed + on different platforms. + +_______________________________________________________________________________ + +Version 1.17.1.1 was made available to a few people by Steve in +a tar file called new_isccp_mark_steve.tar. Note that the version +number in isccp_cloudtypes.f is 1.16 although this version is not +the same as version 1.16. + +The contents were: + +$ tar tvf new_isccp_mark_steve.tar +rwxr-xr-x 1116/77 0 Oct 28 18:57 1999 isccp_mark_steve/ +rw-r--r-- 1116/77 389120 Oct 28 18:59 1999 isccp_mark_steve/Makefile +rw-r--r-- 1116/77 2595 Aug 15 18:02 1999 isccp_mark_steve/coldecomp.steve.data +rw-r--r-- 1116/77 4534 Aug 14 15:57 1999 isccp_mark_steve/input.data +rw-r--r-- 1116/77 870 Aug 14 15:40 1999 isccp_mark_steve/input.data.mark +rw-r--r-- 1116/77 4534 Aug 14 15:56 1999 isccp_mark_steve/input.data.steve +rw-r--r-- 1116/77 34106 Oct 28 18:55 1999 isccp_mark_steve/isccp_cloudtypes.f +rw-r--r-- 1116/77 325816 Aug 15 17:50 1999 isccp_mark_steve/output.steve.data +rw-r--r-- 1116/77 601 Aug 14 16:06 1999 isccp_mark_steve/ran0.f +rw-r--r-- 1116/77 442 Aug 5 16:25 1999 isccp_mark_steve/rcs_ids +rw-r--r-- 1116/77 3045 Aug 15 18:19 1999 isccp_mark_steve/test_isccp_cloudtypes.f + +What was new in 1.17.1.1 compared to 1.17. + + o No functional changes + o Steve's changes to various boolean expressions to improve portability. + +_______________________________________________________________________________ + +What was new in 1.17 compared to 1.16. + + o new code to handles water vapour + o uses a better tau - emissivity relationship + o notes cloud amounts with tau < 0.1 + +Version 1.17 was distributed by Steve in a tar file which was most likely +called isccp_mark_steve.tar ( I don't have a copy or the tarfile! ). +Note that the version number in isccp_cloudtypes.f is also 1.16 although this +version is not the same as version 1.16. This version of isccp_cloudtypes.f +is 33348 bytes long. + +_______________________________________________________________________________ + +Version 1.16 was distributed by Mark in a file called isccp_mark.tar +( as were some previous versions ). This was in August 1999 + +The contents were: + +$ tar tvf isccp_mark.tar +r--r--r-- 275/107 28516 Aug 3 17:20 1999 isccp_mark/isccp_cloudtypes.f +r--r--r-- 275/107 2769 Aug 5 16:22 1999 isccp_mark/test_isccp_cloudtypes.f +r--r--r-- 275/107 587 Jul 29 10:51 1999 isccp_mark/ran0.f +r--r--r-- 275/107 791 Aug 5 16:24 1999 isccp_mark/input.data +r--r--r-- 275/107 432 Aug 3 15:57 1999 isccp_mark/Makefile +rw-r--r-- 275/107 442 Aug 5 16:25 1999 isccp_mark/rcs_ids + +What was new in 1.16 compared to 1.13. + + o correct treatment of top_height=2 + o correct treatment of convective cloud in random & max overlap cases + o correct treatment of stratiform cloud above convective cloud + +_______________________________________________________________________________ + +Version 1.13 was distributed by Mark in a file called isccp_mark.tar +in July 1999. Note that this version was still in development and +had the following problems which were ironed out later: + + o doesn't work for top_height=2 + o convective cloud not treated properly in random or max overlap cases + o stratiform cloud above convective cloud not quite right + +-rw-r--r-- 1 hadmw mec 40960 Mar 20 09:53 isccp_mark.tar + +$ tar tvf isccp_mark.tar +r--r--r-- 275/107 27454 Jul 29 10:48 1999 isccp_mark/isccp_cloudtypes.f +r--r--r-- 275/107 3931 Jul 29 10:54 1999 isccp_mark/test_isccp_cloudtypes.f +r--r--r-- 275/107 587 Jul 29 10:51 1999 isccp_mark/ran0.f +r--r--r-- 275/107 1619 Jul 29 11:07 1999 isccp_mark/input.data +r--r--r-- 275/107 582 Jul 29 11:36 1999 isccp_mark/Makefile +rw-r--r-- 275/107 441 Jul 29 11:36 1999 isccp_mark/rcs_ids + +What was new in 1.13 compared to 1.1. + + o Various changes to make FORTRAN code consistent with Mark's PV-Wave + including: + o support for convective as well as stratiform clouds in the same gridbox + o pseudo-random sampling method to fix 'left fill' problem + +_______________________________________________________________________________ + +Version 1.1 + +Steve's box code, as used in Klein & Jacob 1999. Received by Mark in July 1999. +isccp_cloudtypes.f is 22230 bytes long. + +This version doesn't support convective clouds, and suffers from the 'left fill' +problem. + +_______________________________________________________________________________ + +7. Some other issues to consider +--------------------------------- + +Steve's email accompanying distribution of release 1.1 in Jan 1999. + +> NOTES/QUESTIONS/ISSUES TO BE RESOLVED BY THE GROUP AS A WHOLE +> +> 1. Following our discussion, we have agreed that the optical depth used +> should be exactly the same as that used in the host GCM. Thus the +> program takes as input the optical depth in each model level. OK? +> +> 2. The program takes each vertical profile of cloud cover and subdivides +> an atmospheric column into homogenous columns. The suggested number of +> columns is 100. It is important to note, that the cloud COVER not +> cloud FRACTION of each model level is required as input. For example +> the GISS GCM assumes something that the clouds do not fill the grid +> box in the vertical completely (at least they did in DelGenio's 1996 +> paper). They will need to convert their cloud fraction to a cloud cover +> before input. +> +> 3. Cloud top pressure is determined by 2 methods. If top_height is set +> to 2, then the cloud top pressure is set to be the mean pressure of the +> highest cloudy level of each sub-column that contains clouds. This is +> done in the line: +> +> ptop(ibox)=pfull(ilev) +> +> A choice is made here in that one could use the half-pressure level at +> the top of a given pressure level. I suppose users will customize. OK? +> +> 4. The second method for determining cloud top pressure (used it top_height +> is set to 1), computes an approximate 11 micron radiance and then follows +> ISCCP procedures (assuming a single level of cloud) to determine the cloud +> top pressure. To do this the program requires more input including: +> the model's cloud 11 micron emissivity in each level, the surface skin +> temperature, the air temperature, and the surface's 11 micron emissivity. +> Questions that arise here are: +> +> (a) Should we include a rough simulation of the water vapor continuum +> as is done in Yu et al., Climate Dynamics, 1996, pages 389-401.? +> If we do, we will need the specific humidity of water vapor in each +> level, and a formula for the continuum. I would use the Roberts +> formula used in Yu et al. which is much simpler than the one used +> by ISCCP (see D level documentation page 77). +> (b) If data is not easily available, should we assume a longwave +> emissivity for the skin or a temperature relationship between the +> model's temperature and the skin temperature? + +( Note Steve added the continuum treatment at version 1.17 ) + +> 5. What is the minimum optical depth we should assume ISCCP clouds can detect? +> 0.1 (the default of the program) or 0.2? Should we create (not done in +> the current program) a separate tau category for all the clouds with tau +> less than taumin. ISCCP experts opinions are most needed here. + +( also done at 1.17 ) + +> 6. To distribute the clouds, you need to have an overlap assumption. Currently +> the program has 3 options: maximum, random, and maximum-random. The +> program default is max-random, so that to use the other programs you will +> need to edit the program and uncomment the alternative line of code to +> change the overlap assumption. Don't forget to comment the line of code +> for max-random then. (Search the program for 'CLOUD OVERLAP +> ASSUMPTION' to find these lines of code) +> +> 7. Horizontal Cloud Inhomogeneity. Currently the program distributes the +> cloud optical depth (and longwave emissivity if used) evenly in the hor- +> izontal. Users may wish to do other things here depending on their +> model's assumptions. Note that if you change this, you have to make +> an assumption about the vertical correlation of the cloud inhomogeneity +> (e.g. are the thicker parts of the cloud in level i, directly beneath +> the thicker parts of the cloud in level i+1). The line of code to change +> for optical depth is: +> +> do 16 ibox=1,ncol +> tau(ibox)=tau(ibox)+real(BOX(ilev,ibox))*dtau(ilev) +> 16 continue +> +> where ibox is the index variable for the number of columns. +> The three places the longwave emissivity is used (variable name dem) +> will also need to be changed if you decide to have horizontal cloud +> inhomogeneity. +> +> Cheers, +> Steve + +_______________________________________________________________________________ diff --git a/src/physics/cosp2/src/simulator/icarus/icarus.F90 b/src/physics/cosp2/src/simulator/icarus/icarus.F90 new file mode 100644 index 0000000000..767453b113 --- /dev/null +++ b/src/physics/cosp2/src/simulator/icarus/icarus.F90 @@ -0,0 +1,645 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Lawrence Livemore National Security Limited Liability +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_ICARUS + USE COSP_KINDS, ONLY: wp + USE COSP_PHYS_CONSTANTS, ONLY: amd,amw,avo,grav + use MOD_COSP_STATS, ONLY: hist2D + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,numISCCPTauBins,numISCCPPresBins,isccp_histTau, & + isccp_histPres + implicit none + + ! Shared Parameters + integer,parameter :: & + ncolprint = 0 ! Flag for debug printing (set as parameter to increase performance) + + ! Cloud-top height determination + integer :: & + isccp_top_height, & ! Top height adjustment method + isccp_top_height_direction ! Direction for finding atmosphere pressure level + + ! Parameters used by icarus + real(wp),parameter :: & + tauchk = -1._wp*log(0.9999999_wp), & ! Lower limit on optical depth + isccp_taumin = 0.3_wp, & ! Minimum optical depth for joint-hostogram + pstd = 1013250._wp, & ! Mean sea-level pressure (Pa) + isccp_t0 = 296._wp, & ! Mean surface temperature (K) + output_missing_value = -1.E+30 ! Missing values + +contains + ! ########################################################################## + ! ########################################################################## + SUBROUTINE ICARUS(debug,debugcol,npoints,sunlit,nlev,ncol,pfull, & + phalf,qv,cc,conv,dtau_s,dtau_c,th,thd,frac_out,skt,emsfc_lw,at,& + dem_s,dem_c,fq_isccp,totalcldarea, meanptop,meantaucld, & + meanalbedocld, meantb,meantbclr,boxtau,boxptop,levmatch) + + ! INPUTS + INTEGER,intent(in) :: & ! + npoints, & ! Number of model points in the horizontal + nlev, & ! Number of model levels in column + ncol, & ! Number of subcolumns + debug, & ! Debug flag + debugcol ! Debug column flag + INTEGER,intent(in),dimension(npoints) :: & ! + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in) :: & ! + emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL(WP),intent(in),dimension(npoints) :: & ! + skt ! Skin Temperature (K) + REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & ! + frac_out ! Boxes gridbox divided up into subcolumns + REAL(WP),intent(in),dimension(npoints,nlev) :: & ! + pfull, & ! Pressure of full model levels (Pascals) + qv, & ! Water vapor specific humidity (kg vapor/ kg air) + cc, & ! Cloud cover in each model level (fraction) + conv, & ! Convective cloud cover in each model + at, & ! Temperature in each model level (K) + dem_c, & ! Emissivity for convective clouds + dem_s, & ! Emissivity for stratiform clouds + dtau_c, & ! Optical depth for convective clouds + dtau_s ! Optical depth for stratiform clouds + REAL(WP),intent(in),dimension(npoints,nlev+1) :: & ! + phalf ! Pressure of half model levels (Pascals)! + integer,intent(in) :: th,thd + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,7,7) :: & + fq_isccp ! The fraction of the model grid box covered by clouds + REAL(WP),intent(out),dimension(npoints) :: & + totalcldarea, & ! The fraction of model grid box columns with cloud present + meanptop, & ! Mean cloud top pressure (mb) - linear averaging + meantaucld, & ! Mean optical thickness + meanalbedocld, & ! Mean cloud albedo + meantb, & ! Mean all-sky 10.5 micron brightness temperature + meantbclr ! Mean clear-sky 10.5 micron brightness temperature + REAL(WP),intent(out),dimension(npoints,ncol) :: & + boxtau, & ! Optical thickness in each column + boxptop ! Cloud top pressure (mb) in each column + INTEGER,intent(out),dimension(npoints,ncol) :: & + levmatch ! Used for icarus unit testing only + + + ! INTERNAL VARIABLES + CHARACTER(len=10) :: ftn09 + REAL(WP),dimension(npoints,ncol) :: boxttop + REAL(WP),dimension(npoints,ncol,nlev) :: dtau,demIN + INTEGER :: j,ilev,ibox + INTEGER,dimension(nlev,ncol ) :: acc + + ! PARAMETERS + character ,parameter, dimension(6) :: cchar=(/' ','-','1','+','I','+'/) + character(len=1),parameter,dimension(6) :: cchar_realtops=(/ ' ',' ','1','1','I','I'/) + ! ########################################################################## + + call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dem_c,dem_s,demIN) + call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dtau_c,dtau_s,dtau) + + call ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demIN,skt,emsfc_lw,qv,at, & + pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr) + + call ICARUS_COLUMN(npoints,ncol,boxtau,boxptop/100._wp,sunlit,boxttop,& + fq_isccp,meanalbedocld,meanptop,meantaucld,totalcldarea,meantb) + + ! ########################################################################## + ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM + ! ########################################################################## + + if (debugcol.ne.0) then + do j=1,npoints,debugcol + + ! Produce character output + do ilev=1,nlev + acc(ilev,1:ncol)=frac_out(j,1:ncol,ilev)*2 + where(levmatch(j,1:ncol) .eq. ilev) acc(ilev,1:ncol)=acc(ilev,1:ncol)+1 + enddo + + write(ftn09,11) j +11 format('ftn09.',i4.4) + open(9, FILE=ftn09, FORM='FORMATTED') + + write(9,'(a1)') ' ' + write(9,'(10i5)') (ilev,ilev=5,nlev,5) + write(9,'(a1)') ' ' + + do ibox=1,ncol + write(9,'(40(a1),1x,40(a1))') & + (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),& + (cchar(acc(ilev,ibox)+1),ilev=1,nlev) + end do + close(9) + + enddo + end if + + return + end SUBROUTINE ICARUS + + ! ############################################################################ + ! ############################################################################ + ! ############################################################################ + SUBROUTINE ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demiN,skt,emsfc_lw,qv,at, & + pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr) + ! Inputs + INTEGER, intent(in) :: & + ncol, & ! Number of subcolumns + npoints, & ! Number of horizontal gridpoints + nlev ! Number of vertical levels + INTEGER, intent(in), dimension(npoints) :: & + sunlit ! 1=day 0=night + REAL(WP),intent(in) :: & + emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL(WP),intent(in), dimension(npoints) :: & + skt ! Skin temperature + REAL(WP),intent(in), dimension(npoints,nlev) :: & + at, & ! Temperature + pfull, & ! Presure + qv ! Specific humidity + REAL(WP),intent(in), dimension(npoints,ncol,nlev) :: & + frac_out, & ! Subcolumn cloud cover + dtau, & ! Subcolumn optical thickness + demIN ! Subcolumn emissivity + REAL(WP),intent(in), dimension(npoints,nlev+1) :: & + phalf ! Pressure at model half levels + + ! Outputs + REAL(WP),intent(inout),dimension(npoints) :: & + meantbclr ! Mean clear-sky 10.5 micron brightness temperature + REAL(WP),intent(inout),dimension(npoints,ncol) :: & + boxtau, & ! Optical thickness in each column + boxptop, & ! Cloud top pressure (mb) in each column + boxttop ! Cloud top temperature in each column + INTEGER, intent(inout),dimension(npoints,ncol) :: levmatch + + ! Local Variables + INTEGER :: & + j,ibox,ilev,k1,k2,icycle + INTEGER,dimension(npoints) :: & + nmatch,itrop + INTEGER,dimension(npoints,nlev-1) :: & + match + REAL(WP) :: & + logp,logp1,logp2,atd + REAL(WP),dimension(npoints) :: & + bb,attropmin,attrop,ptrop,atmax,btcmin,transmax,tauir,taumin,fluxtopinit,press, & + dpress,atmden,rvh20,rhoave,rh20s,rfrgn,tmpexp,tauwv,wk,trans_layers_above_clrsky, & + fluxtop_clrsky + REAL(WP),dimension(npoints,nlev) :: & + dem_wv + REAL(WP),dimension(npoints,ncol) :: & + trans_layers_above,dem,tb,emcld,fluxtop,tau,ptop + + ! #################################################################################### + ! Compute cloud optical depth for each column by summing up subcolumns + tau(1:npoints,1:ncol) = 0._wp + tau(1:npoints,1:ncol) = sum(dtau,dim=3) + + ! Set tropopause values + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + ptrop(1:npoints) = 5000._wp + attropmin(1:npoints) = 400._wp + atmax(1:npoints) = 0._wp + attrop(1:npoints) = 120._wp + itrop(1:npoints) = 1 + + do ilev=1,nlev + where(pfull(1:npoints,ilev) .lt. 40000. .and. & + pfull(1:npoints,ilev) .gt. 5000. .and. & + at(1:npoints,ilev) .lt. attropmin(1:npoints)) + ptrop(1:npoints) = pfull(1:npoints,ilev) + attropmin(1:npoints) = at(1:npoints,ilev) + attrop(1:npoints) = attropmin(1:npoints) + itrop = ilev + endwhere + enddo + + do ilev=1,nlev + atmax(1:npoints) = merge(at(1:npoints,ilev),atmax(1:npoints),& + at(1:npoints,ilev) .gt. atmax(1:npoints) .and. ilev .ge. itrop(1:npoints)) + enddo + end if + + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + ! ############################################################################ + ! Clear-sky radiance calculation + ! + ! Compute water vapor continuum emissivity this treatment follows Schwarkzopf + ! and Ramasamy JGR 1999,vol 104, pages 9467-9499. The emissivity is calculated + ! at a wavenumber of 955 cm-1, or 10.47 microns + ! ############################################################################ + do ilev=1,nlev + press(1:npoints) = pfull(1:npoints,ilev)*10._wp + dpress(1:npoints) = (phalf(1:npoints,ilev+1)-phalf(1:npoints,ilev))*10 + atmden(1:npoints) = dpress(1:npoints)/(grav*100._wp) + rvh20(1:npoints) = qv(1:npoints,ilev)*amd/amw + wk(1:npoints) = rvh20(1:npoints)*avo*atmden/amd + rhoave(1:npoints) = (press(1:npoints)/pstd)*(isccp_t0/at(1:npoints,ilev)) + rh20s(1:npoints) = rvh20(1:npoints)*rhoave(1:npoints) + rfrgn(1:npoints) = rhoave(1:npoints)-rh20s(1:npoints) + tmpexp(1:npoints) = exp(-0.02_wp*(at(1:npoints,ilev)-isccp_t0)) + tauwv(1:npoints) = wk(1:npoints)*1.e-20*((0.0224697_wp*rh20s(1:npoints)* & + tmpexp(1:npoints))+(3.41817e-7*rfrgn(1:npoints)))*0.98_wp + dem_wv(1:npoints,ilev) = 1._wp - exp( -1._wp * tauwv(1:npoints)) + enddo + + fluxtop_clrsky(1:npoints) = 0._wp + trans_layers_above_clrsky(1:npoints) = 1._wp + do ilev=1,nlev + ! Black body emission at temperature of the layer + bb(1:npoints) = 1._wp / ( exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp ) + + ! Increase TOA flux by flux emitted from layer times total transmittance in layers above + fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + & + dem_wv(1:npoints,ilev)*bb(1:npoints)*trans_layers_above_clrsky(1:npoints) + + ! Update trans_layers_above with transmissivity from this layer for next time around loop + trans_layers_above_clrsky(1:npoints) = trans_layers_above_clrsky(1:npoints)*& + (1.-dem_wv(1:npoints,ilev)) + enddo + + ! Add in surface emission + bb(1:npoints) = 1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp ) + fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + & + emsfc_lw * bb(1:npoints)*trans_layers_above_clrsky(1:npoints) + + ! Clear Sky brightness temperature + meantbclr(1:npoints) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop_clrsky(1:npoints)))) + + ! ################################################################################# + ! All-sky radiance calculation + ! ################################################################################# + + fluxtop(1:npoints,1:ncol) = 0._wp + trans_layers_above(1:npoints,1:ncol) = 1._wp + do ilev=1,nlev + ! Black body emission at temperature of the layer + bb=1._wp/(exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp) + + do ibox=1,ncol + ! Emissivity + dem(1:npoints,ibox) = merge(dem_wv(1:npoints,ilev), & + 1._wp-(1._wp-demIN(1:npoints,ibox,ilev))*(1._wp-dem_wv(1:npoints,ilev)), & + demIN(1:npoints,ibox,ilev) .eq. 0) + + ! Increase TOA flux emitted from layer + fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + dem(1:npoints,ibox)*bb*trans_layers_above(1:npoints,ibox) + + ! Update trans_layer by emitted layer from above + trans_layers_above(1:npoints,ibox) = trans_layers_above(1:npoints,ibox)*(1._wp-dem(1:npoints,ibox)) + enddo + enddo + + ! Add in surface emission + bb(1:npoints)=1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp ) + do ibox=1,ncol + fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) + end do + + ! All Sky brightness temperature + boxttop(1:npoints,1:ncol) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop(1:npoints,1:ncol)))) + + ! ################################################################################# + ! Cloud-Top Temperature + ! + ! Now that you have the top of atmosphere radiance, account for ISCCP + ! procedures to determine cloud top temperature account for partially + ! transmitting cloud recompute flux ISCCP would see assuming a single layer + ! cloud. *NOTE* choice here of 2.13, as it is primarily ice clouds which have + ! partial emissivity and need the adjustment performed in this section. If it + ! turns out that the cloud brightness temperature is greater than 260K, then + ! the liquid cloud conversion factor of 2.56 is used. *NOTE* that this is + ! discussed on pages 85-87 of the ISCCP D level documentation + ! (Rossow et al. 1996) + ! ################################################################################# + + ! Compute minimum brightness temperature and optical depth + btcmin(1:npoints) = 1._wp / ( exp(1307.27_wp/(attrop(1:npoints)-5._wp)) - 1._wp ) + + do ibox=1,ncol + transmax(1:npoints) = (fluxtop(1:npoints,ibox)-btcmin) /(fluxtop_clrsky(1:npoints)-btcmin(1:npoints)) + tauir(1:npoints) = tau(1:npoints,ibox)/2.13_wp + taumin(1:npoints) = -log(max(min(transmax(1:npoints),0.9999999_wp),0.001_wp)) + if (isccp_top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox)/2.13_wp + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk)) then + if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1._wp - exp(-1._wp * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06_wp,(fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27_wp / (log(1._wp + (1._wp/fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56_wp + end if + end if + end if + enddo + enddo + endif + + ! Cloud-top temperature + where(tau(1:npoints,ibox) .gt. tauchk) + tb(1:npoints,ibox)= 1307.27_wp/ (log(1. + (1._wp/fluxtop(1:npoints,ibox)))) + where (isccp_top_height .eq. 1 .and. tauir(1:npoints) .lt. taumin(1:npoints)) + tb(1:npoints,ibox) = attrop(1:npoints) - 5._wp + tau(1:npoints,ibox) = 2.13_wp*taumin(1:npoints) + endwhere + endwhere + + ! Clear-sky brightness temperature + where(tau(1:npoints,ibox) .le. tauchk) + tb(1:npoints,ibox) = meantbclr(1:npoints) + endwhere + enddo + else + meantbclr(1:npoints) = output_missing_value + end if + + ! #################################################################################### + ! Cloud-Top Pressure + ! + ! The 2 methods differ according to whether or not you use the physical cloud + ! top pressure (isccp_top_height = 2) or the radiatively determined cloud top + ! pressure (isccp_top_height = 1 or 3) + ! #################################################################################### + do ibox=1,ncol + !segregate according to optical thickness + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + + ! Find level whose temperature most closely matches brightness temperature + nmatch(1:npoints)=0 + do k1=1,nlev-1 + ilev = merge(nlev-k1,k1,isccp_top_height_direction .eq. 2) + do j=1,npoints + if (ilev .ge. itrop(j) .and. & + ((at(j,ilev) .ge. tb(j,ibox) .and. & + at(j,ilev+1) .le. tb(j,ibox)) .or. & + (at(j,ilev) .le. tb(j,ibox) .and. & + at(j,ilev+1) .ge. tb(j,ibox)))) then + nmatch(j)=nmatch(j)+1 + match(j,nmatch(j))=ilev + endif + enddo + enddo + + do j=1,npoints + if (nmatch(j) .ge. 1) then + k1 = match(j,nmatch(j)) + k2 = k1 + 1 + logp1 = log(pfull(j,k1)) + logp2 = log(pfull(j,k2)) + atd = max(tauchk,abs(at(j,k2) - at(j,k1))) + logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd + ptop(j,ibox) = exp(logp) + levmatch(j,ibox) = merge(k1,k2,abs(pfull(j,k1)-ptop(j,ibox)) .lt. abs(pfull(j,k2)-ptop(j,ibox))) + else + if (tb(j,ibox) .le. attrop(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .ge. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo + else + ptop(1:npoints,ibox)=0. + do ilev=1,nlev + where((ptop(1:npoints,ibox) .eq. 0. ) .and.(frac_out(1:npoints,ibox,ilev) .ne. 0)) + ptop(1:npoints,ibox)=phalf(1:npoints,ilev) + levmatch(1:npoints,ibox)=ilev + endwhere + end do + end if + where(tau(1:npoints,ibox) .le. tauchk) + ptop(1:npoints,ibox)=0._wp + levmatch(1:npoints,ibox)=0._wp + endwhere + enddo + + ! #################################################################################### + ! Compute subcolumn pressure and optical depth + ! #################################################################################### + boxtau(1:npoints,1:ncol) = output_missing_value + boxptop(1:npoints,1:ncol) = output_missing_value + do ibox=1,ncol + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk) .and. ptop(j,ibox) .gt. 0.) then + if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then + boxtau(j,ibox) = tau(j,ibox) + boxptop(j,ibox) = ptop(j,ibox)!/100._wp + endif + endif + enddo + enddo + + end SUBROUTINE ICARUS_SUBCOLUMN + + ! ###################################################################################### + ! SUBROUTINE icarus_column + ! ###################################################################################### + SUBROUTINE ICARUS_column(npoints,ncol,boxtau,boxptop,sunlit,boxttop,fq_isccp, & + meanalbedocld,meanptop,meantaucld,totalcldarea,meantb) + ! Inputs + INTEGER, intent(in) :: & + ncol, & ! Number of subcolumns + npoints ! Number of horizontal gridpoints + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! day=1 night=0 + REAL(WP),intent(in),dimension(npoints,ncol) :: & + boxttop, & ! Subcolumn top temperature + boxptop, & ! Subcolumn cloud top pressure + boxtau ! Subcolumn optical depth + + ! Outputs + REAL(WP),intent(inout),dimension(npoints) :: & + meanalbedocld, & ! Gridmean cloud albedo + meanptop, & ! Gridmean cloud top pressure (mb) - linear averaging + meantaucld, & ! Gridmean optical thickness + totalcldarea, & ! The fraction of model grid box columns with cloud present + meantb ! Gridmean all-sky 10.5 micron brightness temperature + REAL(WP),intent(inout),dimension(npoints,7,7) :: & + fq_isccp ! The fraction of the model grid box covered by clouds + + ! Local Variables + INTEGER :: j,ilev,ilev2 + REAL(WP),dimension(npoints,ncol) :: albedocld + LOGICAL, dimension(npoints,ncol) :: box_cloudy + + ! Variables for new joint-histogram implementation + logical,dimension(ncol) :: box_cloudy2 + + ! #################################################################################### + ! Brightness Temperature + ! #################################################################################### + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + meantb(1:npoints)=sum(boxttop,2)/ncol + else + meantb(1:npoints) = output_missing_value + endif + + ! #################################################################################### + ! Determines ISCCP cloud type frequencies + ! + ! Now that boxptop and boxtau have been determined, determine amount of each of the + ! 49 ISCCP cloud types. Also compute grid box mean cloud top pressure and + ! optical thickness. The mean cloud top pressure and optical thickness are + ! averages over the cloudy area only. The mean cloud top pressure is a linear + ! average of the cloud top pressures. The mean cloud optical thickness is + ! computed by converting optical thickness to an albedo, averaging in albedo + ! units, then converting the average albedo back to a mean optical thickness. + ! #################################################################################### + + ! Initialize + albedocld(1:npoints,1:ncol) = 0._wp + box_cloudy(1:npoints,1:ncol) = .false. + + ! Reset frequencies + !fq_isccp = spread(spread(merge(0._wp,output_missing_value,sunlit .eq. 1 .or. isccp_top_height .eq. 3),2,7),2,7) + do ilev=1,7 + do ilev2=1,7 + do j=1,npoints ! + if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then + fq_isccp(j,ilev,ilev2)= 0. + else + fq_isccp(j,ilev,ilev2)= output_missing_value + end if + enddo + enddo + enddo + + + ! Reset variables need for averaging cloud properties + where(sunlit .eq. 1 .or. isccp_top_height .eq. 3) + totalcldarea(1:npoints) = 0._wp + meanalbedocld(1:npoints) = 0._wp + meanptop(1:npoints) = 0._wp + meantaucld(1:npoints) = 0._wp + elsewhere + totalcldarea(1:npoints) = output_missing_value + meanalbedocld(1:npoints) = output_missing_value + meanptop(1:npoints) = output_missing_value + meantaucld(1:npoints) = output_missing_value + endwhere + + ! Compute column quantities and joint-histogram + do j=1,npoints + ! Subcolumns that are cloudy(true) and not(false) + box_cloudy2(1:ncol) = merge(.true.,.false.,boxtau(j,1:ncol) .gt. tauchk .and. boxptop(j,1:ncol) .gt. 0.) + + ! Compute joint histogram and column quantities for points that are sunlit and cloudy + if (sunlit(j) .eq.1 .or. isccp_top_height .eq. 3) then + ! Joint-histogram + call hist2D(boxtau(j,1:ncol),boxptop(j,1:ncol),ncol,isccp_histTau,numISCCPTauBins, & + isccp_histPres,numISCCPPresBins,fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)) + fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins) = & + fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)/ncol + + ! Column cloud area + totalcldarea(j) = real(count(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin))/ncol + + ! Subcolumn cloud albedo + !albedocld(j,1:ncol) = merge((boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp),& + ! 0._wp,box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin) + where(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin) + albedocld(j,1:ncol) = (boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp) + elsewhere + albedocld(j,1:ncol) = 0._wp + endwhere + + ! Column cloud albedo + meanalbedocld(j) = sum(albedocld(j,1:ncol))/ncol + + ! Column cloud top pressure + meanptop(j) = sum(boxptop(j,1:ncol),box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)/ncol + endif + enddo + + ! Compute mean cloud properties. Set to mssing value in the event that totalcldarea=0 + where(totalcldarea(1:npoints) .gt. 0) + meanptop(1:npoints) = 100._wp*meanptop(1:npoints)/totalcldarea(1:npoints) + meanalbedocld(1:npoints) = meanalbedocld(1:npoints)/totalcldarea(1:npoints) + meantaucld(1:npoints) = (6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp) + elsewhere + meanptop(1:nPoints) = output_missing_value + meanalbedocld(1:nPoints) = output_missing_value + meantaucld(1:nPoints) = output_missing_value + endwhere + !meanptop(1:npoints) = merge(100._wp*meanptop(1:npoints)/totalcldarea(1:npoints),& + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + !meanalbedocld(1:npoints) = merge(meanalbedocld(1:npoints)/totalcldarea(1:npoints), & + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + !meantaucld(1:npoints) = merge((6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp), & + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + + ! Represent in percent + where(totalcldarea .ne. output_missing_value) totalcldarea = totalcldarea*100._wp + where(fq_isccp .ne. output_missing_value) fq_isccp = fq_isccp*100._wp + + + end SUBROUTINE ICARUS_column + + subroutine cosp_simulator_optics(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT) + ! INPUTS + integer,intent(in) :: & + dim1, & ! Dimension 1 extent (Horizontal) + dim2, & ! Dimension 2 extent (Subcolumn) + dim3 ! Dimension 3 extent (Vertical) + real(wp),intent(in),dimension(dim1,dim2,dim3) :: & + flag ! Logical to determine the of merge var1IN and var2IN + real(wp),intent(in),dimension(dim1, dim3) :: & + varIN1, & ! Input field 1 + varIN2 ! Input field 2 + ! OUTPUTS + real(wp),intent(out),dimension(dim1,dim2,dim3) :: & + varOUT ! Merged output field + ! LOCAL VARIABLES + integer :: j + + varOUT(1:dim1,1:dim2,1:dim3) = 0._wp + do j=1,dim2 + where(flag(:,j,:) .eq. 1) + varOUT(:,j,:) = varIN2 + endwhere + where(flag(:,j,:) .eq. 2) + varOUT(:,j,:) = varIN1 + endwhere + enddo + end subroutine cosp_simulator_optics +end module MOD_ICARUS + diff --git a/src/physics/cosp2/src/simulator/icarus/license b/src/physics/cosp2/src/simulator/icarus/license new file mode 100644 index 0000000000..470d68060d --- /dev/null +++ b/src/physics/cosp2/src/simulator/icarus/license @@ -0,0 +1,34 @@ +# *****************************COPYRIGHT**************************** +# (c) British Crown Copyright 2009, the Met Office. +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the +# following conditions are met: +# +# * Redistributions of source code must retain the above +# copyright notice, this list of conditions and the following +# disclaimer. +# * Redistributions in binary form must reproduce the above +# copyright notice, this list of conditions and the following +# disclaimer in the documentation and/or other materials +# provided with the distribution. +# * Neither the name of the Met Office nor the names of its +# contributors may be used to endorse or promote products +# derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +# OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +# *****************************COPYRIGHT******************************* +! *****************************COPYRIGHT******************************* diff --git a/src/physics/cosp2/src/simulator/parasol/parasol.F90 b/src/physics/cosp2/src/simulator/parasol/parasol.F90 new file mode 100644 index 0000000000..cb3326c257 --- /dev/null +++ b/src/physics/cosp2/src/simulator/parasol/parasol.F90 @@ -0,0 +1,176 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - optimization for vectorization +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_parasol + USE COSP_KINDS, ONLY: wp + USE COSP_MATH_CONSTANTS, ONLY: pi + use mod_cosp_config, ONLY: R_UNDEF,PARASOL_NREFL,PARASOL_NTAU,PARASOL_TAU,PARASOL_SZA,rlumA,rlumB + implicit none + +contains + SUBROUTINE parasol_subcolumn(npoints,nrefl,tautot_S_liq,tautot_S_ice,refl) + ! ########################################################################## + ! Purpose: To compute Parasol reflectance signal from model-simulated profiles + ! of cloud water and cloud fraction in each sub-column of each model + ! gridbox. + ! + ! + ! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : + ! - optimization for vectorization + ! + ! Version 2.0 (October 2008) + ! Version 2.1 (December 2008) + ! ########################################################################## + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + nrefl ! Number of angles for which the reflectance is computed + REAL(WP),intent(inout),dimension(npoints) :: & + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + ! OUTPUTS + REAL(WP),intent(inout),dimension(npoints,nrefl) :: & + refl ! Parasol reflectances + + ! LOCAL VARIABLES + REAL(WP),dimension(npoints) :: & + tautot_S, & ! Cloud optical thickness, from TOA to surface + frac_taucol_liq, & ! + frac_taucol_ice ! + + ! Look up table variables: + INTEGER :: ny,it + REAL(WP),dimension(PARASOL_NREFL) :: r_norm + REAL(WP),dimension(PARASOL_NREFL,PARASOL_NTAU-1) :: aa,ab,ba,bb + REAL(WP),dimension(npoints,5) :: rlumA_mod,rlumB_mod + + !-------------------------------------------------------------------------------- + ! Lum_norm=f(PARASOL_SZA,tau_cloud) derived from adding-doubling calculations + ! valid ONLY ABOVE OCEAN (albedo_sfce=5%) + ! valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�) + ! based on adding-doubling radiative transfer computation + ! for PARASOL_TAU values (0 to 100) and for PARASOL_SZA values (0 to 80) + ! for 2 scattering phase functions: liquid spherical, ice non spherical + + ! Initialize + rlumA_mod(1:npoints,1:5) = 0._wp + rlumB_mod(1:npoints,1:5) = 0._wp + + r_norm(1:PARASOL_NREFL)=1._wp/ cos(pi/180._wp*PARASOL_SZA(1:PARASOL_NREFL)) + + tautot_S_liq(1:npoints) = max(tautot_S_liq(1:npoints),PARASOL_TAU(1)) + tautot_S_ice(1:npoints) = max(tautot_S_ice(1:npoints),PARASOL_TAU(1)) + tautot_S(1:npoints) = tautot_S_ice(1:npoints) + tautot_S_liq(1:npoints) + + ! Relative fraction of the opt. thick due to liquid or ice clouds + WHERE (tautot_S(1:npoints) .gt. 0.) + frac_taucol_liq(1:npoints) = tautot_S_liq(1:npoints) / tautot_S(1:npoints) + frac_taucol_ice(1:npoints) = tautot_S_ice(1:npoints) / tautot_S(1:npoints) + ELSEWHERE + frac_taucol_liq(1:npoints) = 1._wp + frac_taucol_ice(1:npoints) = 0._wp + END WHERE + tautot_S(1:npoints)=MIN(tautot_S(1:npoints),PARASOL_TAU(PARASOL_NTAU)) + + ! Linear interpolation + DO ny=1,PARASOL_NTAU-1 + ! Microphysics A (liquid clouds) + aA(1:PARASOL_NREFL,ny) = (rlumA(1:PARASOL_NREFL,ny+1)-rlumA(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny)) + bA(1:PARASOL_NREFL,ny) = rlumA(1:PARASOL_NREFL,ny) - aA(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny) + ! Microphysics B (ice clouds) + aB(1:PARASOL_NREFL,ny) = (rlumB(1:PARASOL_NREFL,ny+1)-rlumB(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny)) + bB(1:PARASOL_NREFL,ny) = rlumB(1:PARASOL_NREFL,ny) - aB(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny) + ENDDO + + DO it=1,PARASOL_NREFL + DO ny=1,PARASOL_NTAU-1 + WHERE (tautot_S(1:npoints) .ge. PARASOL_TAU(ny).and. & + tautot_S(1:npoints) .le. PARASOL_TAU(ny+1)) + rlumA_mod(1:npoints,it) = aA(it,ny)*tautot_S(1:npoints) + bA(it,ny) + rlumB_mod(1:npoints,it) = aB(it,ny)*tautot_S(1:npoints) + bB(it,ny) + END WHERE + END DO + END DO + + DO it=1,PARASOL_NREFL + refl(1:npoints,it) = frac_taucol_liq(1:npoints) * rlumA_mod(1:npoints,it) & + + frac_taucol_ice(1:npoints) * rlumB_mod(1:npoints,it) + ! Normalized radiance -> reflectance: + refl(1:npoints,it) = refl(1:npoints,it) * r_norm(it) + ENDDO + + RETURN + END SUBROUTINE parasol_subcolumn + ! ###################################################################################### + ! SUBROUTINE parasol_gridbox + ! ###################################################################################### + subroutine parasol_column(npoints,nrefl,ncol,land,refl,parasolrefl) + + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncol, & ! Number of subcolumns + nrefl ! Number of solar zenith angles for parasol reflectances + real(wp),intent(in),dimension(npoints) :: & + land ! Landmask [0 - Ocean, 1 - Land] + real(wp),intent(in),dimension(npoints,ncol,nrefl) :: & + refl ! Subgrid parasol reflectance ! parasol + + ! Outputs + real(wp),intent(out),dimension(npoints,nrefl) :: & + parasolrefl ! Grid-averaged parasol reflectance + + ! Local variables + integer :: k,ic + + ! Compute grid-box averaged Parasol reflectances + parasolrefl(:,:) = 0._wp + do k = 1, nrefl + do ic = 1, ncol + parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k) + enddo + enddo + + do k = 1, nrefl + parasolrefl(:,k) = parasolrefl(:,k) / float(ncol) + ! if land=1 -> parasolrefl=R_UNDEF + ! if land=0 -> parasolrefl=parasolrefl + parasolrefl(:,k) = parasolrefl(:,k) * MAX(1._wp-land(:),0.0) & + + (1._wp - MAX(1._wp-land(:),0.0))*R_UNDEF + enddo + end subroutine parasol_column + +end module mod_parasol diff --git a/src/physics/cosp2/src/simulator/quickbeam/quickbeam.F90 b/src/physics/cosp2/src/simulator/quickbeam/quickbeam.F90 new file mode 100644 index 0000000000..1a4280ea18 --- /dev/null +++ b/src/physics/cosp2/src/simulator/quickbeam/quickbeam.F90 @@ -0,0 +1,387 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! 11/2005: John Haynes - Created +! 09/2006 placed into subroutine form (Roger Marchand,JMH) +! 08/2007 added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand) +! 01/2008 'Do while' to determine if hydrometeor(s) present in volume +! changed for vectorization purposes (A. Bodas-Salcedo) +! +! 07/2010 V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT) +! ... All hydrometeor and radar simulator properties now included in hp structure +! ... hp structure should be initialized by call to radar_simulator_init prior +! ... to calling this subroutine. +! Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added +! ... Changes implement by Roj Marchand following work by Laura Fowler +! +! 10/2011 Modified ngate loop to go in either direction depending on flag +! hp%radar_at_layer_one. This affects the direction in which attenuation is summed. +! +! Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple +! summation. (Roger Marchand) +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module quickbeam + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: DBZE_BINS,DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH, & + R_UNDEF,cloudsat_histRef,use_vgrid,vgrid_zl,vgrid_zu + USE MOD_COSP_STATS, ONLY: COSP_LIDAR_ONLY_CLOUD,hist1D,COSP_CHANGE_VERTICAL_GRID + implicit none + + integer,parameter :: & + maxhclass = 20, & ! Qucikbeam maximum number of hydrometeor classes. + nRe_types = 550, & ! Quickbeam maximum number or Re size bins allowed in N and Z_scaled look up table. + nd = 85, & ! Qucikbeam number of discrete particles used in construction DSDs. + mt_ntt = 39, & ! Quickbeam number of temperatures in mie LUT. + Re_BIN_LENGTH = 10, & ! Quickbeam minimum Re interval in scale LUTs + Re_MAX_BIN = 250 ! Quickbeam maximum Re interval in scale LUTs + real(wp),parameter :: & + dmin = 0.1, & ! Quickbeam minimum size of discrete particle + dmax = 10000. ! Quickbeam maximum size of discrete particle + + !djs logical :: radar_at_layer_one ! If true radar is assume to be at the edge + ! of the first layer, if the first layer is the + ! surface than a ground-based radar. If the + ! first layer is the top-of-atmosphere, then + ! a space borne radar. + + ! ############################################################################################## + type radar_cfg + ! Radar properties + real(wp) :: freq,k2 + integer :: nhclass ! Number of hydrometeor classes in use + integer :: use_gas_abs, do_ray + logical :: radar_at_layer_one ! If true radar is assume to be at the edge + ! of the first layer, if the first layer is the + ! surface than a ground-based radar. If the + ! first layer is the top-of-atmosphere, then + ! a space borne radar. + + ! Variables used to store Z scale factors + character(len=240) :: scale_LUT_file_name + logical :: load_scale_LUTs, update_scale_LUTs + logical, dimension(maxhclass,nRe_types) :: N_scale_flag + logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag + real(wp),dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled + real(wp),dimension(maxhclass,nd,nRe_types) :: fc, rho_eff + real(wp),dimension(Re_MAX_BIN) :: base_list,step_list + + end type radar_cfg + +contains + ! ###################################################################################### + ! SUBROUTINE quickbeam_subcolumn + ! ###################################################################################### + !subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,& + ! a_to_vol,g_to_vol,dBZe,Ze_non,Ze_ray) + subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,dBZe) + + ! INPUTS + type(radar_cfg),intent(inout) :: & + rcfg ! Derived type for radar simulator setup + integer,intent(in) :: & + nprof, & ! Number of hydrometeor profiles + ngate ! Number of vertical layers + real(wp),intent(in),dimension(nprof,ngate) :: & + hgt_matrix, & ! Height of hydrometeors (km) + z_vol, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol, & ! Attenuation coefficient hydro (dB/km) + g_vol ! Attenuation coefficient gases (dB/km) + + ! OUTPUTS + real(wp), intent(out),dimension(nprof,ngate) :: & +! Ze_non, & ! Radar reflectivity without attenuation (dBZ) +! Ze_ray, & ! Rayleigh reflectivity (dBZ) +! g_to_vol, & ! Gaseous atteunation, radar to vol (dB) +! a_to_vol, & ! Hydromets attenuation, radar to vol (dB) + dBZe ! Effective radar reflectivity factor (dBZ) + + ! LOCAL VARIABLES + integer :: k,pr,start_gate,end_gate,d_gate + real(wp),dimension(nprof,ngate) :: & + Ze_non, & ! Radar reflectivity without attenuation (dBZ) + Ze_ray, & ! Rayleigh reflectivity (dBZ) + g_to_vol, & ! Gaseous atteunation, radar to vol (dB) + a_to_vol, & ! Hydromets attenuation, radar to vol (dB) + z_ray ! Reflectivity factor, Rayleigh only (mm^6/m^3) + + ! Load scaling matricies from disk -- but only the first time this subroutine is called + if(rcfg%load_scale_LUTs) then + call load_scale_LUTs(rcfg) + rcfg%load_scale_LUTs=.false. + rcfg%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run + endif + + ! Initialization + g_to_vol = 0._wp + a_to_vol = 0._wp + + ! Loop over each range gate (ngate) ... starting with layer closest to the radar ! + if(rcfg%radar_at_layer_one) then + start_gate = 1 + end_gate = ngate + d_gate = 1 + else + start_gate = ngate + end_gate = 1 + d_gate = -1 + endif + do k=start_gate,end_gate,d_gate + ! Loop over each profile (nprof) + do pr=1,nprof + ! Attenuation due to hydrometeors between radar and volume + + ! NOTE old scheme integrates attenuation only for the layers ABOVE + ! the current layer ... i.e. 1 to k-1 rather than 1 to k ... + ! which may be a problem. ROJ + ! in the new scheme I assign half the attenuation to the current layer + if(d_gate==1) then + ! dheight calcuations assumes hgt_matrix points are the cell mid-points. + if (k>2) then + ! add to previous value to half of above layer + half of current layer + a_to_vol(pr,k)= a_to_vol(pr,k-1) + & + (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k)) + else + a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1)) + endif + else ! d_gate==-1 + if(k1) then + ! Add to previous value to half of above layer + half of current layer + g_to_vol(pr,k) = g_to_vol(pr,k-1) + & + 0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k)) + else + g_to_vol(pr,k)= 0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1)) + endif + else ! d_gate==-1 + if (k 0._wp) + Ze_ray(1:nprof,1:ngate) = 10._wp*log10(z_ray(1:nprof,1:ngate)) + elsewhere + Ze_Ray(1:nprof,1:ngate) = 0._wp + endwhere +!djs Ze_ray(1:nprof,1:ngate) = merge(10._wp*log10(z_ray(1:nprof,1:ngate)), 1._wp*R_UNDEF, z_ray(1:nprof,1:ngate) > 0._wp) + else + Ze_ray(1:nprof,1:ngate) = R_UNDEF + end if + + where(z_vol(1:nprof,1:ngate) > 0._wp) + Ze_non(1:nprof,1:ngate) = 10._wp*log10(z_vol(1:nprof,1:ngate)) + dBZe(1:nprof,1:ngate) = Ze_non(1:nprof,1:ngate)-a_to_vol(1:nprof,1:ngate)-g_to_vol(1:nprof,1:ngate) + elsewhere + dBZe(1:nprof,1:ngate) = R_UNDEF + Ze_non(1:nprof,1:ngate) = R_UNDEF + end where + + ! Save any updates made + if (rcfg%update_scale_LUTs) call save_scale_LUTs(rcfg) + + end subroutine quickbeam_subcolumn + ! ###################################################################################### + ! SUBROUTINE quickbeam_column + ! ###################################################################################### + subroutine quickbeam_column(npoints,ncolumns,nlevels,llm,Ze_tot,zlev,zlev_half,cfad_ze) + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncolumns, & ! Number of subcolumns + nlevels, & ! Number of vertical layers in OLD grid + llm ! NUmber of vertical layers in NEW grid + real(wp),intent(in),dimension(npoints,ncolumns,Nlevels) :: & + Ze_tot ! + real(wp),intent(in),dimension(npoints,Nlevels) :: & + zlev ! Model full levels + real(wp),intent(in),dimension(npoints,Nlevels+1) :: & + zlev_half ! Model half levels + + ! Outputs + real(wp),intent(inout),dimension(npoints,DBZE_BINS,llm) :: & + cfad_ze ! + + ! Local variables + integer :: i,j + real(wp),dimension(npoints,ncolumns,llm) :: ze_totFlip + + if (use_vgrid) then + ! Regrid in the vertical + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),& + zlev_half(:,nlevels:1:-1),Ze_tot(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),& + vgrid_zu(llm:1:-1),Ze_totFlip(:,:,llm:1:-1),log_units=.true.) + + ! Effective reflectivity histogram + do i=1,Npoints + do j=1,llm + cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_totFlip(i,:,j),DBZE_BINS,cloudsat_histRef) + enddo + enddo + where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns + + else + ! Effective reflectivity histogram + do i=1,Npoints + do j=1,llm + cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_tot(i,:,j),DBZE_BINS,cloudsat_histRef) + enddo + enddo + where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns + endif + + end subroutine quickbeam_column + ! ############################################################################################## + ! ############################################################################################## + + + ! ############################################################################################## + ! ############################################################################################## + subroutine load_scale_LUTs(rcfg) + + type(radar_cfg), intent(inout) :: rcfg + logical :: LUT_file_exists + integer :: i,j,k,ind + + ! Load scale LUT from file + inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + if(.not.LUT_file_exists) then + write(*,*) '*************************************************' + write(*,*) 'Warning: Could NOT FIND radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + write(*,*) 'Will calculated LUT values as needed' + write(*,*) '*************************************************' + return + else + OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted', & + err= 89, & + access='DIRECT',& + recl=28) + write(*,*) 'Loading radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + read(12,rec=ind) rcfg%Z_scale_flag(i,j,k), & + rcfg%Ze_scaled(i,j,k), & + rcfg%Zr_scaled(i,j,k), & + rcfg%kr_scaled(i,j,k) + enddo + enddo + enddo + close(unit=12) + return + endif + +89 write(*,*) 'Error: Found but could NOT READ radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + end subroutine load_scale_LUTs + + ! ############################################################################################## + ! ############################################################################################## + subroutine save_scale_LUTs(rcfg) + type(radar_cfg), intent(inout) :: rcfg + logical :: LUT_file_exists + integer :: i,j,k,ind + + inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted',err= 99,access='DIRECT',recl=28) + + write(*,*) 'Creating or Updating radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + if(.not.LUT_file_exists .or. rcfg%Z_scale_added_flag(i,j,k)) then + rcfg%Z_scale_added_flag(i,j,k)=.false. + write(12,rec=ind) rcfg%Z_scale_flag(i,j,k), & + rcfg%Ze_scaled(i,j,k), & + rcfg%Zr_scaled(i,j,k), & + rcfg%kr_scaled(i,j,k) + endif + enddo + enddo + enddo + close(unit=12) + return + +99 write(*,*) 'Error: Unable to create/update radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + return + + end subroutine save_scale_LUTs + ! ############################################################################################## + ! ############################################################################################## + subroutine quickbeam_init() + + + end subroutine quickBeam_init + ! ############################################################################################## + ! ############################################################################################## + + +end module quickbeam + + diff --git a/src/physics/cosp2/src/simulator/rttov/cosp_rttov.F90 b/src/physics/cosp2/src/simulator/rttov/cosp_rttov.F90 new file mode 100644 index 0000000000..5bde602bbd --- /dev/null +++ b/src/physics/cosp2/src/simulator/rttov/cosp_rttov.F90 @@ -0,0 +1,592 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Aug 2008 - V. John - Initial version +! Jun 2010 - A. Bodas-Salcedo - Conversion to module and tidy up +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_RTTOV + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: RTTOV_MAX_CHANNELS + USE RTTOV_CONST, only: errorstatus_fatal, errorstatus_warning, errorstatus_success + USE RTTOV_TYPES, only: rttov_coef, profile_type, transmission_type, & + radiance_type, rttov_coef_scatt_ir, rttov_optpar_ir + USE PARKIND1, Only : jpim, jprb + IMPLICIT NONE + + ! Include subroutine interfaces + include "rttov_errorreport.interface" + include "rttov_setup.interface" + include "rttov_errorhandling.interface" + include "rttov_direct.interface" + include "rttov_alloc_prof.interface" + include "rttov_alloc_rad.interface" + include "rttov_dealloc_coef.interface" + + ! Fields set during initialization + integer :: & + nch_in, & ! Number of RTTOV channels + plat_in, & ! RTTOV platform + sat_in, & ! RTTOV satellite + sens_in ! RTTOV instrument + integer,dimension(RTTOV_MAX_CHANNELS) :: & + ichan_in ! RTTOV channel indices + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE RTTOV_PIXEL + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE RTTOV_subcolumn(surfem_in, prf_num_in, nlevels_in, & + zenang_in, p_in,t_in, q_in, o3_in, co2_in, & + ch4_in, n2o_in, co_in, h_surf, u_surf, & + v_surf, t_skin, p_surf, t_surf, q_surf, & + lsmask, latitude, tbs) + ! INPUTS + integer,intent(in) :: & + prf_num_in, & ! Number of profiles to simulate + nlevels_in ! Number of pressure levels + real(wp),intent(in) :: & + zenang_in, & ! Satellite zenith angle + co2_in, & ! Carbon dioxide + ch4_in, & ! Methane + n2o_in, & ! n2o + co_in ! Carbon monoxide + real(wp),intent(in),dimension(nch_in) :: & + surfem_in ! Surface emissivities for the channels + real(wp),intent(in),dimension(prf_num_in) :: & + h_surf, & ! Surface height + u_surf, & ! U component of surface wind + v_surf, & ! V component of surface wind + t_skin, & ! Surface skin temperature + p_surf, & ! Surface pressure + t_surf, & ! 1.5 m Temperature + q_surf, & ! 1.5 m Specific humidity + lsmask, & ! land-sea mask + latitude ! Latitude + real(wp),intent(in),dimension(prf_num_in,nlevels_in) :: & + p_in, & ! Pressure profiles + t_in, & ! Temperature profiles + q_in, & ! Humidity profiles + o3_in ! Ozone profiles + + ! OUTPUTS + real(wp),intent(inout),dimension(prf_num_in,nch_in) :: & + tbs ! Tbs (in the right format) + + ! LOCAL VARIABLES + type(transmission_type) :: transmission + type(radiance_type) :: radiance + type(rttov_coef ), allocatable, dimension(:) :: coef + type(profile_type), allocatable, dimension(:) :: profiles + type(rttov_coef_scatt_ir),allocatable, dimension(:) :: coef_scatt_ir + type(rttov_optpar_ir), allocatable, dimension(:) :: optp + Integer(Kind=jpim), Allocatable, dimension(:,:) :: & + instrument, & ! Instrument id + nchan, & ! Number of channels per instrument and profile + ichan ! Channel list per instrument + Integer(Kind=jpim), Allocatable, dimension(:) :: & + nchan1, & ! Number of channels per instrument and profile + nchannels, & ! Number of channels per instrument + ifull, & ! Full test (with TL,AD,K) per instrument + nprof, & ! Number of profiles per instrument + nsurf, & ! Surface id number per instrument + nwater, & ! Water id number per instrument + channels, & ! Channel list per instrument*profiles + lprofiles, & ! + rttov_errorstatus, & ! rttov error return code + setup_errorstatus ! Setup return code + Integer(Kind=jpim) :: & + nprofiles,iref,isun,asw,mxchn,i,j,jch,errorstatus,io_status,ioout,interp, & + Err_Unit, & ! Logical error unit (<0 for default) + verbosity_level, & ! (<0 for default) + nrttovid, & ! Maximum number of instruments + no_id, & ! Instrument loop index + Nprofs, & ! Number of calls to RTTOV + nch ! Intermediate variable + Integer(Kind=jpim), Parameter :: & + jpnav = 31, & ! Number of profile variables + jpnsav = 6, & ! Number of surface air variables + jpnssv = 6, & ! Number of skin variables + jpncv = 2, & ! Number of cloud variables + sscvar = jpnsav+jpnssv+jpncv ! Number of surface,skin,cloud vars + Integer(Kind=jpim),dimension(60) :: & + alloc_status + Real(Kind=jprb) :: & + zenang, azang, sunzang, sunazang + Real(kind=jprb), allocatable, dimension(:) :: & + emissivity,fresnrefl,input_emissivity + Real(kind=jprb), allocatable, dimension(:,:) :: & + surfem + Real(Kind=jprb),dimension(nch_in*prf_num_in) :: & + tbs_temp ! A temporary variable to hold Tbs + Character (len=3) :: & + cref, csun + Character (len=80) :: & + errMessage + Character (len=14) :: & + NameOfRoutine = 'rttov_multprof' + Logical :: addinterp,refrac,solrad,laerosl,lclouds,lsun,all_channels + Logical,Allocatable,dimension(:) :: & + calcemis + integer(kind=jpim) :: prof_num,nlevels + + ! Type-casting of input arguments that need to be passed to RTTOV + prof_num = prf_num_in + nlevels = nlevels_in + + ! Unit numbers for input/output + IOOUT = 2 + + ! Curretly we plan to calculate only 1 instrument per call + nrttovid = 1 + mxchn = nch_in + errorstatus = 0 + alloc_status(:) = 0 + all_channels = .false. + sunzang = 0._jprb + sunazang = 0._jprb + + ! Initialise error management with default value for + ! the error unit number and Fatal error message output + Err_unit = -1 + verbosity_level = 0 + + ! All error message output + call rttov_errorhandling( Err_unit, verbosity_level, print_checkinput_warnings=.false. ) + io_status = 0 + errmessage = '' + + ! Assigning the zenith angle + zenang = zenang_in + + ! Allocate + allocate (coef(nrttovid), stat = alloc_status(1)) + allocate (coef_scatt_ir(nrttovid),stat = alloc_status(2)) + allocate (optp(nrttovid), stat = alloc_status(3)) + allocate (instrument(3,nrttovid), stat = alloc_status(4)) + allocate (ifull(nrttovid), stat = alloc_status(5)) + allocate (nprof(nrttovid), stat = alloc_status(6)) + allocate (nsurf(nrttovid), stat = alloc_status(7)) + allocate (nwater(nrttovid), stat = alloc_status(8)) + allocate (nchannels(nrttovid), stat = alloc_status(9)) + allocate (nchan1(nrttovid), stat = alloc_status(10)) + allocate (surfem(mxchn,nrttovid), stat = alloc_status(11)) + allocate (ichan (mxchn,nrttovid), stat = alloc_status(12)) + If( any(alloc_status /= 0) ) then + errorstatus = errorstatus_fatal + Write( errMessage, '( "mem allocation error")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + End If + surfem(:,:) = 0.0_JPRB + ichan(:,:) = 0 + + !!! FIXME: Shall we get rid of this loop? We use only one instrument + DO NO_ID = 1, NRTTOVID + instrument(1,no_id) = plat_in + instrument(2,no_id) = sat_in + instrument(3,no_id) = sens_in + + !! Forward model only (0) or TL and AD (1) or K (2)?' + ! This version supports only Forward model + IFULL(no_id) = 0 + + ! Number of profiles to test per call + NPROF(no_id) = prof_num + nprofiles = NPROF(no_id) + + ! Total number of profiles to process + NPROFS = prof_num + NPROFS = NPROFS / NPROF(no_id) ! Number of calls to RTTOV + + ! Check whether it is OK to use ocean all the time + NWATER(no_id) = 1 ! Water type (0=fresh water, 1=ocean water) + + ! Set up channel numbers + allocate (nchan(nprof(no_id),nrttovid),stat= alloc_status(3)) + nchan(1:nprof(no_id),no_id) = nch_in + ichan(:, 1) = ichan_in + surfem(:, 1) = surfem_in + + ! nchan(1,no_id) is now the real number of channels selected + do j = 1 , nprof(no_id) + nchan(j,no_id) = nch_in + enddo + + ! Compute channels*profiles + nchannels(no_id) = 0 + Do j = 1 , nprof(no_id) + nchannels(no_id) = nchannels(no_id) + nchan (j,no_id) + End Do + nchan1(no_id) = nchan(1,no_id) + END DO + + ! Do you want clouds or aerosol? + laerosl = .False. + lclouds = .False. + + !######################################################### + ! Beginning of rttov_setup test + !######################################################### + alloc_status = 0 + allocate ( setup_errorstatus(nrttovid),stat= alloc_status(1)) + If( any(alloc_status /= 0) ) then + errorstatus = errorstatus_fatal + Write( errMessage, '( "mem allocation error for errorsetup")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + End If + + If (all_channels)Then + Call rttov_setup ( & + setup_errorstatus, &! out + Err_unit, &! in + verbosity_level, &! in + nrttovid, &! in + laerosl, &! in + lclouds, &! in + coef, &! out + coef_scatt_ir, &! out + optp, & + instrument) ! in + Else + Call rttov_setup ( & + setup_errorstatus, &! out + Err_unit, &! in + verbosity_level, &! in + nrttovid, &! in + laerosl, &! in + lclouds, &! in + coef, &! out + coef_scatt_ir, &! out + optp, & + instrument, &! in + ichan ) ! in Optional + Endif + + if(any(setup_errorstatus(:) /= errorstatus_success ) ) then + print*, 'rttov_setup fatal error' + stop + endif + + deallocate( setup_errorstatus ,stat=alloc_status(1)) + If( any(alloc_status /= 0) ) then + errorstatus = errorstatus_fatal + Write( errMessage, '( "mem deallocation error for setup_errorstatus")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + End If + + DO no_id = 1, NRTTOVID + if( any(coef(no_id)%ff_val_chn( : ) /= 1 )) then + WRITE(*,*) ' some requested channels have bad validity parameter' + do i = 1, nchan1(no_id) + write(*,*) i, coef(no_id)%ff_val_chn(i) + end do + endif + End Do + + DO no_id = 1, NRTTOVID + + !######################################################### + ! Allocate memory for RTTOV_DIRECT + !######################################################### + allocate( rttov_errorstatus(nprof(no_id)),stat= alloc_status(3)) + + ! Allocate profiles + allocate( profiles(nprof(no_id)),stat= alloc_status(1)) + + ! Allow profile interpolation + interp = 1 + + if(interp == 0) addinterp = .false. + if(interp == 1) addinterp = .true. + asw = 1 + + call rttov_alloc_prof ( & + errorstatus, & + nprof(no_id), & + profiles, & + nlevels, & + coef_scatt_ir(no_id), & + asw, & + addclouds = lclouds, & + addaerosl = laerosl, & + init = .true. ) + + + Do j = 1 , nprof(no_id) + profiles(j) % nlevels = nlevels + Enddo + + alloc_status = 0_jpim + ! number of channels per RTTOV call is only nchannels + allocate(lprofiles (nchannels(no_id)), stat = alloc_status(9)) + allocate(channels (nchannels(no_id)), stat = alloc_status(10)) + allocate(emissivity (nchannels(no_id)), stat = alloc_status(12)) + allocate(fresnrefl (nchannels(no_id)), stat = alloc_status(13)) + allocate(input_emissivity(nchannels(no_id)), stat = alloc_status(14)) + allocate(calcemis (nchannels(no_id)), stat = alloc_status(15)) + + ! allocate transmittance arrays with number of channels + allocate( transmission % tau_layers (profiles(1) % nlevels,nchannels(no_id) ), & + stat= alloc_status(11)) + allocate( transmission % tau_total (nchannels(no_id) ) , & + stat= alloc_status(12)) + + If( Any(alloc_status /= 0) ) Then + errorstatus = errorstatus_fatal + Write( errMessage, '( "allocation of transmission")' ) + Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine) + !IF (LHOOK) CALL DR_HOOK('RTTOV_DIRECT',1,ZHOOK_HANDLE) + Stop + End If + + transmission % tau_layers = 0._jprb + transmission % tau_total = 0._jprb + + ! Allocate radiance results arrays with number of channels + asw = 1 ! allocate + call rttov_alloc_rad (errorstatus,nchannels(no_id),radiance, & + profiles(1)%nlevels,asw) + + AZANG = 0 + ISUN = 0 + IREF = 1 + + if(iref==0)then + cref='NO' + refrac=.False. + else if(iref==1)then + cref='YES' + refrac=.True. + endif + + if(sunzang<=87._JPRB)then + solrad=.True. + else + solrad=.False. + endif + + if(isun==1)then + lsun=.true. + if(sunzang<=87._JPRB)then + csun='YES' + solrad=.True. + else + csun='NO' + solrad=.False. + endif + else + csun='NO' + solrad=.False. + endif + + do i = 1, NPROF(no_id) + profiles(i) % p(:) = p_in(i, :) + profiles(i) % t(:) = t_in(i, :) + profiles(i) % q(:) = q_in(i, :) + profiles(i) % o3(:) = o3_in(i, :) + profiles(i) % co2(:) = co2_in + profiles(i) % ch4(:) = ch4_in + profiles(i) % n2o(:) = n2o_in + profiles(i) % co(:) = co_in + profiles(i) % ozone_Data = .False. + profiles(i) % co2_Data = .True. + profiles(i) % n2o_data = .True. + profiles(i) % ch4_Data = .True. + profiles(i) % co_Data = .True. + + !FIXME: Make Cloud variables as passing ones if we go for all sky + profiles(i) % cfraction = 0. + profiles(i) % ctp = 500. + profiles(i) % clw_Data = .False. + + ! 2m parameters + profiles(i) % s2m % p = p_surf(i) + profiles(i) % s2m % t = t_in(i, 1) + profiles(i) % s2m % q = q_in(i, 1) + profiles(i) % s2m % u = 2 + profiles(i) % s2m % v = 2 + + ! Skin variables for emissivity calculations + profiles(i) % skin % t = t_skin(i) + profiles(i) % skin % fastem(1) = 3.0 + profiles(i) % skin % fastem(2) = 5.0 + profiles(i) % skin % fastem(3) = 15.0 + profiles(i) % skin % fastem(4) = 0.1 + profiles(i) % skin % fastem(5) = 0.3 + + profiles(i) % zenangle = zenang + profiles(i) % azangle = azang + profiles(i) % latitude = latitude(i) + profiles(i) % elevation = h_surf(i) + profiles(i) % sunzenangle = SUNZANG + profiles(i) % sunazangle = SUNAZANG + profiles(i) % addsolar = solrad + profiles(i) % addrefrac = refrac + ! surface type + profiles(i) % skin % surftype = lsmask(i) + !! FIXME: Check this one + profiles(i) % skin % watertype = nwater(no_id) + profiles(i) % aer_data = laerosl + profiles(i) % cld_data = lclouds + profiles(i) %idg = 0._jprb + profiles(i) %ish = 0._jprb + if( lclouds ) then + profiles(i) %cloud(:,:) = 0._jprb + profiles(i) %cfrac(:,:) = 0._jprb + endif + enddo + + ! Build the list of channels/profiles indices + emissivity(:) = 0.0_JPRB + channels(:) = 0_jpim + lprofiles(:) = 0_jpim + nch = 0_jpim + Do j = 1 , nprof(no_id) + DO jch = 1,nchan1(no_id) + nch = nch +1_jpim + lprofiles ( nch ) = j + if (all_channels)then + channels( nch ) = ichan(jch,no_id) + else + channels( nch ) = jch + endif + emissivity( nch ) = surfem(jch,no_id) + End Do + End Do + + input_emissivity(:) = emissivity(:) + calcemis(:) = emissivity(:) < 0.01_JPRB + + ! FIXME: Check this one with Roger + do j = 1 , NPROFS + call rttov_direct( & + & rttov_errorstatus, &! out + & nprof(no_id), &! in + & nchannels(no_id), &! in + & channels, &! in + & lprofiles, &! in + & addinterp, &! in + & profiles, &! in + & coef(no_id), &! in + & coef_scatt_ir(no_id), & + & optp(no_id) , & + & lsun, &! in + & laerosl, &! in + & lclouds, &! in + & calcemis, &! in + & emissivity, &! inout + & transmission, &! out + & radiance ) ! inout + enddo + + ! Initialising tbs array + tbs(:, :) = 0.0 + tbs_temp(:) = 0.0 + tbs_temp = radiance%bt + + do i = 1, prof_num + tbs(i, :) = tbs_temp((i-1)*nch_in+1:i*nch_in) + enddo + + + If ( any( rttov_errorstatus(:) == errorstatus_warning ) ) Then + Do j = 1, nprof(no_id) + If ( rttov_errorstatus(j) == errorstatus_warning ) Then + write ( ioout, * ) 'rttov warning for profile', j + End If + End Do + End If + + If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then + Do j = 1, nprof(no_id) + If ( rttov_errorstatus(j) == errorstatus_fatal ) Then + write ( ioout, * ) 'rttov error for profile',j + End If + End Do + Stop + End If + + ! Deallocate + ! number of channels per RTTOV call is only nchannels + deallocate( channels ,stat=alloc_status(2)) + deallocate( lprofiles ,stat=alloc_status(3)) + deallocate( emissivity ,stat=alloc_status(4)) + deallocate( fresnrefl ,stat=alloc_status(5)) + deallocate( calcemis ,stat=alloc_status(6)) + deallocate( input_emissivity ,stat= alloc_status(14)) + If( any(alloc_status /= 0) ) then + errorstatus = errorstatus_fatal + Write( errMessage, '( "mem deallocation error for channels etc")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + End If + + asw = 0 ! deallocate radiance arrays + call rttov_alloc_rad (errorstatus,nchan1(no_id),radiance,profiles(1) % nlevels,asw) + If(errorstatus /= errorstatus_success) Then + Write( errMessage, '( "deallocation error for radiances")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Endif + + ! deallocate transmittances + Deallocate( transmission % tau_total ,stat= alloc_status(7)) + Deallocate( transmission % tau_layers ,stat= alloc_status(8)) + If(errorstatus /= errorstatus_success) Then + Write( errMessage, '( "deallocation error for transmittances")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + Endif + + asw = 0 ! deallocate profile arrays + call rttov_alloc_prof (errorstatus,nprof(no_id),profiles,profiles(1)%nlevels,coef_scatt_ir(no_id),asw,& + & addclouds = lclouds, addaerosl = laerosl ) + deallocate( profiles,stat=alloc_status(1)) + If( any(alloc_status /= 0) ) then + errorstatus = errorstatus_fatal + Write( errMessage, '( "mem deallocation error for profiles")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Stop + End If + + EndDo + + DO no_id = 1, NRTTOVID + Call rttov_dealloc_coef (errorstatus, coef(no_id),coef_scatt_ir(no_id),optp(no_id)) + If(errorstatus /= errorstatus_success) Then + Write( errMessage, '( "deallocation error for coeffs")' ) + Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine) + Endif + EndDo + + END SUBROUTINE RTTOV_SUBCOLUMN +END MODULE MOD_COSP_RTTOV diff --git a/src/physics/cosp2/src/simulator/rttov/cosp_rttov11.F90 b/src/physics/cosp2/src/simulator/rttov/cosp_rttov11.F90 new file mode 100644 index 0000000000..94d82379c5 --- /dev/null +++ b/src/physics/cosp2/src/simulator/rttov/cosp_rttov11.F90 @@ -0,0 +1,1060 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2016, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! March 2016 - M. Johnston - Original version +! April 2016 - D. Swales - Modified for use in COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_cosp_rttov + use rttov_const, only : errorstatus_success, errorstatus_fatal + use rttov_types, only : rttov_options,rttov_coefs,profile_type, & + transmission_type,radiance_type,rttov_chanprof, & + rttov_emissivity,profile_cloud_type,rttov_scatt_coef, & + rttov_options_scatt + use rttov_const, only : surftype_sea, surftype_land, surftype_seaice + use rttov_unix_env, only : rttov_exit + use cosp_kinds, only : wp + use mod_cosp_config, only : RTTOV_MAX_CHANNELS,N_HYDRO,rttovDir + use cosp_phys_constants, only : mdry=>amd,mO3=>amO3,mco2=>amCO2,mCH4=>amCH4, & + mn2o=>amN2O,mco=>amCO + implicit none +#include "rttov_direct.interface" +#include "rttov_alloc_prof.interface" +#include "rttov_alloc_rad.interface" +#include "rttov_alloc_transmission.interface" +#include "rttov_dealloc_coefs.interface" +#include "rttov_user_options_checkinput.interface" +#include "rttov_read_coefs.interface" +#include "rttov_get_emis.interface" +#include "rttov_boundaryconditions.interface" + + ! Module parameters + integer, parameter :: maxlim = 10000 + real(wp),parameter :: eps = 0.622 + + ! Initialization parameters + integer :: & + platform, & ! RTTOV platform + sensor, & ! RTTOV instrument + satellite, & ! RTTOV satellite + nChannels ! Number of channels + integer,dimension(RTTOV_MAX_CHANNELS) :: & + iChannel ! RTTOV channel numbers + + ! Scattering coefficients (read in once during initialization) + type(rttov_coefs) :: & + coef_rttov + type(rttov_scatt_coef) :: & + coef_scatt + ! RTTOV setup and options (set during initialization) + type(rttov_options) :: & + opts ! defaults to everything optional switched off + type(rttov_options_scatt) :: & + opts_scatt +contains + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE rttov_column + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine rttov_column(nPoints,nLevels,nSubCols,q,p,t,o3,ph,h_surf,u_surf,v_surf, & + p_surf,t_skin,t2m,q2m,lsmask,lon,lat,seaice,co2,ch4,n2o,co, & + zenang,lCleanup, & + ! Outputs + Tb,error, & + ! Optional arguments for surface emissivity calculation. + surfem,month, & + ! Optional arguments for all-sky calculation. + tca,ciw,clw,rain,snow) + ! Inputs + integer,intent(in) :: & + nPoints, & ! Number of gridpoints + nLevels, & ! Number of vertical levels + nSubCols ! Number of subcolumns + real(wp),intent(in) :: & + co2, & ! CO2 mixing ratio (kg/kg) + ch4, & ! CH4 mixing ratio (kg/kg) + n2o, & ! N2O mixing ratio (kg/kg) + co, & ! CO mixing ratio (kg/kg) + zenang ! Satellite zenith angle + real(wp),dimension(nPoints),intent(in) :: & + h_surf, & ! Surface height (m) + u_surf, & ! Surface u-wind (m/s) + v_surf, & ! Surface v-wind (m/s) + p_surf, & ! Surface pressure (Pa) + t_skin, & ! Skin temperature (K) + t2m, & ! 2-meter temperature (K) + q2m, & ! 2-meter specific humidity (kg/kg) + lsmask, & ! Land/sea mask + lon, & ! Longitude (deg) + lat, & ! Latitude (deg) + seaice ! Seaice fraction (0-1) + real(wp),dimension(nPoints,nLevels),intent(in) :: & + q, & ! Specific humidity (kg/kg) + p, & ! Pressure(Pa) + t, & ! Temperature (K) + o3 ! Ozone + real(wp),dimension(nPoints,nLevels+1),intent(in) :: & + ph ! Pressure @ half-levels (Pa) + logical,intent(in) :: & + lCleanup ! Flag to determine whether to deallocate RTTOV types + + ! Optional inputs (Needed for surface emissivity calculation) + integer,optional :: & + month ! Month (needed to determine table to load) + real(wp),dimension(nChannels),optional :: & + surfem ! Surface emissivity for each RTTOV channel + + ! Optional inputs (Needed for all-sky calculation) + real(wp),dimension(nPoints,nLevels),optional :: & + tca ! Total column cloud amount (0-1) + real(wp),dimension(nPoints,nSubCols,nLevels),optional :: & + ciw, & ! Cloud ice + clw, & ! Cloud liquid + rain, & ! Precipitation flux (kg/m2/s) + snow ! Precipitation flux (kg/m2/s) + + ! Outputs + real(wp),dimension(nPoints,nChannels) :: & + Tb ! RTTOV brightness temperature. + character(len=128) :: & + error ! Error messages (only populated if error encountered) + + ! Local variables + integer :: & + nloop,rmod,il,istart,istop,za,i,j,subcol,errorstatus,npts_it + integer,dimension(60) :: & + alloc_status + real(wp),dimension(nPoints) :: & + sh_surf + real(wp),dimension(nPoints,nLevels) :: & + sh,totalice + real(wp),dimension(nSubCols,nPoints,nChannels) :: & + Tbs ! Subcolumn brightness temperature + logical :: & + use_totalice, mmr_snowrain, cfrac + logical :: & + lallSky, & ! Control for type of brightness temperature calculation + ! (False(default) => clear-sky brightness temperature, True => All-sky) + lsfcEmis ! Control for surface emissivity calculation (true => compute surface emissivity, + ! provided that the field "month" is available) + +#include "rttov_read_coefs.interface" +#include "rttov_read_scattcoeffs.interface" +#include "rttov_user_options_checkinput.interface" +#include "rttov_dealloc_coefs.interface" +#include "rttov_dealloc_scattcoeffs.interface" +#include "rttov_setup_emis_atlas.interface" +#include "rttov_deallocate_emis_atlas.interface" +#include "rttov_print_opts.interface" +#include "rttov_print_profile.interface" +#include "rttov_boundaryconditions.interface" + + ! Initialize some things + totalice = 0._wp + Tbs(:,:,:) = 0._wp + Tb(:,:) = 0._wp + error = '' + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Setup for call to RTTOV + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! First, check to see if we are doing an all-sky or clear-sky calculation brightness + ! temperature + lallSky = .false. + if (present(tca) .and. present(clw) .and. present(ciw) .and. present(rain) & + .and. present(snow)) lallSky=.true. + + ! Check to see if we need to compute the surface emissivity (defualt is to compute + ! surface emissivity using the atlas tables) + lsfcEmis = .true. + if (present(surfem)) lsfcEmis = .false. + + ! We also need the month for the emissivity atlas, so check... + if (.not. present(month)) lsfcEmis = .false. + + if (lsfcEmis .eq. .false. .and. .not. present(surfem)) then + error = 'ERROR (rttov_column): User did not provide surface emissivity and did not '//& + 'request the surface emissivity to be calculated!!!' + return + endif + + ! Convert specific humidity to ppmv + sh = ( q / ( q + eps * ( 1._wp - q ) ) ) * 1e6 + sh_surf = ( q2m / ( q2m + eps * ( 1._wp - q2m ) ) ) * 1e6 + + ! Settings unique to all-sky call. + use_totalice = .false. + mmr_snowrain = .true. + cfrac = .true. + opts_scatt%lusercfrac = cfrac + + ! RTTOV can handle only about 100 profiles at a time (fixme: check this with roger), + ! so we are putting a loop of 100 + nloop = npoints / maxlim + rmod = mod( npoints, maxlim ) + if( rmod .ne. 0 ) then + nloop = nloop + 1 + endif + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Initialize emissivity atlas data for chosen sensor. + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call rttov_setup_emis_atlas(errorstatus,opts,month,coef_rttov,path=trim(rttovDir)//"emis_data/") + if (errorstatus /= errorstatus_success) then + error = 'ERROR (rttov_column): Error reading emis atlas data!' + return + endif + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Some quality control prior to RTTOV call + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Ensure the options and coefficients are consistent + if(opts_scatt%config%do_checkinput) then + call rttov_user_options_checkinput(errorstatus, opts, coef_rttov) + if (errorstatus /= errorstatus_success) then + error = 'ERROR (rttov_column): Error when checking input data!' + return + endif + endif + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Call to RTTOV + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Looping over maxlim number of profiles + do il = 1, nloop + istart = (il - 1) * maxlim + 1 + istop = min(il * maxlim, npoints) + if( ( il .eq. nloop ) .and. ( rmod .ne. 0 ) ) then + npts_it = rmod + else + npts_it = maxlim + endif + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Clear-sky brightness temperature + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (.not. lallSky) then + call rttov_multprof(nChannels,iChannel,surfem,npts_it,nLevels,platform, & + satellite,sensor,opts,coef_rttov,zenang, & + p(istart:istop,:)/100._wp,t(istart:istop,:), & + sh(istart:istop,:),(mdry/mo3)*o3(istart:istop,:)*1e6, & + (mdry/mco2)*co2*1e6,(mdry/mch4)*ch4*1e6,(mdry/mn2o)*n2o*1e6,& + (mdry/mco)*co*1e6,h_surf(istart:istop),u_surf(istart:istop),& + v_surf(istart:istop),t_skin(istart:istop), & + p_surf(istart:istop)/100.,t2m(istart:istop), & + sh_surf(istart:istop),lsmask(istart:istop), & + seaice(istart:istop),lat(istart:istop),lon(istart:istop), & + Tb(istart:istop,:)) + endif + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! All-sky brightness temperature + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (lallSky) then + ! Loop over all subcolumns + do subcol = 1, nSubCols + ! Call RTTOV + call cosp_rttov_mwscatt(nChannels,iChannel,surfem,nPoints,nlevels,platform, & + satellite,sensor,opts,opts_scatt,coef_rttov, & + coef_scatt,zenang,p(istart:istop,:)/100._wp, & + ph(istart:istop,:)/100._wp,t(istart:istop, :), & + sh(istart:istop, :), & + (mdry/mo3)*o3(istart:istop,:)*1e6, & + clw(istart:istop,subcol,:), & + ciw(istart:istop,subcol,:),tca(istart:istop, :), & + totalice(istart:istop,:),snow(istart:istop,subcol,:),& + rain(istart:istop,subcol,:),(mdry/mco2)*co2*1e6, & + (mdry/mch4)*ch4*1e6,(mdry/mn2o)*n2o*1e6, & + (mdry/mco)*co*1e6,h_surf(istart:istop), & + u_surf(istart:istop),v_surf(istart:istop), & + t_skin(istart:istop), p_surf(istart:istop)/100., & + t2m(istart:istop),sh_surf(istart:istop), & + lsmask(istart:istop),seaice(istart:istop), & + lat(istart:istop),lon(istart:istop), use_totalice, & + mmr_snowrain,cfrac,Tbs(subcol,istart:istop,:)) + enddo + endif + enddo + + ! For all-sky calculation we need to average together all of the cloudy subcolumns. + if (lallSky) then + do subcol = 1, nSubCols + Tb = Tb + tbs(subcol,:,:) + enddo + Tb = Tb/nSubCols + endif + + ! Free up space + if (lCleanup) then + call rttov_dealloc_coefs(errorstatus,coef_rttov) + call rttov_deallocate_emis_atlas(coef_rttov) + if (lallSky) call rttov_dealloc_scattcoeffs(coef_scatt) + endif + end subroutine rttov_column + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE rttov_multprof + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine rttov_multprof( & + nch_in, & ! number of channels + ichan_in, & ! channel indices + surfem_in, & ! surface emissivity values + prf_num_in, & ! number of profiles to simulate + nlevels_in, & ! number of pressure levels + plat_in, & ! platform number + sat_in, & ! satellite number + sens_in, & ! instrument number + opts, & + coef_rttov, & + zenang_in, & ! zenith angle + p_in, & ! pressure [hpa] + t_in, & ! temperature [ k ] + q_in, & ! specific humidity [ ppmv ] + o3_in, & ! ozone vmr [ ppmv ] + co2_in, & ! co2 vmr [ ppmv ] *this is a single value* + ch4_in, & ! ch4 vmr [ ppmv ] *this is a single value* + n2o_in, & ! n2o vmr [ ppmv ] *this is a single value* + co_in, & ! co vmr [ ppmv ] *this is a single value* + h_surf, & ! surface height [ m ] + u_surf, & ! u wind at 10 m [ m/s ] + v_surf, & ! v wind at 10 m [ m/s ] + t_skin, & ! skin temperatre [ k ] + p_surf, & ! surface pressure + t_surf, & ! 1.5 m temperature [ k ] + q_surf, & ! 1.5 m specific humidity [ ppmv ] + lsmask, & ! land sea mask + seaice, & ! seaice fraction + latitude, & ! latitude [ deg north ] + longitude, & ! longitude [ deg east ] + tbs & ! brightness temperature [ k ] (output) + ) + + !------ input arguments. no rttov kinds should be used here ----------------- + integer, intent(in) :: nch_in ! number of channels to be computed + integer, intent(in) :: ichan_in(nch_in) ! indices of selected channels + real(wp), intent(in) :: surfem_in(nch_in) ! surface emissivities for the channels + integer, intent(in) :: prf_num_in + integer, intent(in) :: nlevels_in + integer, intent(in) :: plat_in ! satellite platform + integer, intent(in) :: sat_in ! satellite number + integer, intent(in) :: sens_in ! satellite sensor + real(wp), intent(in) :: zenang_in ! satellite zenith angle + + type(rttov_options) :: opts + type(rttov_coefs) :: coef_rttov + + real(wp), intent(in) :: p_in(prf_num_in, nlevels_in) ! pressure profiles + real(wp), intent(in) :: t_in(prf_num_in, nlevels_in) ! temperature profiles + real(wp), intent(in) :: q_in(prf_num_in, nlevels_in) ! humidity profiles + real(wp), intent(in) :: o3_in(prf_num_in, nlevels_in) ! ozone profiles + + ! the following trace gases contain constant values + real(wp), intent(in) :: co2_in ! carbon dioxide + real(wp), intent(in) :: ch4_in ! methane + real(wp), intent(in) :: n2o_in ! n2o + real(wp), intent(in) :: co_in ! carbon monoxide + real(wp), intent(in) :: h_surf(prf_num_in) ! surface height + real(wp), intent(in) :: u_surf(prf_num_in) ! u component of surface wind + real(wp), intent(in) :: v_surf(prf_num_in) ! v component of surface wind + real(wp), intent(in) :: t_skin(prf_num_in) ! surface skin temperature + real(wp), intent(in) :: p_surf(prf_num_in) ! surface pressure + real(wp), intent(in) :: t_surf(prf_num_in) ! 1.5 m temperature + real(wp), intent(in) :: q_surf(prf_num_in) ! 1.5 m specific humidity + real(wp), intent(in) :: lsmask(prf_num_in) ! land-sea mask + real(wp), intent(in) :: seaice(prf_num_in) ! sea-ice fraction + real(wp), intent(in) :: latitude(prf_num_in) ! latitude + real(wp), intent(in) :: longitude(prf_num_in) ! longitude + + real(wp), intent(inout) :: tbs(prf_num_in, nch_in) ! tbs (in the right format) + + !------ local variables. use only rttov kinds or derived types. + ! logical variables are declared with the same kind + ! as integers, as they are affected inthe same way by flags like -qintsize=8 + + ! type(rttov_options) :: opts ! options structure + ! type(rttov_coefs), allocatable :: coefs(:) ! coefficients structure + type(rttov_chanprof), allocatable :: chanprof(:) ! input channel/profile list + type(profile_type), allocatable :: profiles(:) ! input profiles + logical, allocatable :: calcemis(:) ! flag to indicate calculation of emissivity within rttov + type(rttov_emissivity), allocatable :: emissivity(:) ! input/output surface emissivity + type(transmission_type) :: transmission ! output transmittances + type(radiance_type) :: radiance ! output radiances + + integer, allocatable :: instrument(:,:) ! instrument id (3 x n_instruments) + integer, allocatable :: nchan(:) ! number of channels per instrument + integer, allocatable :: ichan(:,:) ! channel list per instrument + + integer :: asw + integer :: mxchn + integer :: nrttovid ! maximum number of instruments + integer :: no_id ! instrument loop index + integer :: i, j, jch + integer :: nprof ! number of calls to rttov + integer :: nch ! intermediate variable + integer :: errorstatus + integer :: ich, ich_temp, nchanprof, nchannels, chan + integer :: alloc_status(60) + + real(wp), allocatable :: input_emissivity (:) + + character (len=14) :: nameofroutine = 'rttov_multprof' + + logical :: refrac, solrad, laerosl, lclouds, lsun, all_channels + + ! local variables for input arguments that need type casting to avoid type-mismatch with + ! rttov kinds. this happens with some compiler flags (-qintsize=8). + integer :: prof_num + integer :: nlevels + + ! -------------------------------------------------------------------------- + ! 0. initialise cosp-specific things + ! -------------------------------------------------------------------------- + + ! type-casting of input arguments that need to be passed to rttov + prof_num = prf_num_in + nlevels = nlevels_in + nprof = prof_num + + ! currently we plan to calculate only 1 instrument per call + nrttovid = 1 + mxchn = nch_in + + errorstatus = 0 + alloc_status(:) = 0 + + ! allocate(coefs(nrttovid), stat = alloc_status(1)) + + ! allocate(instrument(3, nrttovid), stat = alloc_status(4)) + + !maximum number of channels allowed for one instrument is mxchn + ! allocate(surfem(nch_in, nrttovid), stat = alloc_status(11)) + allocate(ichan(nch_in, nrttovid), stat = alloc_status(12)) + call rttov_error('ichan mem allocation error for profile array' , lalloc = .true.) + + + do no_id = 1, nrttovid + ichan(:, no_id) = ichan_in + enddo + + asw = 1 ! switch for allocation passed into rttov subroutines + + ! allocate input profile arrays + allocate(profiles(nprof), stat = alloc_status(1)) + call rttov_error('Profile mem allocation error' , lalloc = .true.) + + call rttov_alloc_prof( & + errorstatus, & + nprof, & + profiles, & + nlevels, & + opts, & + asw, & + coefs = coef_rttov, & + init = .true.) + call rttov_error('Profile 2 mem allocation error' , lalloc = .true.) + ! -------------------------------------------------------------------------- + ! 5. store profile data in profile type + ! -------------------------------------------------------------------------- + do i = 1, nprof + profiles(i)%p(:) = p_in(i, :) + profiles(i)%t(:) = t_in(i, :) + profiles(i)%q(:) = q_in(i, :) + + where(profiles(i)%q(:) < 1e-4) + profiles(i)%q(:) = 1e-4 + end where + + profiles(i)%cfraction = 0. + profiles(i)%ctp = 500. + + ! 2m parameters + profiles(i)%s2m%p = p_surf(i) + profiles(i)%s2m%t = t_surf(i) + profiles(i)%s2m%q = q_surf(i) + profiles(i)%s2m%u = u_surf(i) ! dar: hard-coded at 2ms-1? + profiles(i)%s2m%v = v_surf(i) ! dar: hard-coded at 2ms-1? + profiles(i)%s2m%wfetc = 10000. ! dar: default? + + ! skin variables for emissivity calculations + profiles(i)%skin%t = t_skin(i) + + ! fastem coefficients - for mw calculations + profiles(i)%skin%fastem(1) = 3.0 + profiles(i)%skin%fastem(2) = 5.0 + profiles(i)%skin%fastem(3) = 15.0 + profiles(i)%skin%fastem(4) = 0.1 + profiles(i)%skin%fastem(5) = 0.3 + + profiles(i)%zenangle = zenang_in ! pass in from cosp + + profiles(i)%azangle = 0. ! hard-coded in rttov9 int + + profiles(i)%latitude = latitude(i) + profiles(i)%longitude = longitude(i) + profiles(i)%elevation = h_surf(i) + + profiles(i)%sunzenangle = 0. ! hard-coded in rttov9 int + profiles(i)%sunazangle = 0. ! hard-coded in rttov9 int + + ! surface type + ! land-sea mask indicates proportion of land in grid + if (lsmask(i) < 0.5) then + profiles(i)%skin%surftype = surftype_sea + else + profiles(i)%skin%surftype = surftype_land + endif + ! sea-ice fraction + if (seaice(i) >= 0.5) then + profiles(i)%skin%surftype = surftype_seaice + endif + + ! dar: hard-coded to 1 (=ocean water) in rttov 9 int + profiles(i)%skin%watertype = 1 + profiles(i) %idg = 0. + profiles(i) %ish = 0. + enddo + ! end of 5. + + ich_temp = 1 + nchannels = nch_in + do no_id = 1, nrttovid + + ! -------------------------------------------------------------------------- + ! 3. build the list of profile/channel indices in chanprof + ! -------------------------------------------------------------------------- + + allocate(nchan(nprof)) ! number of channels per profile + nchan(:) = size(ichan(:,no_id)) ! = nch_in + + ! size of chanprof array is total number of channels over all profiles + ! square in this case - here same channels done for all profiles + nchanprof = sum(nchan(:)) + + ! pack channels and input emissivity arrays + allocate(chanprof(nchanprof)) + ! allocate(emis(nchanprof)) + chanprof(:)%chan =0 + + nch = 0 + do j = 1, nprof + do jch = 1, nchan(j) + nch = nch + 1 + chanprof(nch)%prof = j + if(ichan(jch, no_id) < 1) then + errorstatus = errorstatus_fatal + call rttov_error('Sensor channel number must be 1 or greater' , lalloc = .true.) + else + chanprof(nch)%chan = ichan(jch, no_id) + endif + enddo + enddo + ! end of 3. + + ! allocate output radiance arrays + call rttov_alloc_rad( & + errorstatus, & + nchanprof, & + radiance, & + nlevels - 1, & ! nlayers + asw) + call rttov_error('allocation error for radiance arrays' , lalloc = .true.) + + ! allocate transmittance structure + call rttov_alloc_transmission( & + errorstatus, & + transmission, & + nlevels - 1, & + nchanprof, & + asw, & + init=.true.) + call rttov_error('allocation error for transmission arrays' , lalloc = .true.) + + ! allocate arrays for surface emissivity + allocate(calcemis(nchanprof), stat=alloc_status(1)) + allocate(emissivity(nchanprof), stat=alloc_status(2)) + call rttov_error('mem allocation error for emissivity arrays' , lalloc = .true.) + + call rttov_get_emis( & + & errorstatus, & + & opts, & + & chanprof, & + & profiles, & + & coef_rttov, & + !& resolution=resolution, & ! *** MW atlas native + ! resolution is 0.25 degree lat/lon; if you know better + ! value for satellite footprint (larger than this) then + ! you can specify it here + & emissivity=emissivity(:)%emis_in) + ! & emissivity(:)%emis_in) + + call rttov_error('Get emissivity error' , lalloc = .true.) + calcemis(:) = .false. + ! calculate emissivity for missing and ocean location (fastem) + where (emissivity(:)%emis_in <= 0.0) + calcemis(:) = .true. + endwhere + + call rttov_direct( & + errorstatus, &! out + chanprof, & + opts, & + profiles, &! in + coef_rttov, &! in + transmission, &! out + radiance, & + calcemis = calcemis, &! in + emissivity = emissivity) ! inout + call rttov_error('rttov_direct error', lalloc = .true.) + + tbs(1:prof_num , ich_temp:ich_temp + size(ichan(:,no_id)) - 1) = & + transpose(reshape(radiance%bt(1:nchanprof), (/ size(ichan(:,no_id)), prof_num/) )) + + ich_temp = ich_temp + size(ichan(:,no_id)) + + ! -------------------------------------------------------------------------- + ! 8. deallocate all rttov arrays and structures + ! -------------------------------------------------------------------------- + deallocate (nchan, stat=alloc_status(3)) + deallocate (chanprof, stat=alloc_status(4)) + deallocate (emissivity, stat=alloc_status(5)) + deallocate (calcemis, stat=alloc_status(6)) + call rttov_error('rttov array deallocation error', lalloc = .true.) + + asw = 0 ! switch for deallocation passed into rttov subroutines + + ! deallocate radiance arrays + call rttov_alloc_rad(errorstatus, nchannels, radiance, nlevels - 1, asw) + call rttov_error('radiance deallocation error', lalloc = .true.) + + ! deallocate transmission arrays + call rttov_alloc_transmission(errorstatus, transmission, nlevels - 1, nchannels, asw) + call rttov_error('transmission deallocation error', lalloc = .true.) + + enddo + + ! deallocate profile arrays + call rttov_alloc_prof(errorstatus, nprof, profiles, nlevels, opts, asw) + call rttov_error('profile deallocation error', lalloc = .true.) + + deallocate(profiles, stat=alloc_status(1)) + call rttov_error('mem deallocation error for profile array', lalloc= .true.) + + contains + + subroutine rttov_error(msg, lalloc) + character(*) :: msg + logical :: lalloc + + if(lalloc) then + if (any(alloc_status /= 0)) then + write(*,*) msg + errorstatus = 1 + call rttov_exit(errorstatus) + endif + else + if (errorstatus /= errorstatus_success) then + write(*,*) msg + call rttov_exit(errorstatus) + endif + endif + end subroutine rttov_error + + end subroutine rttov_multprof + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !----------------- subroutine cosp_rttov_mwscatt --------------- + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + subroutine cosp_rttov_mwscatt(& + nch_in, & ! number of channels + ichan_in, & ! channel indices + surfem_in, & ! surface emissivity values + prf_num_in, & ! number of profiles to simulate + nlevels_in, & ! number of pressure levels + plat_in, & ! platform number + sat_in, & ! satellite number + sens_in, & ! instrument number + opts, & + opts_scatt, & + coef_rttov, & + coef_scatt, & + zenang_in, & ! zenith angle + p_in, & ! pressure [hpa] + ph_in, & ! pressure on half levels [hpa] + t_in, & ! temperature [ k ] + q_in, & ! specific humidity [ ppmv ] + o3_in, & ! ozone vmr [ ppmv ] + clw_in, & ! cloud water [0-1] + ciw_in, & ! cloud ice [0-1] + cc_in, & ! effective cloud fraction [0-1] + totalice_in,& ! total ice, except snow [kg/kg] or [kg/m2/s] + sp_in, & ! solid precip with snow [kg/kg] or [kg/m2/s] + rain_in, & ! total liquid water [kg/kg] or [kg/m2/s] + co2_in, & ! co2 vmr [ ppmv ] *this is a single value* + ch4_in, & ! ch4 vmr [ ppmv ] *this is a single value* + n2o_in, & ! n2o vmr [ ppmv ] *this is a single value* + co_in, & ! co vmr [ ppmv ] *this is a single value* + h_surf, & ! surface height [ m ] + u_surf, & ! u wind at 10 m [ m/s ] + v_surf, & ! v wind at 10 m [ m/s ] + t_skin, & ! skin temperatre [ k ] + p_surf, & ! surface pressure + t_surf, & ! 1.5 m temperature [ k ] + q_surf, & ! 1.5 m specific humidity [ ppmv ] + lsmask, & ! land sea mask + seaice, & ! seaice fraction + latitude, & ! latitude [ deg north ] + longitude, & ! longitude [ deg east ] + use_totalice,& ! separate ice and snow, or total ice hydrometeor types + mmr_snowrain,& ! set units for snow and rain: if true units are kg/kg (the default) + cfrac, & ! opts_scatt%lusercfrac=true., supply the effective cloud fraction + tbs & ! brightness temperature [ k ] (output) + ) + + + + + + implicit none + + !------ input arguments. no rttov kinds should be used here ----------------- + integer, intent(in) :: nch_in ! number of channels to be computed + integer, intent(in) :: ichan_in(nch_in) ! indices of selected channels + real(wp), intent(in) :: surfem_in(nch_in) ! surface emissivities for the channels + integer, intent(in) :: prf_num_in + integer, intent(in) :: nlevels_in + integer, intent(in) :: plat_in ! satellite platform + integer, intent(in) :: sat_in ! satellite number + integer, intent(in) :: sens_in ! satellite sensor + real(wp), intent(in) :: zenang_in ! satellite zenith angle + + type(rttov_options) :: opts + type(rttov_options_scatt) :: opts_scatt + type(rttov_coefs) :: coef_rttov + type(rttov_scatt_coef) :: coef_scatt + + real(wp), intent(in) :: p_in(prf_num_in, nlevels_in) ! pressure profiles + real(wp), intent(in) :: t_in(prf_num_in, nlevels_in) ! temperature profiles + real(wp), intent(in) :: q_in(prf_num_in, nlevels_in) ! humidity profiles + real(wp), intent(in) :: o3_in(prf_num_in, nlevels_in) ! ozone profiles + real(wp), intent(in) :: clw_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: ciw_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: cc_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: totalice_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: sp_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: rain_in(prf_num_in, nlevels_in) + real(wp), intent(in) :: ph_in(prf_num_in, nlevels_in+1) + + ! the following trace gases contain constant values + real(wp), intent(in) :: co2_in ! carbon dioxide + real(wp), intent(in) :: ch4_in ! methane + real(wp), intent(in) :: n2o_in ! n2o + real(wp), intent(in) :: co_in ! carbon monoxide + real(wp), intent(in) :: h_surf(prf_num_in) ! surface height + real(wp), intent(in) :: u_surf(prf_num_in) ! u component of surface wind + real(wp), intent(in) :: v_surf(prf_num_in) ! v component of surface wind + real(wp), intent(in) :: t_skin(prf_num_in) ! surface skin temperature + real(wp), intent(in) :: p_surf(prf_num_in) ! surface pressure + real(wp), intent(in) :: t_surf(prf_num_in) ! 1.5 m temperature + real(wp), intent(in) :: q_surf(prf_num_in) ! 1.5 m specific humidity + real(wp), intent(in) :: lsmask(prf_num_in) ! land-sea mask + real(wp), intent(in) :: seaice(prf_num_in) ! seaice fraction + real(wp), intent(in) :: latitude(prf_num_in) ! latitude + real(wp), intent(in) :: longitude(prf_num_in) ! longitude + logical, intent(in) :: cfrac, use_totalice, mmr_snowrain + + real(wp), intent(inout) :: tbs(prf_num_in, nch_in) ! tbs (in the right format) + !****************** local variables ********************************************** + logical , allocatable :: calcemis (:) + type(rttov_emissivity) , allocatable :: emissivity (:) + integer , allocatable :: frequencies (:) + type(rttov_chanprof) , allocatable :: chanprof (:) ! channel and profile indices + type(profile_type) , allocatable :: profiles (:) + type(profile_cloud_type) , allocatable :: cld_profiles(:) + + integer, allocatable :: ichan(:,:) ! channel list per instrument + + integer :: errorstatus + type (radiance_type) :: radiance + ! type (rttov_options) :: opts ! defaults to everything optional switched off + ! type (rttov_options_scatt) :: opts_scatt + ! type (rttov_coefs) :: coef_rttov + ! type (rttov_scatt_coef) :: coef_scatt + + ! integer, allocatable :: instrument (:,:) + integer :: j,k,asw + integer :: nchanxnprof, ninstruments + real(wp) :: zenangle + character (len=256) :: outstring + integer :: alloc_status(60) + +#include "rttov_init_rad.interface" +#include "rttov_scatt_setupindex.interface" +#include "rttov_scatt.interface" +#include "rttov_alloc_rad.interface" +#include "rttov_alloc_prof.interface" +#include "rttov_alloc_scatt_prof.interface" +#include "rttov_get_emis.interface" +#include "rttov_boundaryconditions.interface" + + errorstatus = 0 + alloc_status(:) = 0 + ninstruments = 1 ! number of sensors or platforms + + allocate(ichan(nch_in, ninstruments), stat = alloc_status(3)) + + do j = 1, ninstruments + ichan(:, j) = ichan_in + enddo + + nchanxnprof = prf_num_in * nch_in ! total channels to simulate * profiles + + allocate (chanprof(nchanxnprof)) + allocate (frequencies(nchanxnprof)) + allocate (emissivity(nchanxnprof)) + allocate (calcemis(nchanxnprof)) + allocate (profiles(prf_num_in)) + allocate (cld_profiles(prf_num_in)) + + ! request rttov / fastem to calculate surface emissivity + calcemis = .true. + emissivity % emis_in = 0.0 + + ! setup indices + call rttov_scatt_setupindex ( & + & prf_num_in, & ! in + & nch_in, & ! in + & coef_rttov%coef, & ! in + & nchanxnprof, & ! in + & chanprof, & ! out + & frequencies) ! out + + ! allocate profiles (input) and radiance (output) structures + asw = 1 + call rttov_alloc_prof( errorstatus,prf_num_in,profiles,nlevels_in,opts,asw, init = .true.) + call rttov_alloc_scatt_prof(prf_num_in,cld_profiles, nlevels_in, .false., 1, init = .true.) + call rttov_alloc_rad(errorstatus,nchanxnprof,radiance,nlevels_in-1,asw) + + ! fill the profile structures with data + do j = 1, prf_num_in + profiles(j)%latitude = latitude(j) + profiles(j)%longitude = longitude(j) + profiles(j)%elevation = h_surf(j) + profiles(j)%sunzenangle = 0.0 ! hard-coded in rttov9 int + profiles(j)%sunazangle = 0.0 ! hard-coded in rttov9 int + profiles(j)%azangle = 0.0 + profiles(j)%zenangle = zenang_in + profiles(j)%s2m%t = t_surf(j) + profiles(j)%s2m%q = q_surf(j) + profiles(j)%s2m%u = u_surf(j) + profiles(j)%s2m%v = v_surf(j) + profiles(j)%s2m%wfetc = 10000. + profiles(j)%skin%t = t_skin(j) + profiles(j)%skin%watertype = 1 ! ocean water + if (lsmask(j) < 0.5) then + profiles(j)%skin%surftype = surftype_sea + else + profiles(j)%skin%surftype = surftype_land + endif + if (seaice(j) >= 0.5) then + profiles(j)%skin%surftype = surftype_seaice + endif + profiles(j)%skin%fastem(1) = 3.0 + profiles(j)%skin%fastem(2) = 5.0 + profiles(j)%skin%fastem(3) = 15.0 + profiles(j)%skin%fastem(4) = 0.1 + profiles(j)%skin%fastem(5) = 0.3 + profiles(j)%cfraction = 0.0 + profiles(j)%ctp = 500.0 ! not used but still required by rttov + profiles(j)%p(:) = p_in(j,:) + profiles(j)%t(:) = t_in(j,:) + profiles(j)%q(:) = q_in(j,:) + profiles(j)%idg = 0. + profiles(j)%ish = 0. + where(profiles(j)%q(:) < 1e-4) + profiles(j)%q(:) = 1e-4 + end where + cld_profiles(j)%ph(:) = ph_in(j,:) + cld_profiles(j)%cc(:) = cc_in(j,:) + cld_profiles(j)%clw(:) = clw_in(j,:) + cld_profiles(j)%ciw(:) = ciw_in(j,:) + cld_profiles(j)%rain(:) = rain_in(j,:) + cld_profiles(j)%sp(:) = sp_in(j,:) + profiles(j)%s2m%p = cld_profiles(j)%ph(nlevels_in+1) + enddo + + call rttov_get_emis( & + & errorstatus, & + & opts, & + & chanprof, & + & profiles, & + & coef_rttov, & + ! & resolution=resolution, & ! *** MW atlas native resolution is + ! 0.25 degree lat/lon; if you know better value for satellite + ! footprint (larger than this) then you can specify it here + & emissivity=emissivity(:)%emis_in) + if (errorstatus /= errorstatus_success) then + write(*,*) 'In COSP_RTTOV11: Error RTTOV_GET_EMIS!' + call rttov_exit(errorstatus) + endif + + calcemis(:) = .false. + where (emissivity(:)%emis_in <= 0.) + calcemis(:) = .true. + endwhere + + call rttov_scatt (& + & errorstatus, &! out + & opts_scatt, &! in + & nlevels_in, &! in + & chanprof, &! in + & frequencies, &! in + & profiles, &! in + & cld_profiles, &! in + & coef_rttov, &! in + & coef_scatt, &! in + & calcemis, &! in + & emissivity, &! in + & radiance) ! out + + if (errorstatus /= errorstatus_success) then + write(*,*) 'In COSP_RTTOV11: Error RTTOV_SCATT!' + call rttov_exit(errorstatus) + endif + + !write(*,*) 'Checking emissivities: ', maxval(emissivity(:)%emis_out), \ + ! minval(emissivity(:)%emis_out) + tbs(1:prf_num_in,1:1+size(ichan(:,1))-1) = & + transpose(reshape(radiance%bt(1:nchanxnprof),(/ size(ichan(:,1)),prf_num_in/) )) + + ! deallocate all storage + asw = 0 + ! call rttov_dealloc_coefs(errorstatus,coef_rttov) + ! call rttov_dealloc_scattcoeffs(coef_scatt) + call rttov_alloc_prof(errorstatus,prf_num_in,profiles,nlevels_in,opts,asw) + call rttov_alloc_scatt_prof(prf_num_in,cld_profiles,nlevels_in,.false.,asw) + call rttov_alloc_rad(errorstatus,nchanxnprof,radiance,nlevels_in-1,asw) + deallocate(ichan,chanprof,frequencies,emissivity,calcemis) !instrument, + !*************************************************************************** + !-------- end section -------- + !*************************************************************************** + end subroutine cosp_rttov_mwscatt + function construct_rttov_coeffilename(platform,satellite,instrument) + ! Inputs + integer,intent(in) :: platform,satellite,instrument + ! Outputs + character(len=256) :: construct_rttov_coeffilename + ! Local variables + character(len=256) :: coef_file + integer :: error + + ! Initialize + error = 0 + + ! Platform + if (platform .eq. 1) coef_file = 'rtcoef_noaa_' + if (platform .eq. 10) coef_file = 'rtcoef_metop_' + if (platform .eq. 11) coef_file = 'rtcoef_envisat_' + if (platform .ne. 1 .and. platform .ne. 10 .and. platform .ne. 11) then + error=error+1 + write ( *,* ) 'Unsupported platform ID ',platform + return + endif + + ! Satellite + if (satellite .lt. 10) then + coef_file = trim(coef_file) // char(satellite+48) + else if (satellite .lt. 100) then + coef_file = trim(coef_file) // char(int(satellite/10)+48) + coef_file = trim(coef_file) // char(satellite-int(satellite/10)*10+48) + else + error=error+1 + write ( *,* ) 'Unsupported satellite number ',satellite + return + endif + + ! Sensor + if (sensor .eq. 3) coef_file = trim(coef_file) // '_amsua.dat' + if (sensor .eq. 5) coef_file = trim(coef_file) // '_avhrr.dat' + if (sensor .eq. 49) coef_file = trim(coef_file) // '_mwr.dat' + if (sensor .ne. 3 .and. sensor .ne. 5 .and. sensor .ne. 49) then + error=error+1 + write ( *,* ) 'Unsupported sensor number ', sensor + return + endif + + if (error .eq. 0) construct_rttov_coeffilename=coef_file + + end function construct_rttov_coeffilename + function construct_rttov_scatfilename(platform,satellite,instrument) + ! Inputs + integer,intent(in) :: platform,satellite,instrument + ! Outputs + character(len=256) :: construct_rttov_scatfilename + ! Local variables + character(len=256) :: coef_file + integer :: error + + ! Initialize + error = 0 + + ! Platform + if (platform .eq. 1) coef_file = 'sccldcoef_noaa_' + if (platform .eq. 10) coef_file = 'sccldcoef_metop_' + if (platform .eq. 11) coef_file = 'sccldcoef_envisat_' + if (platform .ne. 1 .and. platform .ne. 10 .and. platform .ne. 11) then + error=error+1 + write ( *,* ) 'Unsupported platform ID ',platform + return + endif + + ! Satellite + if (satellite .lt. 10) then + coef_file = trim(coef_file) // char(satellite+48) + else if (satellite .lt. 100) then + coef_file = trim(coef_file) // char(int(satellite/10)+48) + coef_file = trim(coef_file) // char(satellite-int(satellite/10)*10+48) + else + error=error+1 + write ( *,* ) 'Unsupported satellite number ',satellite + return + endif + + ! Sensor + if (sensor .eq. 3) coef_file = trim(coef_file) // '_amsua.dat' + if (sensor .eq. 5) coef_file = trim(coef_file) // '_avhrr.dat' + if (sensor .eq. 49) coef_file = trim(coef_file) // '_mwr.dat' + if (sensor .ne. 3 .and. sensor .ne. 5 .and. sensor .ne. 49) then + error=error+1 + write ( *,* ) 'Unsupported sensor number ', sensor + return + endif + + if (error .eq. 0) construct_rttov_scatfilename=coef_file + + end function construct_rttov_scatfilename + +end module mod_cosp_rttov diff --git a/src/physics/cosp2/src/simulator/rttov/cosp_rttovSTUB.F90 b/src/physics/cosp2/src/simulator/rttov/cosp_rttovSTUB.F90 new file mode 100644 index 0000000000..73a0018362 --- /dev/null +++ b/src/physics/cosp2/src/simulator/rttov/cosp_rttovSTUB.F90 @@ -0,0 +1,212 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE MOD_COSP_RTTOV + use cosp_kinds, only : wp + use mod_cosp_config, only : RTTOV_MAX_CHANNELS,N_HYDRO,rttovDir + use cosp_phys_constants, only : mdry=>amd,mO3=>amO3,mco2=>amCO2,mCH4=>amCH4, & + mn2o=>amN2O,mco=>amCO + IMPLICIT NONE + + ! Module parameters + integer, parameter :: maxlim = 10000 + real(wp),parameter :: eps = 0.622 + + ! Initialization parameters + integer :: & + platform, & ! RTTOV platform + sensor, & ! RTTOV instrument + satellite, & ! RTTOV satellite + nChannels ! Number of channels + integer,dimension(RTTOV_MAX_CHANNELS) :: & + iChannel ! RTTOV channel numbers + +CONTAINS + subroutine rttov_column(nPoints,nLevels,nSubCols,q,p,t,o3,ph,h_surf,u_surf,v_surf, & + p_surf,t_skin,t2m,q2m,lsmask,lon,lat,seaice,co2,ch4,n2o,co, & + zenang,lCleanup, & + ! Outputs + Tb,error, & + ! Optional arguments for surface emissivity calculation. + surfem,month, & + ! Optional arguments for all-sky calculation. + tca,ciw,clw,rain,snow) + ! Inputs + integer,intent(in) :: & + nPoints, & ! Number of gridpoints + nLevels, & ! Number of vertical levels + nSubCols ! Number of subcolumns + real(wp),intent(in) :: & + co2, & ! CO2 mixing ratio (kg/kg) + ch4, & ! CH4 mixing ratio (kg/kg) + n2o, & ! N2O mixing ratio (kg/kg) + co, & ! CO mixing ratio (kg/kg) + zenang ! Satellite zenith angle + real(wp),dimension(nPoints),intent(in) :: & + h_surf, & ! Surface height (m) + u_surf, & ! Surface u-wind (m/s) + v_surf, & ! Surface v-wind (m/s) + p_surf, & ! Surface pressure (Pa) + t_skin, & ! Skin temperature (K) + t2m, & ! 2-meter temperature (K) + q2m, & ! 2-meter specific humidity (kg/kg) + lsmask, & ! Land/sea mask + lon, & ! Longitude (deg) + lat, & ! Latitude (deg) + seaice ! Seaice fraction (0-1) + real(wp),dimension(nPoints,nLevels),intent(in) :: & + q, & ! Specific humidity (kg/kg) + p, & ! Pressure(Pa) + t, & ! Temperature (K) + o3 ! Ozone + real(wp),dimension(nPoints,nLevels+1),intent(in) :: & + ph ! Pressure @ half-levels (Pa) + logical,intent(in) :: & + lCleanup ! Flag to determine whether to deallocate RTTOV types + + ! Optional inputs (Needed for surface emissivity calculation) + integer,optional :: & + month ! Month (needed to determine table to load) + real(wp),dimension(nChannels),optional :: & + surfem ! Surface emissivity for each RTTOV channel + + ! Optional inputs (Needed for all-sky calculation) + real(wp),dimension(nPoints,nLevels),optional :: & + tca ! Total column cloud amount (0-1) + real(wp),dimension(nPoints,nSubCols,nLevels),optional :: & + ciw, & ! Cloud ice + clw, & ! Cloud liquid + rain, & ! Precipitation flux (kg/m2/s) + snow ! Precipitation flux (kg/m2/s) + + ! Outputs + real(wp),dimension(nPoints,nChannels) :: & + Tb ! RTTOV brightness temperature. + character(len=128) :: & + error ! Error messages (only populated if error encountered) + + end subroutine rttov_column + function construct_rttov_coeffilename(platform,satellite,instrument) + ! Inputs + integer,intent(in) :: platform,satellite,instrument + ! Outputs + character(len=256) :: construct_rttov_coeffilename + ! Local variables + character(len=256) :: coef_file + integer :: error + + ! Initialize + error = 0 + + ! Platform + if (platform .eq. 1) coef_file = 'rtcoef_noaa_' + if (platform .eq. 10) coef_file = 'rtcoef_metop_' + if (platform .eq. 11) coef_file = 'rtcoef_envisat_' + if (platform .ne. 1 .and. platform .ne. 10 .and. platform .ne. 11) then + error=error+1 + write ( *,* ) 'Unsupported platform ID ',platform + return + endif + + ! Satellite + if (satellite .lt. 10) then + coef_file = trim(coef_file) // char(satellite+48) + else if (satellite .lt. 100) then + coef_file = trim(coef_file) // char(int(satellite/10)+48) + coef_file = trim(coef_file) // char(satellite-int(satellite/10)*10+48) + else + error=error+1 + write ( *,* ) 'Unsupported satellite number ',satellite + return + endif + + ! Sensor + if (sensor .eq. 3) coef_file = trim(coef_file) // '_amsua.dat' + if (sensor .eq. 5) coef_file = trim(coef_file) // '_avhrr.dat' + if (sensor .eq. 49) coef_file = trim(coef_file) // '_mwr.dat' + if (sensor .ne. 3 .and. sensor .ne. 5 .and. sensor .ne. 49) then + error=error+1 + write ( *,* ) 'Unsupported sensor number ', sensor + return + endif + + if (error .eq. 0) construct_rttov_coeffilename=coef_file + + end function construct_rttov_coeffilename + function construct_rttov_scatfilename(platform,satellite,instrument) + ! Inputs + integer,intent(in) :: platform,satellite,instrument + ! Outputs + character(len=256) :: construct_rttov_scatfilename + ! Local variables + character(len=256) :: coef_file + integer :: error + + ! Initialize + error = 0 + + ! Platform + if (platform .eq. 1) coef_file = 'sccldcoef_noaa_' + if (platform .eq. 10) coef_file = 'sccldcoef_metop_' + if (platform .eq. 11) coef_file = 'sccldcoef_envisat_' + if (platform .ne. 1 .and. platform .ne. 10 .and. platform .ne. 11) then + error=error+1 + write ( *,* ) 'Unsupported platform ID ',platform + return + endif + + ! Satellite + if (satellite .lt. 10) then + coef_file = trim(coef_file) // char(satellite+48) + else if (satellite .lt. 100) then + coef_file = trim(coef_file) // char(int(satellite/10)+48) + coef_file = trim(coef_file) // char(satellite-int(satellite/10)*10+48) + else + error=error+1 + write ( *,* ) 'Unsupported satellite number ',satellite + return + endif + + ! Sensor + if (sensor .eq. 3) coef_file = trim(coef_file) // '_amsua.dat' + if (sensor .eq. 5) coef_file = trim(coef_file) // '_avhrr.dat' + if (sensor .eq. 49) coef_file = trim(coef_file) // '_mwr.dat' + if (sensor .ne. 3 .and. sensor .ne. 5 .and. sensor .ne. 49) then + error=error+1 + write ( *,* ) 'Unsupported sensor number ', sensor + return + endif + + if (error .eq. 0) construct_rttov_scatfilename=coef_file + + end function construct_rttov_scatfilename +END MODULE MOD_COSP_RTTOV diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 83f457bc6e..e65809c11d 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -826,6 +826,8 @@ subroutine radiation_tend( & real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) character(*), parameter :: name = 'radiation_tend' + + logical, parameter :: cosz_rad_call=.true. !+tht !-------------------------------------------------------------------------------------- lchnk = state%lchnk @@ -850,7 +852,7 @@ subroutine radiation_tend( & call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & delta, eccf) do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg) + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht end do ! Gather night/day column indices. diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index a1c5022cb9..4e6ebf6e3a 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -666,23 +666,22 @@ subroutine write_horiz_coord_var(this, File) call this%get_coord_len(fdims(1)) allocate(iodesc) call cam_pio_get_decomp(iodesc, ldims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, this%vardesc, iodesc, this%values, ierr, fillval=grid_fill_value) + call pio_write_darray(File, this%vardesc, iodesc, this%values, ierr) nullify(iodesc) ! CAM PIO system takes over memory management of iodesc #else !!XXgoldyXX: HACK to get around circular dependencies. Fix this!! piosys => shr_pio_getiosys(atm_id) call pio_initdecomp(piosys, pio_double, (/this%dimsize/), this%map, & iodesc) - call pio_write_darray(File, this%vardesc, iodesc, this%values, & - ierr, fillval=grid_fill_value) + call pio_write_darray(File, this%vardesc, iodesc, this%values, ierr) + call pio_syncfile(File) call pio_freedecomp(File, iodesc) ! Take care of bounds if they exist if (associated(this%bnds) .and. associated(this%bndsvdesc)) then call pio_initdecomp(piosys, pio_double, (/2, this%dimsize/), & this%map, iodesc) - call pio_write_darray(File, this%bndsvdesc, iodesc, this%bnds, & - ierr, fillval=grid_fill_value) + call pio_write_darray(File, this%bndsvdesc, iodesc, this%bnds, ierr) call pio_syncfile(File) call pio_freedecomp(File, iodesc) end if @@ -2147,7 +2146,7 @@ subroutine write_cam_grid_attr_0d_int(attr, File) call cam_pio_def_var(File, trim(attr%name), pio_int, attr%vardesc, & existOK=.false.) ierr= pio_put_att(File, attr%vardesc, '_FillValue', int(grid_fill_value)) - call cam_pio_handle_error(ierr, 'Error writing "_FillValue" attr in write_cam_grid_attr_0d_int') + call cam_pio_handle_error(ierr, 'Error writing "_FillValue" attr in write_cam_grid_attr_0d_int') ierr=pio_put_att(File, attr%vardesc, 'long_name', trim(attr%long_name)) call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_0d_int') else @@ -2240,7 +2239,7 @@ subroutine write_cam_grid_attr_1d_int(attr, File) call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), & attr%vardesc, existOK=.false.) ierr= pio_put_att(File, attr%vardesc, '_FillValue', int(grid_fill_value)) - call cam_pio_handle_error(ierr, 'Error writing "_FillValue" attr in write_cam_grid_attr_1d_int') + call cam_pio_handle_error(ierr, 'Error writing "_FillValue" attr in write_cam_grid_attr_1d_int') ierr = pio_put_att(File, attr%vardesc, 'long_name', trim(attr%long_name)) call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_cam_grid_attr_1d_int') end if @@ -2481,7 +2480,7 @@ subroutine write_cam_grid_val_1d_int(attr, File) ! This is a distributed variable, use pio_write_darray allocate(iodesc) call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_int) - call pio_write_darray(File, attr%vardesc, iodesc, attr%values, ierr, fillval=int(grid_fill_value)) + call pio_write_darray(File, attr%vardesc, iodesc, attr%values, ierr) call pio_freedecomp(File, iodesc) deallocate(iodesc) nullify(iodesc) @@ -2519,7 +2518,7 @@ subroutine write_cam_grid_val_1d_r8(attr, File) ! This is a distributed variable, use pio_write_darray allocate(iodesc) call cam_pio_newdecomp(iodesc, (/attr%dimsize/), attr%map, pio_double) - call pio_write_darray(File, attr%vardesc, iodesc, attr%values, ierr, fillval=grid_fill_value) + call pio_write_darray(File, attr%vardesc, iodesc, attr%values, ierr) call pio_freedecomp(File, iodesc) deallocate(iodesc) nullify(iodesc) @@ -3228,7 +3227,7 @@ subroutine cam_grid_write_darray_2d_int(this, File, adims, fdims, hbuf, varid) integer :: ierr call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=int(grid_fill_value)) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_int: Error writing variable') end subroutine cam_grid_write_darray_2d_int @@ -3255,7 +3254,7 @@ subroutine cam_grid_write_darray_3d_int(this, File, adims, fdims, hbuf, varid) integer :: ierr call cam_pio_get_decomp(iodesc, adims, fdims, PIO_INT, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=int(grid_fill_value)) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_int: Error writing variable') end subroutine cam_grid_write_darray_3d_int @@ -3282,7 +3281,7 @@ subroutine cam_grid_write_darray_2d_double(this, File, adims, fdims, hbuf, varid integer :: ierr call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=grid_fill_value) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_double: Error writing variable') end subroutine cam_grid_write_darray_2d_double @@ -3309,7 +3308,7 @@ subroutine cam_grid_write_darray_3d_double(this, File, adims, fdims, hbuf, varid integer :: ierr call cam_pio_get_decomp(iodesc, adims, fdims, PIO_DOUBLE, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=grid_fill_value) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_double: Error writing variable') end subroutine cam_grid_write_darray_3d_double @@ -3337,7 +3336,7 @@ subroutine cam_grid_write_darray_2d_real(this, File, adims, fdims, hbuf, varid) integer :: ierr call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=real(grid_fill_value)) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_2d_real: Error writing variable') end subroutine cam_grid_write_darray_2d_real @@ -3365,7 +3364,7 @@ subroutine cam_grid_write_darray_3d_real(this, File, adims, fdims, hbuf, varid) nullify(iodesc) call cam_pio_get_decomp(iodesc, adims, fdims, PIO_REAL, this%map) - call pio_write_darray(File, varid, iodesc, hbuf, ierr, fillval=real(grid_fill_value)) + call pio_write_darray(File, varid, iodesc, hbuf, ierr) call cam_pio_handle_error(ierr, 'cam_grid_write_darray_3d_real: Error writing variable') end subroutine cam_grid_write_darray_3d_real @@ -3987,7 +3986,7 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) end if end if vdesc => header_info%get_lon_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr, fillval=grid_fill_value) + call pio_write_darray(File, vdesc, iodesc, coord, ierr) call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing longitude') if (.not. associated(this%lonmap)) then deallocate(map) @@ -4020,7 +4019,7 @@ subroutine cam_grid_patch_write_vals(this, File, header_info) end if end if vdesc => header_info%get_lat_varid() - call pio_write_darray(File, vdesc, iodesc, coord, ierr, fillval=grid_fill_value) + call pio_write_darray(File, vdesc, iodesc, coord, ierr) call cam_pio_handle_error(ierr, 'cam_grid_patch_write_vals: Error writing latitude') if (.not. associated(this%latmap)) then deallocate(map) diff --git a/src/utils/orbit.F90 b/src/utils/orbit.F90 index bb110f578e..fcdf7632bf 100644 --- a/src/utils/orbit.F90 +++ b/src/utils/orbit.F90 @@ -2,7 +2,7 @@ module orbit contains -subroutine zenith(calday ,clat , clon ,coszrs ,ncol, dt_avg ) +subroutine zenith(calday ,clat , clon ,coszrs ,ncol, dt_avg, rad_call) !+tht !----------------------------------------------------------------------- ! ! Purpose: @@ -20,7 +20,7 @@ subroutine zenith(calday ,clat , clon ,coszrs ,ncol, dt_avg ) use shr_orb_mod use cam_control_mod, only: lambm0, obliqr, eccen, mvelpp implicit none - + !------------------------------Arguments-------------------------------- ! ! Input arguments @@ -30,6 +30,7 @@ subroutine zenith(calday ,clat , clon ,coszrs ,ncol, dt_avg ) real(r8), intent(in) :: clat(ncol) ! Current centered latitude (radians) real(r8), intent(in) :: clon(ncol) ! Centered longitude (radians) real(r8), intent(in), optional :: dt_avg ! if present, time step to use for the shr_orb_cosz calculation + logical, intent(in), optional :: rad_call !+tht is this a radiation call? ! ! Output arguments ! @@ -48,9 +49,15 @@ subroutine zenith(calday ,clat , clon ,coszrs ,ncol, dt_avg ) ! ! Compute local cosine solar zenith angle, ! - do i=1,ncol + if (present(rad_call)) then !+tht pass rad_call arg + do i=1,ncol + coszrs(i) = shr_orb_cosz( calday, clat(i), clon(i), delta, dt_avg , rad_call) + end do + else + do i=1,ncol coszrs(i) = shr_orb_cosz( calday, clat(i), clon(i), delta, dt_avg ) - end do + end do + endif end subroutine zenith end module orbit diff --git a/test/system/TBL.sh b/test/system/TBL.sh index 18df93012b..526eb24205 100755 --- a/test/system/TBL.sh +++ b/test/system/TBL.sh @@ -63,33 +63,13 @@ if [ -n "${BL_ROOT}" ]; then echo "TBL.sh: calling ****baseline**** TSM.sh for smoke test" if [ "${CAM_BASEBACK}" = "YES" ]; then - if [ -d "${BL_ROOT}/components/cam" ]; then - - env CAM_TESTDIR=${BL_TESTDIR} \ + env CAM_TESTDIR=${BL_TESTDIR} \ CAM_SCRIPTDIR=${BL_ROOT}/components/cam/test/system \ ${BL_ROOT}/components/cam/test/system/TSM.sh $1 $2 $3 - - else - - env CAM_TESTDIR=${BL_TESTDIR} \ - CAM_SCRIPTDIR=${BL_ROOT}/test/system \ - ${BL_ROOT}/test/system/TSM.sh $1 $2 $3 - - fi else - if [ -d "${BL_ROOT}/components/cam" ]; then - - env CAM_TESTDIR=${BL_TESTDIR} \ + env CAM_TESTDIR=${BL_TESTDIR} \ CAM_SCRIPTDIR=${BL_ROOT}/components/cam/test/system \ ${BL_ROOT}/components/cam/test/system/TSM.sh $1 $2 $3 $4 - - else - - env CAM_TESTDIR=${BL_TESTDIR} \ - CAM_SCRIPTDIR=${BL_ROOT}/test/system \ - ${BL_ROOT}/test/system/TSM.sh $1 $2 $3 $4 - - fi fi rc=$? if [ $rc -ne 0 ]; then diff --git a/test/system/TBL_ccsm.sh b/test/system/TBL_ccsm.sh index fa6ae824dc..48b3ddc812 100755 --- a/test/system/TBL_ccsm.sh +++ b/test/system/TBL_ccsm.sh @@ -63,37 +63,15 @@ if [ -n "${BL_ROOT}" ]; then echo "TBL_ccsm.sh: calling ****baseline**** TSM_ccsm.sh for smoke test" if [ "${CAM_BASEBACK}" = "YES" ]; then - if [ -d "${BL_ROOT}/components/cam" ]; then - - env CAM_TESTDIR=${BL_TESTDIR} \ + env CAM_TESTDIR=${BL_TESTDIR} \ CAM_SCRIPTDIR=${BL_ROOT}/components/cam/test/system \ CAM_ROOT=${BL_ROOT} \ ${BL_ROOT}/components/cam/test/system/TSM_ccsm.sh $1 $2 $3 - - else - - env CAM_TESTDIR=${BL_TESTDIR} \ - CAM_SCRIPTDIR=${BL_ROOT}/test/system \ - CAM_ROOT=${BL_ROOT} \ - ${BL_ROOT}/test/system/TSM_ccsm.sh $1 $2 $3 - - fi else - if [ -d "${BL_ROOT}/components/cam" ]; then - - env CAM_TESTDIR=${BL_TESTDIR} \ + env CAM_TESTDIR=${BL_TESTDIR} \ CAM_SCRIPTDIR=${BL_ROOT}/components/cam/test/system \ CAM_ROOT=${BL_ROOT} \ ${BL_ROOT}/components/cam/test/system/TSM_ccsm.sh $1 $2 $3 $4 - - else - - env CAM_TESTDIR=${BL_TESTDIR} \ - CAM_SCRIPTDIR=${BL_ROOT}/test/system \ - CAM_ROOT=${BL_ROOT} \ - ${BL_ROOT}/test/system/TSM_ccsm.sh $1 $2 $3 $4 - - fi fi rc=$? if [ $rc -ne 0 ]; then diff --git a/test/system/TPF.sh b/test/system/TPF.sh index 982dc9432f..9347f1fae5 100755 --- a/test/system/TPF.sh +++ b/test/system/TPF.sh @@ -62,19 +62,9 @@ if [ -n "${BL_ROOT}" ]; then echo "TPF.sh: generating baseline data from root $BL_ROOT - results in $BL_TESTDIR" echo "TPF.sh: calling ****baseline**** TSM.sh for smoke test" - if [ -d "${BL_ROOT}/components/cam" ]; then - - env CAM_TESTDIR=${BL_TESTDIR} \ + env CAM_TESTDIR=${BL_TESTDIR} \ CAM_SCRIPTDIR=${BL_ROOT}/components/cam/test/system \ ${BL_ROOT}/components/cam/test/system/TSM.sh $1 $2 $3 $4 - - else - - env CAM_TESTDIR=${BL_TESTDIR} \ - CAM_SCRIPTDIR=${BL_ROOT}/test/system \ - ${BL_ROOT}/test/system/TSM.sh $1 $2 $3 $4 - - fi rc=$? if [ $rc -ne 0 ]; then echo "TPF.sh: error from *baseline* TSM.sh= $rc" diff --git a/test/system/TR8.sh b/test/system/TR8.sh index f90f300144..bfaea12241 100755 --- a/test/system/TR8.sh +++ b/test/system/TR8.sh @@ -4,8 +4,6 @@ # Check physics -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/cam rc=$? ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/camrt @@ -19,52 +17,15 @@ rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/waccmx rc=`expr $? + $rc` -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/cam -rc=$? -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/camrt -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/rrtmg -s aer_src -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/simple -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/waccm -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/waccmx -rc=`expr $? + $rc` - -fi - #Check Ionosphere -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/ionosphere rc=`expr $? + $rc` -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/ionosphere -rc=`expr $? + $rc` - -fi - #Check Chemistry -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/chemistry rc=`expr $? + $rc` -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/chemistry -rc=`expr $? + $rc` - -fi - #Check Dynamics -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/se rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/fv @@ -72,20 +33,7 @@ rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/dynamics/eul rc=`expr $? + $rc` -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/se -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/fv -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/dynamics/eul -rc=`expr $? + $rc` - -fi - #Check other -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/advection rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/control @@ -93,39 +41,16 @@ rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/utils rc=`expr $? + $rc` -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/advection -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/control -rc=`expr $? + $rc` -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/utils -rc=`expr $? + $rc` - -fi - #Check coupler -if [ -d "${CAM_ROOT}/components/cam" ]; then - ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/cpl rc=`expr $? + $rc` - - -else - -ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/cpl -rc=`expr $? + $rc` - -fi - echo $rc if [ $rc = 255 ]; then rc=1 fi - - echo $rc + exit $rc diff --git a/test/system/input_tests_master b/test/system/input_tests_master index 84134f6498..fa269880e9 100644 --- a/test/system/input_tests_master +++ b/test/system/input_tests_master @@ -1,7 +1,6 @@ r8001 TR8.sh -gt001 TGIT.sh fm001 TFM.sh sm010 TSM.sh f4c5portdh outfrq24h_port 2d diff --git a/test/system/test_driver.sh b/test/system/test_driver.sh index cb4932906b..d198a9ecd1 100755 --- a/test/system/test_driver.sh +++ b/test/system/test_driver.sh @@ -549,24 +549,16 @@ fi ##establish script dir and cam_root if [ -f \${initdir}/test_driver.sh ]; then export CAM_SCRIPTDIR=\`cd \${initdir}; pwd \` - if [ -d "\${CAM_SCRIPTDIR}/../../components" ]; then - export CAM_ROOT=\`cd \${CAM_SCRIPTDIR}/../.. ; pwd \` - else - export CAM_ROOT=\`cd \${CAM_SCRIPTDIR}/../../../.. ; pwd \` - fi + export CAM_ROOT=\`cd \${CAM_SCRIPTDIR}/../../../.. ; pwd \` else if [ -n "\${CAM_ROOT}" ] && [ -f \${CAM_ROOT}/components/cam/test/system/test_driver.sh ]; then export CAM_SCRIPTDIR=\`cd \${CAM_ROOT}/components/cam/test/system; pwd \` else - if [ -n "\${CAM_ROOT}" -a -f "\${CAM_ROOT}/test/system/test_driver.sh" ]; then - export CAM_SCRIPTDIR=\`cd \${CAM_ROOT}/test/system; pwd \` - else - echo "ERROR: unable to determine script directory " - echo " if initiating batch job from directory other than the one containing test_driver.sh, " - echo " you must set the environment variable CAM_ROOT to the full path of directory containing " - echo " . " - exit 3 - fi + echo "ERROR: unable to determine script directory " + echo " if initiating batch job from directory other than the one containing test_driver.sh, " + echo " you must set the environment variable CAM_ROOT to the full path of directory containing " + echo " . " + exit 3 fi fi @@ -864,13 +856,7 @@ if [ "${cesm_test_suite}" != "none" -a -n "${cesm_test_mach}" ]; then currdir="`pwd -P`" logfile="${currdir}/${test_id}.log" tdir="$( cd $( dirname $0 ); pwd -P )" - trial_dir="$( dirname $( dirname $( dirname $( dirname ${tdir} ) ) ) )" - if [ -d "${trial_dir}/cime/scripts" ]; then - root_dir=$trial_dir - else - root_dir="$( dirname $( dirname ${tdir} ) )" - fi - + root_dir="$( dirname $( dirname $( dirname $( dirname ${tdir} ) ) ) )" script_dir="${root_dir}/cime/scripts" if [ ! -d "${script_dir}" ]; then echo "ERROR: CIME scripts dir not found at ${script_dir}" diff --git a/test/system/tests_pretag_hobart_nag b/test/system/tests_pretag_hobart_nag index 75e2e340a7..c02c6d5fba 100644 --- a/test/system/tests_pretag_hobart_nag +++ b/test/system/tests_pretag_hobart_nag @@ -1,4 +1,4 @@ -gt001 +fm001 sm111 er111 br111 bl111 mc111 dd111 sm113 er113 bl113 sm221 er221 bl221 diff --git a/tools/AeroTab/AeroTab.f b/tools/AeroTab/AeroTab.f new file mode 100644 index 0000000000..d04c0d65a0 --- /dev/null +++ b/tools/AeroTab/AeroTab.f @@ -0,0 +1,637 @@ + + program AeroTab ! Program for making Aerosol look-up tables for CAM5-Oslo + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. The code is originally based on the method developed +c and described by KirkevÃ¥g, A., Iversen, T., and Dahlback, A. (1999): On radiative +c effects of black carbon and sulphate aerosols. Atmos. Environ. 33, 2621-2635. +c ********************************************************************************** + +c This program defines initial size distributions (at the point of emission) +c and microphysical properties, such as hygroscopicity and wevelength dependent +c refractive indices, then calculates the modified aerosol size distributions +c (after aerosol processing), and finally it performs Mie and CCN or dry size +c parameter calculations for the clean or internally mixed aerosol modes as a +c function of relative humidity (or supersaturation for CCN) and added internally +c mixed BC, OC and sulfate. The output is a range of look-up tables (*.out) for +c use in CAM5-Oslo (with only some CAM-Oslo/CAM4-Oslo functionality retained). +c +c References for CAM-Oslo (based on CAM3): +c KirkevÃ¥g, A., Iversen, T., Seland, Ø., Debernard, J.B., Storelvmo, T., and +c Kristjánsson, J.E. (2008) Aerosol-cloud-climate interactions in the climate +c model CAM-Oslo. Tellus, 60A, 492-512. +c Seland, Ø., T. Iversen, A. KirkevÃ¥g, and T. Storelvmo (2008) Aerosol-climate +c interactions in the CAM-Oslo atmospheric GCM and investigations of associated +c shortcomings. Tellus, 60A, 459-491. +c Reference for CAM4-Oslo (based on CAM4): +c KirkevÃ¥g, A., T. Iversen, Ø. Seland, C. Hoose, J. E. Kristjánsson, H. Struthers, +c A. Ekman, S. Ghan, J. Griesfeller, D. Nilsson, and M. Schulz: Aerosol-climate +c interactions in the Norwegian Earth System Model - NorESM1-M, Geosci. Model Dev., +c 6, 207-244, doi:10.5194/gmd-6-207-2013, 2013. +c CAM5-Oslo is at present under development. Reference for nucleation and simplest +c SOA treatment (assuming SOA->SO4): Makkonen, R., Seland, Ø., KirkevÃ¥g, A., Iversen, +c T., and Kristjánsson, J. E.: Evaluation of aerosol number concentrations in NorESM +c with improved nucleation parameterisation, Atmos. Chem. Phys. 14, 5127-5152, +c doi:10.5194/acp-14-5127-2014, 2014. + +C =================================================================================== +C Notes on past and present code development: +C Since the CAM4-Oslo look-up tables were made, some parts of the code have been +C slightly modified: The diffusion coefficient and mean free path for sulfuric acid +C (H2SO4) have been updated, see constize.f. Therefore, do not expect to reproduce +C the old look-up tables exactly as they were (small changes). +C +C One inconsistency compared with the CAM4-Oslo life cycle model description in +C KirkevÃ¥g et al. (2013), is that the OC(n) mode (kcomp=3 without condensed SO4), +C is still used when excessive OM mass (exceeding the max table values defined in +C modepar.f) is lumped in the model. Should we remove this mode and rather lump +C mass to a clean OM&BC(Ait) mode (kcomp=4 without condensed SO4)? (See below). +c +c April 2013: +C Due to new SOA treatment, the OC(n) mode may be needed anyway. Possible changes +C to accomodate this may be: add condensed SOA to BC(n/Ait), OC(n/Ait), and (as +C proposed by R. Makkonen) SO4(n/Ait). So far only the SO4(n/Ait) mode has been +C included in this code. +c +C A possible simplification to think about for CAM5-Oslo: +C let DU(c) and SS(c) be externally mixed only. +C Additional functionality: +C Consider to include for ib=31: abs550 for each component (in aerocomk*.out)! +c +C August 2014: Removing dependencies on molar weights (Ms, Msv and Mso4) to +C facilitate corresponding simplifications in CAM5-Oslo. +c +C April 2015: remove modes (kcomp=) 11,12,14, and rename mode 13 to 0. Also: +C r12 is renamed rbcn. +c +c July 2015: +c Including new SOA treatment, allowing for condensation of VOC/SOA onto all +c background modes kcomp= 1 - 10, but treated as OM coagulate for modes 5-10 +c (the same way that H2SO4 condensate is treated as coagulate for these modes). +c We still keep kcomp=3, since it may be used in parts of the code (for lumping +c of overshooting mass w.r.t. upper ceiling in the look-up tables), and since +c there is still no need for a new mode to fill its "place". +c New treatment for kcomp=1 & 4: fombg and fbcbg are now mass fractions of OM +c or BC in the background aerosol (not radius dependent), instead of using the +c trick for kcomp=4 of redifining fac. fac has now the same meaning for all modes. +c +c May 2016: +c Recalibrate cate and cate (in modepar.f) to allow for more/less maximum added +c mass on each background mode, due to large changes since the first AeroTab +c version, since there is now in general more added mass per background particle. +c The cat and cate arrays have also been changed so that their values (for varying +c icat and icate) can be calculated based on the min and max array values... +c Look-up tables for CCN have not been used or needed since CCM-Oslo/early CAM-Oslo, +c and is now removed as an option (since it has not been checked for bugs and +c inconsistencies). +c +c October 2016: +c BC sizes for kcomp = 0 and 2 have been modified, as has also the mass density +c and refractive index for dust, see the gihub issues NE-274 (Short literature +c study on size parameters for emitted and coagulated BC) and NE-344 (Conservation +c of both mass and number of hydrophobic to hydrophilic BC_AX), NE-388 (See if +c the BC mass absorption coefficient (MAC) can be increased/improved), and the +c background document for NE-274, covering also the two other mentioned issues. +c A bug was also found and corrected in conteq.f, which since SOA has been +c introduced has caused an underestimae in the condensated mass of SOA (ca. 18% +c loss column integrated, globally). +c +c Future improvement: Since the calculation of size distributions takes very long +c time for some modes, both LW and SW optics (a big job) and lognormal fitting for +c RH=0 (easier to fix) should be done at the same time, as soon as the modified +c size distributions are made, instead of running AeroTab 3 times as is equired +c in its present form. +c +C =================================================================================== + + implicit none + +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + INTEGER kcom, iband + INTEGER i, imax, imini, imaxi, is, icl, ib, ibcam, ictot, kcomp, + $ kc, ksol, itot, ifbc, ifac, ifaq, irelh, iopt, ismolar, + $ ismolarh, irh, itilp, ifombg, ifbcbg + INTEGER irelh1, irelh2, ictot1, ictot2, ifac1, + $ ifac2, ifbc1, ifbc2, ifaq1, ifaq2, ictote, ictote1, ictote2, + $ ifombg1, ifombg2, ifbcbg1, ifbcbg2 + REAL r(0:100), rp(0:100), fki(-1:100), fracdim(0:100), + $ dndlrk0(0:100), dndlrk(0:100), dndlrkny(0:100), + $ vbci(0:100), voci(0:100), vsi(0:100), vai(0:100), vssol(0:100), + $ vbcsol(0:100), vocsol(0:100), vasol(0:100), vw(0:100) + REAL rk, r0, rbcn, rcoag, d, ntot, Nnatk, Nnat, fcondk, + $ fcoagk, faqk, logsk, logs0, + $ rhos, rhosv, rhoc2, rhobc, rhooc, rhob, rhow, th, mfv, diff, + $ Cac, Cabc, Caoc, Cas1, Cas2, Cas3, Caso4, Ctot, Cdry, dCtot, cat, + $ fac, fabc, faq, rh, numb, bcint, cintbg, + $ cintsu, cintsc, cintsa, cintbc, cintoc, cintbg05, cintsu05, + $ cintsc05, cintsa05, cintbc05, cintoc05, cintbg125, cintsu125, + $ cintsc125, cintsa125, cintbc125, cintoc125, aaero, aaeros, + $ aaerol, vaero, vaeros, vaerol, bclt05, bcgt125, lambda, alpha, + $ fombg, vombg, fbcbg, vbcbg, eps + REAL frombg(6), frbcbg(6) + REAL catote(16), catot(6), frac(6), frabc(6), fraq(6), relh(10) + REAL omega(31), gass(31), bext(31), babs(31), kext(31) + REAL xlam(31), xlami(32), xlamb(31), xlame(31), + $ fband(31), fb(16) + REAL Ctot0, Dm(0:100), Dmp(0:100), K12(0:101), Kp12(0:101), + $ K12oc(0:101), Kp12oc(0:101), K12so4(0:101), Kp12so4(0:101), + $ Ctotnull + REAL rcoag_so4n, rcoag_bcn, rcoag_ocn + REAL xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss + REAL diffsoa, thsoa, mfvsoa, Dmsoa(0:100), Dmpsoa(0:100) + REAL pi, e, testnumb + COMPLEX cref(5,31) + PARAMETER (pi=3.141592654, e=2.718281828) + PARAMETER (eps=1.e-50) + +c Assumed radius for coagulating (fine mode) particles in um +c (a common coagulation radius rcoag=0.04 um was used originally) +co PARAMETER (rcoag_so4n = 0.0118) ! rk for kcomp=1 +co PARAMETER (rcoag_bcn = 0.0118) ! rk for kcomp=2 +co PARAMETER (rcoag_ocn = 0.04) ! rk for kcomp=3 + PARAMETER (rcoag_so4n = 0.025) ! rk for kcomp=1 + PARAMETER (rcoag_bcn = 0.025) ! rk for kcomp=2 + PARAMETER (rcoag_ocn = 0.06) ! rk for kcomp=3 + +c Do not modify the following input: +c number of iterations in the Smolarkiewicz advection scheme, ismolar, and +c a different ismolarh for hygroscopic growth than for dry distributions: + PARAMETER (ismolar=2, ismolarh=3) +c no aportioning between modes (i.e., all material is added onto the same mode): +c (this is relevant to modify only when this code is part of a larger multimodal +c scheme, i.e. for distribution of internally mixed mass onto more than one mode +c at the time). + PARAMETER (Nnatk=1.0, fcondk=1.0, fcoagk=1.0, faqk=1.0) + +c Modify the following input to create different sets of look-up tables: +c Let iopt=1 for optics tables (CCN look-up tables for CAM-Oslo with diagnostic +c CDNC is no longer available), or iopt=0 for size distribution calculations +c (used in CCN activation in CAM4-Oslo and CAM5-Oslo with prognostic CDNC): + iopt=1 +c Lognormal mode fitting (itilp=1, iopt=0) --> logntilp*.out (and nkcomp.out +c for dry, modified size distributions). + itilp=1-iopt +c Outout for iopt=1 --> lwkcomp*.out or kcomp*.out, aerodryk*.out, +c aerocomk*.out, and nkcomp*.out (for size distributions for all RH). +c SW: ib=29 (ave.=>12) SW "bands" (CAMRT), or +c SW: ib=31 (ave.=>14) (RRTMG) (Added November 2013), or +c LW: ib=19 (ave.=>16) (RRTMG) (Added November 2013): + ib=31 + +C Initialization and calculations of look-up tables starts here... + + if(ib.eq.29) then + write(*,*) + $ 'Note: for aerocomk*.out, aerodryk*.out or SW RRTMG, use ib=31' + endif + +c Define spectral bands and spectral solar fluxes (at TOA) to be used +c in Chandrasekhar averaging of the optical parameters (in sizemie) + call specbands(ib, xlami, xlam, xlamb, xlame, fband, fb, ibcam) + +c Define constants and parameters for calculations of size distributions +c (Move some of this to modepar.f!) + call constsize(d, imax, imaxi, r, rp, r0, rbcn, logs0, + $ rhobc, rhooc, rhos, rhosv, rhoc2, rhow, + $ bcint, fracdim, diff, th, mfv, diffsoa, thsoa, mfvsoa) + +c The main loop over aerosol mode number for background modes, kcomp=1,10, +c plus kcomp=0, for the fractal BC(ac) mode (use itot=0). For this mode no +c lognormal mode fitting is needed (it is assumed to be hydrophobic and +c therefore not giving any CCN or CDNC contribution). + + do kcomp=0,10 ! for look-up tables, kcomp=0,10 (only kcomp=1-10 needed for logntilp*.out) + + if(kcomp.eq.0) then + itot = 0 ! not subject to added mass by condensation etc. + else + itot = 1 ! subject to added mass by condensation etc. + endif + +c Set parameters for prescribed initial dry lognormal size +c distributions, and grid for tabulated optical parameters (or CCN) +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + call modepar(kcomp, ksol, imini, Nnat, rk, logsk, rhosv, rhob, + $ frombg,frbcbg,catot, catote, relh, frac, frabc, fraq, alpha) + +c drydist calculates dry background mode size distribution, dndlrk0, +c and dry aerosol contribution to mass concentration, Ctot0 (ug/m^3). + call drydist(kcomp, Nnat, imini, imax, d, r, rk, + $ logsk, logs0, rhob, bcint, pi, dndlrk0, ntot, Ctot0) + + Ctotnull=Ctot0 + +c Diffusion and coagulation coeffecients for the respective background +c mode are then calculated. We here assume that all n/Aitken-modes that +c coagulate on a mineral or sea-salt background all are monodisperse. +c +c Diffusion coefficients Dm for H2SO4 + call condsub (r, imax, diff, mfv, th, alpha, Dm) + call condsub (rp, imax, diff, mfv, th, alpha, Dmp) +c Diffusion coefficients Dm for SOA + call condsub (r, imax, diffsoa, mfvsoa, thsoa, alpha, Dmsoa) + call condsub (rp, imax, diffsoa, mfvsoa, thsoa, alpha, Dmpsoa) +c Coagulation coefficients K12 for H2SO4 + call coagsub (r, imax, rcoag_so4n, rhob, rhosv, K12so4) + call coagsub (rp, imax, rcoag_so4n, rhob, rhosv, Kp12so4) +c Coagulation coefficients K12 for BC + call coagsub (r, imax, rcoag_bcn, rhob, rhobc, K12) + call coagsub (rp, imax, rcoag_bcn, rhob, rhobc, Kp12) +c Coagulation coefficients K12 for OC + call coagsub (r, imax, rcoag_ocn, rhob, rhooc, K12oc) + call coagsub (rp, imax, rcoag_ocn, rhob, rhooc, Kp12oc) + +c Wavelength dependent complex rafractive indices (cref) +c are found from tabulated values for each aerosol component. + call tabrefind (kcomp, ib, xlam, cref) + +c Aerosol hygroscopicities for max rh in the look-up tables (LUT), +c for use as info in the header of each LUT: + rh=relh(10) + call hygro (rh, xbc, xdst, xoc, xs, xa, xss, + $ rhda, rhca, rhdss, rhcss) + +c Open output files for use in CAM-Oslo + call openfiles(kcomp,iopt,ib) + +c Adding header info for all look-up tables for each kcomp (only kcomp*.out yet): + call tableinfo (kcomp, xbc, xdst, xoc, xs, xa, xss, relh, + $ frombg, frbcbg, catote, catot, frac, frabc, fraq, ib, ibcam, + $ itilp) + + +c Editable input values ! Full range for look-up tables + irelh1 = 1 ! 1 - 10 Note: + irelh2 = 10 ! 1 - 10 no loop if iopt=0 + + ifombg1 = 1 ! 1 - 6 Note: + ifombg2 = 6 ! 1 - 6 loop only for kcomp=1 + + ifbcbg1 = 1 ! 1 - 6 Note: + ifbcbg2 = 6 ! 1 - 6 loop only for kcomp=4 + + ictot1 = 1 ! 1 - 6 Note: loop over + ictot2 = 6 ! 1 - 6 ictot OR ictote + + ictote1 = 1 ! 1 - 16 Note: loop over ictot + ictote2 = 16 ! 1 - 16 OR ictote, not both + + ifac1 = 1 ! 1 - 6 Note: + ifac2 = 6 ! 1 - 6 no loop if kcomp=0 + + ifbc1 = 1 ! 1 - 6 Note: + ifbc2 = 6 ! 1 - 6 no loop if kcomp=0-4 + + ifaq1 = 1 ! 1 - 6 Note: + ifaq2 = 6 ! 1 - 6 no loop if kcomp=0-3 + +c Do not edit the following input values!!! + if(iopt.eq.0) then ! no RH loop + irelh1 = 1 + irelh2 = 1 + endif + if(kcomp.ne.1.or.itilp.eq.1) then ! no OM (as SOA) internally mixed in the background + ifombg1 = 1 + ifombg2 = 1 + endif + if(kcomp.ne.4) then ! no BC internally mixed in the background + ifbcbg1 = 1 + ifbcbg2 = 1 + endif + if(kcomp.eq.0) then + ifac1 = 1 + ifac2 = 1 + ifbc1 = 1 + ifbc2 = 1 + ifaq1 = 1 + ifaq2 = 1 + ictote1= 1 + ictote2= 1 + ictot1 = 1 + ictot2 = 1 + elseif(kcomp.ge.1.and.kcomp.le.3) then + ifbc1 = 1 + ifbc2 = 1 + ifaq1 = 1 + ifaq2 = 1 + ictot1 = 1 + ictot2 = 1 + elseif(kcomp.eq.4) then ! background is OC and BC, and all added carbonaceous + ifbc1 = 1 ! comes as SOA (fac=SOA/(SOA+Sulfate) added). + ifbc2 = 1 ! BC and OC is homogeneously mixed (wrt. r) in the + ictot1 = 1 ! background. Added SO4 and SOA are distributed + ictot2 = 1 ! according to D'(r) or r>rc (for sulfate), however. + else + ictote1= 1 + ictote2= 1 + endif ! kcomp + if(itilp.eq.1) then ! no fombg or fbcbg dependency for itilp=1 + ifombg1 = 1 + ifombg2 = 1 + ifbcbg1 = 1 + ifbcbg2 = 1 + endif + + + do 540 irelh = irelh1, irelh2 +c do 540 irelh = 1,1 + +c relative humidity: + rh=relh(irelh) + if(iopt.eq.0) then + rh=0.05 + endif +cX extra test loop for hygroscopic growth plots (with e.g. irelh=1,1 in the loop above) +c do 540 irh=1,99,2 +c rh=0.01*real(irh) +c or +c do 540 irh=1,199 +c rh=0.005*real(irh) +cX + +c Aerosol hygroscopicities (RH dependent) +c and points of deliquescence & crystallisation + call hygro (rh, xbc, xdst, xoc, xs, xa, xss, + $ rhda, rhca, rhdss, rhcss) + + do 540 ifombg = ifombg1, ifombg2 +c do 540 ifombg = 1,1 + + do 540 ifbcbg = ifbcbg1, ifbcbg2 +c do 540 ifbcbg = 6,6 + + do 540 ictot = ictot1, ictot2 + do 540 ictote = ictote1, ictote2 +c do 540 ictot = 6,6 +c do 540 ictote = 16,16 + + do 540 ifac = ifac1, ifac2 +c do 540 ifac = 6,6 + + do 540 ifbc = ifbc1, ifbc2 +c do 540 ifbc = 1,1 + + do 540 ifaq = ifaq1, ifaq2 +c do 540 ifaq = 1,1 + + if(kcomp.eq.1) then + write(*,*) 'kcomp,irelh,ifombg,ictote,ifac=', + $ kcomp,irelh,ifombg,ictote,ifac + write(999,*) 'kcomp,irelh,ifombg,ictote,ifac=', + $ kcomp,irelh,ifombg,ictote,ifac + elseif(kcomp.ge.1.and.kcomp.le.3) then + write(*,*) 'kcomp,irelh,ictote,ifac=',kcomp,irelh,ictote,ifac + write(999,*) 'kcomp,irelh,ictote,ifac=',kcomp,irelh,ictote,ifac + elseif(kcomp.eq.4) then + write(*,*) 'kcomp,irelh,ifbcbg,ictote,ifac,ifaq=', + $ kcomp,irelh,ifbcbg,ictote,ifac,ifaq + write(999,*) 'kcomp,irelh,ifbcbg,ictote,ifac,ifaq=', + $ kcomp,irelh,ifbcbg,ictote,ifac,ifaq + else + write(*,*) 'kcomp,irelh,ictot,ifac,ifbc,ifaq=', + $ kcomp,irelh,ictot,ifac,ifbc,ifaq + write(999,*) 'kcomp,irelh,ictot,ifac,ifbc,ifaq=', + $ kcomp,irelh,ictot,ifac,ifbc,ifaq + endif + +cX extra test loop for hygroscopic growth (with e.g., irelh=1,1 in the loop above) +c do 540 irh=1,99 +c rh=0.01*real(irh) +c do 540 irh=1,199 +c rh=0.005*real(irh) +cX + +c Basic input parameters to the table calculations: + +c concentrations (ug/m^3, per background particle/cm^3) of internally mixed +c SO4, BC and OC. Cas1, Cas2, Cas3 and Caso4 is internally mixed SO4 from +c condensation (H2SO4), coagulation (H2SO4), cloud processing ((NH4)2SO4) +c and all of the above, respectively. Cabc and Caoc is all internally mixed +c BC and OC (from coagulation), respectively. + Cas1=1.e-40 + Cas2=1.e-40 + Cas3=1.e-40 + Cabc=1.e-40 + Caoc=1.e-40 + if(kcomp.ge.1.and.kcomp.le.4) then + Cac=frac(ifac)*catote(ictote) ! added Carbonaceous from condensation (SOA) + else + Cac=frac(ifac)*catot(ictot) ! added Carbonaceous from condensation (SOA) and coagulation + endif + Cabc=frabc(ifbc)*Cac ! added BC from coagulation + if(Cabc.lt.1.e-40) Cabc=1.e-40 + Caoc=(1.0-frabc(ifbc))*Cac ! added OC from condensation and coagulation + if(Caoc.lt.1.e-40) Caoc=1.e-40 + if(kcomp.ge.1.and.kcomp.le.4) then + Caso4=(1.0-frac(ifac))*catote(ictote) ! added Sulfate from condensation (H2SO4) + else + Caso4=(1.0-frac(ifac))*catot(ictot) ! added Sulfate from condensation and coagulation (H2SO4) and wet phase ((NH4)2SO4) + endif + if(Caso4.lt.1.e-40) Caso4=1.e-40 + if(kcomp.ge.1.and.kcomp.le.4) then + Cas1=(1.0-fraq(ifaq))*Caso4 ! added Sulfate from condensation (H2SO4) + Cas2=1.e-40 ! lump coagulation with condensation for these modes + else + Cas1=1.e-40 ! lump condensation with coagulation for these modes + Cas2=(1.0-fraq(ifaq))*Caso4 ! added Sulfate from coagulation (H2SO4) + endif + Cas3=fraq(ifaq)*Caso4 ! added Sulfate from wet phase production ((NH4)2SO4) + if(Cas1.lt.1.e-40) Cas1=1.e-40 + if(Cas2.lt.1.e-40) Cas2=1.e-40 + if(Cas3.lt.1.e-40) Cas3=1.e-40 + + Caso4=Cas1+Cas2+Cas3 + faq=fraq(ifaq) ! wet-phase mass fraction of added sulfate (H2SO4 or (NH4)2SO4) + fac=frac(ifac) ! Carbonaceous mass fraction of total added mass + fabc=frabc(ifbc) ! BC mass fraction of added Carbonaceous mass + fombg=frombg(ifombg) +c fombg is the OM (as SOA) mass fraction in the background SO4&SOA(Ait) mode. +c The respective volume fraction of OM in background is then: + vombg=1.0/(1.0+(1.0-fombg)/(fombg*rhosv/rhooc+eps)) + fbcbg=frbcbg(ifbcbg) +c fbcbg is the BC mass fraction in the background OC&BC(Ait) mode. +c The respective volume fraction of BC in background is then: + vbcbg=1.0/(1.0+(1.0-fbcbg)/(fbcbg*rhooc/rhobc+eps)) + + if(kcomp.ge.1.and.kcomp.le.10) then +c contribution to Ctot from the background mode + if(kcomp.eq.1) then + Ctot0=Ctotnull*(1.0+vombg*(rhooc/rhob-1.0)) ! -> Ctotnull*0.815 for ren OM (vombg=fombg=1). + elseif(kcomp.eq.4) then + Ctot0=Ctotnull*(1.0+vbcbg*(rhobc/rhob-1.0)) ! -> Ctotnull*1.2 for ren BC (vbcbg=fbcbg=1). + endif +c write(*,*) 'Ctotnull =', Ctot0 + write(999,*) 'background contribution:' + write(999,*) Ctot0 +c contribution to Ctot from internally mixed (non-background) H2SO4 and (NH4)2SO4 +c (note: only H2SO4 for kcomp=1 since ifaq=1 there) + dCtot=Caso4 + Ctot=Ctot0+dCtot + write(999,*) 'sulfate contribution (a, tot):' + write(999,*) dCtot, Ctot +c contribution to Ctot from internally mixed (non-background) BC + dCtot=Cabc + Ctot=Ctot+dCtot + write(999,*) 'bc contribution (a, tot):' + write(999,*) dCtot, Ctot +c contribution to Ctot from internally mixed (non-background) OC + dCtot=Caoc + Ctot=Ctot+dCtot + write(999,*) 'oc contribution (a, tot):' + write(999,*) dCtot, Ctot + else + Ctot=Ctot0 + endif + write(*,*) 'dry Ctot =', Ctot + + if(kcomp.ge.1.and.kcomp.le.4) then + cat=catote(ictote) + else + cat=catot(ictot) + endif + +c Calculate modified dry size distributions for process specific +c SO4 and BC (and OC) internally mixed with the background aerosol +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + call conteq (r, rp, rbcn, d, itot, imax, ictot, ictote, ifaq, + $ imini, rhos, rhobc, rhooc, rhob, rhosv, rhoc2, + $ Nnatk, fcondk, fcoagk, faqk, Cas1, Cas2, Cas3, Cabc, Caoc, Ctot0, + $ dndlrk0, dndlrkny, ntot, Dmsoa, Dmpsoa, Dm, Dmp, K12, Kp12, + $ K12oc, Kp12oc, K12so4, Kp12so4, ismolar, vbci, voci, vsi, vai, + $ cintbg, cintsc, cintsa, cintbc, cintoc, cintbg05, cintsc05, + $ cintsa05, cintbc05, cintoc05, cintbg125, cintsc125, cintsa125, + $ cintbc125, cintoc125, aaero, aaeros, vaero, vaeros, fracdim, + $ kcomp, vombg, vbcbg, fac) + +c Hygroscopic growth is taken into account in subroutine rhsub, +c for the given relative humidity (if itilp=0, i.e. iopt=1) + Cdry=Ctot + if(ksol.eq.1.and.itilp.eq.0) then + call rhsub (imax, rh, d, r, rp, dndlrkny, vsi, vbci, voci, + $ fombg, fbcbg, vombg, vbcbg, vssol, vbcsol, vocsol, vasol, + $ vw, fki, itot, rhos, rhosv, rhobc, rhooc, rhob, rhow, Ctot, + $ kcomp, ismolarh, cat, fac, fabc, faq, iopt, + $ xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss) + endif + +c Tabulate aerosol size distribution after hygroscopic growth, +c and check how well total aerosol number is conserved + numb=0.0 + if(itot.eq.0) then + do i=1,imax + dndlrk(i)=dndlrkny(i) + numb=numb+dndlrk(i)*d +ct +c write(12,100) r(i), dndlrk(i) +c write(14,100) r(i), dndlrk(i)*(4.0*pi/3.0)*r(i)**3 +ct + if(iopt.eq.1) + $ write(9001,400) r(i), dndlrk(i), rh, kcomp + enddo + else + do i=1,imax + if(dndlrkny(i).lt.0.0) then + write(*,*) 'dndlrkny(i) < 0 !' + stop + endif + numb=numb+dndlrkny(i)*d +c write(12,100) r(i), dndlrk0(i) +c write(13,100) r(i), dndlrkny(i) +c write(14,100) r(i), dndlrkny(i)*(4.0*pi/3.0)*r(i)**3 + if(ib.ne.19) then + write(9001,500) r(i), dndlrkny(i), + $ cat, fac, fabc, faq, rh, kcomp + endif + enddo + if(itilp.eq.1) then + call modetilp(pi, imax, d, r, dndlrkny, dndlrk0, + $ cat, fac, fabc, faq, kcomp) + endif + endif +c write(*,*) 'numbny=', numb + +c Sizemie determines the spectral aerosol gross (size integrated) +c optical parameters (by calling the Mie code for each particle size), +c and writes the result to file. + if(iopt.eq.1) then + call sizemie(imini, imaxi, r, rbcn, d, vsi, vbci, voci, vai, + $ vombg, fombg, vbcbg, fbcbg, + $ dndlrk, dndlrkny, kcomp, itot, ib, vssol, vbcsol, vocsol, vasol, + $ vw, fki, rh, Ctot, Nnat, cat, fac, fabc, faq, fracdim, xlam, + $ xlami, xlamb, xlame, fband, fb, cref, omega, gass, bext, kext) + endif + + if(iopt.eq.1) then +c write(*,*) 'rh, Caso4, Cas1, Cas3, Cabc' +c write(*,300) rh, Caso4, Cas1, Cas3, Cabc +c write(*,*) +c write(*,*) 'irelh, ictot, ifbc, ifaq' +c write(*,*) irelh, ictot, ifbc, ifaq +c write(1160+kcomp,*) rh, omega(9) +c write(1170+kcomp,*) rh, gass(9) +c write(1180+kcomp,*) rh, bext(9) +c write(1190+kcomp,*) rh, kext(9) +c +c Here comes the aerodryk*.out look-up tables: +c + if(ib.eq.31.and.irelh.eq.1) then + aaerol=aaero-aaeros + vaerol=vaero-vaeros + if(itot.eq.1) then + if(kcomp.eq.1) then + write(9600,2100) kcomp, fombg, cat, fac, + $ cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, + $ cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, + $ cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(9600,2000) kcomp, cat, fac, + $ cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, + $ cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, + $ cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + elseif(kcomp.eq.4) then + write(9600,3000) kcomp, fbcbg, cat, fac, faq, + $ cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, + $ cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, + $ cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + else ! (kcomp=5-10)) + write(9600,3000) kcomp, cat, fac, fabc, faq, + $ cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, + $ cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, + $ cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + endif + else ! itot (kcomp=0) + write(9600,4000) kcomp, cintbg, cintbg05, cintbg125, + $ aaeros, aaerol, vaeros, vaerol + endif ! itot + endif ! ib & relh + +! Very rough control (-> table entry format will be wrong): + if(cintbg.ge.1.e100.or.cintoc.ge.1.e100.or.cintsa.ge.1.e100) then + write(*,*) 'cintbg or cintoc or cintsa too large for format,' + stop + endif + + endif ! iopt + + 540 continue ! ifaq, ifbc, ifac, ictot/ictote, ifombg, ifbcbg, irelh + + close(9000) + close(9001) + close(9002) + close(9003) + close(9600) + + enddo ! kcomp + + + 100 format(2(x,e10.4)) + 300 format(x,f9.3,5(x,e9.3)) + 400 format(2(x,e12.5),f7.2,I3) + 500 format(6(x,e12.5),f7.2,I3) + 2000 format(I2,21e10.3) + 2100 format(I2,22e10.3) + 3000 format(I2,23e10.3) + 4000 format(I2,7e11.4) + + + end diff --git a/tools/AeroTab/MIEV-documentation.txt b/tools/AeroTab/MIEV-documentation.txt new file mode 100644 index 0000000000..10d6f8ca4c --- /dev/null +++ b/tools/AeroTab/MIEV-documentation.txt @@ -0,0 +1,505 @@ + M I E V D O C U M E N T A T I O N + ------------------------------------ + +** NOTE ** The output variable SPIKE, having to do with the detection +of resonances, is still under research and will undoubtedly change in +the future. Presently, SPIKE only detects the broadest spikes, of width +roughly 0.1 in size parameter; ultimately narrower spikes should also +be detected, although the probability of hitting them is much smaller. +SPIKE is mainly of use in avoiding spikes during numerical integration +over a size distribution. + +Author: Dr. Warren J. Wiscombe (wiscombe@climate.gsfc.nasa.gov) + NASA Goddard Space Flight Center + Code 913 + Greenbelt, MD 20771 + +FTP availability: The entire package is available by anonymous ftp + from Internet site climate.gsfc.nasa.gov in subdirectory + pub/wiscombe. (ftp to 'climate', login as 'anonymous', give + your e-mail address as password, then 'cd' to pub/wiscombe.) + + +The MIEV package contains the following files (besides the present one): + +(1) MIEV0.f, the main subroutine which a user calls, plus ancillary + subroutines + +(1a) MIEV0noP.f: MIEV0.f with all the code relating to Legendre + moments PMOM removed (smaller and requires less array storage); + just created 12/89 and seems to be working fine but has not had + the benefit of years of user testing like MIEVO.f; argument + list same as MIEV0.f in order to allow swapping of this with + MIEV0.f without changing calling program(s) + +(2) ErrMsg.f: a set of 4 error-handling routines needed by both + MIEV0.f and MIEV0noP.f + +(3) MVTstOld.f, the main program for running the 8 test cases at + the end of Reference (1) below + +(4) MVTstOld.out, the output generated by MVTstOld.f + +(5) MVTstNew.f, the main program for running an exhaustive set of + 19 test cases. + +(6) MVTstNew.out, the output generated by MVTstNew.f + +(7) PMOMTest.f, a program to test the Legendre coefficients computed + by *MIEV0* against those computed approximately by numerical + quadrature of the phase matrix + +Note that MIEV1, the Cray-customized version of MIEV0 described in +Ref.(1) below, is omitted from this package. Very few users chose to +use MIEV1 because its speed advantage over MIEV0 was only +about 20% in typical cases. The speed advantage could grow to several +hundred percent if only cross-sections and asymmetry factor were needed, +since MIEV1 took advantage of the CRAY's ability to vectorize summing +loops. + +All modules have some internal documentation in addition to what +you will find in this file. Also, all the declaration statements +were standardized using the NAG Fortran Tools. + +MIEV0 computes the following quantities involved in eletromagnetic +scattering from a homogeneous sphere: + + * scattering and extinction efficiencies; + * asymmetry factor; + * forward- and backscatter amplitude; + * scattering amplitudes vs. scattering angle for incident + polarization parallel and perpendicular to the plane + of scattering; + * coefficients in the Legendre polynomial expansions of + either the unpolarized phase function or the polarized + phase matrix; + * some quantities needed in polarized radiative transfer; + * information about whether or not a resonance has been hit. + +NOTE -- MIEV0 differs from the original code published + in Ref. (1) below in the following ways : + + * computes Legendre moments, based on vast + improvements to the formulas of Sekera (see Refs. 3-5) + and correction of errors in the formulas of Ref. 3 + + * returns a measure of how nasty of a spike (resonance) you + are sitting on ( this is invaluable when integrating over + size and you want to exclude unrepresentative points); + this part of the program is a work-in-progress and + is far from finished, but it may prove useful even + in its present form + + * allows real refractive indices less than unity + + * adds a totally reflecting special case + + * performs a self-test on the first call to the routine + + * adds several new input and output variables, and makes + all I/O through arguments of the subroutine + + * allows complete freedom in specifying angles + + * allows printing of all output variables at user option + + * some variables names are more mnemonic + + Also, major improvements have been made, based on + modern ideas of documentation and program structure (e.g., + Kernighan and Plauger, The Elements of Programming Style). + Those interested in my thoughts in this area may find + PostScript documents in the anonymous ftp directory cited + above, under pub/wiscombe/Writing_Programs. + + + REFERENCES + ---------- + + (1) Wiscombe, W., 1979: Mie Scattering Calculations--Advances + in Technique And Fast, Vector-Speed Computer Codes, + Ncar Tech Note Tn-140+Str, National Center For + Atmospheric Research, Boulder, Colorado (NCAR no + longer distributes this, so contact the author or + NTIS for a copy) + + (2) Wiscombe, W., 1980: Improved Mie Scattering Algorithms, + Appl. Opt. 19, 1505-1509 + + (3) Dave, J.V., 1970a: Coefficients of the Legendre and + Fourier Series for the Scattering Functions of + Spherical Particles, Appl. Opt. 9, 1888-1896 + + (4) Dave, J.V., 1970b: Intensity and Polarization of the + Radiation Emerging from a Plane-Parallel Atmosphere + Containing Monodisperse Aerosols, Appl. Opt. 9, 2673-84 + + (5) Van De Hulst, 1957, 1982: Light Scattering by Small + Particles, Dover Press, New York. + + (6) Bohren, C. and D. Huffman, Absorption and Scattering of + Light by Small Particles, Wiley, New York. (has a + Mie program in the back of the book) + + + I N P U T V A R I A B L E S + ----------------------------- + + ( Even if an input variable is not needed for a particular + application, make sure it has a legitimate value that can + be written out and read in -- no indefinites, etc. ) + + XX Mie size parameter ( 2 * pi * radius / wavelength ) + + CREFIN Complex refractive index ( imag part can be + or -, + but internally a negative imaginary index is assumed ). + If imag part is - , scattering amplitudes as in Van + de Hulst are returned; if imag part is + , complex + conjugates of those scattering amplitudes are returned + (the latter is the convention in physics). + ** NOTE ** In the 'PERFECT' case, scattering amplitudes + in the Van de Hulst (Ref. 6 above) convention will + automatically be returned unless Im(CREFIN) is + positive; otherwise, CREFIN plays no role. + + PERFCT TRUE, assume refractive index is infinite and use + special case formulas for Mie coefficients 'a' + and 'b' ( see Kerker, M., The Scattering of + Light and Other Electromagnetic Radiation, p. 90 ). + This is sometimes called the 'totally reflecting', + sometimes the 'perfectly conducting' case. + ( see CREFIN for additional information ) + + MIMCUT (positive) value below which imaginary refractive + index is regarded as zero ( computation proceeds + faster for zero imaginary index ) + + ANYANG TRUE, any angles whatsoever may be input through + XMU. FALSE, the angles are monotone increasing + and mirror symmetric about 90 degrees (this option + is advantageous because the scattering amplitudes + S1,S2 for the angles between 90 and 180 degrees + are evaluable from symmetry relations, and hence + are obtained with little added computational cost.) + + NUMANG No. of angles at which scattering amplitudes + S1,S2 are to be evaluated ( set = 0 to skip + calculation of S1,S2 ). Make sure NUMANG does + not exceed the parameter MAXANG in the program. + + XMU(N) Cosines of angles ( N = 1 TO NUMANG ) at which S1,S2 + are to be evaluated. If ANYANG = FALSE, then + + (a) the angles must be monotone increasing and + mirror symmetric about 90 degrees (if 90-A is + an angle, then 90+A must be also) + + (b) if NUMANG is odd, 90 degrees must be among + the angles + + NMOM Highest Legendre moment PMOM to calculate, + numbering from zero ( NMOM = 0 prevents + calculation of PMOM ) + + IPOLZN POSITIVE, Compute Legendre moments PMOM for the + Mueller matrix elements determined by the + digits of IPOLZN, with 1 referring to M1, + 2 to M2, 3 to S21, and 4 to D21 (Ref. 3). + E.g., if IPOLZN = 14 then only moments for + M1 and D21 will be returned. + + 0, Compute Legendre moments PMOM for the + unpolarized unnormalized phase function. + + NEGATIVE, Compute Legendre moments PMOM for the + Sekera phase quantities determined by the + digits of ABS(IPOLZN), with 1 referring to + R1, 2 to R2, 3 to R3, and 4 to R4 (REF. 4). + E.g., if IPOLZN = -14 then only moments for + R1 and R4 will be returned. + + ( NOT USED IF NMOM = 0 ) + + MOMDIM Determines first dimension of PMOM, which is dimensioned + internally as PMOM( 0:MOMDIM, * ) (second dimension must + be the larger of unity and the highest digit in + IPOLZN; if not, serious errors will occur). + Should be set even when NMOM = 0. A zero value is OK. + + PRT(L) Print flags (LOGICAL). L = 1 prints S1,S2, their + squared absolute values, and degree of polarization, + provided NUMANG is non-zero. L = 2 prints all + output variables other than S1,S2. + + +O U T P U T V A R I A B L E S +------------------------------- + + QEXT (REAL) extinction efficiency factor ( Ref. 2, Eq. 1A ) + + QSCA (REAL) scattering efficiency factor ( Ref. 2, Eq. 1B ) + + GQSC (REAL) asymmetry factor times scattering efficiency + ( Ref. 2, Eq. 1C ) ( allows calculation of radiation + pressure efficiency factor QPR = QEXT - GQSC ) + + ===================================================================== + ==== NOTE -- S1, S2, SFORW, SBACK, TFORW, AND TBACK are calculated + ==== internally for negative imaginary refractive index; + ==== for positive imaginary index, their complex conjugates + ==== are taken before they are returned, to correspond to + ==== customary usage in some parts of physics ( in parti- + ==== cular, in papers on cam approximations to Mie theory ). + ===================================================================== + + S1(N), (COMPLEX) Mie scattering amplitudes at angles specified + S2(N) by XMU(N) ( N=1 to NUMANG ) ( Ref. 2, Eqs. 1d-e ). + + SFORW (COMPLEX) forward-scattering amplitude S1 at + 0 degrees. ( S2(0 deg) = S1(0 deg) ) + + SBACK (COMPLEX) backscattering amplitude S1 at + 180 degrees. ( S2(180 deg) = - S1(180 deg) ) + + TFORW(I) (COMPLEX) values of + + I=1: T1 = ( S2 - (MU)*S1 ) / ( 1 - MU**2 ) + I=2: T2 = ( S1 - (MU)*S2 ) / ( 1 - MU**2 ) + + At angle theta = 0 ( MU = COS(theta) = 1 ), where the + expressions on the right-hand side are indeterminate. + ( these quantities are required for doing polarized + radiative transfer (Ref. 4, Appendix ). ) + + TBACK(I) (COMPLEX) values of T1 (for I=1) or T2 (for I=2) at + angle theta = 180 degrees ( MU = COS(theta) = - 1 ). + + SPIKE (REAL) magnitude of the smallest denominator of + either Mie coefficient (a-sub-n or b-sub-n), + taken over all terms in the Mie series past + N = size parameter XX. Values of SPIKE below + about 0.3 signify a ripple spike, since these + spikes are produced by abnormally small denominators + in the Mie coefficients (normal denominators are of + order unity or higher). Defaults to 1.0 when not + on a spike. Does not identify all resonances + (we are still working on that). + + PMOM(M,NP) (REAL) moments M = 0 to NMOM of unnormalized NP-th + phase quantity PQ ( moments with M .GT. 2*NTRM are + zero, where NTRM = no. terms in Mie series = + XX + 4*XX**1/3 + 1 ) : + + PQ( MU, NP ) = sum( M=0 to infinity ) ( (2M+1) + * PMOM( M,NP ) * P-sub-M( MU ) ) + + WHERE MU = COS( scattering angle ) + P-sub-M = M-th Legendre polynomial + + and the definition of 'PQ' is as follows: + + IPOLZN.GT.0: PQ(MU,1) = CABS( S1(MU) )**2 + PQ(MU,2) = CABS( S2(MU) )**2 + PQ(MU,3) = RE( S1(MU)*CONJG( S2(MU) ) ) + PQ(MU,4) = - IM( S1(MU)*CONJG( S2(MU) ) ) + ( called M1, M2, S21, D21 in literature ) + + IPOLZN=0: PQ(MU,1) = ( CABS(S1)**2 + CABS(S2)**2 ) / 2 + ( the unnormalized phase function ) + + IPOLZN.LT.0: PQ(MU,1) = CABS( T1(MU) )**2 + PQ(MU,2) = CABS( T2(MU) )**2 + PQ(MU,3) = RE( T1(MU)*CONJG( T2(MU) ) ) + PQ(MU,4) = - IM( T1(MU)*CONJG( T2(MU) ) ) + ( called R1, R2, R3, R4 in literature ) + + The sign of the 4th phase quantity is a source of + confusion. It flips if the complex conjugates of + S1,S2 or T1,T2 are used, as occurs when a + refractive index with positive imaginary part is + used (see discussion below). The definition above + is consistent with a negative imaginary part. + + See Ref. 5 for correct formulae for PMOM ( Eqs. 2-5 + of Ref. 3 contain typographical errors ). Ref. 5 also + contains numerous improvements to the Ref. 3 formulas. + + NOTE THAT OUR DEFINITION OF MOMENTS DIFFERS FROM REF. 3 + in that we divide out the factor (2M+1) and number the + moments from zero instead of one. + + ** WARNING ** Make sure the second dimension of PMOM + in the calling program is at least as large as the + absolute value of IPOLZN. + + For small enough values of XX, or large enough values + of M, PMOM will tend to underflow. Thus, it is + unwise to assume the values returned are non-zero and, + for example, to divide some quantity by them. + + + INTEGRATING OVER SIZES + ---------------------- + + The normalized phase function for a single size parameter is + + P(one size) = 4 / ( XX**2 * QSCA ) * ( i1 + i2 ) / 2 + + where i1 + i2 = CABS(S1)**2 + CABS(S2)**2. But it is + ( i1 + i2 ), not P(one size), that must be integrated + over sizes when a size distribution is involved. + (Physically, this means that intensities are added, + not probabilities. ) An a posteriori normalization + then gives the correct size-averaged phase function. + + Similarly, it is the CROSS-SECTIONS, proportional to + XX**2 times QEXT,QSCA,QPR, which should be integrated + over sizes, not QEXT,QSCA,QPR themselves. + + Similar remarks apply to PMOM. The normalized moments are + 4 / ( XX**2 * QSCA ) * PMOM, but it is PMOM itself, not + these normalized moments, which should be integrated over + a size distribution. + + Unless avoided, ripple spikes can cause a systematic upward + bias in any integration over size parameter, because these + spikes tend to be smeared out by typical quadrature rules and + thus over-represented in the final result. Checking the output + parameter SPIKE allows the user to filter out these cases. + + + NOTES ON PROGRAM USE + -------------------- + + *** PMOM dimensioning: + + One user dimensioned PMOM(1,1) in his calling program and + managed to clobber SFORW because he set MOMDIM=1 and + internally PMOM is dimensioned PMOM( 0:MOMDIM, * ). + Fortran seems to allow PMOM(0:0,*) so he could have + saved himself by setting MOMDIM=0, but this is confusing + and it is better to start your PMOM array at 0 just as + the program does internally. + + Be sure to use the test problem drivers as templates + when designing your calls to MIEV0 in order to avoid this + kind of problem. + + *** ON PORTABILITY : + + This package is written entirely in ANSI standard FORTRAN 77 + and should work on any computer. + + *** ON PRECISION : + + "You should be aware that a complex program can produce + different results on one computer than another because of + differences in internal precision. The difference can be + minimized, but not necessarily eliminated, by using double- + precision arithmetic and by using numerical methods that tend + to retain maximum precision." + (IBM Professional FORTRAN Manual) + + This package was developed on computers offering 14-digit + single-precision computation. On IBM-type machines with their + 7-digit single precision, parts of the computation ( like the + upward recurrence for the Ricatti-Bessel functions ) might need + to be done in double precision, depending on how big the Mie + size paramter XX is. See Ref. (1) for further discussion + of this point. + + The package has only been tested for XX up to 20,000 and + for real and imaginary part of CREFIN up to 10 ( this + accomodates almost all imaginable applications ). Slow + deterioration of accuracy may be expected if the program + is pushed beyond these limits. ( Accuracy may degrade well + before XX = 20000 with IBM-type 7-digit precision. ) + + Precision problems are most likely to OVERTLY afflict + users + + (a) in the self-test subroutine TESTMI, where it may be + necessary to lower the required agreement with tabulated + results by changing the variable ACCUR. For example, + to run on the IBM PC in single precision using 'IBM + Professional FORTRAN', a value ACCUR = 1.E-4 was + necessary. + + (b) in the testing routines MVTst..., where the user's + precision may be unsatisfactory for numerically + 'sensitive' quantities. + + The quantities most sensitive to precision are those involving + series of positive and negative terms with much cancellation. + The smaller the end result of summing compared to the average + term size, the worse the problem. The problem can occur + in either of the scattering amplitudes (S1,S2) away from the + forward scattering angle, esp. near a relative minimum. When + the real and imaginary parts of S1 or S2 differ by + orders of magnitude, the smaller part is likely to be less + accurate than the larger. + + The least accurate output quantities will be : + + ** TFORW and TBACK, because the numerical factors + involved are on the order of XX**3 + + ** PMOM( M, 4 ) for any M and larger XX + + ** PMOM( M, NP ) for M approaching 2*XX + + The most accurate will be QEXT, QSCA, GQSC, being sums + of all positive terms. + + Please do not call the author about precision problems. + They are endemic and cannot be solved as long as different + computers do arithmetic differently. + + + *** ON MEMORY REQUIREMENTS : + + The parameter MaxTrm in MIEV0, LPCOEF must be + set to 10,100 in order to do the test problems with + size parameter = 10,000. Memory used by these routines can + be significantly, often dramatically, reduced by lowering + MaxTrm to a value no bigger than XMAX + 4*XMAX**1/3, + where XMAX is the largest size parameter expected. + + If PMOM is never needed, the version MIEV0noP.f should + be used instead of MIEV0.f. This can substantially cut memory + requirements. + + + *** The self-test on the first call to the program is a novel + feature intended to catch bugs which users may introduce into + the code. But it does not begin to test all the possible + branches in the code. The test programs included with + this package should be used for thorough checkout of all + branches. + + *** The arithmetic statement function F3 is built into + *MIEV0*, but not used. It corresponds to the function + f-sub-3 in Ref. 2, Eq. 8, and should be used instead + of F2 when only intensity and degree of polarization + are required. This can be implemented just by + changing F2 to F3 in a single executable statement. + + *** To avoid littering up the code with temporary variables, + a reasonably optimizing compiler (one that recognizes + invariant and repeated sub-expressions in DO-loops) + has been assumed. This may make the code look wasteful + to those accustomed to dumb FORTRAN compilers. + + *** Equivalenced arrays have been used in one place (module + LPCOEF). (EQUIVALENCE is a dangerous feature of FORTRAN + and should generally be avoided.) + + *** MIEV0 sacrifices some computational speed on vector computers + in order to use the minimum possible amount of computer + memory; however, it still allows loops over scattering + angle to vectorize; and on vector computers which vectorize + summing loops ( like the Cray ), the potentially + time-consuming inner loops in the Legendre coefficient + subroutine will also vectorize ( these two kinds of loops + account for the lion's share of computing time in a typical + application ). \ No newline at end of file diff --git a/tools/AeroTab/Makefile b/tools/AeroTab/Makefile new file mode 100644 index 0000000000..48767c32c3 --- /dev/null +++ b/tools/AeroTab/Makefile @@ -0,0 +1,241 @@ +################################################################## +# Makefile for multiple platforms +################################################################## +# +#Get machine info +UNAMES = $(shell uname -s) +MAKEFILE = Makefile +MAIN = AeroTab +MAKDEP= ./makdep +MY_OBJ_DIR=./obj +#List of directories in which to search for source files +MDL_PTH:=. ../../src/chemistry/oslo_aero +#################################################### +#Normally don't touch anything below this line +#(except to add or remove a source file) + +#Define some signs needed for the Makefile below +null= +comma=${null},${null} +space=${null} ${null} +kolon=${null}:${null} + +#Directory where you store dependency files (same as MY_OBJ_DIR) +MY_DPN_DIR:=${MY_OBJ_DIR} + +LDFLAGS := + +#Initialize includes (Directories to include when looking for files to compile) +INCLUDES:= + + +# Set the right compiler and compiler options for the right architecture +# This part (and the directories above) should in theory be the only machine +# dependent things... +#----------------------------------------------------------------------------- + +#Set the value of DPN_GNR to makdep +DPN_GNR:=${MAKDEP} + +#OPTIONS SET FOR GFORTRAN!! +FC = gfortran +CC = gcc +FIXEDFLAGS = -ffixed-form +FREEFLAGS = -ffree-form +STDOPT = -fdefault-real-8 +FCOPT = -O4 +DEBUG = -g -ggdb + +OPTFLAGS=${FCOPT} + +############################################################################# + +#Set the Makefile VPATH variable (change space for colon in modelpath) +VPATH_TMP:=$(subst ${space},${kolon},${MDL_PTH}) +# Source file names with directories removed +SRC_LST := shr_kind_mod.F90\ + commondefinitions.F90\ + AeroTab.f\ + specbands.f\ + constsize.f\ + hygro.f\ + tableinfo.f\ + openfiles.f\ + modepar.f\ + drydist.f\ + conteq.f\ + sizemie.f\ + chandrav.f\ + tabrefind.f\ + refind.f\ + miev0.f\ + coagsub.f\ + condsub.f\ + rhsub.f\ + koehler.f\ + mixsub.f\ + smolar.f\ + modetilp.f + +# Prepend -I to use for compiler argument +#include directories to search for #included files +MDL_INC := $(foreach dir,${MDL_PTH},-I${dir}) + +#Set model source to be SRC_LST +MDL_SRC:= ${SRC_LST} + +#Expand includes +INCLUDES += ${MDL_INC} + +#Set LDFLAGS (only needed if libraries. eg for including netcdf) +#LDFLAGS += -L${NETCDF_LIB} -lnetcdf -lnetcdff +LDFLAGS += + +#USR_TKN has to be changed for AIX where the preprocessing is of the form +#-WF,-DTKN1,-DTKN2.... All the other machines use the form -DTKN1 -DTKN2... +ifeq (${UNAMES},AIX) +USR_TKN := $(subst $(space)${space}$(space),$(null),${USR_TKN}) #Get rid of triple spaces +USR_TKN := $(subst $(space)${space},$(null),${USR_TKN}) #Get rid of double spaces +USR_TKN := $(subst $(space),$(null),${USR_TKN}) #Get rid of single spaces +USR_TKN := $(subst -D,$(comma)-D,$(USR_TKN)) #Change "-D" to ",-D" +USR_TKN2 := $(subst -WF${comma},${null},$(USR_TKN)) #Argument to c processor.. +USR_TKN2 := $(subst ${comma},${space},$(USR_TKN2)) #..is on the form -D1 -D2 +else #not AIX +USR_TKN2 := ${USR_TKN} #Needed for compiling .F90 files +endif + +#Includes for makdep (in should not look for netcdf.o) +#MAKDEPINC := $(subst -I${NETCDF_INC},$(null),${INCLUDES}) +MAKDEPINC := ${INCLUDES} + +#After VPATH_TMP has been expanded by all different modules, +#we now construct the variable VPATH by changing space with kolon +VPATH := $(subst $(space),$(kolon),${VPATH_TMP}) + +# List of object files is constructed directly from source files +# It is made made AFTER the source list is constructed +# In this statement we say that all object files are in MY_OBJ_DIR +# and that they are based on the files in MDL_SRC +MDL_OBJ := ${addprefix ${MY_OBJ_DIR}/,${addsuffix .o, ${basename ${MDL_SRC}}}} + +OBJDIR = ${MY_OBJ_DIR} + +#List of dependency files. Make will read the dependency files and find out what files need +#To be recompiled in case of a change in any file. This is useful if you use modules and #include +MDL_DPN := $(addprefix ${MY_OBJ_DIR}/,$(addsuffix .d, $(basename ${MDL_SRC}))) + +# limit what files to check for updates +.SUFFIXES: +.SUFFIXES: .f .f90 .F .F90 .c .o + +#Pattern rules: Tell make how to construct a pattern from another pattern +#Note the pattern to construct *.f90 from *.F90: The HP-UX compiler does not recognize .F90 as fortran code +#Other compilers recognize *.F90 as fortran code, but it is better to to it general for all compilers. +#Normally, *.F90 is fortran code in free format with CPP statements (#ifdefs) +#http://devrsrc1.external.hp.com/STK/man/11.20/f90_1.html +${MY_OBJ_DIR}/%.o : %.f + ${FC} ${FIXEDFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +${MY_OBJ_DIR}/%.o : %.F + ${FC} ${FIXEDFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} ${USR_TKN} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +${MY_OBJ_DIR}/%.o : %.f90 + ${FC} ${FREEFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +%.f90 : %.F90 + ${CC} -C -E ${INCLUDES} ${USR_TKN2} $< > $@ + +#Dependency rules Generate dependency files which tells Make what files to +#recompile and not after a given change in the code. You need the makdep program +#to do this. The last line in the makefile -include ${MDL_DPN} tells make to use this. +#Makdep is publicly available, f.ex. http://dust.ps.uci.edu/dead/makdep.c +#Compile it with ${CC} -o makdep makdep.c and put the binary somewhere in your path. +${MY_DPN_DIR}/%.d : %.F + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.f + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.F90 + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.f90 + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ + +#Make will try to execute the first target of the Makefile +.PHONY: all +all: ${MAIN} ${MDL_OBJ} ${MDL_DPN} +# I think .PHONY tells make that "all" is a non file target +# I am not sure if it helps, but the manual recommends it. + +# Here I tell make only to update MAIN if +# MDL_OBJ is newer +${MAIN}: ${MDL_OBJ} + @echo COMPILING AND LINKING MAIN + ${FC} ${STDOPT} ${OPTFLAGS} -o $@ ${MDL_OBJ} ${LDFLAGS} + +${MDL_OBJ}: | ${OBJDIR} + +${MDL_DPN}: | ${OBJDIR} + +${MDL_DPN}: | ${MAKDEP} + + +${MAKDEP}: makdep.c + cc -o ./makdep makdep.c + +$(OBJDIR): + mkdir -p $(OBJDIR) + +#We need new object files if the Makefile is newer +${MDL_OBJ}: ${MAKEFILE} + +#We need new dependency files if the Makefile is newer +${MDL_DPN}: ${MAKEFILE} + +#Check if what you think is really set in this makefile +#The command "make check" will print all the stuff below +check: + @echo SOURCE FILES ${MDL_SRC} + @echo MDL_OBJ ${MDL_OBJ} + @echo INCLUDES ${INCLUDES} + @echo makdepinc ${MAKDEPINC} + @echo CORE ${CORE_SRC} + @echo USR_TKN ${USR_TKN} + @echo FIXEDFLAGS ${FIXEDFLAGS} + @echo MY_OBJ_DIR ${MY_OBJ_DIR} + @echo OBJDIR ${OBJDIR} + @echo MAIN ${MAIN} + @echo MAKEFILE ${MAKEFILE} + @echo Dependency files ${MDL_DPN} + @echo VPATH_TMP ${VPATH_TMP} + @echo VPATH ${VPATH} + @echo comma a${comma}a + @echo space a${space}a + @echo kolon a${kolon}a + @echo USR_TKN2 ${USR_TKN2} + @echo MAKDEP ${MAKDEP} +# Clean up +clean: + rm -f ${MY_OBJ_DIR}/*.o + rm -f ${MY_DPN_DIR}/*.d + rm -f ${MDL_DPN} + rm -f ${MDL_OBJ} + rm -f loader.info + rm -f ${MAIN} + rm -f core + rm -f *.mod + rm -f *~ + +#This last part includes the dependencies +#But we only want to do this for options which actually compile something +#That's why we want to check on "GOALS_WHICH...BLA BLA.." +INCLUDE_DPN := TRUE +GOALS_WHICH_IGNORE_DEPENDENCY_FILES := clean clean_all check +ifeq (${null},$(findstring $(MAKECMDGOALS),${GOALS_WHICH_IGNORE_DEPENDENCY_FILES})) + INCLUDE_DPN := TRUE +else + INCLUDE_DPN := FALSE +endif +ifeq (${INCLUDE_DPN},TRUE) +# Following incorporates dependency files into Makefile rules +-include ${MDL_DPN} +endif diff --git a/tools/AeroTab/chandrav.f b/tools/AeroTab/chandrav.f new file mode 100644 index 0000000000..1bcbe06967 --- /dev/null +++ b/tools/AeroTab/chandrav.f @@ -0,0 +1,175 @@ +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + subroutine chandrav (ib, xlam, xlamb, xlame, fband, fb, + $ omega, gass, bext, omch, gch, bch) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Here Chandrasekhar averaged optical parameters are calculated +c for the wavelength bands, ibm (each covering several iband's) + + implicit none + + integer i, iband, ib, ibm, ibmb, ibme + real xlam(31), xlamb(31), xlame(31), fband(31), omega(31), + $ gass(31), bext(31), omch(16), gch(16), bch(16), fb(16) + + + if(ib.eq.31) then + +c initialize spectral optical parameters + do ibm = 1, 9 + omch(ibm) = 0.0 + gch(ibm) = 0.0 + bch(ibm) = 0.0 + enddo +c Chandrasekhar averaging band 1' (iband=1-2: 0.2 - 0.263 um) + ibm =1 + ibmb=1 + ibme=2 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 2' (iband=3-5: 0.263 - 0.345 um) + ibm =2 + ibmb=3 + ibme=5 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 3' (iband=6-9: 0.345 - 0.442 um) + ibm =3 + ibmb=6 + ibme=9 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 4' (iband=10-13: 0.442 - 0.625 um) + ibm =4 + ibmb=10 + ibme=13 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 5' (iband=14-17: 0.625 - 0.778 um) + ibm =5 + ibmb=14 + ibme=17 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 6' (iband=18-21: 0.778 - 1.242 um) + ibm =6 + ibmb=18 + ibme=21 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Band 7' (iband=22: 1.242 - 1.299 um) no Chandrasekhar averaging needed... +c ibm =7 +c ibmb=22 +c ibme=22 +c call chsub (ibm, ibmb, ibme, fb, fband, +c $ omega, gass, bext, omch, gch, bch) + omch(7) = omega(22) + gch(7) = gass(22) + bch(7) = bext(22) +c Chandrasekhar averaging band 8' (iband=23-24: 1.299 - 1.626 um) + ibm =8 + ibmb=23 + ibme=24 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 9' (iband=25-26: 1.626 - 1.942 um) + ibm =9 + ibmb=25 + ibme=26 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) + +c***************************************************************** + + elseif(ib.eq.19) then + +c initialize spectral optical parameters +c do ibm = 1, 4 + do ibm = 1, 16 + omch(ibm) = 0.0 + gch(ibm) = 0.0 + bch(ibm) = 0.0 + enddo +c Chandrasekhar averaging the last band (28.571-100um): + ibm =16 + ibmb=16 + ibme=19 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) + +c***************************************************************** + + elseif(ib.eq.29) then + +c initialize spectral optical parameters + do ibm = 8, 12 + omch(ibm) = 0.0 + gch(ibm) = 0.0 + bch(ibm) = 0.0 + enddo +c Chandrasekhar averaging band 8' (0.35-0.64um): + ibm =8 + ibmb=8 + ibme=12 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 10' (0.69-1.19um): + ibm =10 + ibmb=14 + ibme=19 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 11' (1.19-2.38um): + ibm =11 + ibmb=20 + ibme=25 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) +c Chandrasekhar averaging band 12' (2.38-4.0um): + ibm =12 + ibmb=26 + ibme=29 + call chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) + + endif ! ib = 29 or 31 + + + return + end + + +c************************************************************************* +c Here the Chandrasekhar averaging itself is carried out (weighting +c of optical properties with the spectrally resolved TOA irradiance). + + subroutine chsub (ibm, ibmb, ibme, fb, fband, + $ omega, gass, bext, omch, gch, bch) + + implicit none + + integer iband, ibm, ibmb, ibme + real fband(31), omega(31), gass(31), bext(31) + real fb(16), omch(16), gch(16), bch(16) + + do iband = ibmb, ibme + omch(ibm)=omch(ibm)+omega(iband)*fband(iband) + gch(ibm) =gch(ibm) +gass(iband)*fband(iband) + bch(ibm) =bch(ibm) +bext(iband)*fband(iband) +c write(123,*) 'i, fband, om=', iband, fband(iband), omega(iband) +c write(*,*) 'i, fband, om=', iband, fband(iband), omega(iband) + enddo + omch(ibm)=omch(ibm)/fb(ibm) + gch(ibm) =gch(ibm)/fb(ibm) + bch(ibm) =bch(ibm)/fb(ibm) +c write(124,*) 'ibm, omch =', ibm, omch(ibm) +c write(125,*) 'ibm, gch =', ibm, gch(ibm) +c write(126,*) 'ibm, bch =', ibm, bch(ibm) +c write(127,*) 'i, fb =', ibm, fb(ibm) +c write(*,*) 'i, fb, bch =', ibm, fb(ibm), bch(ibm) + + return + end diff --git a/tools/AeroTab/coagsub.f b/tools/AeroTab/coagsub.f new file mode 100644 index 0000000000..27f2893105 --- /dev/null +++ b/tools/AeroTab/coagsub.f @@ -0,0 +1,43 @@ + subroutine coagsub (r, imax, rcoag, rhob, rhoc2, Kg12) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Brownian coagulation coefficient on Fuchs form, Kg12, for monodisperse +c nucleation mode particles (with radius rcoag) of sulfate, BC or OC (OM). + + implicit none + + INTEGER i, imax + REAL rhob, rhoc2, r(0:100), Kg12(0:101), + $ diff1(0:101), diff2(0:101), g12(0:101), + $ g1(0:101), g2(0:101), c12(0:101), c1(0:101), c2(0:101), + $ mfv1(0:101), mfv2(0:101), rcoag, pi + PARAMETER (pi=3.141592654) + + do i=0,imax + c1(i)=4.786e4/(rhob*r(i)**3)**0.5 ! unit um/s + c2(i)=4.786e4/(rhoc2*rcoag**3)**0.5 ! unit um/s + c12(i)=(c1(i)**2+c2(i)**2)**0.5 ! unit um/s + diff1(i)=(11.64/r(i))*(5.0+0.253/r(i)+0.024/r(i)**2 + $ +0.00457/r(i)**3)/(5.0-0.0633/r(i)+0.0446/r(i)**2) ! unit um^2/s + diff2(i)=(11.64/rcoag)*(5.0+0.253/rcoag+0.024/rcoag**2 + $ +0.00457/rcoag**3)/(5.0-0.0633/rcoag+0.0446/rcoag**2) ! unit um^2/s + mfv1(i)=8.0*diff1(i)/(pi*c1(i)) ! unit um + mfv2(i)=8.0*diff2(i)/(pi*c2(i)) ! unit um + g1(i)=((2*r(i)+mfv1(i))**3 + $ -(4.0*r(i)**2+mfv1(i)**2)**1.5) + $ /(6.0*r(i)*mfv1(i))-2*r(i) ! unit um + g2(i)=((2*rcoag+mfv2(i))**3 + $ -(4.0*rcoag**2+mfv2(i)**2)**1.5) + $ /(6.0*rcoag*mfv2(i))-2*rcoag + g12(i)=(g1(i)**2+g2(i)**2)**0.5 ! unit um + Kg12(i)=4*pi*(r(i)+rcoag)*(diff1(i)+diff2(i)) + $ /((r(i)+rcoag)/(r(i)+rcoag+g12(i)) + $ +(4.0/c12(i))*(diff1(i)+diff2(i))/(rcoag+r(i))) ! unit um^3/s +c write(*,*) r(i), Kg12(i) + enddo + + return + end diff --git a/tools/AeroTab/commondefinitions.F90 b/tools/AeroTab/commondefinitions.F90 new file mode 100644 index 0000000000..41c4781e9d --- /dev/null +++ b/tools/AeroTab/commondefinitions.F90 @@ -0,0 +1,83 @@ + +module commondefinitions + +!--------------------------------------------------------------------------------- +! Module for aerosol hygroscopicities and dry size parameters (and soon also +! mass densities) which are common in AeroTab and CAM5-Oslo +!--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + + + !Define some aerosol types and their properties.. + integer, parameter, public :: N_AEROSOL_TYPES = 5 + integer, parameter, public :: AEROSOL_TYPE_SULFATE = 1 + integer, parameter, public :: AEROSOL_TYPE_BC = 2 + integer, parameter, public :: AEROSOL_TYPE_OM = 3 + integer, parameter, public :: AEROSOL_TYPE_DUST = 4 + integer, parameter, public :: AEROSOL_TYPE_SALT = 5 + + !NUMBERS BELOW ARE ESSENTIAL TO CALCULATE HYGROSCOPICITY AND THEREFORE INDIRECT EFFECT! + !These numbers define the "hygroscopicity parameter" Numbers are selected so that they give reasonable hygroscipity + !note that changing numbers individually changes the hygroscopicity! + !Hygroscopicity is defined in Abdul-Razzak and S. Ghan: (B in their eqn 4) + !A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 + !http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract + ! + !Further note that changing any of these numbers without changing aerotab will lead to + !inconsistencies in the simulation since Aerotab tabulates hygroscopical growth! + ! + !Main reference for numbers chosen: Ghan et al MIRAGE paper (JRG, vol 106, D6, pp 5295), 2001 + !References: + !SULFATE : Using same numbers as MIRAGE paper (ammonium sulfate) + !BC : Does not really matter as long as soluble mass fraction is small + ! However, numbers below reproduces values from MIRAGE paper + !OM : Soluble mass fraction tuned to give B of MIRAGE Paper + !DUST : The numbers give B of ~ 0.07 (high end of Kohler, Kreidenweis et al, GRL, vol 36, 2009. + ! (10% as soluble mass fraction seems reasonable) + ! (see also Osada et al, Atmospheric Research, vol 124, 2013, pp 101 + !SEA SALT: Soluble mass fraction tuned to give consistent values for (r/r0) at 99% when using the parametrization in + ! Koepke, Hess, Schult and Shettle: Max-Plack-Institut fur Meteorolgie, report No. 243 "GLOBAL AEROSOL DATA SET" + ! These values give "B" of 1.20 instead of 1.16 in MIRAGE paper. + + character(len=8),public, dimension(N_AEROSOL_TYPES) :: aerosol_type_name = & + (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_density = & +!cbc (/1769.0_r8, 2000.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 + (/1769.0_r8, 1800.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_molecular_weight = & +!csoa (/132.0_r8, 12.0_r8, 144.0_r8, 135.0_r8, 58.44_r8 /) !kg/kmol + (/132.0_r8, 12.0_r8, 168.2_r8, 135.0_r8, 58.44_r8 /) !kg/kmol + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_osmotic_coefficient = & +!cbc (/0.7_r8, 1.0_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] + (/0.7_r8, 1.111_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_soluble_mass_fraction = & +!csoa (/1.0_r8, 1.67e-7_r8, 0.747_r8, 0.1_r8, 0.885_r8 /) ![-] + (/1.0_r8, 1.67e-7_r8, 0.8725_r8, 0.1_r8, 0.885_r8 /) ![-] + real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_number_of_ions = & + (/3.0_r8, 1.0_r8, 1.0_r8, 2.0_r8, 2.0_r8 /) ![-] + +! Define lognormal size parameters for each size mode (dry, at point of emission/production) + integer, public, parameter :: nmodes = 14 + integer, public, parameter :: nbmodes = 10 + !Number median radius of background emissions THESE DO NOT ASSUME IMPLICIT GROWTH!! + real(r8), parameter, public, dimension(0:nmodes) :: originalNumberMedianRadius = & +!cBC_AX 1.e-6_r8* (/ 0.1_r8, & !0 + 1.e-6_r8* (/ 0.0626_r8, & !0 +!cr2 0.0118_r8, 0.0118_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 +!cSS 0.22_r8, 0.63_r8, 0.022_r8, 0.13_r8, 0.74_r8, & !6-10 + 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & !6-10 ! Salter SS +!cr12 0.0118_r8, 0.0118_r8, 0.04_r8, 0.04_r8 /) !11-14 + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) !11-14 + + !sigma of background aerosols ) + real(r8), parameter, public, dimension(0:nmodes) :: originalSigma = & + (/1.6_r8, & !0 + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.59_r8, & !1-5 +!cSS 1.59_r8, 2.0_r8, 1.59_r8, 1.59_r8, 2.0_r8, & !6-10 + 1.59_r8, 2.0_r8, 2.1_r8, 1.72_r8, 1.60_r8, & !6-10 ! Salter SS + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 /) !11-14 + +end module diff --git a/tools/AeroTab/condsub.f b/tools/AeroTab/condsub.f new file mode 100644 index 0000000000..bd80191fdf --- /dev/null +++ b/tools/AeroTab/condsub.f @@ -0,0 +1,21 @@ + subroutine condsub (r, imax, diff, mfv, th, alpha, Dm) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Calculation of radius dependent diffusion coefficients for sulfate or SOA (OM) + + implicit none + + INTEGER i, imax +cerr REAL diff, mfv, th, r(0:100), Dm(0:101), alpha + REAL diff, mfv, th, r(0:100), Dm(0:100), alpha + + do i=0,imax + Dm(i)=diff/(r(i)/(r(i)+mfv)+4.0*diff/(alpha*th*r(i))) ! unit um^2/s +c write(*,*) r(i), r(i)*Dm(i) + enddo + + return + end diff --git a/tools/AeroTab/constsize.f b/tools/AeroTab/constsize.f new file mode 100644 index 0000000000..54fae09233 --- /dev/null +++ b/tools/AeroTab/constsize.f @@ -0,0 +1,158 @@ + subroutine constsize(d, imax, imaxi, r, rp, r0, rbcn, + $ logs0, rhobc, rhooc, rhos, rhosv, rhoc2, + $ rhow, bcint, fracdim, diff, th, mfv, diffsoa, thsoa, mfvsoa) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Define constants and parameters for calculations of size distributions. + + use commondefinitions + + implicit none + + INTEGER i, imax, imaxi + REAL d, r0, rbcn, logs0 + REAL diff, th, mfv, rhobc, rhooc, rhos, rhosv, rhoc2, rhorbc + REAL diffsoa, thsoa, mfvsoa + REAL rhobcax, rhow, bcint, vbcint, xlastval + REAL r(0:100), rp(0:100), fracdim(0:100) + REAL pi, e + REAL aunit, boltz, Mair, Msv, Msoa, Mdual, rair, rmol, t0, p0, + $ Vad, Vadair, Vadsoa + + PARAMETER (pi=3.141592654, e=2.718281828) + + +c character(len=8),public, dimension(N_AEROSOL_TYPES) :: aerosol_type_name = & +c (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) +c mass densities (kg/m^3) + rhow=1.0e3 ! mass density of water + rhosv=1841.0 ! mass density of sulfuric acid, H2SO4 +c the rest are already defined in CAM5-Oslo +c rhos=1769.0 ! mass density of ammonium sulfate, (NH4)2SO4 + rhos=aerosol_type_density(1) +c rhobc=2000.0 ! mass density of nucleation mode BC + rhobc=aerosol_type_density(2) + rhoc2=rhobc ! mass density used in c2 (in K12 coeffiecient in koagsub.f) +c rhooc=1.5e3 ! mass density of OC + rhooc=aerosol_type_density(3) + +c modal radius and standard deviation for externally mixed +c nucleation modes of sulfate (mode 11), BC (mode 12) and OC (mode 14) +cbt r11=0.0695 ! for comparison with Box & Trautman +ckb r11=0.05 ! for comparison with Kiehl & Briegleb +cbt logs11=0.307 ! for comparison with Box & Trautman +c r11=0.0118 ! base case +c logs11=0.2553 ! base case ! AEROCOM & Stier et al., 2005. +c r12=0.04 ! cak_jacobson +c r12=0.0118 ! base case +c logs12=0.2553 ! base case ! Aerocom & Stier et al., 2005. +c r14=0.04 ! base caes ! Aerocom +c logs14=0.2553 ! base case ! Aerocom + rbcn=originalNumberMedianRadius(12)*1.e6 +c modal radius and standard deviation for externally mixed +c fractal soot accumulation mode (mode 13) +ctest r13=0.2 ! old base case +c r13=0.1 ! cak_jacobson/Strom +c logs13=0.2041 ! base case + r0=originalNumberMedianRadius(0)*1.e6 + logs0=log10(originalSigma(0)) + +c bin-size in log(r) space, d=log(r(i+1))-log(r(i)) + d=0.1 +c value of imax, which with defined d gives minimum and maximum +c modelled aerosol radius, rmin=0.001 and rmax=20 (or 100) micron: +c imax=1+nint(5.0/d) ! rmax=100 + imax=1+nint(4.3/d) ! rmax=20 +c index for largest radius in the Mie calculations + imaxi=imax + +c define discrete radii in log(r) space, r(i) and rp(i)=r(i+1/2), and +c mass density (rhorbc) for fractal mode 0 (based on Strom et al, 1992). + bcint=0.0 + vbcint=0.0 + do i=0,imax + r(i)=10.0**(d*(i-1.0)-3.0) + rp(i)=r(i)*10.0**(d/2.0) + fracdim(i)=2.5 ! fractal dimension for aged soot aggregates +ctest fracdim(i)=1.8 +ctest fracdim(i)=3.0 + if(r(i).le.rbcn) then + fracdim(i)=3.0 + rhorbc=rhobc + else + rhorbc=rhobc*(rbcn/r(i))**(3.0-fracdim(i)) +ctest rhorbc=rhobc + endif +c write(51,*) r(i), rhorbc*1.e-3 + bcint=bcint+d*rhorbc*r(i)**3.0 + $ *exp(-0.5*(log10(r(i)/r0)/logs0)**2.0) + enddo + do i=0,imax + vbcint=vbcint+d*r(i)**3.0 + $ *exp(-0.5*(log10(r(i)/r0)/logs0)**2.0) + enddo + rhobcax=bcint/vbcint +c write(*,*) 'rhobcax = ', rhobcax + + +c key parameters for sulfuric acid, H2SO4 (for standard atmosphere), +c updated values May 2013, based on Seinfeld & Pandis and Poling, +c Prausnitz and O'Connell (5'th edition of The Properties of Gases +c and Fluids), using the method by Fuller et al. for diffusion, +c assuming p = 1 atm and T=273 K (see notes, folder XXVI). +c diff=9.5e6 ! diffusion coeffisient (um^2/s) +c th=2.43e8 ! thermal velocity (um/s) +c mfv=1.65e-2 ! mean free path (um) +c adding SOA-values for the same variables, based on the same as above, +c assuming molar mass of SOA to be 144 (or 150) (jfr. notater s. 336 i perm XXVI). +c (rhosoa=rhooc) for M=144 (for M=150) +c diffsoa=6.1e6 ! diffusion coeffisient (um^2/s) (5.9e6) +c thsoa=2.0e8 ! thermal velocity (um/s) (2.0e8) +c mfvsoa=1.2e-2 ! mean free path (um) (1.1e-2) + +c From july 2015: diff(soa), th(soa) and mfv(soa) is instead calculated in the code: +c physical constants and properties for ambient dry air at standard temperature and pressure +c (mainly taken from Seinfeld & Pandis (1998), Appendix A): + boltz=1.381e-23 ! Boltzmann constant (J/K) + aunit=1.6606e-27 ! Atomic mass unit (kg) + t0=273.15 ! Standard temperature (K) + p0=101325.0 ! Standard pressure (Pa) + rair=1.73e-10 ! Typical air molecule (collision) radius (m) + Mair=28.97 ! Molecular weight for dry air (atomic units) + Msv=98.08 ! Molecular weight of sulfuric acid (H2SO4) + Msoa=aerosol_type_molecular_weight(3) ! ! Molecular weight of SOA +c calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): + th=1.e6*sqrt(8.0*boltz*t0/(pi*Msv*aunit)) ! thermal velocity for H2SO4 in air (um/s) + thsoa=1.e6*sqrt(8.0*boltz*t0/(pi*Msoa*aunit)) ! thermal velocity for SOA in air (um/s) + rmol=(3*Msv*aunit/(4*pi*rhosv))**(1.0/3.0) ! molecule radius for H2SO4 (m) + mfv=1.0e6/(pi*sqrt(1.0+Msv/Mair)*(rair+rmol)**2*p0/(boltz*t0)) ! mean free path for H2SO4 in air (um) + rmol=(3*Msoa*aunit/(4*pi*rhooc))**(1.0/3.0) ! molecule radius for H2SO4 (m) + mfvsoa=1.0e6/(pi*sqrt(1.0+Msoa/Mair)*(rair+rmol)**2*p0/(boltz*t0)) ! mean free path for SOA in air (um) +c formula for collisions between "hard sphere" molecules, for comparison with the Fuller treatment below: +c diff=(3*pi/32.0)*(1.0+Msv/Mair)*th*mfv ! diffusion coeffisient for H2SO4 in air (um^2/s) +c diffsoa=(3*pi/32.0)*(1.0+Msoa/Mair)*thsoa*mfvsoa ! diffusion coeffisient for SOA in air (um^2/s) +c semi-empirically based formula from Fuller et al (1965, 1966, 1969), see "The Properties of Gases and +c Liquids" by Poling et al., 5'th edition (DOI:10.1036/0070116822), Eq. 11-4.4: + Vadair=19.7 ! atomic diffusion volume for air (Table 11-1) + Vad=51.96 ! atomic diffusion volume for H2SO4 (estimated from atomic values in Table 11-1) + Vadsoa=208.18 ! atomic diffusion volume for SOA as C10H16O2 (estimated from atomic values in Table 11-1) ! Does not follow from Msoa!!! + Mdual=2.0/(1.0/Mair+1.0/Msv) + diff=1.e8*0.00143*t0**1.75 + $ /((p0/1.0e5)*sqrt(Mdual) + $ *(((Vad)**(1.0/3.0)+(Vadair)**(1.0/3.0))**2)) ! diffusion coeffisient for H2SO4 in air (um^2/s) + Mdual=2.0/(1.0/Mair+1.0/Msoa) + diffsoa=1.e8*0.00143*t0**1.75 + $ /((p0/1.0e5)*sqrt(Mdual) + $ *(((Vadsoa)**(1.0/3.0)+(Vadair)**(1.0/3.0))**2)) ! diffusion coeffisient for SOA in air (um^2/s) +c write(*,*) ' th = ', th +c write(*,*) ' thsoa = ', thsoa +c write(*,*) ' mfv = ', mfv +c write(*,*) ' mfvsoa = ', mfvsoa +c write(*,*) ' diff = ', diff +c write(*,*) ' diffsoa = ', diffsoa + + return + end diff --git a/tools/AeroTab/conteq.f b/tools/AeroTab/conteq.f new file mode 100644 index 0000000000..1246b50bb6 --- /dev/null +++ b/tools/AeroTab/conteq.f @@ -0,0 +1,539 @@ + subroutine conteq (r, rp, rbcn, d, itot, imax, ictot, + $ ictote, ifaq, imini, rhos, rhobc, rhooc, rhob, + $ rhosv, rhoc2, Nnatk, fcondk, fcoagk, faqk, Cas1, Cas2, Cas3, + $ Cabc, Caoc, Ctot0, dndlrk, dndlrkny, ntot, Dmsoa, Dmpsoa, Dm, + $ Dmp, K12in, Kp12in, K12ocin, Kp12ocin, K12so4in, Kp12so4in, + $ ismolar, vbci, voci, vsi, vai, cintbg, cintsc, cintsa, cintbc, + $ cintoc, cintbg05, cintsc05, cintsa05, cintbc05, cintoc05, + $ cintbg125, cintsc125, cintsa125, cintbc125, cintoc125, aaero, + $ aaeros, vaero, vaeros, fracdim, kcomp, vombg, vbcbg, fac) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Here the modified dry size distributions for process specific +c SO4, BC and OC internally mixed with the background aerosol is +c calculated. +c NOTE: For kcomp=4 (the OC&BC(Ait) mode) we assume that the +c background mode consists of OC, and add BC homogeneously wrt. +c radius (except at very small radii due to small OC amounts due +c to a frac a little <1), if no so4 from condensation is added. +c Therefore we assume that dvbc=0 in calculating modified size +c distributions, but take the homogeneously internally mixed BC +c into account afterwards, by using an adjusted cbc(i) wrt. the +c volume fractions vbci etc. (for use in rhsub and sizemie) as +c well as by remembering to multiply the normalized N4 numbers +c by a constant when the tables are to be used in CAM-Oslo. +c +c New treatment for kcomp=4: fac is now mass fraction of added OC +c (as SOA), as for the other modes, while instead fbcbg is the mass +c fraction of BC in the background OC&BC(Ait) mode. Similarly, fombg +c is the mass fraction of OM in the background SO4&SOA(ait) mode. +c +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + implicit none + + INTEGER i, ic, imax, ix, imini, itot, ictot, ictote, + $ ismolar, ifaq, j, jmax, jmaxx, k, kcomp, itest, incjmax + REAL K12in(0:101), Kp12in(0:101), K12ocin(0:101), + $ Kp12ocin(0:101), K12so4in(0:101), Kp12so4in(0:101), + $ K12(0:101), Kp12(0:101), K12oc(0:101), Kp12oc(0:101), + $ K12so4(0:101), Kp12so4(0:101) + REAL r(0:100), rp(0:100), dip(0:100), Dm(0:100), + $ Dmp(0:100), dninc(0:100), dndlrk(0:100), dndlrkny(0:100), + $ dncny(0:100), cbg(0:100), csu12(0:100), csu3(0:100), + $ csu(0:100), cbc(0:100), coc(0:100), vbci(0:100), voci(0:100), + $ vsi(0:100), vai(0:100), fracdim(0:100), + $ rhorbc(0:100), Dmsoa(0:100), Dmpsoa(0:100) + REAL vcbg(100), vcbc(100), vcoc(100), vcsu12(100), vcsu3(100), + $ vcsu(100), dqsu12(100), dqsu3(100), dqbc(100), dqoc(100), + $ dcincbg(100), dcincs12(100), dcincs3(100), dcincbc(100), + $ dcincoc(100) + REAL rbcn, rc, rcmin, rcmax, rjm, rjmg, rjmax, rjmaxx, d, + $ Nnatk, ntot, nt, Nag, NrD, NK12, NK12oc, NK12so4, fcondk, fcoagk, + $ faqk, fr, frcoag, radikand, dv, dvcon, dvcos, dvcoa, dvcoaoc, + $ dvaq, dvbc, dvoc, dvaq0, dvs1, dvs2, dvs3, rhos, rhooc, rhobc, + $ rhob, rhosv, rhoc2, Cas1, Cas2, Cas3, Caso4, Cabc, Caoc, Ctot0, + $ cintbg, cintsc, cintsa, cintbc, cintoc, cintbg05, cintsc05, + $ cintsa05, cintbc05, cintoc05, cintbg125, cintsc125, cintsa125, + $ cintbc125, cintoc125, dcintbg, vtot, aaero, aaeros, vaero, + $ vaeros, pi, e, p1, p2, fac + REAL NrDsoa, dvsoa, dvconsoa, vombg, vbcbg, rhobg + +c Critical radius for cloud processing, rc, ranging between rcmin and +c rcmax (and smoothed over this range), from Chuang and Penner (1995). +c We have assumed that this range is independent of background aerosol + PARAMETER (rcmin=0.05, rcmax=0.2) + + PARAMETER (pi=3.141592654, e=2.718281828 ) + + Caso4=Cas1+Cas2+Cas3 ! total mass conc. of H2SO4 and (NH4)2SO4 + frcoag=Cas2/Caso4 ! (H2SO4 coagulate)/Caso4 + fr=Cas3/Caso4 ! (wet-phase (NH4)2SO4)/Caso4 +c write(*,*) 'Cas1,2,3=', Cas1, Cas2, Cas3 +c write(*,*) 'fr, frcoag=', fr, frcoag + +c Initial guess of jmax, the maximum required iterations to satisfy +c the stability criterion for the continuity equation. + jmaxx=10000 + +c Initiate modified size distribution calculations. Estimate +c amount of "moves to the right" (ix) so that jmax < jmaxx, +c and search for a sufficiently large total iteration number, +c jmax, to satisfy the stability criterium. + + do i=0,imax + K12(i) = K12in(i) + Kp12(i) = Kp12in(i) + K12oc(i) = K12ocin(i) + Kp12oc(i) = Kp12ocin(i) + K12so4(i) = K12so4in(i) + Kp12so4(i)= Kp12so4in(i) +c write(19,*) r(i), Dm(i) +c write(20,*) r(i), Dmsoa(i) + enddo + +c Initially, modified size distribution = background size distribution + + itest=0 + incjmax=0 + 11 do i=0,imax + dndlrkny(i)=dndlrk(i) + enddo + if(itot.eq.0) then + ix=0 + else + if(itest.eq.0) ix=1 + endif + 12 do i=0,imax + if(i.le.ix) then + K12(i)=0.0 + Kp12(i)=0.0 + K12oc(i)=0.0 + Kp12oc(i)=0.0 + K12so4(i)=0.0 + Kp12so4(i)=0.0 + dndlrkny(i)=1e-50 + endif + enddo + +c Below, condensation of H2SO4 or SOA and coagulation of BC, OC and SO4 aerosol +c onto the background distribution for the first time step is calculated +c For SOA, add condensation --> NrDsoa (NrD is for so4 only)! + NrD=0.0 ! H2SO4 + NrDsoa=0.0 ! SOA + NK12=0.0 ! BC + NK12oc=0.0 ! OC (OM) + NK12so4=0.0 ! H2SO4 + do i=0,imax +cerr NrD=NrD+dndlrkny(i)*Dm(i)*r(i)*d ! unit 1.e-12 s^-1 +cerr NrDsoa=NrDsoa+dndlrkny(i)*Dmsoa(i)*r(i)*d ! unit 1.e-12 s^-1 +cerr NK12=NK12+dndlrkny(i)*K12(i)*d ! unit 1.e-12 s^-1 +cerr NK12oc=NK12oc+dndlrkny(i)*K12oc(i)*d ! unit 1.e-12 s^-1 +cerr NK12so4=NK12so4+dndlrkny(i)*K12so4(i)*d ! unit 1.e-12 s^-1 +c corrected 18/10-2016 + NrD=NrD+dndlrkny(i)*Dmp(i)*rp(i)*d ! unit 1.e-12 s^-1 + NrDsoa=NrDsoa+dndlrkny(i)*Dmpsoa(i)*rp(i)*d ! unit 1.e-12 s^-1 + NK12=NK12+dndlrkny(i)*Kp12(i)*d ! unit 1.e-12 s^-1 + NK12oc=NK12oc+dndlrkny(i)*Kp12oc(i)*d ! unit 1.e-12 s^-1 + NK12so4=NK12so4+dndlrkny(i)*Kp12so4(i)*d ! unit 1.e-12 s^-1 + enddo + +c Process specific volumes per volume of dry air to be added (unit: +c (ug/m^3/cm^-3)/(ug/m^3)=cm^3): cloud processed sulfate (s3) is +c assumed to exist as (NH4)2SO4, while sulfate from diffusional growth +c (s1) and coagulation (s2) exists (like in the nucleation mode) as H2SO4 + dvs1=(fcondk/Nnatk)*1e-9*(1.0-frcoag-fr)*Caso4/rhosv ! volume of H2SO4 condensate + dvs2=(fcoagk/Nnatk)*1e-9*frcoag*Caso4/rhosv ! volume of H2SO4 coagulate + dvbc=(fcoagk/Nnatk)*1e-9*Cabc/rhobc ! volume of BC coagulate + if(kcomp.ge.1.and.kcomp.le.4) then ! OC only comes as SOA + dvsoa=1.e-9*Caoc/rhooc + dvoc=1.e-50 + else ! SOA is lumped together with and treated as OC coagulate + dvsoa=1.e-50 + dvoc=(fcoagk/Nnatk)*1e-9*Caoc/rhooc + endif + + if(incjmax.eq.0) then + +c Searching for sufficiently large total number of iterations, +c jmax (>10000), to satisfy the stability criterium for the +c continuity equation. If incjmax=1 (last guess was too small), +c jmax is doubled. Also estimate the necessary amount of +c "moves to the right" (ix), to facicitate a solution. + rjmg=0.0 + do i=ix+1,imax + + dvcon=dvs1*rp(i)*Dmp(i)/NrD ! as H2SO4 + dvcos=dvs2*Kp12so4(i)/NK12so4 ! as H2SO4 + dvcoa=dvbc*Kp12(i)/NK12 + dvcoaoc=dvoc*Kp12oc(i)/NK12oc + +c dv* unit: ug/m^3/(ug/m^3/cm^-3)=cm^3 +cerr dvcon=dvs1*r(i)*Dm(i)/NrD +cerr dvcos=dvs2*K12so4(i)/NK12so4 +cerr dvcoa=dvbc*K12(i)/NK12 +cerr dvcoaoc=dvoc*K12oc(i)/NK12oc +cerr dvconsoa=dvsoa*r(i)*Dmsoa(i)/NrDsoa +c corrected 18/10-2016 + dvcon=dvs1*rp(i)*Dmp(i)/NrD + dvcos=dvs2*Kp12so4(i)/NK12so4 + dvcoa=dvbc*Kp12(i)/NK12 + dvcoaoc=dvoc*Kp12oc(i)/NK12oc + dvconsoa=dvsoa*rp(i)*Dmpsoa(i)/NrDsoa +c + dv=dvcon+dvcoa+dvcos+dvcoaoc+dvconsoa +c (Possible improvement for small added volumes: use Taylor series...) + rjm=3e12*dv/(4.0*pi*r(i)**3.0*((1.0+d/log10(e))**3.0-1.0)) + rjm=rjm/(1.01-fr) + if(rjm.gt.rjmg) then + rjmax=rjm +c write(*,*) i, r(i), rjmax + endif + rjmg=rjm + enddo + rjmaxx=1.0*jmaxx + if(rjmax.gt.rjmaxx) then + ix=ix+1 + if(ix.gt.imini) then + itest=1 + jmaxx=jmaxx+jmaxx +c write(*,*) jmaxx + goto 11 + endif + goto 12 + endif + jmax=int(rjmax)+1 + if(jmax.lt.10000.and.(ictot.gt.1.or.ictote.gt.1)) then + jmax=10000 + if(ifaq.eq.6) jmax=20000 + endif + write(*,*) 'jmax, ix =', jmax, ix + + endif ! incjmax + + +c Process specific volumes of SO4, BC and OC per volume of dry air +c to be added PER ITERATION is then determined: + dvs1=(fcondk/Nnatk)*1e-9*(1.0-frcoag-fr)*Caso4 + $ /(rhosv*jmax) + dvs2=(fcoagk/Nnatk)*1e-9*frcoag*Caso4/(rhosv*jmax) + dvs3=(faqk/Nnatk)*1e-9*fr*Caso4/(rhos*jmax) + dvbc=(fcoagk/Nnatk)*1e-9*Cabc/(rhobc*jmax) + if(kcomp.ge.1.and.kcomp.le.4) then + dvsoa=1e-9*Caoc/(rhooc*jmax) + dvoc=1.e-50 + else + dvsoa=1.e-50 + dvoc=(fcoagk/Nnatk)*1e-9*Caoc/(rhooc*jmax) + endif + +c Initialize arrays for mass concentrations of the background aerosol +c (after correcting for internal mixtures in the background aerosol)... + if(kcomp.eq.1) then + rhobg=rhob*(1.0+vombg*(rhooc/rhob-1.0)) + elseif(kcomp.eq.4) then + rhobg=rhob*(1.0+vbcbg*(rhobc/rhob-1.0)) + else + rhobg=rhob + endif + do i=1,imax + cbg(i)=1.0e-3*(4.0*pi/3.0)*r(i)**3.0*(rhobg*dndlrkny(i)) ! ug/m^3 + enddo + +c ... and initialize arrays for internally mixed +c BC, H2SO4 and OC (POM or SOA) from condensation and coagulation +c and (NH4)2SO4 from cloud processing +c do i=1,imax + do i=0,imax + cbc(i)=1.0e-100 + coc(i)=1.0e-100 + csu12(i)=1.0e-100 + csu3(i)=1.0e-100 + enddo + +c Then solve continuity equation using jmax time steps/iterations + do 20 j=1,jmax + +c + rc=rcmin+j*(rcmax-rcmin)/jmax + +c Initialization of key variables for each time step + NrD=0.0 ! H2SO4 + NrDsoa=0.0 ! SOA + NK12=0.0 ! BC + NK12oc=0.0 ! OC (OM) + NK12so4=0.0 ! H2SO4 + Nag=0.0 ! (NH4)2SO4 + k=0 +c Variables for growth by condensation and coagulation + do i=1,imax +co if(i.le.ix) dndlrkny(i)=1.0e-50 + if(i.le.ix.or.dndlrkny(i).lt.1.e-50) dndlrkny(i)=1.0e-50 ! fix + NrD=NrD+dndlrkny(i)*Dmp(i)*rp(i)*d ! unit 1.e-12 s^-1 + NrDsoa=NrDsoa+dndlrkny(i)*Dmpsoa(i)*rp(i)*d ! unit 1.e-12 s^-1 + NK12=NK12+dndlrkny(i)*Kp12(i)*d ! unit 1.e-12 s^-1 + NK12oc=NK12oc+dndlrkny(i)*Kp12oc(i)*d ! unit 1.e-12 s^-1 + NK12so4=NK12so4+dndlrkny(i)*Kp12so4(i)*d ! unit 1.e-12 s^-1 + if(rp(i).ge.rc) k=k+1 + if(k.eq.1) ic=i + enddo +c Variables for growth by cloud processing (wetphase chemistry) + Nag=dndlrkny(ic)*log10(rp(ic)/rc) + if(Nag.lt.0.0) write(*,*) 'ic, dndlrkny =', ic, dndlrkny(ic) + do i=ic+1,imax + Nag=Nag+dndlrkny(i)*d + enddo + dvaq0=dvs3/Nag ! as (NH4)2SO4 + +c Calculate process specific volumes of SO4 aerosol, BC and OC +c per volume of dry air to be added (per particle) in each size bin + do i=1,imax + if(i.lt.ic) then + dvaq=0.0 + elseif(i.eq.ic) then + dvaq=dvaq0*(log10(rp(ic)/rc))/d + elseif(i.ge.ic+1) then + dvaq=dvaq0 + endif + dvcon=dvs1*rp(i)*Dmp(i)/NrD ! as H2SO4 + dvcos=dvs2*Kp12so4(i)/NK12so4 ! as H2SO4 + dvcoa=dvbc*Kp12(i)/NK12 + dvcoaoc=dvoc*Kp12oc(i)/NK12oc +cerr dvconsoa=dvsoa*r(i)*Dmsoa(i)/NrDsoa + dvconsoa=dvsoa*rp(i)*Dmpsoa(i)/NrDsoa ! corrected 18/10-2016 + dv=dvcon+dvaq+dvcoa+dvcos+dvcoaoc+dvconsoa +c Find the incement of log(r/um) at r=rp, i.e. in the center +c of the size bin, dip + radikand=1.0+3.0e12*dv/(4.0*pi*rp(i)**3.0) + dip(i)=log10(e)*(radikand**(1/3.0)-1.0) + if(dip(i).lt.0.0) write(*,*) 'r, dip =', r(i), dip(i) +c Process specific mass concentration increments (ug/m^3) + dqbc(i)=1e9*rhobc*dvcoa*dndlrkny(i) + dqoc(i)=1e9*rhooc*(dvcoaoc+dvconsoa)*dndlrkny(i) + dqsu12(i)=1e9*rhosv*(dvcon+dvcos)*dndlrkny(i) ! as H2SO4 + dqsu3(i)=1e9*rhos*dvaq*dndlrkny(i) ! as (NH4)2SO4 + enddo + +c Finally solve the continuity equations (using a simple upwind +c advection scheme) for the size distribution, dndlrkny, and for +c the process specific mass concentrations, dcinc* + dip(0)=0.0 + do i=1,imax + dninc(i)=-(dndlrkny(i)*dip(i)-dndlrkny(i-1)*dip(i-1))/d + dcincbg(i)=-(cbg(i)*dip(i)-cbg(i-1)*dip(i-1))/d + if(ismolar.eq.0) then + dcincbc(i)=-(cbc(i)*dip(i)-cbc(i-1)*dip(i-1))/d+dqbc(i) + dcincoc(i)=-(coc(i)*dip(i)-coc(i-1)*dip(i-1))/d+dqoc(i) + dcincs12(i)=-(csu12(i)*dip(i)-csu12(i-1)*dip(i-1))/d + $ +dqsu12(i) + dcincs3(i)=-(csu3(i)*dip(i)-csu3(i-1)*dip(i-1))/d+dqsu3(i) + else + dcincbc(i)=-(cbc(i)*dip(i)-cbc(i-1)*dip(i-1))/d + dcincoc(i)=-(coc(i)*dip(i)-coc(i-1)*dip(i-1))/d + dcincs12(i)=-(csu12(i)*dip(i)-csu12(i-1)*dip(i-1))/d + dcincs3(i)=-(csu3(i)*dip(i)-csu3(i-1)*dip(i-1))/d + endif + enddo + do i=1,imax + dndlrkny(i)=dndlrkny(i)+dninc(i) + if(dndlrkny(i).lt.1.e-99) dndlrkny(i)=1.e-99 + cbg(i)=cbg(i)+dcincbg(i) + coc(i)=coc(i)+dcincoc(i) + cbc(i)=cbc(i)+dcincbc(i) + csu12(i)=csu12(i)+dcincs12(i) + csu3(i)=csu3(i)+dcincs3(i) + csu(i)=csu12(i)+csu3(i) +c + cbg(i)=max(cbg(i),0.0) + coc(i)=max(coc(i),0.0) + cbc(i)=max(cbc(i),0.0) + csu12(i)=max(csu12(i),0.0) + csu3(i)=max(csu3(i),0.0) + csu(i)=max(csu12(i),0.0) +c + enddo + +c Here the anti-diffusive part of the upwind scheme by +c Smolarkiewicz (1983) kicks in, providing that the +c number of corrective steps is chosen larger than 0 + if(ismolar.gt.0) then +c size distribution (number concentration) + call smolar (ismolar, imax, d, dndlrkny, dip) +c background mass concentration + call smolar (ismolar, imax, d, cbg, dip) +c non-backgrond OC mass concentration + do i=1,imax + dncny(i)=coc(i) + enddo + call smolar (ismolar, imax, d, dncny, dip) + do i=1,imax + coc(i)=dncny(i)+dqoc(i) + enddo +c non-backgrond BC mass concentration + do i=1,imax + dncny(i)=cbc(i) + enddo + call smolar (ismolar, imax, d, dncny, dip) + do i=1,imax + cbc(i)=dncny(i)+dqbc(i) + enddo +c process specific and total (non-backgrond) H2SO4 or/and (NH4)2SO4 mass concentrations + do i=1,imax + dncny(i)=csu12(i) ! as H2SO4 + enddo + call smolar (ismolar, imax, d, dncny, dip) + do i=1,imax + csu12(i)=dncny(i)+dqsu12(i) + enddo + do i=1,imax + dncny(i)=csu3(i) ! as (NH4)2SO4 + enddo + call smolar (ismolar, imax, d, dncny, dip) + do i=1,imax + csu3(i)=dncny(i)+dqsu3(i) + csu(i)=csu12(i)+csu3(i) ! as H2SO4 + (NH4)2SO4 mass + enddo + endif ! ismolar + + 20 continue ! j=1,jmax + +c Check if total dry aerosol number is conserved +c and calculate aerosol area and volume, total and below 0.5um +c (thereby implicitely also above 0.5um), for AEROCOM diagnostics + nt=0.0 + aaero=0.0 + vaero=0.0 + p1=4.0*pi + p2=p1/3.0 + aaeros=0.99*p1*r(28)**2*dndlrkny(28)*d + vaeros=0.99*p2*r(28)**3*dndlrkny(28)*d + do i=1,imax + nt=nt+dndlrkny(i)*d + aaero=aaero+p1*r(i)**2*dndlrkny(i)*d + vaero=vaero+p2*r(i)**3*dndlrkny(i)*d + if(i.le.27) then + aaeros=aaeros+p1*r(i)**2*dndlrkny(i)*d + vaeros=vaeros+p2*r(i)**3*dndlrkny(i)*d + endif + enddo + write(*,*) 'Nt / Ntot = :', nt / ntot +cold if(nt/ntot.lt.0.95.or.nt/ntot.gt.1.05) then +c Accept bigger number error for extreme cases, but print to log + if(((nt/ntot.lt.0.95.or.nt/ntot.gt.1.05).and.jmax.le.300000) + $.or.((nt/ntot.lt.0.1.or.nt/ntot.gt.1.05).and.jmax.gt.300000)) then + jmax=jmax*2 + incjmax=1 + write(*,*) 'jmax_ny, ix =', jmax, ix + goto 11 + endif + +c Size-integrated dry mass concentrations, integrated over all r, +c and r<0.5um and r>1.25um (for AEROCOM). + cintbg=0.0 + cintbc=0.0 + cintoc=0.0 + cintsc=0.0 + cintsa=0.0 + cintbg05=0.99*cbg(28)*d + cintbc05=0.99*cbc(28)*d + cintoc05=0.99*coc(28)*d + cintsc05=0.99*csu12(28)*d ! as H2SO4 + cintsa05=0.99*csu3(28)*d ! as (NH4)2SO4 + cintbg125=0.03*cbg(31)*d + cintbc125=0.03*cbc(31)*d + cintoc125=0.03*coc(31)*d + cintsc125=0.03*csu12(31)*d ! as H2SO4 + cintsa125=0.03*csu3(31)*d ! as (NH4)2SO4 + do i=1,imax + if(cbg(i).lt.1.e-100) cbg(i)=1.e-100 + if(cbc(i).lt.1.e-100) cbc(i)=1.e-100 + if(coc(i).lt.1.e-100) coc(i)=1.e-100 + if(csu12(i).lt.1.e-100) csu12(i)=1.e-100 + if(csu3(i).lt.1.e-100) csu3(i)=1.e-100 + csu(i)=csu12(i)+csu3(i) ! as H2SO4 + (NH4)2SO4 mass + cintbg=cintbg+cbg(i)*d + cintbc=cintbc+cbc(i)*d + cintoc=cintoc+coc(i)*d + cintsc=cintsc+csu12(i)*d ! as H2SO4 + cintsa=cintsa+csu3(i)*d ! as (NH4)2SO4 + if(i.le.27) then + cintbg05=cintbg05+cbg(i)*d + cintbc05=cintbc05+cbc(i)*d + cintoc05=cintoc05+coc(i)*d + cintsc05=cintsc05+csu12(i)*d ! as H2SO4 + cintsa05=cintsa05+csu3(i)*d ! as (NH4)2SO4 + endif + if(i.ge.32) then + cintbg125=cintbg125+cbg(i)*d + cintbc125=cintbc125+cbc(i)*d + cintoc125=cintoc125+coc(i)*d + cintsc125=cintsc125+csu12(i)*d ! as H2SO4 + cintsa125=cintsa125+csu3(i)*d ! as (NH4)2SO4 + endif + enddo +c**************************************** + if(kcomp.eq.0) then + do i=0,imax + if(r(i).le.rbcn) then + rhorbc(i)=rhobc + else + rhorbc(i)=rhobc*(rbcn/r(i))**(3.0-fracdim(i)) + endif +c write(30,*) r(i), rhorbc(i), fracdim(i) + enddo + cintbg =0.0 + cintbg05 =0.99*1.0e-3*(4.0*pi/3.0)*r(28)**3.0 + $ *(rhorbc(28)*dndlrk(28))*d + cintbg125=0.03*1.0e-3*(4.0*pi/3.0)*r(31)**3.0 + $ *(rhorbc(31)*dndlrk(31))*d + do i=0,imax + dcintbg=1.0e-3*p2*r(i)**3.0*(rhorbc(i)*dndlrk(i))*d + cintbg=cintbg+dcintbg + if(i.le.27) cintbg05 =cintbg05 +dcintbg + if(i.ge.32) cintbg125=cintbg125+dcintbg + enddo + endif +c***************************************** + write(*,*) 'Cbc, Coc, Csu12, Csu3 og Cbg =' + write(*,*) cintbc, cintoc, cintsc, cintsa, cintbg + write(*,*) 'Ctot integrated / Ctot in =', + $ (cintbc + cintoc + cintsc + cintsa + cintbg) / + $ (Ctot0 + Caso4 + Cabc + Caoc) + + write(999,*) 'Ntot integrated / Ntot in =', nt / ntot + write(999,*) 'Ctot integrated / Ctot in =', + $ (cintbc + cintoc + cintsc + cintsa + cintbg) / + $ (Ctot0 + Caso4 + Cabc + Caoc) + +c write(1001,*) 'cintoc/Caoc = ', cintoc/Caoc +c write(1002,*) 'cintoc, Caoc = ', cintoc, Caoc + +c Dry volume fractions for H2SO4+(NH4)2SO4, vsi, soot, vbci, oc, voci, +c and background aerosol, vai. Note that vsi+vbci+voci+vai=1. + do i=1,imax + vtot=cbc(i)/rhobc+coc(i)/rhooc+csu12(i)/rhosv+csu3(i)/rhos + $ +cbg(i)/rhobg + vcbg(i)=(cbg(i)/rhobg)/vtot + vcbc(i)=(cbc(i)/rhobc)/vtot + vcoc(i)=(coc(i)/rhooc)/vtot + vcsu12(i)=(csu12(i)/rhosv)/vtot + vcsu3(i)=(csu3(i)/rhos)/vtot + vcsu(i)=vcsu12(i)+vcsu3(i) + vai(i)=vcbg(i) ! background (sulfate, OC, BC, SS or DU, or a mixture of two both for kcomp=1&4) + vbci(i)=vcbc(i) ! non-background BC + voci(i)=vcoc(i) ! non-background OC + vsi(i)=vcsu(i) ! non-background sulfate + enddo +c do i=1,imax +c write(60,*) r(i), vsi(i) +c write(61,*) r(i), vbci(i) +c write(62,*) r(i), voci(i) +c write(63,*) r(i), vai(i) +c write(12,*), r(i), dndlrkny(i) +c enddo + + return + end diff --git a/tools/AeroTab/drydist.f b/tools/AeroTab/drydist.f new file mode 100644 index 0000000000..6df36461f5 --- /dev/null +++ b/tools/AeroTab/drydist.f @@ -0,0 +1,46 @@ + subroutine drydist(kcomp, Nnat, imini, imax, d, r, rk, + $ logsk, logs0, rhob, bcint, pi, dndlrk, ntot, Ctot) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Dry background mode size distribution, dndlrk (cm^-3), and dry background +c aerosol contribution to the mass concentration Ctot (ug/m^3). +c Note: this calculation of Ctot does not take into account that the +c backrgound aerosol can be an internal mixture of two constituents. +c This must be compensated for (by scaling) other places in the code. + + implicit none + + INTEGER kcomp, i, imini, imax + REAL d, rk, logsk, nk, ntot, Nnat, rhob, bcint, pi, Ctot, dCtot + REAL logs0 + REAL r(0:100), dndlrk(0:100) + + ntot=0.0 + do i=0,imax + nk=(1.0/logsk)*exp(-0.5*(log10(r(i)/rk)/logsk)**2.0) + dndlrk(i)=Nnat*nk/sqrt(2.0*pi) + ntot=ntot+dndlrk(i)*d +ctest write(*,*) 'r, ntot =', i, r(i), ntot +c write(14,*) r(i), dndlrk(i) + enddo + + Ctot=0.0 + if(kcomp.ne.0) then + do i=imini,imax +ctst if(r(i).ge.1.25) then ! amount larger than 2.5um in diameter + dCtot=1.0e-3*(4.0*pi/3.0)*r(i)**3.0*(rhob*dndlrk(i))*d + Ctot=Ctot+dCtot +c write(*,*) 'r, Ctot =', r(i), Ctot +ctst endif + enddo + else + dCtot=Nnat/(3e3*logs0/(sqrt(8.0*pi)*bcint)) + Ctot=Ctot+dCtot + endif +c write(*,*) 'Background mass conc. (normalized mode) =', Ctot + + return + end diff --git a/tools/AeroTab/hygro.f b/tools/AeroTab/hygro.f new file mode 100644 index 0000000000..d4b11ab154 --- /dev/null +++ b/tools/AeroTab/hygro.f @@ -0,0 +1,151 @@ + subroutine hygro (rh, xbc, xdst, xoc, xs, xa, xss, + $ rhda, rhca, rhdss, rhcss) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g and Alf Grini. +c ********************************************************************************** + +c Hygro calculates hygroscopic properties (given by x*) for each pure aerosol +c component, for use in mixsub. For the hygroscopicities which are assumed to +c depend on RH, these have been found by solving the Kohler equation w.r.t. x +c for a given (measured/calculated) growth factor as function of RH. Linear +c fits (x=a*RH+b) have here been made for the available number of RH intervals. +c The hygroscopicity is defined as (using input from commondefinitions.F90): +c x = soluble_mass_fraction * number_of_ions * osmotic_coefficient +c * (mwh2o/molecular_weight) * (density/rhoh2o). + + use commondefinitions + + implicit none + + REAL rh, rhda, rhca, rhdss, rhcss + REAL x, xbc, xoc, xs, xa, xss, xdst, xcam + REAL get_hygroscopicity + +c Soot/BC (aerosoltype 2 in CAM5-Oslo), +c a practically hydrophobic component. + xbc=5.0e-7 ! This is the value previously used + xcam=get_hygroscopicity(AEROSOL_TYPE_BC) + if(abs((xbc-xcam)/xcam).gt.0.005) then + write(*,*) 'xbc differs (more than 0.5%) from CAM5-Oslo value.' + write(*,*) 'Edit xbc here or in CAM5-Oslo before continuing.' + stop + endif + +c Mineral (aerosoltype 4 in CAM5-Oslo) + xdst=0.0693 ! This is the value previously used + xcam=get_hygroscopicity(AEROSOL_TYPE_DUST) + if(abs((xdst-xcam)/xcam).gt.0.005) then + write(*,*) 'xdst differs (more than 0.5%) from CAM5-Oslo value.' + write(*,*) 'Edit xdst here or in CAM5-Oslo before continuing.' + stop + endif + +c Organic carbon (OC) (aerosoltype 3 in CAM5-Oslo) +c (MIRAGE-based (Ghan et al., 2001) for large RH, ~0.25*ammonium-sulfate) + xoc=0.14 ! This is the value previously used + xcam=get_hygroscopicity(AEROSOL_TYPE_OM) + if(abs((xoc-xcam)/xcam).gt.0.005) then + write(*,*) 'xoc differs (more than 0.5%) from CAM5-Oslo value.' + write(*,*) 'Edit xoc here or in CAM5-Oslo before continuing.' + stop + endif + +c Sulphuric acid (not an aerosoltype in CAM5-Oslo), hygroscopicity +c as inferred from Table 2 (for SUSO) in Kopke ert al. (1997): +c These values are not used in CAM-Oslo, where sulfate is assumed +c to exist only as ammonium sulfate. + if(rh.le.0.5) then + xs=1.23 + elseif(rh.gt.0.5.and.rh.le.0.7) then + xs=-1.05*rh+1.755 + elseif(rh.gt.0.7.and.rh.le.0.8) then + xs=-1.35*rh+1.965 + elseif(rh.gt.0.8.and.rh.le.0.9) then + xs=-1.79*rh+2.317 + elseif(rh.gt.0.9.and.rh.le.0.95) then + xs=-1.74*rh+2.272 + elseif(rh.gt.0.95.and.rh.le.0.98) then + xs=-2.5*rh+2.994 + elseif(rh.gt.0.98.and.rh.le.0.99) then + xs=-1.0*rh+1.524 + else + xs=0.534 + endif + +c Ammonium sulphate (aerosoltype 1 in CAM5-Oslo) +c (Ghan et al., 2001; RHC and RHD from Tang & Minkelwitz, 1994) + xa=0.507 ! This is the value previously used + xcam=get_hygroscopicity(AEROSOL_TYPE_SULFATE) + if(abs((xa-xcam)/xcam).gt.0.005) then + write(*,*) 'xa differs (more than 0.5%) from CAM5-Oslo value.' + write(*,*) 'Edit xa here or in CAM5-Oslo before continuing.' + stop + endif + rhca=0.37 ! point of crystallisation (Tang & Minkelwitz, 1994) + rhda=0.80 ! point of crystallisation (Tang & Minkelwitz, 1994) + if(rh.ge.rhda) then + xa=xa ! value used for cloud activation calculations + elseif(rh.lt.rhca) then ! below point of crystallization, assume a small but non-zero value + xa=xbc + else ! assume half hygroscopicity in the hysteresis regime + xa=0.5*xa + endif + +c Sea-salt (aerosoltype 5 in CAM5-Oslo), hygroscopicity +c as inferred from Table 2 in Kopke et al. (1997): + if(rh.le.0.5) then + xss=2.19 + elseif(rh.gt.0.5.and.rh.le.0.7) then + xss=-2.15*rh+3.265 + elseif(rh.gt.0.7.and.rh.le.0.9) then + xss=-2.2*rh+3.3 + elseif(rh.gt.0.9.and.rh.le.0.95) then + xss=-1.0*rh+2.22 + elseif(rh.gt.0.95.and.rh.le.0.98) then + xss=-2.333*rh+3.486 + else + xss=1.20 ! This is the value previously used + xcam=get_hygroscopicity(AEROSOL_TYPE_SALT) + if(abs((xss-xcam)/xcam).gt.0.005) then + write(*,*) 'xss differs (more than 0.5%) from CAM5-Oslo value.' + write(*,*) 'Edit xss here or in CAM5-Oslo before continuing.' + stop + endif + endif + rhcss=0.46 ! point of crystallisation (Tang, 1966) + rhdss=0.75 ! point of crystallisation (Tang, 1966) +c Assuming half hygroscopicity in the hysteresis regime + if(rh.ge.rhcss.and.rh.le.rhdss) then + xss=0.5*xss + elseif(rh.lt.rhcss) then + xss=xbc + endif + + return + end + + +!****************************************************************** + + function get_hygroscopicity (typeindex) result(hygroscopicity) + + use commondefinitions + + implicit none + integer, intent(in) :: typeindex + real hygroscopicity + real Mw, rhow + + data Mw, rhow / 1.8016e1, 1.0e3 / ! bør defineres ett sentralt sted felles for hele koden!!! + + hygroscopicity = + $ aerosol_type_soluble_mass_fraction(typeindex) + $ * aerosol_type_number_of_ions(typeindex) + $ * aerosol_type_osmotic_coefficient(typeindex) + $ * Mw/aerosol_type_molecular_weight(typeindex) + $ * aerosol_type_density(typeindex)/rhow + + end function + +!****************************************************************** diff --git a/tools/AeroTab/input/ammons.inp b/tools/AeroTab/input/ammons.inp new file mode 100644 index 0000000000..ff2fdd9c1a --- /dev/null +++ b/tools/AeroTab/input/ammons.inp @@ -0,0 +1,87 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c ammoniumsulfat i krystall-form i V og IR, etter Toon et al (1976). + +c lambda nr ni + + 0.2 1.55 1e-7 ! lagt inn for haand (av meg selv) + 0.3 1.55 1e-7 ! ------------ || --------------- + 0.405 1.54 1e-7 + 0.535 1.53 1e-7 + 0.656 1.53 1e-7 + 0.706 1.52 1e-7 + 0.8 1.52 1e-7 + 1.0 1.51 3.5e-7 + 1.07 1.51 2.4e-6 + 1.15 1.51 9.5e-7 + 1.2 1.50 3.4e-6 + 1.3 1.50 1.7e-5 + 1.4 1.50 1.1e-5 + 1.5 1.49 3.4e-5 + 1.58 1.49 2.1e-4 + 1.6 1.49 1.9e-4 + 1.7 1.49 9.0e-5 + 1.8 1.48 7.6e-5 + 1.9 1.48 1.5e-4 + 2.0 1.47 1.0e-3 + 2.05 1.47 1.5e-3 + 2.14 1.47 3.4e-3 + 2.2 1.46 1.7e-3 + 2.3 1.46 7.7e-4 + 2.4 1.45 4.5e-4 + 2.5 1.44 3.5e-4 + 2.63 1.42 9.0e-4 + 2.78 1.40 5.0e-3 + 2.94 1.33 5.0e-2 + 3.08 1.27 2.3e-1 + 3.13 1.39 3.3e-1 + 3.18 1.49 2.7e-1 + 3.23 1.48 2.4e-1 + 3.3 1.56 2.7e-1 + 3.33 1.61 2.4e-1 + 3.39 1.61 1.7e-1 + 3.45 1.60 1.5e-1 + 3.51 1.62 1.4e-1 + 3.57 1.63 1.0e-1 + 3.85 1.56 2.0e-2 + 4.17 1.53 1.0e-2 + 4.55 1.49 7.0e-3 + 4.76 1.48 6.0e-3 + 5.26 1.44 7.0e-3 + 5.88 1.37 1.0e-2 + 6.25 1.30 2.0e-2 + 6.67 1.11 9.0e-2 + 6.9 0.84 4.0e-1 + 7.07 1.33 1.1e-0 + 7.14 1.85 8.7e-1 + 7.19 1.94 5.8e-1 + 7.41 1.68 1.4e-1 + 7.81 1.41 7.0e-2 + 8.0 1.31 8.0e-2 + 8.33 1.07 1.5e-1 + 8.77 0.64 8.6e-1 + 9.01 0.99 1.7e-0 + 9.17 1.95 2.1e-0 + 9.35 2.86 1.25e0 + 9.52 2.68 5.3e-1 + 10.0 2.19 1.3e-1 + 10.5 1.99 6.0e-2 + 11.1 1.88 4.0e-2 + 11.8 1.81 2.0e-2 + 12.5 1.75 2.0e-2 + 13.3 1.70 2.0e-2 + 14.3 1.63 2.0e-2 + 15.4 1.47 3.0e-2 + 16.1 0.74 1.18e0 + 16.3 2.04 2.09e0 + 16.4 2.77 5.8e-1 + 16.7 2.16 1.0e-1 + 18.2 1.77 2.0e-2 + 20.0 1.69 2.0e-2 + 22.2 1.62 3.0e-2 + 25.0 1.55 5.0e-2 + 28.6 1.42 1.1e-1 + 33.3 1.18 4.6e-1 + 40.0 2.14 1.12e0 + 100.0 2.14 1.12e0 ! lagt inn for haand (av meg selv) + + diff --git a/tools/AeroTab/input/dustl.inp b/tools/AeroTab/input/dustl.inp new file mode 100644 index 0000000000..185caff4fc --- /dev/null +++ b/tools/AeroTab/input/dustl.inp @@ -0,0 +1,58 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'dust-like' aerosolkomponent i V og IR, ifoelge d'Almeida et al. + +c lambda nr ni + + 0.2 1.53 8.0e-3 ! lagt inn for haand + 0.75 1.53 8.0e-3 + 0.80 1.52 8.0e-3 + 1.00 1.52 8.0e-3 + 1.25 1.46 8.0e-3 + 1.50 1.41 8.0e-3 + 1.75 1.34 8.0e-3 + 2.00 1.26 8.0e-3 + 2.50 1.18 9.0e-3 + 3.00 1.16 1.2e-2 + 3.20 1.22 1.0e-2 + 3.392 1.26 1.3e-2 + 3.50 1.28 1.1e-2 + 3.75 1.27 1.1e-2 + 4.00 1.26 1.2e-2 + 4.50 1.26 1.4e-2 + 5.00 1.25 1.6e-2 + 5.50 1.22 2.1e-2 + 6.00 1.15 3.7e-2 + 6.20 1.14 3.9e-2 + 6.50 1.13 4.2e-2 + 7.20 1.40 5.5e-2 + 7.90 1.15 4.0e-2 + 8.20 1.13 7.42e-2 + 8.50 1.30 9.0e-2 + 8.70 1.40 1.0e-1 + 9.00 1.70 1.4e-1 + 9.20 1.72 1.5e-1 + 9.50 1.73 1.62e-1 + 9.80 1.74 1.62e-1 + 10.0 1.75 1.62e-1 + 10.951 1.62 1.2e-1 + 11.0 1.62 1.05e-1 + 11.5 1.59 1.0e-1 + 12.5 1.51 9.0e-2 + 13.0 1.47 1.0e-1 + 14.0 1.52 8.5e-2 + 14.8 1.57 1.0e-2 + 15.0 1.57 1.0e-1 + 16.4 1.60 1.0e-1 + 17.2 1.63 1.0e-1 + 18.0 1.64 1.15e-1 + 18.5 1.64 1.2e-1 + 20.0 1.68 2.2e-1 + 21.3 1.77 2.8e-1 + 22.5 1.90 2.8e-1 + 25.0 1.97 2.44e-1 + 27.9 1.89 3.2e-1 + 30.0 1.80 4.2e-1 + 35.0 1.90 5.0e-1 + 40.0 2.10 6.0e-1 + 100.0 2.10 6.0e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/inso_gads.inp b/tools/AeroTab/input/inso_gads.inp new file mode 100644 index 0000000000..8ea099a6ba --- /dev/null +++ b/tools/AeroTab/input/inso_gads.inp @@ -0,0 +1,60 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c INSO aerosolkomponent i V og IR, ifoelge Kopke et al. (GADS) + +c lambda nr ni + + 0.20 1.53 3.0e-2 ! lagt inn for haand + 0.25 1.53 3.0e-2 + 0.30 1.53 8.0e-3 + 0.75 1.53 8.0e-3 + 0.80 1.52 8.0e-3 + 1.00 1.52 8.0e-3 + 1.25 1.46 8.0e-3 + 1.50 1.41 8.0e-3 + 1.75 1.34 8.0e-3 + 2.00 1.26 8.0e-3 + 2.50 1.18 9.0e-3 + 3.00 1.16 1.2e-2 + 3.20 1.22 1.0e-2 + 3.39 1.258 1.285e-2 + 3.50 1.28 1.1e-2 + 3.75 1.27 1.1e-2 + 4.00 1.26 1.2e-2 + 4.50 1.26 1.4e-2 + 5.00 1.25 1.6e-2 + 5.50 1.22 2.1e-2 + 6.00 1.15 3.7e-2 + 6.20 1.14 3.9e-2 + 6.50 1.13 4.2e-2 + 7.20 1.40 5.5e-2 + 7.90 1.15 4.0e-2 + 8.20 1.13 7.42e-2 + 8.50 1.30 9.0e-2 + 8.70 1.40 1.0e-1 + 9.00 1.70 1.4e-1 + 9.20 1.72 1.5e-1 + 9.50 1.73 1.62e-1 + 9.80 1.74 1.62e-1 + 10.0 1.75 1.62e-1 + 10.6 1.62 1.2e-1 + 11.0 1.62 1.05e-1 + 11.5 1.59 1.0e-1 + 12.5 1.51 9.0e-2 + 13.0 1.47 1.0e-1 + 14.0 1.52 8.5e-2 + 14.8 1.57 1.0e-1 + 15.0 1.57 1.0e-1 + 16.4 1.60 1.0e-1 + 17.2 1.63 1.0e-1 + 18.0 1.64 1.15e-1 + 18.5 1.64 1.2e-1 + 20.0 1.68 2.2e-1 + 21.3 1.77 2.8e-1 + 22.5 1.90 2.8e-1 + 25.0 1.97 2.4e-1 + 27.9 1.89 3.2e-1 + 30.0 1.80 4.2e-1 + 35.0 1.90 5.0e-1 + 40.0 2.10 6.0e-1 + 100.0 2.10 6.0e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/mineral.inp b/tools/AeroTab/input/mineral.inp new file mode 100644 index 0000000000..cbc2bdb9ac --- /dev/null +++ b/tools/AeroTab/input/mineral.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'mineral' aerosolkomponent i V og IR, ifoelge d'Almeida et al. + +c lambda nr ni + + 0.20 1.53 2.5e-2 ! lagt inn for haand + 0.30 1.53 2.5e-2 + 0.35 1.53 1.7e-2 + 0.40 1.53 1.3e-2 + 0.45 1.53 8.5e-3 + 0.50 1.53 7.8e-3 + 0.55 1.53 5.5e-3 + 0.60 1.53 4.5e-3 + 0.65 1.53 4.5e-3 + 0.70 1.53 4.0e-3 + 0.75 1.53 4.0e-3 + 0.80 1.53 1.2e-3 + 0.90 1.53 1.2e-3 + 1.00 1.53 1.0e-3 + 1.25 1.53 1.3e-3 + 1.50 1.42 1.4e-3 + 1.75 1.37 1.8e-3 + 2.00 1.267 2.0e-3 + 2.50 1.18 3.4e-3 + 3.00 1.16 1.2e-2 + 3.20 1.22 1.0e-2 + 3.392 1.26 1.3e-2 + 3.50 1.28 1.1e-2 + 3.75 1.27 1.1e-2 + 4.00 1.26 1.2e-2 + 4.50 1.26 1.4e-2 + 5.00 1.25 1.6e-2 + 5.50 1.22 2.1e-2 + 6.00 1.22 2.1e-2 + 6.20 1.14 3.9e-2 + 6.50 1.13 4.2e-2 + 7.20 1.40 5.5e-2 + 7.90 1.15 4.0e-2 + 8.20 1.13 7.42e-2 + 8.50 1.30 9.0e-2 + 8.70 1.40 1.0e-1 + 9.00 1.40 1.4e-1 + 9.20 1.72 1.5e-1 + 9.50 1.73 1.62e-1 + 9.80 1.74 1.62e-1 + 10.0 1.75 1.62e-1 + 10.951 1.30 9.00e-2 + 11.0 1.62 1.05e-1 + 11.5 1.59 1.0e-1 + 12.5 1.51 9.0e-2 + 13.0 1.47 1.0e-1 + 14.0 1.52 8.5e-2 + 14.8 1.57 1.0e-2 + 15.0 1.57 1.0e-1 + 16.4 1.60 1.0e-1 + 17.2 1.63 1.0e-1 + 18.0 1.64 1.15e-1 + 18.5 1.64 1.2e-1 + 20.0 1.68 2.2e-1 + 21.3 1.77 2.8e-1 + 22.5 1.90 2.8e-1 + 25.0 1.97 2.44e-1 + 27.9 1.89 3.2e-1 + 30.0 1.80 4.2e-1 + 35.0 1.90 5.0e-1 + 40.0 2.10 6.0e-1 + 100.0 2.10 6.0e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/mineral_gads.inp b/tools/AeroTab/input/mineral_gads.inp new file mode 100644 index 0000000000..77f78f4dd2 --- /dev/null +++ b/tools/AeroTab/input/mineral_gads.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'mineral' aerosolkomponent i V og IR, ifoelge Kopke et al. (GADS). + +c lambda nr ni + + 0.20 1.53 3.5e-2 ! lagt inn for haand + 2.500E-01 1.530E+00 3.000E-02 + 3.000E-01 1.530E+00 2.500E-02 + 3.500E-01 1.530E+00 1.700E-02 + 4.000E-01 1.530E+00 1.300E-02 + 4.500E-01 1.530E+00 8.500E-03 + 5.000E-01 1.530E+00 7.800E-03 + 5.500E-01 1.530E+00 5.500E-03 + 6.000E-01 1.530E+00 4.500E-03 + 6.500E-01 1.530E+00 4.500E-03 + 7.000E-01 1.530E+00 4.000E-03 + 7.500E-01 1.530E+00 4.000E-03 + 8.000E-01 1.530E+00 4.000E-03 + 9.000E-01 1.530E+00 4.000E-03 + 1.000E+00 1.530E+00 4.000E-03 + 1.250E+00 1.530E+00 5.000E-03 + 1.500E+00 1.530E+00 5.700E-03 + 1.750E+00 1.530E+00 6.400E-03 + 2.000E+00 1.530E+00 7.600E-03 + 2.500E+00 1.520E+00 1.400E-02 + 3.000E+00 1.520E+00 3.900E-02 + 3.200E+00 1.510E+00 2.400E-02 + 3.390E+00 1.510E+00 1.925E-02 + 3.500E+00 1.510E+00 1.800E-02 + 3.750E+00 1.500E+00 1.200E-02 + 4.000E+00 1.500E+00 6.700E-03 + 4.500E+00 1.500E+00 8.700E-03 + 5.000E+00 1.480E+00 1.800E-02 + 5.500E+00 1.460E+00 3.600E-02 + 6.000E+00 1.440E+00 5.500E-02 + 6.200E+00 1.430E+00 6.300E-02 + 6.500E+00 1.420E+00 5.200E-02 + 7.200E+00 1.460E+00 1.300E-01 + 7.900E+00 1.220E+00 8.900E-02 + 8.200E+00 1.120E+00 1.200E-01 + 8.500E+00 1.060E+00 2.100E-01 + 8.700E+00 1.190E+00 2.900E-01 + 9.000E+00 1.850E+00 4.400E-01 + 9.200E+00 2.220E+00 5.400E-01 + 9.500E+00 2.940E+00 6.500E-01 + 9.800E+00 2.910E+00 6.500E-01 + 1.000E+01 2.570E+00 5.000E-01 + 1.060E+01 1.910E+00 2.500E-01 + 1.100E+01 1.830E+00 2.000E-01 + 1.150E+01 1.810E+00 3.500E-01 + 1.250E+01 1.740E+00 5.000E-01 + 1.300E+01 2.000E+00 3.500E-01 + 1.400E+01 1.630E+00 2.200E-01 + 1.480E+01 1.540E+00 2.400E-01 + 1.500E+01 1.510E+00 2.600E-01 + 1.640E+01 1.470E+00 3.200E-01 + 1.720E+01 1.490E+00 3.700E-01 + 1.800E+01 1.770E+00 4.700E-01 + 1.850E+01 2.050E+00 5.700E-01 + 2.000E+01 2.200E+00 8.200E-01 + 2.130E+01 2.390E+00 9.400E-01 + 2.250E+01 2.690E+00 1.000E+00 + 2.500E+01 2.990E+00 8.000E-01 + 2.790E+01 2.570E+00 7.800E-01 + 3.000E+01 2.420E+00 6.700E-01 + 3.500E+01 2.420E+00 6.200E-01 + 4.000E+01 2.340E+00 7.000E-01 + 100.0 2.34 7.0e-1 ! lagt inn for haand diff --git a/tools/AeroTab/input/mineral_gadsx.inp b/tools/AeroTab/input/mineral_gadsx.inp new file mode 100644 index 0000000000..55492f6975 --- /dev/null +++ b/tools/AeroTab/input/mineral_gadsx.inp @@ -0,0 +1,61 @@ + 2.500E-01 1.530E+00 3.000E-02 + 3.000E-01 1.530E+00 2.500E-02 + 3.500E-01 1.530E+00 1.700E-02 + 4.000E-01 1.530E+00 1.300E-02 + 4.500E-01 1.530E+00 8.500E-03 + 5.000E-01 1.530E+00 7.800E-03 + 5.500E-01 1.530E+00 5.500E-03 + 6.000E-01 1.530E+00 4.500E-03 + 6.500E-01 1.530E+00 4.500E-03 + 7.000E-01 1.530E+00 4.000E-03 + 7.500E-01 1.530E+00 4.000E-03 + 8.000E-01 1.530E+00 4.000E-03 + 9.000E-01 1.530E+00 4.000E-03 + 1.000E+00 1.530E+00 4.000E-03 + 1.250E+00 1.530E+00 5.000E-03 + 1.500E+00 1.530E+00 5.700E-03 + 1.750E+00 1.530E+00 6.400E-03 + 2.000E+00 1.530E+00 7.600E-03 + 2.500E+00 1.520E+00 1.400E-02 + 3.000E+00 1.520E+00 3.900E-02 + 3.200E+00 1.510E+00 2.400E-02 + 3.390E+00 1.510E+00 1.925E-02 + 3.500E+00 1.510E+00 1.800E-02 + 3.750E+00 1.500E+00 1.200E-02 + 4.000E+00 1.500E+00 6.700E-03 + 4.500E+00 1.500E+00 8.700E-03 + 5.000E+00 1.480E+00 1.800E-02 + 5.500E+00 1.460E+00 3.600E-02 + 6.000E+00 1.440E+00 5.500E-02 + 6.200E+00 1.430E+00 6.300E-02 + 6.500E+00 1.420E+00 5.200E-02 + 7.200E+00 1.460E+00 1.300E-01 + 7.900E+00 1.220E+00 8.900E-02 + 8.200E+00 1.120E+00 1.200E-01 + 8.500E+00 1.060E+00 2.100E-01 + 8.700E+00 1.190E+00 2.900E-01 + 9.000E+00 1.850E+00 4.400E-01 + 9.200E+00 2.220E+00 5.400E-01 + 9.500E+00 2.940E+00 6.500E-01 + 9.800E+00 2.910E+00 6.500E-01 + 1.000E+01 2.570E+00 5.000E-01 + 1.060E+01 1.910E+00 2.500E-01 + 1.100E+01 1.830E+00 2.000E-01 + 1.150E+01 1.810E+00 3.500E-01 + 1.250E+01 1.740E+00 5.000E-01 + 1.300E+01 2.000E+00 3.500E-01 + 1.400E+01 1.630E+00 2.200E-01 + 1.480E+01 1.540E+00 2.400E-01 + 1.500E+01 1.510E+00 2.600E-01 + 1.640E+01 1.470E+00 3.200E-01 + 1.720E+01 1.490E+00 3.700E-01 + 1.800E+01 1.770E+00 4.700E-01 + 1.850E+01 2.050E+00 5.700E-01 + 2.000E+01 2.200E+00 8.200E-01 + 2.130E+01 2.390E+00 9.400E-01 + 2.250E+01 2.690E+00 1.000E+00 + 2.500E+01 2.990E+00 8.000E-01 + 2.790E+01 2.570E+00 7.800E-01 + 3.000E+01 2.420E+00 6.700E-01 + 3.500E+01 2.420E+00 6.200E-01 + 4.000E+01 2.340E+00 7.000E-01 diff --git a/tools/AeroTab/input/mineral_mix.inp b/tools/AeroTab/input/mineral_mix.inp new file mode 100644 index 0000000000..110a288aa1 --- /dev/null +++ b/tools/AeroTab/input/mineral_mix.inp @@ -0,0 +1,16 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for aerosolkomponent i V og IR, +c fra Sokolik & Toon, 1999 (99% quartz, 1% hematitt) og fra Dubovik et al. 2001 (Saudi-Arabia). + +c lambda nr ni + + 0.2 1.66 0.013 ! fra Sokolik and Toon (1999) + 0.25 1.61 0.012 + 0.3 1.58 0.0087 + 0.4 1.57 0.0071 + 0.45 1.56 0.0052 + 0.5 1.56 0.0033 + 0.57 1.56 0.0022 + 0.67 1.55 0.0013 ! fra Dubovik et al. (2001) + 0.87 1.55 0.001 + 1.02 1.55 0.001 + 100.0 1.55 0.001 ! ekstrapolert diff --git a/tools/AeroTab/input/mineral_soktoon99.inp b/tools/AeroTab/input/mineral_soktoon99.inp new file mode 100644 index 0000000000..ee0a905b1f --- /dev/null +++ b/tools/AeroTab/input/mineral_soktoon99.inp @@ -0,0 +1,34 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c aerosolkomponent i V og IR, avlest fra figur i Sokolik & Toon, 1999. + +c lambda nr ni + + 0.2 1.66 0.013 ! alt lest av fra figurer + 0.25 1.61 0.012 + 0.3 1.58 0.0087 + 0.4 1.57 0.0071 + 0.45 1.56 0.0052 + 0.5 1.56 0.0033 + 0.57 1.56 0.0022 + 0.6 1.56 0.0010 + 0.67 1.55 0.00057 + 0.7 1.55 0.00046 + 0.82 1.55 0.00037 + 0.91 1.55 0.00035 + 1.0 1.54 0.00028 + 1.1 1.54 0.00024 + 1.2 1.54 0.00024 + 1.3 1.54 0.00023 + 1.4 1.54 0.00024 + 1.5 1.54 0.00024 + 1.6 1.53 0.00024 + 1.7 1.53 0.00025 + 1.8 1.53 0.00025 + 1.9 1.53 0.00030 + 2.0 1.53 0.00028 + 2.1 1.53 0.00028 + 2.2 1.53 0.00028 + 2.3 1.52 0.00028 + 2.4 1.52 0.00027 + 2.5 1.52 0.00024 + 10.0 1.52 0.00024 ! lagt inn for haand diff --git a/tools/AeroTab/input/minsea.inp b/tools/AeroTab/input/minsea.inp new file mode 100644 index 0000000000..84bb39f52e --- /dev/null +++ b/tools/AeroTab/input/minsea.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for 'minsea' +c aerosolkomponent i V og I, fra 0.845*mineral_gads.inp+0.155*ss_gads.inp: + +c lambda nr ni + + 0.2000E+00 0.1527E+01 0.2959E-01 ! lagt inn for haand + 0.2500E+00 0.1527E+01 0.2535E-01 + 0.3000E+00 0.1527E+01 0.2113E-01 + 0.3500E+00 0.1527E+01 0.1437E-01 + 0.4000E+00 0.1525E+01 0.1099E-01 + 0.4500E+00 0.1525E+01 0.7183E-02 + 0.5000E+00 0.1525E+01 0.6591E-02 + 0.5500E+00 0.1525E+01 0.4648E-02 + 0.6000E+00 0.1524E+01 0.3803E-02 + 0.6500E+00 0.1524E+01 0.3803E-02 + 0.7000E+00 0.1524E+01 0.3380E-02 + 0.7500E+00 0.1524E+01 0.3380E-02 + 0.8000E+00 0.1522E+01 0.3380E-02 + 0.9000E+00 0.1522E+01 0.3387E-02 + 0.1000E+01 0.1521E+01 0.3402E-02 + 0.1250E+01 0.1521E+01 0.4280E-02 + 0.1500E+01 0.1519E+01 0.4905E-02 + 0.1750E+01 0.1518E+01 0.5526E-02 + 0.2000E+01 0.1518E+01 0.6577E-02 + 0.2500E+01 0.1506E+01 0.1245E-01 + 0.3000E+01 0.1534E+01 0.3451E-01 + 0.3200E+01 0.1507E+01 0.2075E-01 + 0.3390E+01 0.1505E+01 0.1658E-01 + 0.3500E+01 0.1505E+01 0.1546E-01 + 0.3750E+01 0.1495E+01 0.1036E-01 + 0.4000E+01 0.1497E+01 0.5879E-02 + 0.4500E+01 0.1498E+01 0.7569E-02 + 0.5000E+01 0.1478E+01 0.1560E-01 + 0.5500E+01 0.1454E+01 0.3098E-01 + 0.6000E+01 0.1435E+01 0.4818E-01 + 0.6200E+01 0.1456E+01 0.5665E-01 + 0.6500E+01 0.1426E+01 0.4472E-01 + 0.7200E+01 0.1454E+01 0.1109E+00 + 0.7900E+01 0.1248E+01 0.7722E-01 + 0.8200E+01 0.1167E+01 0.1045E+00 + 0.8500E+01 0.1125E+01 0.1815E+00 + 0.8700E+01 0.1254E+01 0.2497E+00 + 0.9000E+01 0.1819E+01 0.3761E+00 + 0.9200E+01 0.2125E+01 0.4604E+00 + 0.9500E+01 0.2729E+01 0.5520E+00 + 0.9800E+01 0.2701E+01 0.5517E+00 + 0.1000E+02 0.2410E+01 0.4248E+00 + 0.1060E+02 0.1846E+01 0.2134E+00 + 0.1100E+02 0.1776E+01 0.1712E+00 + 0.1150E+02 0.1759E+01 0.2979E+00 + 0.1250E+02 0.1690E+01 0.4250E+00 + 0.1300E+02 0.1909E+01 0.2985E+00 + 0.1400E+02 0.1596E+01 0.1895E+00 + 0.1480E+02 0.1523E+01 0.2075E+00 + 0.1500E+02 0.1501E+01 0.2251E+00 + 0.1640E+02 0.1484E+01 0.2844E+00 + 0.1720E+02 0.1529E+01 0.3313E+00 + 0.1800E+02 0.1772E+01 0.4173E+00 + 0.1850E+02 0.2007E+01 0.5026E+00 + 0.2000E+02 0.2132E+01 0.7165E+00 + 0.2130E+02 0.2292E+01 0.8199E+00 + 0.2250E+02 0.2546E+01 0.8729E+00 + 0.2500E+02 0.2799E+01 0.7078E+00 + 0.2790E+02 0.2446E+01 0.7017E+00 + 0.3000E+02 0.2319E+01 0.6127E+00 + 0.3500E+02 0.2318E+01 0.6014E+00 + 0.4000E+02 0.2247E+01 0.7465E+00 + 0.1000E+03 0.2247E+01 0.7465E+00 ! lagt inn for haand diff --git a/tools/AeroTab/input/ocean.inp b/tools/AeroTab/input/ocean.inp new file mode 100644 index 0000000000..794f3b8b2e --- /dev/null +++ b/tools/AeroTab/input/ocean.inp @@ -0,0 +1,69 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'oceanic' aerosolkomponent i V og IR, ifoelge d'Almeida et al. + +c lambda nr ni + + 0.20 1.429 2.87e-5 ! WCP-verdier + 0.25 1.404 1.45e-6 + 0.30 1.395 5.83e-7 + 0.35 1.390 1.20e-7 + 0.40 1.385 9.90e-9 + 0.45 1.383 9.90e-9 + 0.50 1.382 6.41e-9 + 0.55 1.381 3.70e-9 + 0.60 1.379 4.26e-9 + 0.65 1.377 1.62e-8 + 0.70 1.376 5.04e-8 + 0.75 1.375 1.09e-6 + 0.80 1.374 6.01e-5 + 0.90 1.373 1.41e-5 + 1.00 1.370 2.43e-5 + 1.25 1.365 3.11e-4 + 1.50 1.360 1.07e-3 + 1.75 1.352 8.50e-4 + 2.00 1.347 2.39e-3 + 2.50 1.309 1.56e-2 + 3.00 1.439 1.97e-1 + 3.20 1.481 6.69e-2 + 3.392 1.439 1.51e-2 + 3.50 1.423 7.17e-3 + 3.75 1.398 2.90e-3 + 4.00 1.388 3.69e-3 + 4.50 1.377 9.97e-3 + 5.00 1.366 9.57e-3 + 5.50 1.333 9.31e-3 + 6.00 1.306 7.96e-2 + 6.20 1.431 6.91e-2 + 6.50 1.374 2.94e-2 + 7.20 1.343 2.49e-2 + 7.90 1.324 2.79e-2 + 8.20 1.324 3.08e-2 + 8.50 1.336 3.36e-2 + 8.70 1.366 3.56e-2 + 9.00 1.373 3.65e-2 + 9.20 1.356 3.71e-2 + 9.50 1.339 3.68e-2 + 9.80 1.324 3.88e-2 + 10.0 1.310 4.06e-2 + 10.951 1.271 5.22e-2 + 11.0 1.246 7.31e-2 + 11.5 1.227 1.05e-1 + 12.5 1.208 1.90e-1 + 13.0 1.221 2.23e-1 + 14.0 1.267 2.31e-1 + 14.8 1.307 2.92e-1 + 15.0 1.321 2.97e-1 + 16.4 1.407 3.31e-1 + 17.2 1.487 3.41e-1 + 18.0 1.525 3.41e-1 + 18.5 1.536 3.39e-1 + 20.0 1.560 3.24e-1 + 21.3 1.568 3.18e-1 + 22.5 1.579 3.16e-1 + 25.0 1.596 3.13e-1 + 27.9 1.612 3.20e-1 + 30.0 1.614 3.20e-1 + 35.0 1.597 3.83e-1 + 40.0 1.582 5.61e-1 + 100.0 1.582 5.61e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/ocean112.inp b/tools/AeroTab/input/ocean112.inp new file mode 100644 index 0000000000..b04d33b029 --- /dev/null +++ b/tools/AeroTab/input/ocean112.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'oceanic' aerosolkomponent i V og IR, ifoelge WCP-112. + +c lambda nr ni + + 0.20 1.429 2.87e-5 + 0.25 1.404 1.45e-6 + 0.30 1.395 5.83e-7 + 0.337 1.392 1.20e-7 + 0.40 1.385 9.90e-9 + 0.488 1.382 6.41e-9 + 0.515 1.381 3.70e-9 + 0.55 1.381 4.26e-9 + 0.633 1.377 1.62e-8 + 0.694 1.376 5.04e-8 + 0.86 1.372 1.09e-6 + 1.06 1.367 6.01e-5 + 1.30 1.365 1.41e-4 + 1.536 1.359 2.43e-4 + 1.80 1.351 3.11e-4 + 2.00 1.347 1.07e-3 + 2.25 1.334 8.50e-4 + 2.50 1.309 2.39e-3 + 2.70 1.249 1.56e-2 + 3.00 1.439 1.97e-1 + 3.20 1.481 6.69e-2 + 3.392 1.439 1.51e-2 + 3.50 1.423 7.17e-3 + 3.75 1.398 2.90e-3 + 4.00 1.388 3.69e-3 + 4.50 1.377 9.97e-3 + 5.00 1.366 9.57e-3 + 5.50 1.333 9.31e-3 + 6.00 1.306 7.96e-2 + 6.20 1.431 6.91e-2 + 6.50 1.374 2.94e-2 + 7.20 1.343 2.49e-2 + 7.90 1.324 2.79e-2 + 8.20 1.324 3.08e-2 + 8.50 1.336 3.36e-2 + 8.70 1.366 3.56e-2 + 9.00 1.373 3.65e-2 + 9.20 1.356 3.71e-2 + 9.50 1.339 3.68e-2 + 9.80 1.324 3.88e-2 + 10.0 1.310 4.06e-2 + 10.951 1.271 5.22e-2 + 11.0 1.246 7.31e-2 + 11.5 1.227 1.05e-1 + 12.5 1.208 1.90e-1 + 13.0 1.221 2.23e-1 + 14.0 1.267 2.71e-1 + 14.8 1.307 2.92e-1 + 15.0 1.321 2.97e-1 + 16.4 1.407 3.31e-1 + 17.2 1.487 3.41e-1 + 18.0 1.525 3.41e-1 + 18.5 1.536 3.39e-1 + 20.0 1.560 3.24e-1 + 21.3 1.568 3.18e-1 + 22.5 1.579 3.16e-1 + 25.0 1.596 3.13e-1 + 27.9 1.612 3.20e-1 + 30.0 1.614 3.20e-1 + 35.0 1.597 3.83e-1 + 40.0 1.582 5.61e-1 + 100.0 1.582 5.61e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/sot.inp b/tools/AeroTab/input/sot.inp new file mode 100644 index 0000000000..5bef9837a9 --- /dev/null +++ b/tools/AeroTab/input/sot.inp @@ -0,0 +1,42 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for sot i +c V og IR, ifoelge Landolt & Boernstein (evt d'Almeida et al./ WCP-112). + +c lambda nr ni + + 0.2 1.50 0.35 + 0.3 1.74 0.47 + 0.4 1.75 0.46 + 0.50 1.75 0.45 + 0.55 1.75 0.44 + 0.694 1.75 0.43 + 0.86 1.75 0.43 + 1.06 1.76 0.44 + 1.3 1.76 0.45 + 1.8 1.79 0.48 + 2.0 1.80 0.49 + 2.5 1.82 0.51 + 3.0 1.84 0.54 + 3.5 1.88 0.56 + 4.0 1.92 0.58 + 4.5 1.94 0.59 + 5.0 1.97 0.60 + 5.5 1.99 0.61 + 6.0 2.02 0.62 + 6.5 2.04 0.63 + 7.9 2.12 0.67 + 8.5 2.15 0.69 + 9.0 2.17 0.70 + 9.5 2.19 0.71 + 10.0 2.21 0.72 + 11.0 2.23 0.73 + 13.0 2.28 0.76 + 14.0 2.31 0.78 + 15.0 2.33 0.79 + 18.0 2.40 0.83 + 20.0 2.45 0.85 + 25.0 2.51 0.89 + 30.0 2.57 0.93 + 40.0 2.69 1.00 + 100.0 2.69 1.00 ! lagt inn for haand + + diff --git a/tools/AeroTab/input/sot_bond.inp b/tools/AeroTab/input/sot_bond.inp new file mode 100644 index 0000000000..e9db4e7b7b --- /dev/null +++ b/tools/AeroTab/input/sot_bond.inp @@ -0,0 +1,9 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c sot i V og IR. Verdiene er fra Scarnato et al. (2013), (0.2-1um egentlig) + +c lambda nr ni + + 0.2 1.95 0.79 + 100.0 1.95 0.79 + + diff --git a/tools/AeroTab/input/sot_gads.inp b/tools/AeroTab/input/sot_gads.inp new file mode 100644 index 0000000000..20cec5c03b --- /dev/null +++ b/tools/AeroTab/input/sot_gads.inp @@ -0,0 +1,43 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for sot i +c V og IR, ifoelge Landolt & Boernstein (evt d'Almeida et al./ WCP-112). + +c lambda nr ni + + 0.2 1.50 0.35 + 0.25 1.62 0.45 ! fra Koepke et al, 1997 (GADS) + 0.3 1.74 0.47 + 0.4 1.75 0.46 + 0.50 1.75 0.45 + 0.55 1.75 0.44 + 0.694 1.75 0.43 + 0.86 1.75 0.43 + 1.06 1.76 0.44 + 1.3 1.76 0.45 + 1.8 1.79 0.48 + 2.0 1.80 0.49 + 2.5 1.82 0.51 + 3.0 1.84 0.54 + 3.5 1.88 0.56 + 4.0 1.92 0.58 + 4.5 1.94 0.59 + 5.0 1.97 0.60 + 5.5 1.99 0.61 + 6.0 2.02 0.62 + 6.5 2.04 0.63 + 7.9 2.12 0.67 + 8.5 2.15 0.69 + 9.0 2.17 0.70 + 9.5 2.19 0.71 + 10.0 2.21 0.72 + 11.0 2.23 0.73 + 13.0 2.28 0.76 + 14.0 2.31 0.78 + 15.0 2.33 0.79 + 18.0 2.40 0.83 + 20.0 2.45 0.85 + 25.0 2.51 0.89 + 30.0 2.57 0.93 + 40.0 2.69 1.00 + 100.0 2.69 1.00 ! lagt inn for haand + + diff --git a/tools/AeroTab/input/sot_janzen.inp b/tools/AeroTab/input/sot_janzen.inp new file mode 100644 index 0000000000..63f6ad572e --- /dev/null +++ b/tools/AeroTab/input/sot_janzen.inp @@ -0,0 +1,9 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c sot i V og IR. Verdiene er fra Janzen, 1979 (0.35-1um egentlig) + +c lambda nr ni + + 0.2 2.0 1.0 + 100.0 2.0 1.0 + + diff --git a/tools/AeroTab/input/ss_gads.inp b/tools/AeroTab/input/ss_gads.inp new file mode 100644 index 0000000000..994a508261 --- /dev/null +++ b/tools/AeroTab/input/ss_gads.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'ssa-ssm-ssc' aerosolkomponent i V og IR, ifoelge Kopke et al. (GADS). + +c lambda nr ni + + 0.20 1.51 9.9e-5 ! lagt inn for hånd + 2.500E-01 1.510E+00 5.000E-06 + 3.000E-01 1.510E+00 2.000E-06 + 3.500E-01 1.510E+00 3.240E-07 + 4.000E-01 1.500E+00 3.000E-08 + 4.500E-01 1.500E+00 2.430E-08 + 5.000E-01 1.500E+00 1.550E-08 + 5.500E-01 1.500E+00 1.000E-08 + 6.000E-01 1.490E+00 1.600E-08 + 6.500E-01 1.490E+00 4.240E-08 + 7.000E-01 1.490E+00 2.000E-07 + 7.500E-01 1.490E+00 1.080E-06 + 8.000E-01 1.480E+00 1.950E-06 + 9.000E-01 1.480E+00 4.240E-05 + 1.000E+00 1.470E+00 1.410E-04 + 1.250E+00 1.470E+00 3.580E-04 + 1.500E+00 1.460E+00 5.700E-04 + 1.750E+00 1.450E+00 7.620E-04 + 2.000E+00 1.450E+00 1.000E-03 + 2.500E+00 1.430E+00 4.000E-03 + 3.000E+00 1.610E+00 1.000E-02 + 3.200E+00 1.490E+00 3.000E-03 + 3.390E+00 1.480E+00 2.050E-03 + 3.500E+00 1.480E+00 1.600E-03 + 3.750E+00 1.470E+00 1.400E-03 + 4.000E+00 1.480E+00 1.400E-03 + 4.500E+00 1.490E+00 1.400E-03 + 5.000E+00 1.470E+00 2.500E-03 + 5.500E+00 1.420E+00 3.600E-03 + 6.000E+00 1.410E+00 1.100E-02 + 6.200E+00 1.600E+00 2.200E-02 + 6.500E+00 1.460E+00 5.000E-03 + 7.200E+00 1.420E+00 7.000E-03 + 7.900E+00 1.400E+00 1.300E-02 + 8.200E+00 1.420E+00 2.000E-02 + 8.500E+00 1.480E+00 2.600E-02 + 8.700E+00 1.600E+00 3.000E-02 + 9.000E+00 1.650E+00 2.800E-02 + 9.200E+00 1.610E+00 2.620E-02 + 9.500E+00 1.580E+00 1.800E-02 + 9.800E+00 1.560E+00 1.600E-02 + 1.000E+01 1.540E+00 1.500E-02 + 1.060E+01 1.500E+00 1.400E-02 + 1.100E+01 1.480E+00 1.400E-02 + 1.150E+01 1.480E+00 1.400E-02 + 1.250E+01 1.420E+00 1.600E-02 + 1.300E+01 1.410E+00 1.800E-02 + 1.400E+01 1.410E+00 2.300E-02 + 1.480E+01 1.430E+00 3.000E-02 + 1.500E+01 1.450E+00 3.500E-02 + 1.640E+01 1.560E+00 9.000E-02 + 1.720E+01 1.740E+00 1.200E-01 + 1.800E+01 1.780E+00 1.300E-01 + 1.850E+01 1.770E+00 1.350E-01 + 2.000E+01 1.760E+00 1.520E-01 + 2.130E+01 1.760E+00 1.650E-01 + 2.250E+01 1.760E+00 1.800E-01 + 2.500E+01 1.760E+00 2.050E-01 + 2.790E+01 1.770E+00 2.750E-01 + 3.000E+01 1.770E+00 3.000E-01 + 3.500E+01 1.760E+00 5.000E-01 + 4.000E+01 1.740E+00 1.000E+00 + 100.0 1.74 1.0 ! lagt inn for haand diff --git a/tools/AeroTab/input/sulfat.inp b/tools/AeroTab/input/sulfat.inp new file mode 100644 index 0000000000..41d2c42221 --- /dev/null +++ b/tools/AeroTab/input/sulfat.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'sulfate' aerosolkomponent i V og IR, ifoelge d'Almeida et al. + +c lambda nr ni + + 0.20 1.469 1.00e-8 ! lagt inn for haand + 0.30 1.469 1.00e-8 + 0.35 1.452 1.00e-8 + 0.40 1.440 1.00e-8 + 0.45 1.432 1.00e-8 + 0.50 1.431 1.00e-8 + 0.55 1.430 1.00e-8 + 0.60 1.429 1.47e-8 + 0.65 1.429 1.47e-8 + 0.70 1.428 1.99e-8 + 0.75 1.427 1.89e-8 + 0.80 1.426 1.70e-7 + 0.90 1.425 1.79e-7 + 1.00 1.423 1.50e-6 + 1.25 1.410 1.00e-5 + 1.50 1.403 1.34e-4 + 1.75 1.390 5.50e-4 + 2.00 1.384 1.26e-3 + 2.50 1.344 3.76e-3 + 3.00 1.293 9.55e-2 + 3.20 1.311 1.35e-1 + 3.392 1.352 1.59e-1 + 3.50 1.376 1.58e-1 + 3.75 1.396 1.31e-1 + 4.00 1.398 1.36e-1 + 4.50 1.385 1.20e-1 + 5.00 1.360 1.21e-1 + 5.50 1.337 1.83e-1 + 6.00 1.425 1.95e-1 + 6.20 1.424 1.65e-1 + 6.50 1.37 1.28e-1 + 7.20 1.21 1.76e-1 + 7.90 1.14 4.88e-1 + 8.20 1.20 6.45e-1 + 8.50 1.37 7.55e-1 + 8.70 1.53 7.72e-1 + 9.00 1.65 6.33e-1 + 9.20 1.60 5.86e-1 + 9.50 1.67 7.50e-1 + 9.80 1.91 6.80e-1 + 10.0 1.89 4.55e-1 + 10.951 1.72 3.40e-1 + 11.0 1.67 4.85e-1 + 11.5 1.89 3.74e-1 + 12.5 1.74 1.98e-1 + 13.0 1.69 1.95e-1 + 14.0 1.64 1.95e-1 + 14.8 1.61 2.05e-1 + 15.0 1.59 2.11e-1 + 16.4 1.52 4.14e-1 + 17.2 1.724 5.90e-1 + 18.0 1.95 4.10e-2 + 18.5 1.927 3.02e-2 + 20.0 1.823 2.35e-2 + 21.3 1.78 2.92e-1 + 22.5 1.87 3.15e-2 + 25.0 1.93 2.00e-1 + 27.9 1.92 1.80e-1 + 30.0 1.92 1.80e-1 + 35.0 1.90 1.90e-1 + 40.0 1.89 2.20e-1 + 100.0 1.89 2.20e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/suso_gads.inp b/tools/AeroTab/input/suso_gads.inp new file mode 100644 index 0000000000..2970d06421 --- /dev/null +++ b/tools/AeroTab/input/suso_gads.inp @@ -0,0 +1,69 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'sulfate' aerosolkomponent i V og IR, ifoelge Koepke et al (GADS). + +c lambda nr ni + + 0.20 1.469 1.00e-8 ! lagt inn for haand + 2.500E-01 1.484E+00 1.000E-08 + 3.000E-01 1.469E+00 1.000E-08 + 3.500E-01 1.452E+00 1.000E-08 + 4.000E-01 1.440E+00 1.000E-08 + 4.500E-01 1.432E+00 1.000E-08 + 5.000E-01 1.431E+00 1.000E-08 + 5.500E-01 1.430E+00 1.000E-08 + 6.000E-01 1.429E+00 1.470E-08 + 6.500E-01 1.429E+00 1.670E-08 + 7.000E-01 1.428E+00 2.050E-08 + 7.500E-01 1.427E+00 7.170E-08 + 8.000E-01 1.426E+00 8.630E-08 + 9.000E-01 1.425E+00 2.550E-07 + 1.000E+00 1.422E+00 1.530E-06 + 1.250E+00 1.413E+00 6.940E-06 + 1.500E+00 1.403E+00 1.200E-04 + 1.750E+00 1.394E+00 4.160E-04 + 2.000E+00 1.384E+00 1.260E-03 + 2.500E+00 1.344E+00 3.760E-03 + 3.000E+00 1.293E+00 9.550E-02 + 3.200E+00 1.311E+00 1.350E-01 + 3.390E+00 1.350E+00 1.578E-01 + 3.500E+00 1.376E+00 1.580E-01 + 3.750E+00 1.396E+00 1.310E-01 + 4.000E+00 1.385E+00 1.260E-01 + 4.500E+00 1.385E+00 1.200E-01 + 5.000E+00 1.360E+00 1.210E-01 + 5.500E+00 1.337E+00 1.830E-01 + 6.000E+00 1.425E+00 1.950E-01 + 6.200E+00 1.424E+00 1.650E-01 + 6.500E+00 1.370E+00 1.280E-01 + 7.200E+00 1.210E+00 1.760E-01 + 7.900E+00 1.140E+00 4.880E-01 + 8.200E+00 1.200E+00 6.450E-01 + 8.500E+00 1.370E+00 7.550E-01 + 8.700E+00 1.530E+00 7.720E-01 + 9.000E+00 1.650E+00 6.330E-01 + 9.200E+00 1.600E+00 5.860E-01 + 9.500E+00 1.670E+00 7.500E-01 + 9.800E+00 1.910E+00 6.800E-01 + 1.000E+01 1.890E+00 4.550E-01 + 1.060E+01 1.720E+00 3.400E-01 + 1.100E+01 1.670E+00 4.850E-01 + 1.150E+01 1.890E+00 3.740E-01 + 1.250E+01 1.740E+00 1.980E-01 + 1.300E+01 1.690E+00 1.950E-01 + 1.400E+01 1.640E+00 1.950E-01 + 1.480E+01 1.610E+00 2.050E-01 + 1.500E+01 1.590E+00 2.110E-01 + 1.640E+01 1.520E+00 4.140E-01 + 1.720E+01 1.724E+00 5.900E-01 + 1.800E+01 1.950E+00 4.100E-02 + 1.850E+01 1.927E+00 3.025E-02 + 2.000E+01 1.823E+00 2.352E-02 + 2.130E+01 1.780E+00 2.925E-01 + 2.250E+01 1.870E+00 3.150E-02 + 2.500E+01 1.930E+00 2.000E-01 + 2.790E+01 1.920E+00 1.800E-01 + 3.000E+01 1.920E+00 1.800E-01 + 3.500E+01 1.900E+00 1.900E-01 + 4.000E+01 1.890E+00 2.200E-01 + 100.0 1.89 2.20e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/waso_gads.inp b/tools/AeroTab/input/waso_gads.inp new file mode 100644 index 0000000000..93034f1617 --- /dev/null +++ b/tools/AeroTab/input/waso_gads.inp @@ -0,0 +1,69 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c WASO aerosolkomponent i V og IR, ifoelge Kopke et al. (GADS) + +c lambda nr ni + + 0.20 1.53 3.0e-2 ! lagt inn for haand + 0.25 1.53 3.0e-2 + 0.30 1.53 8.0e-3 + 0.35 1.53 5.0e-3 + 0.40 1.53 5.0e-3 + 0.45 1.53 5.0e-3 + 0.50 1.53 5.0e-3 + 0.55 1.53 6.0e-3 + 0.60 1.53 6.0e-3 + 0.65 1.53 7.0e-3 + 0.70 1.53 7.0e-3 + 0.75 1.53 8.5e-3 + 0.80 1.52 1.0e-2 + 0.90 1.52 1.15e-2 + 1.00 1.52 1.55e-2 + 1.25 1.51 1.9e-2 + 1.50 1.51 2.25e-2 + 1.75 1.47 1.75e-2 + 2.00 1.42 8.0e-3 + 2.50 1.42 1.2e-2 + 3.00 1.42 2.2e-2 + 3.20 1.43 8.0e-3 + 3.392 1.43 7.0e-3 + 3.50 1.45 5.0e-3 + 3.75 1.452 4.0e-3 + 4.00 1.455 5.0e-3 + 4.50 1.46 1.3e-2 + 5.00 1.45 1.2e-2 + 5.50 1.44 1.8e-2 + 6.00 1.41 2.3e-2 + 6.20 1.43 2.7e-2 + 6.50 1.46 3.3e-2 + 7.20 1.40 7.0e-2 + 7.90 1.20 6.5e-2 + 8.20 1.01 1.0e-1 + 8.50 1.30 2.15e-1 + 8.70 2.40 2.9e-1 + 9.00 2.56 3.7e-1 + 9.20 2.20 4.2e-1 + 9.50 1.95 1.6e-1 + 9.80 1.87 9.5e-2 + 10.0 1.82 9.0e-2 + 10.951 1.76 7.0e-2 + 11.0 1.72 5.0e-2 + 11.5 1.67 4.7e-2 + 12.5 1.62 5.3e-2 + 13.0 1.62 5.5e-2 + 14.0 1.56 7.3e-2 + 14.8 1.44 1.0e-1 + 15.0 1.42 2.0e-1 + 16.4 1.75 1.6e-1 + 17.2 2.08 2.4e-1 + 18.0 1.98 1.8e-1 + 18.5 1.85 1.7e-1 + 20.0 2.12 2.2e-1 + 21.3 2.06 2.3e-1 + 22.5 2.00 2.4e-1 + 25.0 1.88 2.8e-1 + 27.9 1.84 2.9e-1 + 30.0 1.82 3.0e-1 + 35.0 1.92 4.0e-1 + 40.0 1.86 5.0e-1 + 100.0 1.86 5.0e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/waso_transp.inp b/tools/AeroTab/input/waso_transp.inp new file mode 100644 index 0000000000..0c55bd1e62 --- /dev/null +++ b/tools/AeroTab/input/waso_transp.inp @@ -0,0 +1,69 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c WASO aerosolkomponent i V og IR, men test: SUSO-absorpsjon! + +c lambda nr ni + + 0.20 1.53 1.000E-08 + 0.25 1.53 1.000E-08 + 0.30 1.53 1.000E-08 + 0.35 1.53 1.000E-08 + 0.40 1.53 1.000E-08 + 0.45 1.53 1.000E-08 + 0.50 1.53 1.000E-08 + 0.55 1.53 1.000E-08 + 0.60 1.53 1.000E-08 + 0.65 1.53 1.000E-08 + 0.70 1.53 1.000E-08 + 0.75 1.53 1.000E-08 + 0.80 1.52 1.000E-08 + 0.90 1.52 1.000E-08 + 1.00 1.52 1.000E-08 + 1.25 1.51 1.000E-08 + 1.50 1.51 1.000E-08 + 1.75 1.47 1.000E-08 + 2.00 1.42 1.000E-08 + 2.50 1.42 1.000E-08 + 3.00 1.42 1.000E-08 + 3.20 1.43 1.000E-08 + 3.392 1.43 1.000E-08 + 3.50 1.45 1.000E-08 + 3.75 1.452 1.000E-08 + 4.00 1.455 1.000E-08 + 4.50 1.46 1.000E-08 + 5.00 1.45 1.000E-08 + 5.50 1.44 1.000E-08 + 6.00 1.41 1.000E-08 + 6.20 1.43 1.000E-08 + 6.50 1.46 1.000E-08 + 7.20 1.40 1.000E-08 + 7.90 1.20 1.000E-08 + 8.20 1.01 1.000E-08 + 8.50 1.30 1.000E-08 + 8.70 2.40 1.000E-08 + 9.00 2.56 1.000E-08 + 9.20 2.20 1.000E-08 + 9.50 1.95 1.000E-08 + 9.80 1.87 1.000E-08 + 10.0 1.82 1.000E-08 + 10.951 1.76 1.000E-08 + 11.0 1.72 1.000E-08 + 11.5 1.67 1.000E-08 + 12.5 1.62 1.000E-08 + 13.0 1.62 1.000E-08 + 14.0 1.56 1.000E-08 + 14.8 1.44 1.000E-08 + 15.0 1.42 1.000E-08 + 16.4 1.75 1.000E-08 + 17.2 2.08 1.000E-08 + 18.0 1.98 1.000E-08 + 18.5 1.85 1.000E-08 + 20.0 2.12 1.000E-08 + 21.3 2.06 1.000E-08 + 22.5 2.00 1.000E-08 + 25.0 1.88 1.000E-08 + 27.9 1.84 1.000E-08 + 30.0 1.82 1.000E-08 + 35.0 1.92 1.000E-08 + 40.0 1.86 1.000E-08 + 100.0 1.86 1.000E-08 + diff --git a/tools/AeroTab/input/wasoc_ghan.inp b/tools/AeroTab/input/wasoc_ghan.inp new file mode 100644 index 0000000000..6f8d9f01cd --- /dev/null +++ b/tools/AeroTab/input/wasoc_ghan.inp @@ -0,0 +1,7 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c OC i synlig lys. Verdiene er fra Ghan et al. (2001). + +c lambda nr ni + + 0.2 1.55 0.0 + 5.0 1.55 0.0 diff --git a/tools/AeroTab/input/water.inp b/tools/AeroTab/input/water.inp new file mode 100644 index 0000000000..8ac44578b6 --- /dev/null +++ b/tools/AeroTab/input/water.inp @@ -0,0 +1,85 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for 'water' +c aerosolkomponent i V og IR, ifoelge d'Almeida et al, og Hale & Querry(1973). + +c lambda nr ni + + 0.20 1.396 1.10e-7 + 0.225 1.373 4.90e-7 + 0.25 1.362 3.35e-8 + 0.30 1.349 1.60e-8 + 0.35 1.343 6.50e-9 + 0.40 1.339 1.86e-9 + 0.45 1.337 1.02e-9 + 0.50 1.335 1.00e-9 + 0.55 1.333 1.96e-9 + 0.60 1.332 1.09e-8 + 0.65 1.331 1.64e-8 + 0.675 1.331 2.23e-8 + 0.70 1.331 3.35e-8 + 0.725 1.330 9.15e-8 + 0.75 1.330 1.56e-7 + 0.80 1.329 1.25e-7 + 0.85 1.329 2.93e-7 + 0.90 1.328 4.86e-7 + 0.925 1.328 1.06e-6 + 0.95 1.327 2.93e-6 + 1.00 1.327 2.89e-6 + 1.25 1.323 4.69e-5 + 1.50 1.321 1.12e-4 + 1.75 1.313 1.00e-4 + 2.00 1.306 1.10e-3 + 2.50 1.261 1.74e-3 + 2.60 1.242 3.17e-3 + 2.65 1.219 6.70e-3 + 2.70 1.188 1.90e-2 + 2.75 1.157 5.90e-2 + 2.80 1.142 1.15e-1 + 2.90 1.201 2.68e-1 + 3.00 1.371 2.72e-1 + 3.10 1.467 1.92e-1 + 3.20 1.478 9.24e-2 + 3.30 1.450 3.68e-2 + 3.392 1.422 2.04e-2 + 3.50 1.400 9.40e-2 + 3.60 1.385 5.15e-3 + 3.75 1.369 3.50e-3 + 4.00 1.351 4.60e-3 + 4.30 1.338 8.45e-3 + 4.50 1.332 1.34e-2 + 5.00 1.325 1.24e-2 + 5.50 1.298 1.16e-2 + 6.00 1.265 1.07e-2 + 6.20 1.363 8.80e-2 + 6.50 1.339 3.92e-2 + 7.20 1.312 3.21e-2 + 7.90 1.294 3.39e-2 + 8.20 1.286 3.51e-2 + 8.50 1.278 3.67e-2 + 8.70 1.272 3.79e-2 + 9.00 1.262 3.99e-2 + 9.20 1.255 4.15e-2 + 9.50 1.243 4.44e-2 + 9.80 1.229 4.79e-2 + 10.0 1.218 5.08e-2 + 10.951 1.179 6.74e-2 + 11.0 1.153 9.68e-2 + 11.5 1.126 1.14e-1 + 12.5 1.123 2.59e-1 + 13.0 1.246 3.05e-1 + 14.0 1.210 3.70e-1 + 14.8 1.258 3.96e-1 + 15.0 1.270 4.02e-1 + 16.4 1.346 4.27e-1 + 17.2 1.386 4.29e-1 + 18.0 1.423 4.26e-1 + 18.5 1.443 4.21e-1 + 20.0 1.480 3.93e-1 + 21.3 1.491 3.79e-1 + 22.5 1.506 3.70e-1 + 25.0 1.531 3.56e-1 + 27.9 1.549 3.39e-1 + 30.0 1.551 3.28e-1 + 35.0 1.532 3.36e-1 + 40.0 1.519 3.85e-1 + 100.0 1.519 3.85e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/water_gads.inp b/tools/AeroTab/input/water_gads.inp new file mode 100644 index 0000000000..2476cc8cf0 --- /dev/null +++ b/tools/AeroTab/input/water_gads.inp @@ -0,0 +1,70 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for 'water' +c aerosolkomponent i V og IR, ifølge Kopke et al. (GADS). + +c lambda nr ni + + 0.20 1.396 1.10e-7 ! Hale & Querry (1972) + 0.225 1.373 4.90e-7 ! Hale & Querry (1972) + 2.500E-01 1.362E+00 3.350E-08 + 3.000E-01 1.349E+00 1.600E-08 + 3.500E-01 1.343E+00 6.500E-09 + 4.000E-01 1.339E+00 1.860E-09 + 4.500E-01 1.337E+00 1.020E-09 + 5.000E-01 1.335E+00 1.000E-09 + 5.500E-01 1.333E+00 1.960E-09 + 6.000E-01 1.332E+00 1.090E-08 + 6.500E-01 1.331E+00 1.640E-08 + 7.000E-01 1.331E+00 3.350E-08 + 7.500E-01 1.330E+00 1.560E-07 + 8.000E-01 1.329E+00 1.250E-07 + 9.000E-01 1.328E+00 4.860E-07 + 1.000E+00 1.327E+00 2.890E-06 + 1.250E+00 1.323E+00 8.700E-06 + 1.500E+00 1.321E+00 2.000E-04 + 1.750E+00 1.313E+00 1.000E-04 + 2.000E+00 1.306E+00 1.100E-03 + 2.500E+00 1.261E+00 1.740E-03 + 3.000E+00 1.371E+00 2.720E-01 + 3.200E+00 1.478E+00 9.240E-02 + 3.390E+00 1.423E+00 2.314E-02 + 3.500E+00 1.400E+00 9.400E-03 + 3.750E+00 1.369E+00 3.500E-03 + 4.000E+00 1.351E+00 4.600E-03 + 4.500E+00 1.332E+00 1.340E-02 + 5.000E+00 1.325E+00 1.240E-02 + 5.500E+00 1.298E+00 1.160E-02 + 6.000E+00 1.265E+00 1.070E-01 + 6.200E+00 1.363E+00 8.800E-02 + 6.500E+00 1.339E+00 3.920E-02 + 7.200E+00 1.312E+00 3.210E-02 + 7.900E+00 1.294E+00 3.390E-02 + 8.200E+00 1.286E+00 3.510E-02 + 8.500E+00 1.278E+00 3.670E-02 + 8.700E+00 1.272E+00 3.790E-02 + 9.000E+00 1.262E+00 3.990E-02 + 9.200E+00 1.255E+00 4.150E-02 + 9.500E+00 1.243E+00 4.440E-02 + 9.800E+00 1.229E+00 4.790E-02 + 1.000E+01 1.218E+00 5.080E-02 + 1.060E+01 1.179E+00 6.740E-02 + 1.100E+01 1.153E+00 9.680E-02 + 1.150E+01 1.126E+00 1.420E-01 + 1.250E+01 1.123E+00 2.590E-01 + 1.300E+01 1.146E+00 3.050E-01 + 1.400E+01 1.210E+00 3.700E-01 + 1.480E+01 1.258E+00 3.960E-01 + 1.500E+01 1.270E+00 4.020E-01 + 1.640E+01 1.346E+00 4.270E-01 + 1.720E+01 1.386E+00 4.290E-01 + 1.800E+01 1.423E+00 4.260E-01 + 1.850E+01 1.443E+00 4.210E-01 + 2.000E+01 1.480E+00 3.930E-01 + 2.130E+01 1.491E+00 3.790E-01 + 2.250E+01 1.506E+00 3.700E-01 + 2.500E+01 1.531E+00 3.560E-01 + 2.790E+01 1.549E+00 3.390E-01 + 3.000E+01 1.551E+00 3.280E-01 + 3.500E+01 1.532E+00 3.360E-01 + 4.000E+01 1.519E+00 3.850E-01 + 100.0 1.519 3.85e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/wsol.inp b/tools/AeroTab/input/wsol.inp new file mode 100644 index 0000000000..62980b4b2a --- /dev/null +++ b/tools/AeroTab/input/wsol.inp @@ -0,0 +1,68 @@ +c boelgelengde (i um), reell og kompleks brytningsindeks for +c 'water soluble' aerosolkomponent i V og IR, ifoelge d'Almeida et al. + +c lambda nr ni + + 0.20 1.53 8.0e-3 ! lagt inn for haand + 0.30 1.53 8.0e-3 + 0.35 1.53 5.0e-3 + 0.40 1.53 5.0e-3 + 0.45 1.53 5.0e-3 + 0.50 1.53 5.0e-3 + 0.55 1.53 6.0e-3 + 0.60 1.53 6.0e-3 + 0.65 1.53 7.0e-3 + 0.70 1.53 7.0e-3 + 0.75 1.53 8.5e-3 + 0.80 1.52 1.0e-2 + 0.90 1.52 1.15e-2 + 1.00 1.52 1.55e-2 + 1.25 1.51 1.9e-2 + 1.50 1.42 2.25e-2 + 1.75 1.42 1.75e-2 + 2.00 1.42 8.0e-2 + 2.50 1.42 1.2e-2 + 3.00 1.42 2.2e-2 + 3.20 1.43 8.0e-3 + 3.392 1.43 7.0e-3 + 3.50 1.45 5.0e-3 + 3.75 1.452 4.0e-3 + 4.00 1.455 5.0e-3 + 4.50 1.46 1.3e-2 + 5.00 1.45 1.2e-2 + 5.50 1.44 1.8e-2 + 6.00 1.41 2.3e-2 + 6.20 1.43 2.7e-2 + 6.50 1.46 3.3e-2 + 7.20 1.40 7.0e-2 + 7.90 1.20 6.5e-2 + 8.20 1.01 1.0e-1 + 8.50 1.30 2.15e-1 + 8.70 2.40 2.9e-1 + 9.00 2.56 3.7e-1 + 9.20 2.20 4.2e-1 + 9.50 1.95 1.6e-1 + 9.80 1.87 9.5e-2 + 10.0 1.82 9.0e-2 + 10.951 1.76 7.0e-2 + 11.0 1.72 5.0e-2 + 11.5 1.67 4.7e-2 + 12.5 1.62 5.3e-2 + 13.0 1.62 5.5e-2 + 14.0 1.56 7.3e-2 + 14.8 1.44 1.0e-1 + 15.0 1.42 2.0e-1 + 16.4 1.75 1.6e-1 + 17.2 2.08 2.4e-1 + 18.0 1.98 1.8e-1 + 18.5 1.85 1.7e-1 + 20.0 2.12 2.2e-1 + 21.3 2.06 2.3e-1 + 22.5 2.00 2.4e-1 + 25.0 1.88 2.8e-1 + 27.9 1.84 2.9e-1 + 30.0 1.82 3.0e-1 + 35.0 1.92 4.0e-1 + 40.0 1.86 5.0e-1 + 100.0 1.86 5.0e-1 ! lagt inn for haand + diff --git a/tools/AeroTab/input/xtspec.dat b/tools/AeroTab/input/xtspec.dat new file mode 100644 index 0000000000..af6731e57e --- /dev/null +++ b/tools/AeroTab/input/xtspec.dat @@ -0,0 +1,4801 @@ + 200 0.7091E-02 + 201 0.8180E-02 + 202 0.8480E-02 + 203 0.9110E-02 + 204 0.1021E-01 + 205 0.1100E-01 + 206 0.1140E-01 + 207 0.1250E-01 + 208 0.1430E-01 + 209 0.1840E-01 + 210 0.2520E-01 + 211 0.3090E-01 + 212 0.3290E-01 + 213 0.3200E-01 + 214 0.3591E-01 + 215 0.3800E-01 + 216 0.3420E-01 + 217 0.3231E-01 + 218 0.3950E-01 + 219 0.4730E-01 + 220 0.4840E-01 + 221 0.4181E-01 + 222 0.4210E-01 + 223 0.5681E-01 + 224 0.6110E-01 + 225 0.5450E-01 + 226 0.4380E-01 + 227 0.3680E-01 + 228 0.4400E-01 + 229 0.4801E-01 + 230 0.4890E-01 + 231 0.4960E-01 + 232 0.4810E-01 + 233 0.4590E-01 + 234 0.3830E-01 + 235 0.4410E-01 + 236 0.4860E-01 + 237 0.4750E-01 + 238 0.4370E-01 + 239 0.4020E-01 + 240 0.4201E-01 + 241 0.4480E-01 + 242 0.6101E-01 + 243 0.6850E-01 + 244 0.6441E-01 + 245 0.5700E-01 + 246 0.5000E-01 + 247 0.5331E-01 + 248 0.5010E-01 + 249 0.5160E-01 + 250 0.5980E-01 + 251 0.5350E-01 + 252 0.4430E-01 + 253 0.4820E-01 + 254 0.5720E-01 + 255 0.7240E-01 + 256 0.9281E-01 + 257 0.1110E+00 + 258 0.1240E+00 + 259 0.1210E+00 + 260 0.1070E+00 + 261 0.9788E-01 + 262 0.1090E+00 + 263 0.1430E+00 + 264 0.2170E+00 + 265 0.2700E+00 + 266 0.2680E+00 + 267 0.2660E+00 + 268 0.2660E+00 + 269 0.2550E+00 + 270 0.2720E+00 + 271 0.2730E+00 + 272 0.2210E+00 + 273 0.2090E+00 + 274 0.1780E+00 + 275 0.1660E+00 + 276 0.2310E+00 + 277 0.3300E+00 + 278 0.2820E+00 + 279 0.1270E+00 + 280 0.9273E-01 + 281 0.1700E+00 + 282 0.2860E+00 + 283 0.3480E+00 + 284 0.3200E+00 + 285 0.2140E+00 + 286 0.2640E+00 + 287 0.3950E+00 + 288 0.3820E+00 + 289 0.4360E+00 + 290 0.6020E+00 + 291 0.6580E+00 + 292 0.5870E+00 + 293 0.5680E+00 + 294 0.5641E+00 + 295 0.5730E+00 + 296 0.5721E+00 + 297 0.5620E+00 + 298 0.5150E+00 + 299 0.5050E+00 + 300 0.4860E+00 + 301 0.4610E+00 + 302 0.5280E+00 + 303 0.6080E+00 + 304 0.6619E+00 + 305 0.6440E+00 + 306 0.6460E+00 + 307 0.6859E+00 + 308 0.7159E+00 + 309 0.6280E+00 + 310 0.6350E+00 + 311 0.7773E+00 + 312 0.7869E+00 + 313 0.7717E+00 + 314 0.7598E+00 + 315 0.7132E+00 + 316 0.6978E+00 + 317 0.8002E+00 + 318 0.8158E+00 + 319 0.7323E+00 + 320 0.8262E+00 + 321 0.8243E+00 + 322 0.7533E+00 + 323 0.7601E+00 + 324 0.8099E+00 + 325 0.9242E+00 + 326 0.1020E+01 + 327 0.1040E+01 + 328 0.9823E+00 + 329 0.1070E+01 + 330 0.1110E+01 + 331 0.1040E+01 + 332 0.1010E+01 + 333 0.9759E+00 + 334 0.9849E+00 + 335 0.1020E+01 + 336 0.9318E+00 + 337 0.8730E+00 + 338 0.9468E+00 + 339 0.1010E+01 + 340 0.1060E+01 + 341 0.1040E+01 + 342 0.1040E+01 + 343 0.1080E+01 + 344 0.9303E+00 + 345 0.9190E+00 + 346 0.1040E+01 + 347 0.9881E+00 + 348 0.9773E+00 + 349 0.9511E+00 + 350 0.1050E+01 + 351 0.1120E+01 + 352 0.1010E+01 + 353 0.1060E+01 + 354 0.1200E+01 + 355 0.1180E+01 + 356 0.1090E+01 + 357 0.1050E+01 + 358 0.8939E+00 + 359 0.1010E+01 + 360 0.1170E+01 + 361 0.1040E+01 + 362 0.1140E+01 + 363 0.1170E+01 + 364 0.1080E+01 + 365 0.1260E+01 + 366 0.1410E+01 + 367 0.1390E+01 + 368 0.1310E+01 + 369 0.1380E+01 + 370 0.1380E+01 + 371 0.1400E+01 + 372 0.1390E+01 + 373 0.1130E+01 + 374 0.1030E+01 + 375 0.1170E+01 + 376 0.1260E+01 + 377 0.1370E+01 + 378 0.1560E+01 + 379 0.1420E+01 + 380 0.1380E+01 + 381 0.1450E+01 + 382 0.1160E+01 + 383 0.8931E+00 + 384 0.1040E+01 + 385 0.1220E+01 + 386 0.1200E+01 + 387 0.1150E+01 + 388 0.1070E+01 + 389 0.1260E+01 + 390 0.1450E+01 + 391 0.1520E+01 + 392 0.1380E+01 + 393 0.8932E+00 + 394 0.9559E+00 + 395 0.1430E+01 + 396 0.1190E+01 + 397 0.9992E+00 + 398 0.1500E+01 + 399 0.1850E+01 + 400 0.1770E+01 + 401 0.1750E+01 + 402 0.1810E+01 + 403 0.1730E+01 + 404 0.1640E+01 + 405 0.1620E+01 + 406 0.1630E+01 + 407 0.1650E+01 + 408 0.1760E+01 + 409 0.1810E+01 + 410 0.1660E+01 + 411 0.1700E+01 + 412 0.1830E+01 + 413 0.1820E+01 + 414 0.1830E+01 + 415 0.1800E+01 + 416 0.1860E+01 + 417 0.1820E+01 + 418 0.1700E+01 + 419 0.1780E+01 + 420 0.1810E+01 + 421 0.1830E+01 + 422 0.1730E+01 + 423 0.1640E+01 + 424 0.1760E+01 + 425 0.1750E+01 + 426 0.1730E+01 + 427 0.1690E+01 + 428 0.1640E+01 + 429 0.1560E+01 + 430 0.1520E+01 + 431 0.1660E+01 + 432 0.1680E+01 + 433 0.1700E+01 + 434 0.1730E+01 + 435 0.1740E+01 + 436 0.1870E+01 + 437 0.1880E+01 + 438 0.1690E+01 + 439 0.1710E+01 + 440 0.1800E+01 + 441 0.1870E+01 + 442 0.1970E+01 + 443 0.1950E+01 + 444 0.1950E+01 + 445 0.1910E+01 + 446 0.1890E+01 + 447 0.2010E+01 + 448 0.2040E+01 + 449 0.2010E+01 + 450 0.2090E+01 + 451 0.2140E+01 + 452 0.2020E+01 + 453 0.1950E+01 + 454 0.1990E+01 + 455 0.2020E+01 + 456 0.2060E+01 + 457 0.2100E+01 + 458 0.2070E+01 + 459 0.2020E+01 + 460 0.2030E+01 + 461 0.2050E+01 + 462 0.2090E+01 + 463 0.2080E+01 + 464 0.2020E+01 + 465 0.2020E+01 + 466 0.1990E+01 + 467 0.1980E+01 + 468 0.2010E+01 + 469 0.2010E+01 + 470 0.1960E+01 + 471 0.1980E+01 + 472 0.2050E+01 + 473 0.2040E+01 + 474 0.2040E+01 + 475 0.2050E+01 + 476 0.2020E+01 + 477 0.2050E+01 + 478 0.2060E+01 + 479 0.2070E+01 + 480 0.2070E+01 + 481 0.2070E+01 + 482 0.2060E+01 + 483 0.2030E+01 + 484 0.2010E+01 + 485 0.1900E+01 + 486 0.1730E+01 + 487 0.1750E+01 + 488 0.1880E+01 + 489 0.1940E+01 + 490 0.2000E+01 + 491 0.1960E+01 + 492 0.1900E+01 + 493 0.1920E+01 + 494 0.2000E+01 + 495 0.1990E+01 + 496 0.1970E+01 + 497 0.2020E+01 + 498 0.1950E+01 + 499 0.1920E+01 + 500 0.1920E+01 + 501 0.1860E+01 + 502 0.1880E+01 + 503 0.1910E+01 + 504 0.1910E+01 + 505 0.1970E+01 + 506 0.1990E+01 + 507 0.1930E+01 + 508 0.1920E+01 + 509 0.1930E+01 + 510 0.1940E+01 + 511 0.1980E+01 + 512 0.1940E+01 + 513 0.1870E+01 + 514 0.1860E+01 + 515 0.1880E+01 + 516 0.1780E+01 + 517 0.1700E+01 + 518 0.1700E+01 + 519 0.1730E+01 + 520 0.1830E+01 + 521 0.1880E+01 + 522 0.1870E+01 + 523 0.1860E+01 + 524 0.1910E+01 + 525 0.1940E+01 + 526 0.1810E+01 + 527 0.1750E+01 + 528 0.1860E+01 + 529 0.1900E+01 + 530 0.1950E+01 + 531 0.1970E+01 + 532 0.1870E+01 + 533 0.1850E+01 + 534 0.1890E+01 + 535 0.1930E+01 + 536 0.1910E+01 + 537 0.1850E+01 + 538 0.1880E+01 + 539 0.1870E+01 + 540 0.1800E+01 + 541 0.1810E+01 + 542 0.1840E+01 + 543 0.1850E+01 + 544 0.1870E+01 + 545 0.1870E+01 + 546 0.1880E+01 + 547 0.1870E+01 + 548 0.1840E+01 + 549 0.1860E+01 + 550 0.1860E+01 + 551 0.1850E+01 + 552 0.1830E+01 + 553 0.1840E+01 + 554 0.1870E+01 + 555 0.1880E+01 + 556 0.1850E+01 + 557 0.1820E+01 + 558 0.1800E+01 + 559 0.1780E+01 + 560 0.1800E+01 + 561 0.1800E+01 + 562 0.1810E+01 + 563 0.1850E+01 + 564 0.1840E+01 + 565 0.1810E+01 + 566 0.1800E+01 + 567 0.1830E+01 + 568 0.1820E+01 + 569 0.1820E+01 + 570 0.1800E+01 + 571 0.1790E+01 + 572 0.1870E+01 + 573 0.1880E+01 + 574 0.1860E+01 + 575 0.1850E+01 + 576 0.1850E+01 + 577 0.1850E+01 + 578 0.1840E+01 + 579 0.1830E+01 + 580 0.1820E+01 + 581 0.1830E+01 + 582 0.1850E+01 + 583 0.1850E+01 + 584 0.1860E+01 + 585 0.1830E+01 + 586 0.1810E+01 + 587 0.1840E+01 + 588 0.1800E+01 + 589 0.1690E+01 + 590 0.1720E+01 + 591 0.1810E+01 + 592 0.1800E+01 + 593 0.1800E+01 + 594 0.1800E+01 + 595 0.1780E+01 + 596 0.1790E+01 + 597 0.1800E+01 + 598 0.1770E+01 + 599 0.1770E+01 + 600 0.1780E+01 + 601 0.1740E+01 + 602 0.1720E+01 + 603 0.1750E+01 + 604 0.1720E+01 + 605 0.1740E+01 + 606 0.1790E+01 + 607 0.1810E+01 + 608 0.1760E+01 + 609 0.1730E+01 + 610 0.1750E+01 + 611 0.1730E+01 + 612 0.1700E+01 + 613 0.1670E+01 + 614 0.1680E+01 + 615 0.1700E+01 + 616 0.1650E+01 + 617 0.1660E+01 + 618 0.1710E+01 + 619 0.1750E+01 + 620 0.1740E+01 + 621 0.1720E+01 + 622 0.1700E+01 + 623 0.1660E+01 + 624 0.1620E+01 + 625 0.1640E+01 + 626 0.1700E+01 + 627 0.1700E+01 + 628 0.1660E+01 + 629 0.1660E+01 + 630 0.1650E+01 + 631 0.1630E+01 + 632 0.1670E+01 + 633 0.1670E+01 + 634 0.1640E+01 + 635 0.1620E+01 + 636 0.1630E+01 + 637 0.1660E+01 + 638 0.1690E+01 + 639 0.1680E+01 + 640 0.1610E+01 + 641 0.1580E+01 + 642 0.1610E+01 + 643 0.1620E+01 + 644 0.1600E+01 + 645 0.1620E+01 + 646 0.1620E+01 + 647 0.1580E+01 + 648 0.1560E+01 + 649 0.1510E+01 + 650 0.1520E+01 + 651 0.1600E+01 + 652 0.1600E+01 + 653 0.1610E+01 + 654 0.1600E+01 + 655 0.1500E+01 + 656 0.1400E+01 + 657 0.1440E+01 + 658 0.1540E+01 + 659 0.1550E+01 + 660 0.1560E+01 + 661 0.1570E+01 + 662 0.1570E+01 + 663 0.1570E+01 + 664 0.1570E+01 + 665 0.1570E+01 + 666 0.1570E+01 + 667 0.1560E+01 + 668 0.1570E+01 + 669 0.1560E+01 + 670 0.1560E+01 + 671 0.1540E+01 + 672 0.1510E+01 + 673 0.1520E+01 + 674 0.1570E+01 + 675 0.1570E+01 + 676 0.1540E+01 + 677 0.1540E+01 + 678 0.1540E+01 + 679 0.1530E+01 + 680 0.1540E+01 + 681 0.1530E+01 + 682 0.1520E+01 + 683 0.1520E+01 + 684 0.1510E+01 + 685 0.1500E+01 + 686 0.1480E+01 + 687 0.1440E+01 + 688 0.1420E+01 + 689 0.1440E+01 + 690 0.1480E+01 + 691 0.1470E+01 + 692 0.1460E+01 + 693 0.1470E+01 + 694 0.1490E+01 + 695 0.1500E+01 + 696 0.1480E+01 + 697 0.1490E+01 + 698 0.1510E+01 + 699 0.1470E+01 + 700 0.1440E+01 + 701 0.1450E+01 + 702 0.1440E+01 + 703 0.1440E+01 + 704 0.1440E+01 + 705 0.1430E+01 + 706 0.1410E+01 + 707 0.1400E+01 + 708 0.1400E+01 + 709 0.1410E+01 + 710 0.1410E+01 + 711 0.1410E+01 + 712 0.1400E+01 + 713 0.1400E+01 + 714 0.1390E+01 + 715 0.1380E+01 + 716 0.1370E+01 + 717 0.1370E+01 + 718 0.1360E+01 + 719 0.1350E+01 + 720 0.1340E+01 + 721 0.1350E+01 + 722 0.1360E+01 + 723 0.1370E+01 + 724 0.1370E+01 + 725 0.1370E+01 + 726 0.1360E+01 + 727 0.1350E+01 + 728 0.1340E+01 + 729 0.1330E+01 + 730 0.1330E+01 + 731 0.1330E+01 + 732 0.1330E+01 + 733 0.1330E+01 + 734 0.1330E+01 + 735 0.1330E+01 + 736 0.1330E+01 + 737 0.1310E+01 + 738 0.1300E+01 + 739 0.1290E+01 + 740 0.1280E+01 + 741 0.1280E+01 + 742 0.1270E+01 + 743 0.1270E+01 + 744 0.1270E+01 + 745 0.1270E+01 + 746 0.1280E+01 + 747 0.1280E+01 + 748 0.1280E+01 + 749 0.1280E+01 + 750 0.1270E+01 + 751 0.1270E+01 + 752 0.1270E+01 + 753 0.1270E+01 + 754 0.1270E+01 + 755 0.1260E+01 + 756 0.1260E+01 + 757 0.1260E+01 + 758 0.1250E+01 + 759 0.1240E+01 + 760 0.1240E+01 + 761 0.1240E+01 + 762 0.1240E+01 + 763 0.1230E+01 + 764 0.1230E+01 + 765 0.1220E+01 + 766 0.1220E+01 + 767 0.1210E+01 + 768 0.1210E+01 + 769 0.1200E+01 + 770 0.1200E+01 + 771 0.1190E+01 + 772 0.1190E+01 + 773 0.1190E+01 + 774 0.1180E+01 + 775 0.1180E+01 + 776 0.1170E+01 + 777 0.1180E+01 + 778 0.1190E+01 + 779 0.1190E+01 + 780 0.1190E+01 + 781 0.1190E+01 + 782 0.1190E+01 + 783 0.1190E+01 + 784 0.1190E+01 + 785 0.1190E+01 + 786 0.1180E+01 + 787 0.1180E+01 + 788 0.1170E+01 + 789 0.1170E+01 + 790 0.1160E+01 + 791 0.1140E+01 + 792 0.1140E+01 + 793 0.1140E+01 + 794 0.1150E+01 + 795 0.1150E+01 + 796 0.1140E+01 + 797 0.1140E+01 + 798 0.1130E+01 + 799 0.1130E+01 + 800 0.1130E+01 + 801 0.1120E+01 + 802 0.1120E+01 + 803 0.1120E+01 + 804 0.1120E+01 + 805 0.1120E+01 + 806 0.1110E+01 + 807 0.1100E+01 + 808 0.1090E+01 + 809 0.1080E+01 + 810 0.1080E+01 + 811 0.1080E+01 + 812 0.1080E+01 + 813 0.1080E+01 + 814 0.1090E+01 + 815 0.1080E+01 + 816 0.1070E+01 + 817 0.1060E+01 + 818 0.1060E+01 + 819 0.1060E+01 + 820 0.1050E+01 + 821 0.1040E+01 + 822 0.1040E+01 + 823 0.1050E+01 + 824 0.1050E+01 + 825 0.1050E+01 + 826 0.1050E+01 + 827 0.1050E+01 + 828 0.1040E+01 + 829 0.1030E+01 + 830 0.1020E+01 + 831 0.1030E+01 + 832 0.1030E+01 + 833 0.1020E+01 + 834 0.1010E+01 + 835 0.1010E+01 + 836 0.1010E+01 + 837 0.1010E+01 + 838 0.1020E+01 + 839 0.1010E+01 + 840 0.1000E+01 + 841 0.1000E+01 + 842 0.1000E+01 + 843 0.9899E+00 + 844 0.9801E+00 + 845 0.9801E+00 + 846 0.9850E+00 + 847 0.9871E+00 + 848 0.9829E+00 + 849 0.9710E+00 + 850 0.9551E+00 + 851 0.9842E+00 0.7714E-27 + 852 0.9820E+00 0.7677E-27 + 853 0.9799E+00 0.7642E-27 + 854 0.9777E+00 0.7606E-27 + 855 0.9756E+00 0.7570E-27 + 856 0.9734E+00 0.7535E-27 + 857 0.9713E+00 0.7500E-27 + 858 0.9691E+00 0.7465E-27 + 859 0.9670E+00 0.7430E-27 + 860 0.9649E+00 0.7396E-27 + 861 0.9627E+00 0.7361E-27 + 862 0.9606E+00 0.7327E-27 + 863 0.9585E+00 0.7293E-27 + 864 0.9564E+00 0.7260E-27 + 865 0.9542E+00 0.7226E-27 + 866 0.9521E+00 0.7193E-27 + 867 0.9500E+00 0.7160E-27 + 868 0.9479E+00 0.7127E-27 + 869 0.9458E+00 0.7094E-27 + 870 0.9437E+00 0.7062E-27 + 871 0.9416E+00 0.7029E-27 + 872 0.9395E+00 0.6997E-27 + 873 0.9375E+00 0.6965E-27 + 874 0.9354E+00 0.6933E-27 + 875 0.9333E+00 0.6902E-27 + 876 0.9312E+00 0.6870E-27 + 877 0.9292E+00 0.6839E-27 + 878 0.9271E+00 0.6808E-27 + 879 0.9250E+00 0.6777E-27 + 880 0.9230E+00 0.6746E-27 + 881 0.9209E+00 0.6715E-27 + 882 0.9189E+00 0.6685E-27 + 883 0.9168E+00 0.6655E-27 + 884 0.9148E+00 0.6625E-27 + 885 0.9128E+00 0.6595E-27 + 886 0.9107E+00 0.6565E-27 + 887 0.9087E+00 0.6536E-27 + 888 0.9067E+00 0.6506E-27 + 889 0.9046E+00 0.6477E-27 + 890 0.9026E+00 0.6448E-27 + 891 0.9006E+00 0.6419E-27 + 892 0.8986E+00 0.6390E-27 + 893 0.8966E+00 0.6362E-27 + 894 0.8946E+00 0.6333E-27 + 895 0.8926E+00 0.6305E-27 + 896 0.8906E+00 0.6277E-27 + 897 0.8886E+00 0.6249E-27 + 898 0.8866E+00 0.6221E-27 + 899 0.8847E+00 0.6194E-27 + 900 0.8827E+00 0.6166E-27 + 901 0.8807E+00 0.6139E-27 + 902 0.8787E+00 0.6112E-27 + 903 0.8768E+00 0.6085E-27 + 904 0.8748E+00 0.6058E-27 + 905 0.8728E+00 0.6031E-27 + 906 0.8709E+00 0.6004E-27 + 907 0.8689E+00 0.5978E-27 + 908 0.8670E+00 0.5952E-27 + 909 0.8650E+00 0.5925E-27 + 910 0.8631E+00 0.5899E-27 + 911 0.8612E+00 0.5874E-27 + 912 0.8592E+00 0.5848E-27 + 913 0.8573E+00 0.5822E-27 + 914 0.8554E+00 0.5797E-27 + 915 0.8535E+00 0.5772E-27 + 916 0.8516E+00 0.5746E-27 + 917 0.8497E+00 0.5721E-27 + 918 0.8477E+00 0.5696E-27 + 919 0.8458E+00 0.5672E-27 + 920 0.8439E+00 0.5647E-27 + 921 0.8420E+00 0.5623E-27 + 922 0.8402E+00 0.5598E-27 + 923 0.8383E+00 0.5574E-27 + 924 0.8364E+00 0.5550E-27 + 925 0.8345E+00 0.5526E-27 + 926 0.8326E+00 0.5502E-27 + 927 0.8308E+00 0.5478E-27 + 928 0.8289E+00 0.5455E-27 + 929 0.8270E+00 0.5431E-27 + 930 0.8252E+00 0.5408E-27 + 931 0.8233E+00 0.5385E-27 + 932 0.8215E+00 0.5362E-27 + 933 0.8196E+00 0.5339E-27 + 934 0.8178E+00 0.5316E-27 + 935 0.8159E+00 0.5293E-27 + 936 0.8141E+00 0.5271E-27 + 937 0.8123E+00 0.5248E-27 + 938 0.8104E+00 0.5226E-27 + 939 0.8086E+00 0.5204E-27 + 940 0.8068E+00 0.5182E-27 + 941 0.8050E+00 0.5160E-27 + 942 0.8032E+00 0.5138E-27 + 943 0.8014E+00 0.5116E-27 + 944 0.7996E+00 0.5094E-27 + 945 0.7978E+00 0.5073E-27 + 946 0.7960E+00 0.5051E-27 + 947 0.7942E+00 0.5030E-27 + 948 0.7924E+00 0.5009E-27 + 949 0.7906E+00 0.4988E-27 + 950 0.7888E+00 0.4967E-27 + 951 0.7870E+00 0.4946E-27 + 952 0.7853E+00 0.4925E-27 + 953 0.7835E+00 0.4905E-27 + 954 0.7817E+00 0.4884E-27 + 955 0.7800E+00 0.4864E-27 + 956 0.7782E+00 0.4843E-27 + 957 0.7765E+00 0.4823E-27 + 958 0.7747E+00 0.4803E-27 + 959 0.7730E+00 0.4783E-27 + 960 0.7712E+00 0.4763E-27 + 961 0.7695E+00 0.4743E-27 + 962 0.7677E+00 0.4724E-27 + 963 0.7660E+00 0.4704E-27 + 964 0.7643E+00 0.4685E-27 + 965 0.7626E+00 0.4665E-27 + 966 0.7608E+00 0.4646E-27 + 967 0.7591E+00 0.4627E-27 + 968 0.7574E+00 0.4608E-27 + 969 0.7557E+00 0.4589E-27 + 970 0.7540E+00 0.4570E-27 + 971 0.7523E+00 0.4551E-27 + 972 0.7506E+00 0.4532E-27 + 973 0.7489E+00 0.4514E-27 + 974 0.7472E+00 0.4495E-27 + 975 0.7455E+00 0.4477E-27 + 976 0.7439E+00 0.4458E-27 + 977 0.7422E+00 0.4440E-27 + 978 0.7405E+00 0.4422E-27 + 979 0.7388E+00 0.4404E-27 + 980 0.7372E+00 0.4386E-27 + 981 0.7355E+00 0.4368E-27 + 982 0.7339E+00 0.4350E-27 + 983 0.7322E+00 0.4333E-27 + 984 0.7305E+00 0.4315E-27 + 985 0.7289E+00 0.4298E-27 + 986 0.7273E+00 0.4280E-27 + 987 0.7256E+00 0.4263E-27 + 988 0.7240E+00 0.4246E-27 + 989 0.7223E+00 0.4229E-27 + 990 0.7207E+00 0.4211E-27 + 991 0.7191E+00 0.4195E-27 + 992 0.7175E+00 0.4178E-27 + 993 0.7159E+00 0.4161E-27 + 994 0.7142E+00 0.4144E-27 + 995 0.7126E+00 0.4127E-27 + 996 0.7110E+00 0.4111E-27 + 997 0.7094E+00 0.4094E-27 + 998 0.7078E+00 0.4078E-27 + 999 0.7062E+00 0.4062E-27 + 1000 0.7046E+00 0.4046E-27 + 1001 0.7031E+00 0.4029E-27 + 1002 0.7015E+00 0.4013E-27 + 1003 0.6999E+00 0.3997E-27 + 1004 0.6983E+00 0.3981E-27 + 1005 0.6967E+00 0.3966E-27 + 1006 0.6952E+00 0.3950E-27 + 1007 0.6936E+00 0.3934E-27 + 1008 0.6920E+00 0.3919E-27 + 1009 0.6905E+00 0.3903E-27 + 1010 0.6889E+00 0.3888E-27 + 1011 0.6874E+00 0.3872E-27 + 1012 0.6858E+00 0.3857E-27 + 1013 0.6843E+00 0.3842E-27 + 1014 0.6827E+00 0.3827E-27 + 1015 0.6812E+00 0.3812E-27 + 1016 0.6797E+00 0.3797E-27 + 1017 0.6781E+00 0.3782E-27 + 1018 0.6766E+00 0.3767E-27 + 1019 0.6751E+00 0.3752E-27 + 1020 0.6736E+00 0.3737E-27 + 1021 0.6721E+00 0.3723E-27 + 1022 0.6705E+00 0.3708E-27 + 1023 0.6690E+00 0.3694E-27 + 1024 0.6675E+00 0.3679E-27 + 1025 0.6660E+00 0.3665E-27 + 1026 0.6645E+00 0.3651E-27 + 1027 0.6630E+00 0.3637E-27 + 1028 0.6615E+00 0.3622E-27 + 1029 0.6601E+00 0.3608E-27 + 1030 0.6586E+00 0.3594E-27 + 1031 0.6571E+00 0.3580E-27 + 1032 0.6556E+00 0.3567E-27 + 1033 0.6541E+00 0.3553E-27 + 1034 0.6527E+00 0.3539E-27 + 1035 0.6512E+00 0.3525E-27 + 1036 0.6497E+00 0.3512E-27 + 1037 0.6483E+00 0.3498E-27 + 1038 0.6468E+00 0.3485E-27 + 1039 0.6454E+00 0.3471E-27 + 1040 0.6439E+00 0.3458E-27 + 1041 0.6425E+00 0.3445E-27 + 1042 0.6410E+00 0.3432E-27 + 1043 0.6396E+00 0.3419E-27 + 1044 0.6382E+00 0.3405E-27 + 1045 0.6367E+00 0.3392E-27 + 1046 0.6353E+00 0.3379E-27 + 1047 0.6339E+00 0.3367E-27 + 1048 0.6325E+00 0.3354E-27 + 1049 0.6310E+00 0.3341E-27 + 1050 0.6296E+00 0.3328E-27 + 1051 0.6282E+00 0.3316E-27 + 1052 0.6268E+00 0.3303E-27 + 1053 0.6254E+00 0.3291E-27 + 1054 0.6240E+00 0.3278E-27 + 1055 0.6226E+00 0.3266E-27 + 1056 0.6212E+00 0.3253E-27 + 1057 0.6198E+00 0.3241E-27 + 1058 0.6184E+00 0.3229E-27 + 1059 0.6170E+00 0.3217E-27 + 1060 0.6157E+00 0.3204E-27 + 1061 0.6143E+00 0.3192E-27 + 1062 0.6129E+00 0.3180E-27 + 1063 0.6115E+00 0.3168E-27 + 1064 0.6102E+00 0.3157E-27 + 1065 0.6088E+00 0.3145E-27 + 1066 0.6074E+00 0.3133E-27 + 1067 0.6061E+00 0.3121E-27 + 1068 0.6047E+00 0.3110E-27 + 1069 0.6034E+00 0.3098E-27 + 1070 0.6020E+00 0.3086E-27 + 1071 0.6007E+00 0.3075E-27 + 1072 0.5993E+00 0.3063E-27 + 1073 0.5980E+00 0.3052E-27 + 1074 0.5967E+00 0.3041E-27 + 1075 0.5953E+00 0.3029E-27 + 1076 0.5940E+00 0.3018E-27 + 1077 0.5927E+00 0.3007E-27 + 1078 0.5914E+00 0.2996E-27 + 1079 0.5900E+00 0.2985E-27 + 1080 0.5887E+00 0.2974E-27 + 1081 0.5874E+00 0.2963E-27 + 1082 0.5861E+00 0.2952E-27 + 1083 0.5848E+00 0.2941E-27 + 1084 0.5835E+00 0.2930E-27 + 1085 0.5822E+00 0.2919E-27 + 1086 0.5809E+00 0.2908E-27 + 1087 0.5796E+00 0.2898E-27 + 1088 0.5783E+00 0.2887E-27 + 1089 0.5770E+00 0.2877E-27 + 1090 0.5757E+00 0.2866E-27 + 1091 0.5744E+00 0.2855E-27 + 1092 0.5732E+00 0.2845E-27 + 1093 0.5719E+00 0.2835E-27 + 1094 0.5706E+00 0.2824E-27 + 1095 0.5693E+00 0.2814E-27 + 1096 0.5681E+00 0.2804E-27 + 1097 0.5668E+00 0.2794E-27 + 1098 0.5655E+00 0.2783E-27 + 1099 0.5643E+00 0.2773E-27 + 1100 0.5630E+00 0.2763E-27 + 1101 0.5618E+00 0.2753E-27 + 1102 0.5605E+00 0.2743E-27 + 1103 0.5593E+00 0.2733E-27 + 1104 0.5580E+00 0.2723E-27 + 1105 0.5568E+00 0.2713E-27 + 1106 0.5556E+00 0.2704E-27 + 1107 0.5543E+00 0.2694E-27 + 1108 0.5531E+00 0.2684E-27 + 1109 0.5519E+00 0.2675E-27 + 1110 0.5507E+00 0.2665E-27 + 1111 0.5494E+00 0.2655E-27 + 1112 0.5482E+00 0.2646E-27 + 1113 0.5470E+00 0.2636E-27 + 1114 0.5458E+00 0.2627E-27 + 1115 0.5446E+00 0.2617E-27 + 1116 0.5434E+00 0.2608E-27 + 1117 0.5422E+00 0.2599E-27 + 1118 0.5410E+00 0.2589E-27 + 1119 0.5398E+00 0.2580E-27 + 1120 0.5386E+00 0.2571E-27 + 1121 0.5374E+00 0.2562E-27 + 1122 0.5362E+00 0.2553E-27 + 1123 0.5350E+00 0.2544E-27 + 1124 0.5338E+00 0.2535E-27 + 1125 0.5326E+00 0.2526E-27 + 1126 0.5315E+00 0.2517E-27 + 1127 0.5303E+00 0.2508E-27 + 1128 0.5291E+00 0.2499E-27 + 1129 0.5280E+00 0.2490E-27 + 1130 0.5268E+00 0.2481E-27 + 1131 0.5256E+00 0.2472E-27 + 1132 0.5245E+00 0.2464E-27 + 1133 0.5233E+00 0.2455E-27 + 1134 0.5222E+00 0.2446E-27 + 1135 0.5210E+00 0.2438E-27 + 1136 0.5199E+00 0.2429E-27 + 1137 0.5187E+00 0.2421E-27 + 1138 0.5176E+00 0.2412E-27 + 1139 0.5164E+00 0.2404E-27 + 1140 0.5153E+00 0.2395E-27 + 1141 0.5142E+00 0.2387E-27 + 1142 0.5130E+00 0.2379E-27 + 1143 0.5119E+00 0.2370E-27 + 1144 0.5108E+00 0.2362E-27 + 1145 0.5096E+00 0.2354E-27 + 1146 0.5085E+00 0.2346E-27 + 1147 0.5074E+00 0.2337E-27 + 1148 0.5063E+00 0.2329E-27 + 1149 0.5052E+00 0.2321E-27 + 1150 0.5041E+00 0.2313E-27 + 1151 0.5030E+00 0.2305E-27 + 1152 0.5019E+00 0.2297E-27 + 1153 0.5007E+00 0.2289E-27 + 1154 0.4996E+00 0.2281E-27 + 1155 0.4986E+00 0.2273E-27 + 1156 0.4975E+00 0.2265E-27 + 1157 0.4964E+00 0.2258E-27 + 1158 0.4953E+00 0.2250E-27 + 1159 0.4942E+00 0.2242E-27 + 1160 0.4931E+00 0.2234E-27 + 1161 0.4920E+00 0.2227E-27 + 1162 0.4910E+00 0.2219E-27 + 1163 0.4899E+00 0.2211E-27 + 1164 0.4888E+00 0.2204E-27 + 1165 0.4877E+00 0.2196E-27 + 1166 0.4867E+00 0.2189E-27 + 1167 0.4856E+00 0.2181E-27 + 1168 0.4845E+00 0.2174E-27 + 1169 0.4835E+00 0.2166E-27 + 1170 0.4824E+00 0.2159E-27 + 1171 0.4814E+00 0.2152E-27 + 1172 0.4803E+00 0.2144E-27 + 1173 0.4793E+00 0.2137E-27 + 1174 0.4782E+00 0.2130E-27 + 1175 0.4772E+00 0.2122E-27 + 1176 0.4761E+00 0.2115E-27 + 1177 0.4751E+00 0.2108E-27 + 1178 0.4741E+00 0.2101E-27 + 1179 0.4730E+00 0.2094E-27 + 1180 0.4720E+00 0.2087E-27 + 1181 0.4710E+00 0.2080E-27 + 1182 0.4699E+00 0.2073E-27 + 1183 0.4689E+00 0.2066E-27 + 1184 0.4679E+00 0.2059E-27 + 1185 0.4669E+00 0.2052E-27 + 1186 0.4659E+00 0.2045E-27 + 1187 0.4648E+00 0.2038E-27 + 1188 0.4638E+00 0.2031E-27 + 1189 0.4628E+00 0.2024E-27 + 1190 0.4618E+00 0.2017E-27 + 1191 0.4608E+00 0.2011E-27 + 1192 0.4598E+00 0.2004E-27 + 1193 0.4588E+00 0.1997E-27 + 1194 0.4578E+00 0.1990E-27 + 1195 0.4568E+00 0.1984E-27 + 1196 0.4558E+00 0.1977E-27 + 1197 0.4548E+00 0.1971E-27 + 1198 0.4539E+00 0.1964E-27 + 1199 0.4529E+00 0.1957E-27 + 1200 0.4519E+00 0.1951E-27 + 1201 0.4509E+00 0.1944E-27 + 1202 0.4499E+00 0.1938E-27 + 1203 0.4490E+00 0.1932E-27 + 1204 0.4480E+00 0.1925E-27 + 1205 0.4470E+00 0.1919E-27 + 1206 0.4461E+00 0.1912E-27 + 1207 0.4451E+00 0.1906E-27 + 1208 0.4441E+00 0.1900E-27 + 1209 0.4432E+00 0.1894E-27 + 1210 0.4422E+00 0.1887E-27 + 1211 0.4413E+00 0.1881E-27 + 1212 0.4403E+00 0.1875E-27 + 1213 0.4393E+00 0.1869E-27 + 1214 0.4384E+00 0.1863E-27 + 1215 0.4375E+00 0.1856E-27 + 1216 0.4365E+00 0.1850E-27 + 1217 0.4356E+00 0.1844E-27 + 1218 0.4346E+00 0.1838E-27 + 1219 0.4337E+00 0.1832E-27 + 1220 0.4328E+00 0.1826E-27 + 1221 0.4318E+00 0.1820E-27 + 1222 0.4309E+00 0.1814E-27 + 1223 0.4300E+00 0.1808E-27 + 1224 0.4290E+00 0.1802E-27 + 1225 0.4281E+00 0.1797E-27 + 1226 0.4272E+00 0.1791E-27 + 1227 0.4263E+00 0.1785E-27 + 1228 0.4254E+00 0.1779E-27 + 1229 0.4244E+00 0.1773E-27 + 1230 0.4235E+00 0.1767E-27 + 1231 0.4226E+00 0.1762E-27 + 1232 0.4217E+00 0.1756E-27 + 1233 0.4208E+00 0.1750E-27 + 1234 0.4199E+00 0.1745E-27 + 1235 0.4190E+00 0.1739E-27 + 1236 0.4181E+00 0.1733E-27 + 1237 0.4172E+00 0.1728E-27 + 1238 0.4163E+00 0.1722E-27 + 1239 0.4154E+00 0.1717E-27 + 1240 0.4145E+00 0.1711E-27 + 1241 0.4137E+00 0.1706E-27 + 1242 0.4128E+00 0.1700E-27 + 1243 0.4119E+00 0.1695E-27 + 1244 0.4110E+00 0.1689E-27 + 1245 0.4101E+00 0.1684E-27 + 1246 0.4092E+00 0.1678E-27 + 1247 0.4084E+00 0.1673E-27 + 1248 0.4075E+00 0.1668E-27 + 1249 0.4066E+00 0.1662E-27 + 1250 0.4058E+00 0.1657E-27 + 1251 0.4049E+00 0.1652E-27 + 1252 0.4040E+00 0.1646E-27 + 1253 0.4032E+00 0.1641E-27 + 1254 0.4023E+00 0.1636E-27 + 1255 0.4015E+00 0.1631E-27 + 1256 0.4006E+00 0.1626E-27 + 1257 0.3997E+00 0.1620E-27 + 1258 0.3989E+00 0.1615E-27 + 1259 0.3980E+00 0.1610E-27 + 1260 0.3972E+00 0.1605E-27 + 1261 0.3964E+00 0.1600E-27 + 1262 0.3955E+00 0.1595E-27 + 1263 0.3947E+00 0.1590E-27 + 1264 0.3938E+00 0.1585E-27 + 1265 0.3930E+00 0.1580E-27 + 1266 0.3922E+00 0.1575E-27 + 1267 0.3913E+00 0.1570E-27 + 1268 0.3905E+00 0.1565E-27 + 1269 0.3897E+00 0.1560E-27 + 1270 0.3888E+00 0.1555E-27 + 1271 0.3880E+00 0.1550E-27 + 1272 0.3872E+00 0.1545E-27 + 1273 0.3864E+00 0.1541E-27 + 1274 0.3856E+00 0.1536E-27 + 1275 0.3847E+00 0.1531E-27 + 1276 0.3839E+00 0.1526E-27 + 1277 0.3831E+00 0.1521E-27 + 1278 0.3823E+00 0.1517E-27 + 1279 0.3815E+00 0.1512E-27 + 1280 0.3807E+00 0.1507E-27 + 1281 0.3799E+00 0.1502E-27 + 1282 0.3791E+00 0.1498E-27 + 1283 0.3783E+00 0.1493E-27 + 1284 0.3775E+00 0.1488E-27 + 1285 0.3767E+00 0.1484E-27 + 1286 0.3759E+00 0.1479E-27 + 1287 0.3751E+00 0.1475E-27 + 1288 0.3743E+00 0.1470E-27 + 1289 0.3735E+00 0.1465E-27 + 1290 0.3727E+00 0.1461E-27 + 1291 0.3719E+00 0.1456E-27 + 1292 0.3712E+00 0.1452E-27 + 1293 0.3704E+00 0.1447E-27 + 1294 0.3696E+00 0.1443E-27 + 1295 0.3688E+00 0.1438E-27 + 1296 0.3680E+00 0.1434E-27 + 1297 0.3673E+00 0.1430E-27 + 1298 0.3665E+00 0.1425E-27 + 1299 0.3657E+00 0.1421E-27 + 1300 0.3650E+00 0.1416E-27 + 1301 0.3642E+00 0.1412E-27 + 1302 0.3634E+00 0.1408E-27 + 1303 0.3627E+00 0.1403E-27 + 1304 0.3619E+00 0.1399E-27 + 1305 0.3611E+00 0.1395E-27 + 1306 0.3604E+00 0.1391E-27 + 1307 0.3596E+00 0.1386E-27 + 1308 0.3589E+00 0.1382E-27 + 1309 0.3581E+00 0.1378E-27 + 1310 0.3574E+00 0.1374E-27 + 1311 0.3566E+00 0.1370E-27 + 1312 0.3559E+00 0.1365E-27 + 1313 0.3551E+00 0.1361E-27 + 1314 0.3544E+00 0.1357E-27 + 1315 0.3537E+00 0.1353E-27 + 1316 0.3529E+00 0.1349E-27 + 1317 0.3522E+00 0.1345E-27 + 1318 0.3515E+00 0.1341E-27 + 1319 0.3507E+00 0.1337E-27 + 1320 0.3500E+00 0.1333E-27 + 1321 0.3493E+00 0.1329E-27 + 1322 0.3485E+00 0.1324E-27 + 1323 0.3478E+00 0.1320E-27 + 1324 0.3471E+00 0.1317E-27 + 1325 0.3464E+00 0.1313E-27 + 1326 0.3456E+00 0.1309E-27 + 1327 0.3449E+00 0.1305E-27 + 1328 0.3442E+00 0.1301E-27 + 1329 0.3435E+00 0.1297E-27 + 1330 0.3428E+00 0.1293E-27 + 1331 0.3421E+00 0.1289E-27 + 1332 0.3413E+00 0.1285E-27 + 1333 0.3406E+00 0.1281E-27 + 1334 0.3399E+00 0.1277E-27 + 1335 0.3392E+00 0.1274E-27 + 1336 0.3385E+00 0.1270E-27 + 1337 0.3378E+00 0.1266E-27 + 1338 0.3371E+00 0.1262E-27 + 1339 0.3364E+00 0.1259E-27 + 1340 0.3357E+00 0.1255E-27 + 1341 0.3350E+00 0.1251E-27 + 1342 0.3343E+00 0.1247E-27 + 1343 0.3336E+00 0.1244E-27 + 1344 0.3330E+00 0.1240E-27 + 1345 0.3323E+00 0.1236E-27 + 1346 0.3316E+00 0.1233E-27 + 1347 0.3309E+00 0.1229E-27 + 1348 0.3302E+00 0.1225E-27 + 1349 0.3295E+00 0.1222E-27 + 1350 0.3288E+00 0.1218E-27 + 1351 0.3282E+00 0.1214E-27 + 1352 0.3275E+00 0.1211E-27 + 1353 0.3268E+00 0.1207E-27 + 1354 0.3261E+00 0.1204E-27 + 1355 0.3255E+00 0.1200E-27 + 1356 0.3248E+00 0.1197E-27 + 1357 0.3241E+00 0.1193E-27 + 1358 0.3235E+00 0.1190E-27 + 1359 0.3228E+00 0.1186E-27 + 1360 0.3221E+00 0.1183E-27 + 1361 0.3215E+00 0.1179E-27 + 1362 0.3208E+00 0.1176E-27 + 1363 0.3202E+00 0.1172E-27 + 1364 0.3195E+00 0.1169E-27 + 1365 0.3188E+00 0.1165E-27 + 1366 0.3182E+00 0.1162E-27 + 1367 0.3175E+00 0.1159E-27 + 1368 0.3169E+00 0.1155E-27 + 1369 0.3162E+00 0.1152E-27 + 1370 0.3156E+00 0.1148E-27 + 1371 0.3149E+00 0.1145E-27 + 1372 0.3143E+00 0.1142E-27 + 1373 0.3136E+00 0.1138E-27 + 1374 0.3130E+00 0.1135E-27 + 1375 0.3124E+00 0.1132E-27 + 1376 0.3117E+00 0.1129E-27 + 1377 0.3111E+00 0.1125E-27 + 1378 0.3105E+00 0.1122E-27 + 1379 0.3098E+00 0.1119E-27 + 1380 0.3092E+00 0.1115E-27 + 1381 0.3086E+00 0.1112E-27 + 1382 0.3079E+00 0.1109E-27 + 1383 0.3073E+00 0.1106E-27 + 1384 0.3067E+00 0.1103E-27 + 1385 0.3060E+00 0.1099E-27 + 1386 0.3054E+00 0.1096E-27 + 1387 0.3048E+00 0.1093E-27 + 1388 0.3042E+00 0.1090E-27 + 1389 0.3036E+00 0.1087E-27 + 1390 0.3029E+00 0.1084E-27 + 1391 0.3023E+00 0.1081E-27 + 1392 0.3017E+00 0.1078E-27 + 1393 0.3011E+00 0.1074E-27 + 1394 0.3005E+00 0.1071E-27 + 1395 0.2999E+00 0.1068E-27 + 1396 0.2993E+00 0.1065E-27 + 1397 0.2987E+00 0.1062E-27 + 1398 0.2981E+00 0.1059E-27 + 1399 0.2974E+00 0.1056E-27 + 1400 0.2968E+00 0.1053E-27 + 1401 0.2962E+00 0.1050E-27 + 1402 0.2956E+00 0.1047E-27 + 1403 0.2950E+00 0.1044E-27 + 1404 0.2944E+00 0.1041E-27 + 1405 0.2939E+00 0.1038E-27 + 1406 0.2933E+00 0.1035E-27 + 1407 0.2927E+00 0.1032E-27 + 1408 0.2921E+00 0.1029E-27 + 1409 0.2915E+00 0.1026E-27 + 1410 0.2909E+00 0.1024E-27 + 1411 0.2903E+00 0.1021E-27 + 1412 0.2897E+00 0.1018E-27 + 1413 0.2891E+00 0.1015E-27 + 1414 0.2886E+00 0.1012E-27 + 1415 0.2880E+00 0.1009E-27 + 1416 0.2874E+00 0.1006E-27 + 1417 0.2868E+00 0.1003E-27 + 1418 0.2862E+00 0.1001E-27 + 1419 0.2857E+00 0.9978E-28 + 1420 0.2851E+00 0.9950E-28 + 1421 0.2845E+00 0.9922E-28 + 1422 0.2839E+00 0.9894E-28 + 1423 0.2834E+00 0.9866E-28 + 1424 0.2828E+00 0.9839E-28 + 1425 0.2822E+00 0.9811E-28 + 1426 0.2817E+00 0.9784E-28 + 1427 0.2811E+00 0.9756E-28 + 1428 0.2805E+00 0.9729E-28 + 1429 0.2800E+00 0.9702E-28 + 1430 0.2794E+00 0.9675E-28 + 1431 0.2788E+00 0.9648E-28 + 1432 0.2783E+00 0.9621E-28 + 1433 0.2777E+00 0.9594E-28 + 1434 0.2772E+00 0.9567E-28 + 1435 0.2766E+00 0.9540E-28 + 1436 0.2761E+00 0.9514E-28 + 1437 0.2755E+00 0.9487E-28 + 1438 0.2750E+00 0.9461E-28 + 1439 0.2744E+00 0.9435E-28 + 1440 0.2739E+00 0.9409E-28 + 1441 0.2733E+00 0.9383E-28 + 1442 0.2728E+00 0.9357E-28 + 1443 0.2722E+00 0.9331E-28 + 1444 0.2717E+00 0.9305E-28 + 1445 0.2711E+00 0.9279E-28 + 1446 0.2706E+00 0.9253E-28 + 1447 0.2701E+00 0.9228E-28 + 1448 0.2695E+00 0.9202E-28 + 1449 0.2690E+00 0.9177E-28 + 1450 0.2685E+00 0.9152E-28 + 1451 0.2679E+00 0.9127E-28 + 1452 0.2674E+00 0.9101E-28 + 1453 0.2669E+00 0.9076E-28 + 1454 0.2663E+00 0.9051E-28 + 1455 0.2658E+00 0.9027E-28 + 1456 0.2653E+00 0.9002E-28 + 1457 0.2647E+00 0.8977E-28 + 1458 0.2642E+00 0.8953E-28 + 1459 0.2637E+00 0.8928E-28 + 1460 0.2632E+00 0.8904E-28 + 1461 0.2626E+00 0.8879E-28 + 1462 0.2621E+00 0.8855E-28 + 1463 0.2616E+00 0.8831E-28 + 1464 0.2611E+00 0.8807E-28 + 1465 0.2606E+00 0.8783E-28 + 1466 0.2601E+00 0.8759E-28 + 1467 0.2595E+00 0.8735E-28 + 1468 0.2590E+00 0.8711E-28 + 1469 0.2585E+00 0.8687E-28 + 1470 0.2580E+00 0.8664E-28 + 1471 0.2575E+00 0.8640E-28 + 1472 0.2570E+00 0.8617E-28 + 1473 0.2565E+00 0.8593E-28 + 1474 0.2560E+00 0.8570E-28 + 1475 0.2555E+00 0.8547E-28 + 1476 0.2550E+00 0.8524E-28 + 1477 0.2545E+00 0.8501E-28 + 1478 0.2540E+00 0.8478E-28 + 1479 0.2535E+00 0.8455E-28 + 1480 0.2530E+00 0.8432E-28 + 1481 0.2525E+00 0.8409E-28 + 1482 0.2520E+00 0.8387E-28 + 1483 0.2515E+00 0.8364E-28 + 1484 0.2510E+00 0.8341E-28 + 1485 0.2505E+00 0.8319E-28 + 1486 0.2500E+00 0.8297E-28 + 1487 0.2495E+00 0.8274E-28 + 1488 0.2490E+00 0.8252E-28 + 1489 0.2485E+00 0.8230E-28 + 1490 0.2480E+00 0.8208E-28 + 1491 0.2476E+00 0.8186E-28 + 1492 0.2471E+00 0.8164E-28 + 1493 0.2466E+00 0.8142E-28 + 1494 0.2461E+00 0.8120E-28 + 1495 0.2456E+00 0.8099E-28 + 1496 0.2451E+00 0.8077E-28 + 1497 0.2447E+00 0.8055E-28 + 1498 0.2442E+00 0.8034E-28 + 1499 0.2437E+00 0.8013E-28 + 1500 0.2432E+00 0.7991E-28 + 1501 0.2428E+00 0.7970E-28 + 1502 0.2423E+00 0.7949E-28 + 1503 0.2418E+00 0.7928E-28 + 1504 0.2413E+00 0.7907E-28 + 1505 0.2409E+00 0.7886E-28 + 1506 0.2404E+00 0.7865E-28 + 1507 0.2399E+00 0.7844E-28 + 1508 0.2395E+00 0.7823E-28 + 1509 0.2390E+00 0.7802E-28 + 1510 0.2385E+00 0.7782E-28 + 1511 0.2381E+00 0.7761E-28 + 1512 0.2376E+00 0.7741E-28 + 1513 0.2371E+00 0.7720E-28 + 1514 0.2367E+00 0.7700E-28 + 1515 0.2362E+00 0.7679E-28 + 1516 0.2358E+00 0.7659E-28 + 1517 0.2353E+00 0.7639E-28 + 1518 0.2348E+00 0.7619E-28 + 1519 0.2344E+00 0.7599E-28 + 1520 0.2339E+00 0.7579E-28 + 1521 0.2335E+00 0.7559E-28 + 1522 0.2330E+00 0.7539E-28 + 1523 0.2326E+00 0.7519E-28 + 1524 0.2321E+00 0.7500E-28 + 1525 0.2317E+00 0.7480E-28 + 1526 0.2312E+00 0.7460E-28 + 1527 0.2308E+00 0.7441E-28 + 1528 0.2303E+00 0.7421E-28 + 1529 0.2299E+00 0.7402E-28 + 1530 0.2295E+00 0.7383E-28 + 1531 0.2290E+00 0.7363E-28 + 1532 0.2286E+00 0.7344E-28 + 1533 0.2281E+00 0.7325E-28 + 1534 0.2277E+00 0.7306E-28 + 1535 0.2272E+00 0.7287E-28 + 1536 0.2268E+00 0.7268E-28 + 1537 0.2264E+00 0.7249E-28 + 1538 0.2259E+00 0.7230E-28 + 1539 0.2255E+00 0.7211E-28 + 1540 0.2251E+00 0.7193E-28 + 1541 0.2246E+00 0.7174E-28 + 1542 0.2242E+00 0.7155E-28 + 1543 0.2238E+00 0.7137E-28 + 1544 0.2233E+00 0.7118E-28 + 1545 0.2229E+00 0.7100E-28 + 1546 0.2225E+00 0.7082E-28 + 1547 0.2221E+00 0.7063E-28 + 1548 0.2216E+00 0.7045E-28 + 1549 0.2212E+00 0.7027E-28 + 1550 0.2208E+00 0.7009E-28 + 1551 0.2204E+00 0.6991E-28 + 1552 0.2199E+00 0.6973E-28 + 1553 0.2195E+00 0.6955E-28 + 1554 0.2191E+00 0.6937E-28 + 1555 0.2187E+00 0.6919E-28 + 1556 0.2183E+00 0.6901E-28 + 1557 0.2178E+00 0.6884E-28 + 1558 0.2174E+00 0.6866E-28 + 1559 0.2170E+00 0.6848E-28 + 1560 0.2166E+00 0.6831E-28 + 1561 0.2162E+00 0.6813E-28 + 1562 0.2158E+00 0.6796E-28 + 1563 0.2154E+00 0.6779E-28 + 1564 0.2149E+00 0.6761E-28 + 1565 0.2145E+00 0.6744E-28 + 1566 0.2141E+00 0.6727E-28 + 1567 0.2137E+00 0.6710E-28 + 1568 0.2133E+00 0.6693E-28 + 1569 0.2129E+00 0.6676E-28 + 1570 0.2125E+00 0.6659E-28 + 1571 0.2121E+00 0.6642E-28 + 1572 0.2117E+00 0.6625E-28 + 1573 0.2113E+00 0.6608E-28 + 1574 0.2109E+00 0.6591E-28 + 1575 0.2105E+00 0.6574E-28 + 1576 0.2101E+00 0.6558E-28 + 1577 0.2097E+00 0.6541E-28 + 1578 0.2093E+00 0.6525E-28 + 1579 0.2089E+00 0.6508E-28 + 1580 0.2085E+00 0.6492E-28 + 1581 0.2081E+00 0.6475E-28 + 1582 0.2077E+00 0.6459E-28 + 1583 0.2073E+00 0.6442E-28 + 1584 0.2069E+00 0.6426E-28 + 1585 0.2065E+00 0.6410E-28 + 1586 0.2061E+00 0.6394E-28 + 1587 0.2058E+00 0.6378E-28 + 1588 0.2054E+00 0.6362E-28 + 1589 0.2050E+00 0.6346E-28 + 1590 0.2046E+00 0.6330E-28 + 1591 0.2042E+00 0.6314E-28 + 1592 0.2038E+00 0.6298E-28 + 1593 0.2034E+00 0.6282E-28 + 1594 0.2031E+00 0.6266E-28 + 1595 0.2027E+00 0.6251E-28 + 1596 0.2023E+00 0.6235E-28 + 1597 0.2019E+00 0.6220E-28 + 1598 0.2015E+00 0.6204E-28 + 1599 0.2012E+00 0.6188E-28 + 1600 0.2008E+00 0.6173E-28 + 1601 0.2004E+00 0.6158E-28 + 1602 0.2000E+00 0.6142E-28 + 1603 0.1996E+00 0.6127E-28 + 1604 0.1993E+00 0.6112E-28 + 1605 0.1989E+00 0.6096E-28 + 1606 0.1985E+00 0.6081E-28 + 1607 0.1981E+00 0.6066E-28 + 1608 0.1978E+00 0.6051E-28 + 1609 0.1974E+00 0.6036E-28 + 1610 0.1970E+00 0.6021E-28 + 1611 0.1967E+00 0.6006E-28 + 1612 0.1963E+00 0.5991E-28 + 1613 0.1959E+00 0.5976E-28 + 1614 0.1956E+00 0.5962E-28 + 1615 0.1952E+00 0.5947E-28 + 1616 0.1948E+00 0.5932E-28 + 1617 0.1945E+00 0.5917E-28 + 1618 0.1941E+00 0.5903E-28 + 1619 0.1937E+00 0.5888E-28 + 1620 0.1934E+00 0.5874E-28 + 1621 0.1930E+00 0.5859E-28 + 1622 0.1927E+00 0.5845E-28 + 1623 0.1923E+00 0.5830E-28 + 1624 0.1919E+00 0.5816E-28 + 1625 0.1916E+00 0.5802E-28 + 1626 0.1912E+00 0.5788E-28 + 1627 0.1909E+00 0.5773E-28 + 1628 0.1905E+00 0.5759E-28 + 1629 0.1902E+00 0.5745E-28 + 1630 0.1898E+00 0.5731E-28 + 1631 0.1895E+00 0.5717E-28 + 1632 0.1891E+00 0.5703E-28 + 1633 0.1888E+00 0.5689E-28 + 1634 0.1884E+00 0.5675E-28 + 1635 0.1881E+00 0.5661E-28 + 1636 0.1877E+00 0.5647E-28 + 1637 0.1874E+00 0.5634E-28 + 1638 0.1870E+00 0.5620E-28 + 1639 0.1867E+00 0.5606E-28 + 1640 0.1863E+00 0.5592E-28 + 1641 0.1860E+00 0.5579E-28 + 1642 0.1856E+00 0.5565E-28 + 1643 0.1853E+00 0.5552E-28 + 1644 0.1849E+00 0.5538E-28 + 1645 0.1846E+00 0.5525E-28 + 1646 0.1843E+00 0.5511E-28 + 1647 0.1839E+00 0.5498E-28 + 1648 0.1836E+00 0.5485E-28 + 1649 0.1832E+00 0.5471E-28 + 1650 0.1829E+00 0.5458E-28 + 1651 0.1826E+00 0.5445E-28 + 1652 0.1822E+00 0.5432E-28 + 1653 0.1819E+00 0.5419E-28 + 1654 0.1816E+00 0.5405E-28 + 1655 0.1812E+00 0.5392E-28 + 1656 0.1809E+00 0.5379E-28 + 1657 0.1806E+00 0.5366E-28 + 1658 0.1802E+00 0.5354E-28 + 1659 0.1799E+00 0.5341E-28 + 1660 0.1796E+00 0.5328E-28 + 1661 0.1792E+00 0.5315E-28 + 1662 0.1789E+00 0.5302E-28 + 1663 0.1786E+00 0.5289E-28 + 1664 0.1782E+00 0.5277E-28 + 1665 0.1779E+00 0.5264E-28 + 1666 0.1776E+00 0.5251E-28 + 1667 0.1773E+00 0.5239E-28 + 1668 0.1769E+00 0.5226E-28 + 1669 0.1766E+00 0.5214E-28 + 1670 0.1763E+00 0.5201E-28 + 1671 0.1760E+00 0.5189E-28 + 1672 0.1757E+00 0.5176E-28 + 1673 0.1753E+00 0.5164E-28 + 1674 0.1750E+00 0.5152E-28 + 1675 0.1747E+00 0.5139E-28 + 1676 0.1744E+00 0.5127E-28 + 1677 0.1741E+00 0.5115E-28 + 1678 0.1737E+00 0.5103E-28 + 1679 0.1734E+00 0.5091E-28 + 1680 0.1731E+00 0.5079E-28 + 1681 0.1728E+00 0.5066E-28 + 1682 0.1725E+00 0.5054E-28 + 1683 0.1722E+00 0.5042E-28 + 1684 0.1718E+00 0.5030E-28 + 1685 0.1715E+00 0.5019E-28 + 1686 0.1712E+00 0.5007E-28 + 1687 0.1709E+00 0.4995E-28 + 1688 0.1706E+00 0.4983E-28 + 1689 0.1703E+00 0.4971E-28 + 1690 0.1700E+00 0.4959E-28 + 1691 0.1697E+00 0.4948E-28 + 1692 0.1694E+00 0.4936E-28 + 1693 0.1691E+00 0.4924E-28 + 1694 0.1687E+00 0.4913E-28 + 1695 0.1684E+00 0.4901E-28 + 1696 0.1681E+00 0.4890E-28 + 1697 0.1678E+00 0.4878E-28 + 1698 0.1675E+00 0.4867E-28 + 1699 0.1672E+00 0.4855E-28 + 1700 0.1669E+00 0.4844E-28 + 1701 0.1666E+00 0.4832E-28 + 1702 0.1663E+00 0.4821E-28 + 1703 0.1660E+00 0.4810E-28 + 1704 0.1657E+00 0.4798E-28 + 1705 0.1654E+00 0.4787E-28 + 1706 0.1651E+00 0.4776E-28 + 1707 0.1648E+00 0.4765E-28 + 1708 0.1645E+00 0.4754E-28 + 1709 0.1642E+00 0.4743E-28 + 1710 0.1639E+00 0.4731E-28 + 1711 0.1636E+00 0.4720E-28 + 1712 0.1633E+00 0.4709E-28 + 1713 0.1630E+00 0.4698E-28 + 1714 0.1627E+00 0.4687E-28 + 1715 0.1625E+00 0.4676E-28 + 1716 0.1622E+00 0.4666E-28 + 1717 0.1619E+00 0.4655E-28 + 1718 0.1616E+00 0.4644E-28 + 1719 0.1613E+00 0.4633E-28 + 1720 0.1610E+00 0.4622E-28 + 1721 0.1607E+00 0.4612E-28 + 1722 0.1604E+00 0.4601E-28 + 1723 0.1601E+00 0.4590E-28 + 1724 0.1598E+00 0.4580E-28 + 1725 0.1596E+00 0.4569E-28 + 1726 0.1593E+00 0.4558E-28 + 1727 0.1590E+00 0.4548E-28 + 1728 0.1587E+00 0.4537E-28 + 1729 0.1584E+00 0.4527E-28 + 1730 0.1581E+00 0.4516E-28 + 1731 0.1579E+00 0.4506E-28 + 1732 0.1576E+00 0.4496E-28 + 1733 0.1573E+00 0.4485E-28 + 1734 0.1570E+00 0.4475E-28 + 1735 0.1567E+00 0.4465E-28 + 1736 0.1565E+00 0.4454E-28 + 1737 0.1562E+00 0.4444E-28 + 1738 0.1559E+00 0.4434E-28 + 1739 0.1556E+00 0.4424E-28 + 1740 0.1553E+00 0.4413E-28 + 1741 0.1551E+00 0.4403E-28 + 1742 0.1548E+00 0.4393E-28 + 1743 0.1545E+00 0.4383E-28 + 1744 0.1542E+00 0.4373E-28 + 1745 0.1540E+00 0.4363E-28 + 1746 0.1537E+00 0.4353E-28 + 1747 0.1534E+00 0.4343E-28 + 1748 0.1531E+00 0.4333E-28 + 1749 0.1529E+00 0.4323E-28 + 1750 0.1526E+00 0.4313E-28 + 1751 0.1523E+00 0.4304E-28 + 1752 0.1521E+00 0.4294E-28 + 1753 0.1518E+00 0.4284E-28 + 1754 0.1515E+00 0.4274E-28 + 1755 0.1512E+00 0.4265E-28 + 1756 0.1510E+00 0.4255E-28 + 1757 0.1507E+00 0.4245E-28 + 1758 0.1504E+00 0.4235E-28 + 1759 0.1502E+00 0.4226E-28 + 1760 0.1499E+00 0.4216E-28 + 1761 0.1496E+00 0.4207E-28 + 1762 0.1494E+00 0.4197E-28 + 1763 0.1491E+00 0.4188E-28 + 1764 0.1489E+00 0.4178E-28 + 1765 0.1486E+00 0.4169E-28 + 1766 0.1483E+00 0.4159E-28 + 1767 0.1481E+00 0.4150E-28 + 1768 0.1478E+00 0.4140E-28 + 1769 0.1475E+00 0.4131E-28 + 1770 0.1473E+00 0.4122E-28 + 1771 0.1470E+00 0.4112E-28 + 1772 0.1468E+00 0.4103E-28 + 1773 0.1465E+00 0.4094E-28 + 1774 0.1463E+00 0.4085E-28 + 1775 0.1460E+00 0.4076E-28 + 1776 0.1457E+00 0.4066E-28 + 1777 0.1455E+00 0.4057E-28 + 1778 0.1452E+00 0.4048E-28 + 1779 0.1450E+00 0.4039E-28 + 1780 0.1447E+00 0.4030E-28 + 1781 0.1445E+00 0.4021E-28 + 1782 0.1442E+00 0.4012E-28 + 1783 0.1440E+00 0.4003E-28 + 1784 0.1437E+00 0.3994E-28 + 1785 0.1434E+00 0.3985E-28 + 1786 0.1432E+00 0.3976E-28 + 1787 0.1429E+00 0.3967E-28 + 1788 0.1427E+00 0.3958E-28 + 1789 0.1424E+00 0.3949E-28 + 1790 0.1422E+00 0.3941E-28 + 1791 0.1419E+00 0.3932E-28 + 1792 0.1417E+00 0.3923E-28 + 1793 0.1415E+00 0.3914E-28 + 1794 0.1412E+00 0.3906E-28 + 1795 0.1410E+00 0.3897E-28 + 1796 0.1407E+00 0.3888E-28 + 1797 0.1405E+00 0.3880E-28 + 1798 0.1402E+00 0.3871E-28 + 1799 0.1400E+00 0.3862E-28 + 1800 0.1397E+00 0.3854E-28 + 1801 0.1395E+00 0.3845E-28 + 1802 0.1392E+00 0.3837E-28 + 1803 0.1390E+00 0.3828E-28 + 1804 0.1388E+00 0.3820E-28 + 1805 0.1385E+00 0.3811E-28 + 1806 0.1383E+00 0.3803E-28 + 1807 0.1380E+00 0.3794E-28 + 1808 0.1378E+00 0.3786E-28 + 1809 0.1376E+00 0.3778E-28 + 1810 0.1373E+00 0.3769E-28 + 1811 0.1371E+00 0.3761E-28 + 1812 0.1368E+00 0.3753E-28 + 1813 0.1366E+00 0.3744E-28 + 1814 0.1364E+00 0.3736E-28 + 1815 0.1361E+00 0.3728E-28 + 1816 0.1359E+00 0.3720E-28 + 1817 0.1357E+00 0.3712E-28 + 1818 0.1354E+00 0.3703E-28 + 1819 0.1352E+00 0.3695E-28 + 1820 0.1350E+00 0.3687E-28 + 1821 0.1347E+00 0.3679E-28 + 1822 0.1345E+00 0.3671E-28 + 1823 0.1343E+00 0.3663E-28 + 1824 0.1340E+00 0.3655E-28 + 1825 0.1338E+00 0.3647E-28 + 1826 0.1336E+00 0.3639E-28 + 1827 0.1333E+00 0.3631E-28 + 1828 0.1331E+00 0.3623E-28 + 1829 0.1329E+00 0.3615E-28 + 1830 0.1327E+00 0.3607E-28 + 1831 0.1324E+00 0.3599E-28 + 1832 0.1322E+00 0.3591E-28 + 1833 0.1320E+00 0.3584E-28 + 1834 0.1317E+00 0.3576E-28 + 1835 0.1315E+00 0.3568E-28 + 1836 0.1313E+00 0.3560E-28 + 1837 0.1311E+00 0.3553E-28 + 1838 0.1308E+00 0.3545E-28 + 1839 0.1306E+00 0.3537E-28 + 1840 0.1304E+00 0.3529E-28 + 1841 0.1302E+00 0.3522E-28 + 1842 0.1299E+00 0.3514E-28 + 1843 0.1297E+00 0.3507E-28 + 1844 0.1295E+00 0.3499E-28 + 1845 0.1293E+00 0.3491E-28 + 1846 0.1291E+00 0.3484E-28 + 1847 0.1288E+00 0.3476E-28 + 1848 0.1286E+00 0.3469E-28 + 1849 0.1284E+00 0.3461E-28 + 1850 0.1282E+00 0.3454E-28 + 1851 0.1280E+00 0.3446E-28 + 1852 0.1277E+00 0.3439E-28 + 1853 0.1275E+00 0.3431E-28 + 1854 0.1273E+00 0.3424E-28 + 1855 0.1271E+00 0.3417E-28 + 1856 0.1269E+00 0.3409E-28 + 1857 0.1266E+00 0.3402E-28 + 1858 0.1264E+00 0.3395E-28 + 1859 0.1262E+00 0.3387E-28 + 1860 0.1260E+00 0.3380E-28 + 1861 0.1258E+00 0.3373E-28 + 1862 0.1256E+00 0.3366E-28 + 1863 0.1254E+00 0.3358E-28 + 1864 0.1251E+00 0.3351E-28 + 1865 0.1249E+00 0.3344E-28 + 1866 0.1247E+00 0.3337E-28 + 1867 0.1245E+00 0.3330E-28 + 1868 0.1243E+00 0.3323E-28 + 1869 0.1241E+00 0.3315E-28 + 1870 0.1239E+00 0.3308E-28 + 1871 0.1237E+00 0.3301E-28 + 1872 0.1235E+00 0.3294E-28 + 1873 0.1232E+00 0.3287E-28 + 1874 0.1230E+00 0.3280E-28 + 1875 0.1228E+00 0.3273E-28 + 1876 0.1226E+00 0.3266E-28 + 1877 0.1224E+00 0.3259E-28 + 1878 0.1222E+00 0.3252E-28 + 1879 0.1220E+00 0.3245E-28 + 1880 0.1218E+00 0.3239E-28 + 1881 0.1216E+00 0.3232E-28 + 1882 0.1214E+00 0.3225E-28 + 1883 0.1212E+00 0.3218E-28 + 1884 0.1210E+00 0.3211E-28 + 1885 0.1208E+00 0.3204E-28 + 1886 0.1206E+00 0.3198E-28 + 1887 0.1204E+00 0.3191E-28 + 1888 0.1202E+00 0.3184E-28 + 1889 0.1200E+00 0.3177E-28 + 1890 0.1197E+00 0.3171E-28 + 1891 0.1195E+00 0.3164E-28 + 1892 0.1193E+00 0.3157E-28 + 1893 0.1191E+00 0.3150E-28 + 1894 0.1189E+00 0.3144E-28 + 1895 0.1187E+00 0.3137E-28 + 1896 0.1185E+00 0.3131E-28 + 1897 0.1183E+00 0.3124E-28 + 1898 0.1181E+00 0.3117E-28 + 1899 0.1179E+00 0.3111E-28 + 1900 0.1177E+00 0.3104E-28 + 1901 0.1176E+00 0.3098E-28 + 1902 0.1174E+00 0.3091E-28 + 1903 0.1172E+00 0.3085E-28 + 1904 0.1170E+00 0.3078E-28 + 1905 0.1168E+00 0.3072E-28 + 1906 0.1166E+00 0.3065E-28 + 1907 0.1164E+00 0.3059E-28 + 1908 0.1162E+00 0.3053E-28 + 1909 0.1160E+00 0.3046E-28 + 1910 0.1158E+00 0.3040E-28 + 1911 0.1156E+00 0.3033E-28 + 1912 0.1154E+00 0.3027E-28 + 1913 0.1152E+00 0.3021E-28 + 1914 0.1150E+00 0.3014E-28 + 1915 0.1148E+00 0.3008E-28 + 1916 0.1146E+00 0.3002E-28 + 1917 0.1144E+00 0.2996E-28 + 1918 0.1143E+00 0.2989E-28 + 1919 0.1141E+00 0.2983E-28 + 1920 0.1139E+00 0.2977E-28 + 1921 0.1137E+00 0.2971E-28 + 1922 0.1135E+00 0.2965E-28 + 1923 0.1133E+00 0.2958E-28 + 1924 0.1131E+00 0.2952E-28 + 1925 0.1129E+00 0.2946E-28 + 1926 0.1127E+00 0.2940E-28 + 1927 0.1126E+00 0.2934E-28 + 1928 0.1124E+00 0.2928E-28 + 1929 0.1122E+00 0.2922E-28 + 1930 0.1120E+00 0.2916E-28 + 1931 0.1118E+00 0.2910E-28 + 1932 0.1116E+00 0.2904E-28 + 1933 0.1114E+00 0.2898E-28 + 1934 0.1113E+00 0.2892E-28 + 1935 0.1111E+00 0.2886E-28 + 1936 0.1109E+00 0.2880E-28 + 1937 0.1107E+00 0.2874E-28 + 1938 0.1105E+00 0.2868E-28 + 1939 0.1103E+00 0.2862E-28 + 1940 0.1102E+00 0.2856E-28 + 1941 0.1100E+00 0.2850E-28 + 1942 0.1098E+00 0.2844E-28 + 1943 0.1096E+00 0.2838E-28 + 1944 0.1094E+00 0.2833E-28 + 1945 0.1092E+00 0.2827E-28 + 1946 0.1091E+00 0.2821E-28 + 1947 0.1089E+00 0.2815E-28 + 1948 0.1087E+00 0.2809E-28 + 1949 0.1085E+00 0.2804E-28 + 1950 0.1083E+00 0.2798E-28 + 1951 0.1082E+00 0.2792E-28 + 1952 0.1080E+00 0.2786E-28 + 1953 0.1078E+00 0.2781E-28 + 1954 0.1076E+00 0.2775E-28 + 1955 0.1075E+00 0.2769E-28 + 1956 0.1073E+00 0.2764E-28 + 1957 0.1071E+00 0.2758E-28 + 1958 0.1069E+00 0.2752E-28 + 1959 0.1068E+00 0.2747E-28 + 1960 0.1066E+00 0.2741E-28 + 1961 0.1064E+00 0.2736E-28 + 1962 0.1062E+00 0.2730E-28 + 1963 0.1061E+00 0.2725E-28 + 1964 0.1059E+00 0.2719E-28 + 1965 0.1057E+00 0.2713E-28 + 1966 0.1055E+00 0.2708E-28 + 1967 0.1054E+00 0.2702E-28 + 1968 0.1052E+00 0.2697E-28 + 1969 0.1050E+00 0.2692E-28 + 1970 0.1048E+00 0.2686E-28 + 1971 0.1047E+00 0.2681E-28 + 1972 0.1045E+00 0.2675E-28 + 1973 0.1043E+00 0.2670E-28 + 1974 0.1042E+00 0.2664E-28 + 1975 0.1040E+00 0.2659E-28 + 1976 0.1038E+00 0.2654E-28 + 1977 0.1036E+00 0.2648E-28 + 1978 0.1035E+00 0.2643E-28 + 1979 0.1033E+00 0.2638E-28 + 1980 0.1031E+00 0.2632E-28 + 1981 0.1030E+00 0.2627E-28 + 1982 0.1028E+00 0.2622E-28 + 1983 0.1026E+00 0.2616E-28 + 1984 0.1025E+00 0.2611E-28 + 1985 0.1023E+00 0.2606E-28 + 1986 0.1021E+00 0.2601E-28 + 1987 0.1020E+00 0.2595E-28 + 1988 0.1018E+00 0.2590E-28 + 1989 0.1016E+00 0.2585E-28 + 1990 0.1015E+00 0.2580E-28 + 1991 0.1013E+00 0.2574E-28 + 1992 0.1011E+00 0.2569E-28 + 1993 0.1010E+00 0.2564E-28 + 1994 0.1008E+00 0.2559E-28 + 1995 0.1007E+00 0.2554E-28 + 1996 0.1005E+00 0.2549E-28 + 1997 0.1003E+00 0.2544E-28 + 1998 0.1002E+00 0.2539E-28 + 1999 0.1000E+00 0.2534E-28 + 2000 0.9984E-01 0.2528E-28 + 2001 0.9968E-01 0.2523E-28 + 2002 0.9952E-01 0.2518E-28 + 2003 0.9936E-01 0.2513E-28 + 2004 0.9920E-01 0.2508E-28 + 2005 0.9904E-01 0.2503E-28 + 2006 0.9888E-01 0.2498E-28 + 2007 0.9872E-01 0.2493E-28 + 2008 0.9856E-01 0.2488E-28 + 2009 0.9840E-01 0.2483E-28 + 2010 0.9824E-01 0.2479E-28 + 2011 0.9808E-01 0.2474E-28 + 2012 0.9793E-01 0.2469E-28 + 2013 0.9777E-01 0.2464E-28 + 2014 0.9761E-01 0.2459E-28 + 2015 0.9745E-01 0.2454E-28 + 2016 0.9730E-01 0.2449E-28 + 2017 0.9714E-01 0.2444E-28 + 2018 0.9698E-01 0.2439E-28 + 2019 0.9683E-01 0.2435E-28 + 2020 0.9667E-01 0.2430E-28 + 2021 0.9652E-01 0.2425E-28 + 2022 0.9636E-01 0.2420E-28 + 2023 0.9621E-01 0.2415E-28 + 2024 0.9605E-01 0.2411E-28 + 2025 0.9590E-01 0.2406E-28 + 2026 0.9575E-01 0.2401E-28 + 2027 0.9559E-01 0.2396E-28 + 2028 0.9544E-01 0.2392E-28 + 2029 0.9529E-01 0.2387E-28 + 2030 0.9513E-01 0.2382E-28 + 2031 0.9498E-01 0.2378E-28 + 2032 0.9483E-01 0.2373E-28 + 2033 0.9468E-01 0.2368E-28 + 2034 0.9453E-01 0.2364E-28 + 2035 0.9438E-01 0.2359E-28 + 2036 0.9423E-01 0.2354E-28 + 2037 0.9407E-01 0.2350E-28 + 2038 0.9392E-01 0.2345E-28 + 2039 0.9377E-01 0.2340E-28 + 2040 0.9363E-01 0.2336E-28 + 2041 0.9348E-01 0.2331E-28 + 2042 0.9333E-01 0.2327E-28 + 2043 0.9318E-01 0.2322E-28 + 2044 0.9303E-01 0.2318E-28 + 2045 0.9288E-01 0.2313E-28 + 2046 0.9273E-01 0.2309E-28 + 2047 0.9259E-01 0.2304E-28 + 2048 0.9244E-01 0.2300E-28 + 2049 0.9229E-01 0.2295E-28 + 2050 0.9215E-01 0.2291E-28 + 2051 0.9200E-01 0.2286E-28 + 2052 0.9185E-01 0.2282E-28 + 2053 0.9171E-01 0.2277E-28 + 2054 0.9156E-01 0.2273E-28 + 2055 0.9142E-01 0.2268E-28 + 2056 0.9127E-01 0.2264E-28 + 2057 0.9113E-01 0.2260E-28 + 2058 0.9098E-01 0.2255E-28 + 2059 0.9084E-01 0.2251E-28 + 2060 0.9069E-01 0.2247E-28 + 2061 0.9055E-01 0.2242E-28 + 2062 0.9041E-01 0.2238E-28 + 2063 0.9026E-01 0.2233E-28 + 2064 0.9012E-01 0.2229E-28 + 2065 0.8998E-01 0.2225E-28 + 2066 0.8984E-01 0.2221E-28 + 2067 0.8969E-01 0.2216E-28 + 2068 0.8955E-01 0.2212E-28 + 2069 0.8941E-01 0.2208E-28 + 2070 0.8927E-01 0.2203E-28 + 2071 0.8913E-01 0.2199E-28 + 2072 0.8899E-01 0.2195E-28 + 2073 0.8885E-01 0.2191E-28 + 2074 0.8871E-01 0.2186E-28 + 2075 0.8857E-01 0.2182E-28 + 2076 0.8843E-01 0.2178E-28 + 2077 0.8829E-01 0.2174E-28 + 2078 0.8815E-01 0.2170E-28 + 2079 0.8801E-01 0.2166E-28 + 2080 0.8787E-01 0.2161E-28 + 2081 0.8774E-01 0.2157E-28 + 2082 0.8760E-01 0.2153E-28 + 2083 0.8746E-01 0.2149E-28 + 2084 0.8732E-01 0.2145E-28 + 2085 0.8719E-01 0.2141E-28 + 2086 0.8705E-01 0.2137E-28 + 2087 0.8691E-01 0.2132E-28 + 2088 0.8678E-01 0.2128E-28 + 2089 0.8664E-01 0.2124E-28 + 2090 0.8650E-01 0.2120E-28 + 2091 0.8637E-01 0.2116E-28 + 2092 0.8623E-01 0.2112E-28 + 2093 0.8610E-01 0.2108E-28 + 2094 0.8596E-01 0.2104E-28 + 2095 0.8583E-01 0.2100E-28 + 2096 0.8570E-01 0.2096E-28 + 2097 0.8556E-01 0.2092E-28 + 2098 0.8543E-01 0.2088E-28 + 2099 0.8529E-01 0.2084E-28 + 2100 0.8516E-01 0.2080E-28 + 2101 0.8503E-01 0.2076E-28 + 2102 0.8490E-01 0.2072E-28 + 2103 0.8476E-01 0.2068E-28 + 2104 0.8463E-01 0.2064E-28 + 2105 0.8450E-01 0.2060E-28 + 2106 0.8437E-01 0.2057E-28 + 2107 0.8424E-01 0.2053E-28 + 2108 0.8411E-01 0.2049E-28 + 2109 0.8397E-01 0.2045E-28 + 2110 0.8384E-01 0.2041E-28 + 2111 0.8371E-01 0.2037E-28 + 2112 0.8358E-01 0.2033E-28 + 2113 0.8345E-01 0.2029E-28 + 2114 0.8332E-01 0.2026E-28 + 2115 0.8319E-01 0.2022E-28 + 2116 0.8306E-01 0.2018E-28 + 2117 0.8294E-01 0.2014E-28 + 2118 0.8281E-01 0.2010E-28 + 2119 0.8268E-01 0.2007E-28 + 2120 0.8255E-01 0.2003E-28 + 2121 0.8242E-01 0.1999E-28 + 2122 0.8230E-01 0.1995E-28 + 2123 0.8217E-01 0.1991E-28 + 2124 0.8204E-01 0.1988E-28 + 2125 0.8191E-01 0.1984E-28 + 2126 0.8179E-01 0.1980E-28 + 2127 0.8166E-01 0.1977E-28 + 2128 0.8153E-01 0.1973E-28 + 2129 0.8141E-01 0.1969E-28 + 2130 0.8128E-01 0.1965E-28 + 2131 0.8116E-01 0.1962E-28 + 2132 0.8103E-01 0.1958E-28 + 2133 0.8091E-01 0.1954E-28 + 2134 0.8078E-01 0.1951E-28 + 2135 0.8066E-01 0.1947E-28 + 2136 0.8053E-01 0.1943E-28 + 2137 0.8041E-01 0.1940E-28 + 2138 0.8028E-01 0.1936E-28 + 2139 0.8016E-01 0.1933E-28 + 2140 0.8004E-01 0.1929E-28 + 2141 0.7991E-01 0.1925E-28 + 2142 0.7979E-01 0.1922E-28 + 2143 0.7967E-01 0.1918E-28 + 2144 0.7955E-01 0.1915E-28 + 2145 0.7942E-01 0.1911E-28 + 2146 0.7930E-01 0.1907E-28 + 2147 0.7918E-01 0.1904E-28 + 2148 0.7906E-01 0.1900E-28 + 2149 0.7894E-01 0.1897E-28 + 2150 0.7882E-01 0.1893E-28 + 2151 0.7870E-01 0.1890E-28 + 2152 0.7857E-01 0.1886E-28 + 2153 0.7845E-01 0.1883E-28 + 2154 0.7833E-01 0.1879E-28 + 2155 0.7821E-01 0.1876E-28 + 2156 0.7809E-01 0.1872E-28 + 2157 0.7798E-01 0.1869E-28 + 2158 0.7786E-01 0.1865E-28 + 2159 0.7774E-01 0.1862E-28 + 2160 0.7762E-01 0.1858E-28 + 2161 0.7750E-01 0.1855E-28 + 2162 0.7738E-01 0.1852E-28 + 2163 0.7726E-01 0.1848E-28 + 2164 0.7714E-01 0.1845E-28 + 2165 0.7703E-01 0.1841E-28 + 2166 0.7691E-01 0.1838E-28 + 2167 0.7679E-01 0.1835E-28 + 2168 0.7668E-01 0.1831E-28 + 2169 0.7656E-01 0.1828E-28 + 2170 0.7644E-01 0.1824E-28 + 2171 0.7633E-01 0.1821E-28 + 2172 0.7621E-01 0.1818E-28 + 2173 0.7609E-01 0.1814E-28 + 2174 0.7598E-01 0.1811E-28 + 2175 0.7586E-01 0.1808E-28 + 2176 0.7575E-01 0.1804E-28 + 2177 0.7563E-01 0.1801E-28 + 2178 0.7552E-01 0.1798E-28 + 2179 0.7540E-01 0.1795E-28 + 2180 0.7529E-01 0.1791E-28 + 2181 0.7517E-01 0.1788E-28 + 2182 0.7506E-01 0.1785E-28 + 2183 0.7495E-01 0.1781E-28 + 2184 0.7483E-01 0.1778E-28 + 2185 0.7472E-01 0.1775E-28 + 2186 0.7461E-01 0.1772E-28 + 2187 0.7449E-01 0.1768E-28 + 2188 0.7438E-01 0.1765E-28 + 2189 0.7427E-01 0.1762E-28 + 2190 0.7415E-01 0.1759E-28 + 2191 0.7404E-01 0.1756E-28 + 2192 0.7393E-01 0.1752E-28 + 2193 0.7382E-01 0.1749E-28 + 2194 0.7371E-01 0.1746E-28 + 2195 0.7360E-01 0.1743E-28 + 2196 0.7348E-01 0.1740E-28 + 2197 0.7337E-01 0.1736E-28 + 2198 0.7326E-01 0.1733E-28 + 2199 0.7315E-01 0.1730E-28 + 2200 0.7304E-01 0.1727E-28 + 2201 0.7293E-01 0.1724E-28 + 2202 0.7282E-01 0.1721E-28 + 2203 0.7271E-01 0.1718E-28 + 2204 0.7260E-01 0.1714E-28 + 2205 0.7249E-01 0.1711E-28 + 2206 0.7239E-01 0.1708E-28 + 2207 0.7228E-01 0.1705E-28 + 2208 0.7217E-01 0.1702E-28 + 2209 0.7206E-01 0.1699E-28 + 2210 0.7195E-01 0.1696E-28 + 2211 0.7184E-01 0.1693E-28 + 2212 0.7174E-01 0.1690E-28 + 2213 0.7163E-01 0.1687E-28 + 2214 0.7152E-01 0.1684E-28 + 2215 0.7141E-01 0.1681E-28 + 2216 0.7131E-01 0.1678E-28 + 2217 0.7120E-01 0.1675E-28 + 2218 0.7109E-01 0.1672E-28 + 2219 0.7099E-01 0.1669E-28 + 2220 0.7088E-01 0.1666E-28 + 2221 0.7077E-01 0.1663E-28 + 2222 0.7067E-01 0.1660E-28 + 2223 0.7056E-01 0.1657E-28 + 2224 0.7046E-01 0.1654E-28 + 2225 0.7035E-01 0.1651E-28 + 2226 0.7025E-01 0.1648E-28 + 2227 0.7014E-01 0.1645E-28 + 2228 0.7004E-01 0.1642E-28 + 2229 0.6993E-01 0.1639E-28 + 2230 0.6983E-01 0.1636E-28 + 2231 0.6972E-01 0.1633E-28 + 2232 0.6962E-01 0.1630E-28 + 2233 0.6952E-01 0.1627E-28 + 2234 0.6941E-01 0.1624E-28 + 2235 0.6931E-01 0.1621E-28 + 2236 0.6921E-01 0.1618E-28 + 2237 0.6910E-01 0.1616E-28 + 2238 0.6900E-01 0.1613E-28 + 2239 0.6890E-01 0.1610E-28 + 2240 0.6879E-01 0.1607E-28 + 2241 0.6869E-01 0.1604E-28 + 2242 0.6859E-01 0.1601E-28 + 2243 0.6849E-01 0.1598E-28 + 2244 0.6839E-01 0.1595E-28 + 2245 0.6829E-01 0.1593E-28 + 2246 0.6818E-01 0.1590E-28 + 2247 0.6808E-01 0.1587E-28 + 2248 0.6798E-01 0.1584E-28 + 2249 0.6788E-01 0.1581E-28 + 2250 0.6778E-01 0.1579E-28 + 2251 0.6768E-01 0.1576E-28 + 2252 0.6758E-01 0.1573E-28 + 2253 0.6748E-01 0.1570E-28 + 2254 0.6738E-01 0.1567E-28 + 2255 0.6728E-01 0.1565E-28 + 2256 0.6718E-01 0.1562E-28 + 2257 0.6708E-01 0.1559E-28 + 2258 0.6698E-01 0.1556E-28 + 2259 0.6688E-01 0.1554E-28 + 2260 0.6678E-01 0.1551E-28 + 2261 0.6669E-01 0.1548E-28 + 2262 0.6659E-01 0.1545E-28 + 2263 0.6649E-01 0.1543E-28 + 2264 0.6639E-01 0.1540E-28 + 2265 0.6629E-01 0.1537E-28 + 2266 0.6620E-01 0.1534E-28 + 2267 0.6610E-01 0.1532E-28 + 2268 0.6600E-01 0.1529E-28 + 2269 0.6590E-01 0.1526E-28 + 2270 0.6581E-01 0.1524E-28 + 2271 0.6571E-01 0.1521E-28 + 2272 0.6561E-01 0.1518E-28 + 2273 0.6552E-01 0.1516E-28 + 2274 0.6542E-01 0.1513E-28 + 2275 0.6532E-01 0.1510E-28 + 2276 0.6523E-01 0.1508E-28 + 2277 0.6513E-01 0.1505E-28 + 2278 0.6504E-01 0.1502E-28 + 2279 0.6494E-01 0.1500E-28 + 2280 0.6485E-01 0.1497E-28 + 2281 0.6475E-01 0.1494E-28 + 2282 0.6466E-01 0.1492E-28 + 2283 0.6456E-01 0.1489E-28 + 2284 0.6447E-01 0.1487E-28 + 2285 0.6437E-01 0.1484E-28 + 2286 0.6428E-01 0.1481E-28 + 2287 0.6418E-01 0.1479E-28 + 2288 0.6409E-01 0.1476E-28 + 2289 0.6400E-01 0.1474E-28 + 2290 0.6390E-01 0.1471E-28 + 2291 0.6381E-01 0.1469E-28 + 2292 0.6372E-01 0.1466E-28 + 2293 0.6362E-01 0.1463E-28 + 2294 0.6353E-01 0.1461E-28 + 2295 0.6344E-01 0.1458E-28 + 2296 0.6335E-01 0.1456E-28 + 2297 0.6325E-01 0.1453E-28 + 2298 0.6316E-01 0.1451E-28 + 2299 0.6307E-01 0.1448E-28 + 2300 0.6298E-01 0.1446E-28 + 2301 0.6289E-01 0.1443E-28 + 2302 0.6279E-01 0.1441E-28 + 2303 0.6270E-01 0.1438E-28 + 2304 0.6261E-01 0.1436E-28 + 2305 0.6252E-01 0.1433E-28 + 2306 0.6243E-01 0.1431E-28 + 2307 0.6234E-01 0.1428E-28 + 2308 0.6225E-01 0.1426E-28 + 2309 0.6216E-01 0.1423E-28 + 2310 0.6207E-01 0.1421E-28 + 2311 0.6198E-01 0.1418E-28 + 2312 0.6189E-01 0.1416E-28 + 2313 0.6180E-01 0.1413E-28 + 2314 0.6171E-01 0.1411E-28 + 2315 0.6162E-01 0.1409E-28 + 2316 0.6153E-01 0.1406E-28 + 2317 0.6144E-01 0.1404E-28 + 2318 0.6135E-01 0.1401E-28 + 2319 0.6126E-01 0.1399E-28 + 2320 0.6117E-01 0.1396E-28 + 2321 0.6109E-01 0.1394E-28 + 2322 0.6100E-01 0.1392E-28 + 2323 0.6091E-01 0.1389E-28 + 2324 0.6082E-01 0.1387E-28 + 2325 0.6073E-01 0.1384E-28 + 2326 0.6065E-01 0.1382E-28 + 2327 0.6056E-01 0.1380E-28 + 2328 0.6047E-01 0.1377E-28 + 2329 0.6038E-01 0.1375E-28 + 2330 0.6030E-01 0.1373E-28 + 2331 0.6021E-01 0.1370E-28 + 2332 0.6012E-01 0.1368E-28 + 2333 0.6004E-01 0.1366E-28 + 2334 0.5995E-01 0.1363E-28 + 2335 0.5986E-01 0.1361E-28 + 2336 0.5978E-01 0.1359E-28 + 2337 0.5969E-01 0.1356E-28 + 2338 0.5961E-01 0.1354E-28 + 2339 0.5952E-01 0.1352E-28 + 2340 0.5943E-01 0.1349E-28 + 2341 0.5935E-01 0.1347E-28 + 2342 0.5926E-01 0.1345E-28 + 2343 0.5918E-01 0.1342E-28 + 2344 0.5909E-01 0.1340E-28 + 2345 0.5901E-01 0.1338E-28 + 2346 0.5892E-01 0.1336E-28 + 2347 0.5884E-01 0.1333E-28 + 2348 0.5876E-01 0.1331E-28 + 2349 0.5867E-01 0.1329E-28 + 2350 0.5859E-01 0.1326E-28 + 2351 0.5850E-01 0.1324E-28 + 2352 0.5842E-01 0.1322E-28 + 2353 0.5834E-01 0.1320E-28 + 2354 0.5825E-01 0.1318E-28 + 2355 0.5817E-01 0.1315E-28 + 2356 0.5809E-01 0.1313E-28 + 2357 0.5800E-01 0.1311E-28 + 2358 0.5792E-01 0.1309E-28 + 2359 0.5784E-01 0.1306E-28 + 2360 0.5775E-01 0.1304E-28 + 2361 0.5767E-01 0.1302E-28 + 2362 0.5759E-01 0.1300E-28 + 2363 0.5751E-01 0.1298E-28 + 2364 0.5743E-01 0.1295E-28 + 2365 0.5734E-01 0.1293E-28 + 2366 0.5726E-01 0.1291E-28 + 2367 0.5718E-01 0.1289E-28 + 2368 0.5710E-01 0.1287E-28 + 2369 0.5702E-01 0.1284E-28 + 2370 0.5694E-01 0.1282E-28 + 2371 0.5686E-01 0.1280E-28 + 2372 0.5677E-01 0.1278E-28 + 2373 0.5669E-01 0.1276E-28 + 2374 0.5661E-01 0.1274E-28 + 2375 0.5653E-01 0.1272E-28 + 2376 0.5645E-01 0.1269E-28 + 2377 0.5637E-01 0.1267E-28 + 2378 0.5629E-01 0.1265E-28 + 2379 0.5621E-01 0.1263E-28 + 2380 0.5613E-01 0.1261E-28 + 2381 0.5605E-01 0.1259E-28 + 2382 0.5597E-01 0.1257E-28 + 2383 0.5589E-01 0.1255E-28 + 2384 0.5582E-01 0.1252E-28 + 2385 0.5574E-01 0.1250E-28 + 2386 0.5566E-01 0.1248E-28 + 2387 0.5558E-01 0.1246E-28 + 2388 0.5550E-01 0.1244E-28 + 2389 0.5542E-01 0.1242E-28 + 2390 0.5534E-01 0.1240E-28 + 2391 0.5527E-01 0.1238E-28 + 2392 0.5519E-01 0.1236E-28 + 2393 0.5511E-01 0.1234E-28 + 2394 0.5503E-01 0.1232E-28 + 2395 0.5495E-01 0.1230E-28 + 2396 0.5488E-01 0.1228E-28 + 2397 0.5480E-01 0.1225E-28 + 2398 0.5472E-01 0.1223E-28 + 2399 0.5464E-01 0.1221E-28 + 2400 0.5457E-01 0.1219E-28 + 2401 0.5449E-01 0.1217E-28 + 2402 0.5441E-01 0.1215E-28 + 2403 0.5434E-01 0.1213E-28 + 2404 0.5426E-01 0.1211E-28 + 2405 0.5418E-01 0.1209E-28 + 2406 0.5411E-01 0.1207E-28 + 2407 0.5403E-01 0.1205E-28 + 2408 0.5396E-01 0.1203E-28 + 2409 0.5388E-01 0.1201E-28 + 2410 0.5381E-01 0.1199E-28 + 2411 0.5373E-01 0.1197E-28 + 2412 0.5365E-01 0.1195E-28 + 2413 0.5358E-01 0.1193E-28 + 2414 0.5350E-01 0.1191E-28 + 2415 0.5343E-01 0.1189E-28 + 2416 0.5335E-01 0.1187E-28 + 2417 0.5328E-01 0.1185E-28 + 2418 0.5320E-01 0.1183E-28 + 2419 0.5313E-01 0.1182E-28 + 2420 0.5306E-01 0.1180E-28 + 2421 0.5298E-01 0.1178E-28 + 2422 0.5291E-01 0.1176E-28 + 2423 0.5283E-01 0.1174E-28 + 2424 0.5276E-01 0.1172E-28 + 2425 0.5269E-01 0.1170E-28 + 2426 0.5261E-01 0.1168E-28 + 2427 0.5254E-01 0.1166E-28 + 2428 0.5247E-01 0.1164E-28 + 2429 0.5239E-01 0.1162E-28 + 2430 0.5232E-01 0.1160E-28 + 2431 0.5225E-01 0.1158E-28 + 2432 0.5217E-01 0.1156E-28 + 2433 0.5210E-01 0.1155E-28 + 2434 0.5203E-01 0.1153E-28 + 2435 0.5196E-01 0.1151E-28 + 2436 0.5188E-01 0.1149E-28 + 2437 0.5181E-01 0.1147E-28 + 2438 0.5174E-01 0.1145E-28 + 2439 0.5167E-01 0.1143E-28 + 2440 0.5160E-01 0.1141E-28 + 2441 0.5152E-01 0.1139E-28 + 2442 0.5145E-01 0.1138E-28 + 2443 0.5138E-01 0.1136E-28 + 2444 0.5131E-01 0.1134E-28 + 2445 0.5124E-01 0.1132E-28 + 2446 0.5117E-01 0.1130E-28 + 2447 0.5110E-01 0.1128E-28 + 2448 0.5102E-01 0.1127E-28 + 2449 0.5095E-01 0.1125E-28 + 2450 0.5088E-01 0.1123E-28 + 2451 0.5081E-01 0.1121E-28 + 2452 0.5074E-01 0.1119E-28 + 2453 0.5067E-01 0.1117E-28 + 2454 0.5060E-01 0.1116E-28 + 2455 0.5053E-01 0.1114E-28 + 2456 0.5046E-01 0.1112E-28 + 2457 0.5039E-01 0.1110E-28 + 2458 0.5032E-01 0.1108E-28 + 2459 0.5025E-01 0.1106E-28 + 2460 0.5018E-01 0.1105E-28 + 2461 0.5011E-01 0.1103E-28 + 2462 0.5005E-01 0.1101E-28 + 2463 0.4998E-01 0.1099E-28 + 2464 0.4991E-01 0.1098E-28 + 2465 0.4984E-01 0.1096E-28 + 2466 0.4977E-01 0.1094E-28 + 2467 0.4970E-01 0.1092E-28 + 2468 0.4963E-01 0.1090E-28 + 2469 0.4956E-01 0.1089E-28 + 2470 0.4950E-01 0.1087E-28 + 2471 0.4943E-01 0.1085E-28 + 2472 0.4936E-01 0.1083E-28 + 2473 0.4929E-01 0.1082E-28 + 2474 0.4922E-01 0.1080E-28 + 2475 0.4916E-01 0.1078E-28 + 2476 0.4909E-01 0.1076E-28 + 2477 0.4902E-01 0.1075E-28 + 2478 0.4895E-01 0.1073E-28 + 2479 0.4889E-01 0.1071E-28 + 2480 0.4882E-01 0.1069E-28 + 2481 0.4875E-01 0.1068E-28 + 2482 0.4869E-01 0.1066E-28 + 2483 0.4862E-01 0.1064E-28 + 2484 0.4855E-01 0.1063E-28 + 2485 0.4849E-01 0.1061E-28 + 2486 0.4842E-01 0.1059E-28 + 2487 0.4835E-01 0.1057E-28 + 2488 0.4829E-01 0.1056E-28 + 2489 0.4822E-01 0.1054E-28 + 2490 0.4816E-01 0.1052E-28 + 2491 0.4809E-01 0.1051E-28 + 2492 0.4802E-01 0.1049E-28 + 2493 0.4796E-01 0.1047E-28 + 2494 0.4789E-01 0.1046E-28 + 2495 0.4783E-01 0.1044E-28 + 2496 0.4776E-01 0.1042E-28 + 2497 0.4770E-01 0.1041E-28 + 2498 0.4763E-01 0.1039E-28 + 2499 0.4757E-01 0.1037E-28 + 2500 0.4750E-01 0.1036E-28 + 2501 0.4744E-01 0.1034E-28 + 2502 0.4737E-01 0.1032E-28 + 2503 0.4731E-01 0.1031E-28 + 2504 0.4724E-01 0.1029E-28 + 2505 0.4718E-01 0.1027E-28 + 2506 0.4711E-01 0.1026E-28 + 2507 0.4705E-01 0.1024E-28 + 2508 0.4699E-01 0.1023E-28 + 2509 0.4692E-01 0.1021E-28 + 2510 0.4686E-01 0.1019E-28 + 2511 0.4680E-01 0.1018E-28 + 2512 0.4673E-01 0.1016E-28 + 2513 0.4667E-01 0.1014E-28 + 2514 0.4660E-01 0.1013E-28 + 2515 0.4654E-01 0.1011E-28 + 2516 0.4648E-01 0.1010E-28 + 2517 0.4642E-01 0.1008E-28 + 2518 0.4635E-01 0.1006E-28 + 2519 0.4629E-01 0.1005E-28 + 2520 0.4623E-01 0.1003E-28 + 2521 0.4616E-01 0.1002E-28 + 2522 0.4610E-01 0.1000E-28 + 2523 0.4604E-01 0.9984E-29 + 2524 0.4598E-01 0.9968E-29 + 2525 0.4591E-01 0.9952E-29 + 2526 0.4585E-01 0.9937E-29 + 2527 0.4579E-01 0.9921E-29 + 2528 0.4573E-01 0.9905E-29 + 2529 0.4567E-01 0.9890E-29 + 2530 0.4561E-01 0.9874E-29 + 2531 0.4554E-01 0.9858E-29 + 2532 0.4548E-01 0.9843E-29 + 2533 0.4542E-01 0.9827E-29 + 2534 0.4536E-01 0.9812E-29 + 2535 0.4530E-01 0.9796E-29 + 2536 0.4524E-01 0.9781E-29 + 2537 0.4518E-01 0.9766E-29 + 2538 0.4512E-01 0.9750E-29 + 2539 0.4505E-01 0.9735E-29 + 2540 0.4499E-01 0.9719E-29 + 2541 0.4493E-01 0.9704E-29 + 2542 0.4487E-01 0.9689E-29 + 2543 0.4481E-01 0.9674E-29 + 2544 0.4475E-01 0.9658E-29 + 2545 0.4469E-01 0.9643E-29 + 2546 0.4463E-01 0.9628E-29 + 2547 0.4457E-01 0.9613E-29 + 2548 0.4451E-01 0.9598E-29 + 2549 0.4445E-01 0.9583E-29 + 2550 0.4439E-01 0.9568E-29 + 2551 0.4433E-01 0.9553E-29 + 2552 0.4427E-01 0.9538E-29 + 2553 0.4421E-01 0.9523E-29 + 2554 0.4416E-01 0.9508E-29 + 2555 0.4410E-01 0.9493E-29 + 2556 0.4404E-01 0.9478E-29 + 2557 0.4398E-01 0.9464E-29 + 2558 0.4392E-01 0.9449E-29 + 2559 0.4386E-01 0.9434E-29 + 2560 0.4380E-01 0.9419E-29 + 2561 0.4374E-01 0.9405E-29 + 2562 0.4368E-01 0.9390E-29 + 2563 0.4363E-01 0.9375E-29 + 2564 0.4357E-01 0.9361E-29 + 2565 0.4351E-01 0.9346E-29 + 2566 0.4345E-01 0.9331E-29 + 2567 0.4339E-01 0.9317E-29 + 2568 0.4334E-01 0.9302E-29 + 2569 0.4328E-01 0.9288E-29 + 2570 0.4322E-01 0.9274E-29 + 2571 0.4316E-01 0.9259E-29 + 2572 0.4311E-01 0.9245E-29 + 2573 0.4305E-01 0.9230E-29 + 2574 0.4299E-01 0.9216E-29 + 2575 0.4293E-01 0.9202E-29 + 2576 0.4288E-01 0.9187E-29 + 2577 0.4282E-01 0.9173E-29 + 2578 0.4276E-01 0.9159E-29 + 2579 0.4271E-01 0.9145E-29 + 2580 0.4265E-01 0.9131E-29 + 2581 0.4259E-01 0.9116E-29 + 2582 0.4254E-01 0.9102E-29 + 2583 0.4248E-01 0.9088E-29 + 2584 0.4242E-01 0.9074E-29 + 2585 0.4237E-01 0.9060E-29 + 2586 0.4231E-01 0.9046E-29 + 2587 0.4225E-01 0.9032E-29 + 2588 0.4220E-01 0.9018E-29 + 2589 0.4214E-01 0.9004E-29 + 2590 0.4209E-01 0.8990E-29 + 2591 0.4203E-01 0.8977E-29 + 2592 0.4197E-01 0.8963E-29 + 2593 0.4192E-01 0.8949E-29 + 2594 0.4186E-01 0.8935E-29 + 2595 0.4181E-01 0.8921E-29 + 2596 0.4175E-01 0.8908E-29 + 2597 0.4170E-01 0.8894E-29 + 2598 0.4164E-01 0.8880E-29 + 2599 0.4159E-01 0.8867E-29 + 2600 0.4153E-01 0.8853E-29 + 2601 0.4148E-01 0.8839E-29 + 2602 0.4142E-01 0.8826E-29 + 2603 0.4137E-01 0.8812E-29 + 2604 0.4131E-01 0.8799E-29 + 2605 0.4126E-01 0.8785E-29 + 2606 0.4120E-01 0.8772E-29 + 2607 0.4115E-01 0.8758E-29 + 2608 0.4110E-01 0.8745E-29 + 2609 0.4104E-01 0.8731E-29 + 2610 0.4099E-01 0.8718E-29 + 2611 0.4093E-01 0.8705E-29 + 2612 0.4088E-01 0.8691E-29 + 2613 0.4083E-01 0.8678E-29 + 2614 0.4077E-01 0.8665E-29 + 2615 0.4072E-01 0.8651E-29 + 2616 0.4067E-01 0.8638E-29 + 2617 0.4061E-01 0.8625E-29 + 2618 0.4056E-01 0.8612E-29 + 2619 0.4051E-01 0.8599E-29 + 2620 0.4045E-01 0.8586E-29 + 2621 0.4040E-01 0.8573E-29 + 2622 0.4035E-01 0.8559E-29 + 2623 0.4029E-01 0.8546E-29 + 2624 0.4024E-01 0.8533E-29 + 2625 0.4019E-01 0.8520E-29 + 2626 0.4013E-01 0.8507E-29 + 2627 0.4008E-01 0.8494E-29 + 2628 0.4003E-01 0.8482E-29 + 2629 0.3998E-01 0.8469E-29 + 2630 0.3992E-01 0.8456E-29 + 2631 0.3987E-01 0.8443E-29 + 2632 0.3982E-01 0.8430E-29 + 2633 0.3977E-01 0.8417E-29 + 2634 0.3972E-01 0.8405E-29 + 2635 0.3966E-01 0.8392E-29 + 2636 0.3961E-01 0.8379E-29 + 2637 0.3956E-01 0.8366E-29 + 2638 0.3951E-01 0.8354E-29 + 2639 0.3946E-01 0.8341E-29 + 2640 0.3941E-01 0.8328E-29 + 2641 0.3935E-01 0.8316E-29 + 2642 0.3930E-01 0.8303E-29 + 2643 0.3925E-01 0.8291E-29 + 2644 0.3920E-01 0.8278E-29 + 2645 0.3915E-01 0.8266E-29 + 2646 0.3910E-01 0.8253E-29 + 2647 0.3905E-01 0.8241E-29 + 2648 0.3900E-01 0.8228E-29 + 2649 0.3895E-01 0.8216E-29 + 2650 0.3890E-01 0.8203E-29 + 2651 0.3885E-01 0.8191E-29 + 2652 0.3879E-01 0.8179E-29 + 2653 0.3874E-01 0.8166E-29 + 2654 0.3869E-01 0.8154E-29 + 2655 0.3864E-01 0.8142E-29 + 2656 0.3859E-01 0.8130E-29 + 2657 0.3854E-01 0.8117E-29 + 2658 0.3849E-01 0.8105E-29 + 2659 0.3844E-01 0.8093E-29 + 2660 0.3839E-01 0.8081E-29 + 2661 0.3834E-01 0.8069E-29 + 2662 0.3829E-01 0.8056E-29 + 2663 0.3824E-01 0.8044E-29 + 2664 0.3820E-01 0.8032E-29 + 2665 0.3815E-01 0.8020E-29 + 2666 0.3810E-01 0.8008E-29 + 2667 0.3805E-01 0.7996E-29 + 2668 0.3800E-01 0.7984E-29 + 2669 0.3795E-01 0.7972E-29 + 2670 0.3790E-01 0.7960E-29 + 2671 0.3785E-01 0.7948E-29 + 2672 0.3780E-01 0.7937E-29 + 2673 0.3775E-01 0.7925E-29 + 2674 0.3770E-01 0.7913E-29 + 2675 0.3766E-01 0.7901E-29 + 2676 0.3761E-01 0.7889E-29 + 2677 0.3756E-01 0.7877E-29 + 2678 0.3751E-01 0.7866E-29 + 2679 0.3746E-01 0.7854E-29 + 2680 0.3741E-01 0.7842E-29 + 2681 0.3737E-01 0.7831E-29 + 2682 0.3732E-01 0.7819E-29 + 2683 0.3727E-01 0.7807E-29 + 2684 0.3722E-01 0.7796E-29 + 2685 0.3717E-01 0.7784E-29 + 2686 0.3713E-01 0.7772E-29 + 2687 0.3708E-01 0.7761E-29 + 2688 0.3703E-01 0.7749E-29 + 2689 0.3698E-01 0.7738E-29 + 2690 0.3693E-01 0.7726E-29 + 2691 0.3689E-01 0.7715E-29 + 2692 0.3684E-01 0.7703E-29 + 2693 0.3679E-01 0.7692E-29 + 2694 0.3675E-01 0.7680E-29 + 2695 0.3670E-01 0.7669E-29 + 2696 0.3665E-01 0.7658E-29 + 2697 0.3660E-01 0.7646E-29 + 2698 0.3656E-01 0.7635E-29 + 2699 0.3651E-01 0.7624E-29 + 2700 0.3646E-01 0.7612E-29 + 2701 0.3642E-01 0.7601E-29 + 2702 0.3637E-01 0.7590E-29 + 2703 0.3632E-01 0.7579E-29 + 2704 0.3628E-01 0.7567E-29 + 2705 0.3623E-01 0.7556E-29 + 2706 0.3618E-01 0.7545E-29 + 2707 0.3614E-01 0.7534E-29 + 2708 0.3609E-01 0.7523E-29 + 2709 0.3605E-01 0.7512E-29 + 2710 0.3600E-01 0.7501E-29 + 2711 0.3595E-01 0.7490E-29 + 2712 0.3591E-01 0.7479E-29 + 2713 0.3586E-01 0.7468E-29 + 2714 0.3582E-01 0.7457E-29 + 2715 0.3577E-01 0.7446E-29 + 2716 0.3573E-01 0.7435E-29 + 2717 0.3568E-01 0.7424E-29 + 2718 0.3563E-01 0.7413E-29 + 2719 0.3559E-01 0.7402E-29 + 2720 0.3554E-01 0.7391E-29 + 2721 0.3550E-01 0.7380E-29 + 2722 0.3545E-01 0.7369E-29 + 2723 0.3541E-01 0.7358E-29 + 2724 0.3536E-01 0.7348E-29 + 2725 0.3532E-01 0.7337E-29 + 2726 0.3527E-01 0.7326E-29 + 2727 0.3523E-01 0.7315E-29 + 2728 0.3518E-01 0.7305E-29 + 2729 0.3514E-01 0.7294E-29 + 2730 0.3509E-01 0.7283E-29 + 2731 0.3505E-01 0.7273E-29 + 2732 0.3501E-01 0.7262E-29 + 2733 0.3496E-01 0.7251E-29 + 2734 0.3492E-01 0.7241E-29 + 2735 0.3487E-01 0.7230E-29 + 2736 0.3483E-01 0.7220E-29 + 2737 0.3478E-01 0.7209E-29 + 2738 0.3474E-01 0.7199E-29 + 2739 0.3470E-01 0.7188E-29 + 2740 0.3465E-01 0.7178E-29 + 2741 0.3461E-01 0.7167E-29 + 2742 0.3456E-01 0.7157E-29 + 2743 0.3452E-01 0.7146E-29 + 2744 0.3448E-01 0.7136E-29 + 2745 0.3443E-01 0.7125E-29 + 2746 0.3439E-01 0.7115E-29 + 2747 0.3435E-01 0.7105E-29 + 2748 0.3430E-01 0.7094E-29 + 2749 0.3426E-01 0.7084E-29 + 2750 0.3422E-01 0.7074E-29 + 2751 0.3417E-01 0.7063E-29 + 2752 0.3413E-01 0.7053E-29 + 2753 0.3409E-01 0.7043E-29 + 2754 0.3404E-01 0.7033E-29 + 2755 0.3400E-01 0.7022E-29 + 2756 0.3396E-01 0.7012E-29 + 2757 0.3392E-01 0.7002E-29 + 2758 0.3387E-01 0.6992E-29 + 2759 0.3383E-01 0.6982E-29 + 2760 0.3379E-01 0.6972E-29 + 2761 0.3375E-01 0.6962E-29 + 2762 0.3370E-01 0.6952E-29 + 2763 0.3366E-01 0.6942E-29 + 2764 0.3362E-01 0.6931E-29 + 2765 0.3358E-01 0.6921E-29 + 2766 0.3353E-01 0.6911E-29 + 2767 0.3349E-01 0.6901E-29 + 2768 0.3345E-01 0.6891E-29 + 2769 0.3341E-01 0.6882E-29 + 2770 0.3337E-01 0.6872E-29 + 2771 0.3332E-01 0.6862E-29 + 2772 0.3328E-01 0.6852E-29 + 2773 0.3324E-01 0.6842E-29 + 2774 0.3320E-01 0.6832E-29 + 2775 0.3316E-01 0.6822E-29 + 2776 0.3312E-01 0.6812E-29 + 2777 0.3308E-01 0.6803E-29 + 2778 0.3303E-01 0.6793E-29 + 2779 0.3299E-01 0.6783E-29 + 2780 0.3295E-01 0.6773E-29 + 2781 0.3291E-01 0.6764E-29 + 2782 0.3287E-01 0.6754E-29 + 2783 0.3283E-01 0.6744E-29 + 2784 0.3279E-01 0.6734E-29 + 2785 0.3275E-01 0.6725E-29 + 2786 0.3271E-01 0.6715E-29 + 2787 0.3266E-01 0.6705E-29 + 2788 0.3262E-01 0.6696E-29 + 2789 0.3258E-01 0.6686E-29 + 2790 0.3254E-01 0.6677E-29 + 2791 0.3250E-01 0.6667E-29 + 2792 0.3246E-01 0.6658E-29 + 2793 0.3242E-01 0.6648E-29 + 2794 0.3238E-01 0.6639E-29 + 2795 0.3234E-01 0.6629E-29 + 2796 0.3230E-01 0.6620E-29 + 2797 0.3226E-01 0.6610E-29 + 2798 0.3222E-01 0.6601E-29 + 2799 0.3218E-01 0.6591E-29 + 2800 0.3214E-01 0.6582E-29 + 2801 0.3210E-01 0.6572E-29 + 2802 0.3206E-01 0.6563E-29 + 2803 0.3202E-01 0.6554E-29 + 2804 0.3198E-01 0.6544E-29 + 2805 0.3194E-01 0.6535E-29 + 2806 0.3190E-01 0.6526E-29 + 2807 0.3186E-01 0.6516E-29 + 2808 0.3182E-01 0.6507E-29 + 2809 0.3178E-01 0.6498E-29 + 2810 0.3174E-01 0.6489E-29 + 2811 0.3170E-01 0.6479E-29 + 2812 0.3166E-01 0.6470E-29 + 2813 0.3163E-01 0.6461E-29 + 2814 0.3159E-01 0.6452E-29 + 2815 0.3155E-01 0.6443E-29 + 2816 0.3151E-01 0.6433E-29 + 2817 0.3147E-01 0.6424E-29 + 2818 0.3143E-01 0.6415E-29 + 2819 0.3139E-01 0.6406E-29 + 2820 0.3135E-01 0.6397E-29 + 2821 0.3131E-01 0.6388E-29 + 2822 0.3127E-01 0.6379E-29 + 2823 0.3124E-01 0.6370E-29 + 2824 0.3120E-01 0.6361E-29 + 2825 0.3116E-01 0.6352E-29 + 2826 0.3112E-01 0.6343E-29 + 2827 0.3108E-01 0.6334E-29 + 2828 0.3104E-01 0.6325E-29 + 2829 0.3101E-01 0.6316E-29 + 2830 0.3097E-01 0.6307E-29 + 2831 0.3093E-01 0.6298E-29 + 2832 0.3089E-01 0.6289E-29 + 2833 0.3085E-01 0.6280E-29 + 2834 0.3082E-01 0.6272E-29 + 2835 0.3078E-01 0.6263E-29 + 2836 0.3074E-01 0.6254E-29 + 2837 0.3070E-01 0.6245E-29 + 2838 0.3066E-01 0.6236E-29 + 2839 0.3063E-01 0.6228E-29 + 2840 0.3059E-01 0.6219E-29 + 2841 0.3055E-01 0.6210E-29 + 2842 0.3051E-01 0.6201E-29 + 2843 0.3048E-01 0.6193E-29 + 2844 0.3044E-01 0.6184E-29 + 2845 0.3040E-01 0.6175E-29 + 2846 0.3036E-01 0.6166E-29 + 2847 0.3033E-01 0.6158E-29 + 2848 0.3029E-01 0.6149E-29 + 2849 0.3025E-01 0.6141E-29 + 2850 0.3022E-01 0.6132E-29 + 2851 0.3018E-01 0.6123E-29 + 2852 0.3014E-01 0.6115E-29 + 2853 0.3010E-01 0.6106E-29 + 2854 0.3007E-01 0.6098E-29 + 2855 0.3003E-01 0.6089E-29 + 2856 0.2999E-01 0.6081E-29 + 2857 0.2996E-01 0.6072E-29 + 2858 0.2992E-01 0.6064E-29 + 2859 0.2988E-01 0.6055E-29 + 2860 0.2985E-01 0.6047E-29 + 2861 0.2981E-01 0.6038E-29 + 2862 0.2978E-01 0.6030E-29 + 2863 0.2974E-01 0.6021E-29 + 2864 0.2970E-01 0.6013E-29 + 2865 0.2967E-01 0.6005E-29 + 2866 0.2963E-01 0.5996E-29 + 2867 0.2959E-01 0.5988E-29 + 2868 0.2956E-01 0.5979E-29 + 2869 0.2952E-01 0.5971E-29 + 2870 0.2949E-01 0.5963E-29 + 2871 0.2945E-01 0.5954E-29 + 2872 0.2941E-01 0.5946E-29 + 2873 0.2938E-01 0.5938E-29 + 2874 0.2934E-01 0.5930E-29 + 2875 0.2931E-01 0.5921E-29 + 2876 0.2927E-01 0.5913E-29 + 2877 0.2924E-01 0.5905E-29 + 2878 0.2920E-01 0.5897E-29 + 2879 0.2917E-01 0.5889E-29 + 2880 0.2913E-01 0.5880E-29 + 2881 0.2909E-01 0.5872E-29 + 2882 0.2906E-01 0.5864E-29 + 2883 0.2902E-01 0.5856E-29 + 2884 0.2899E-01 0.5848E-29 + 2885 0.2895E-01 0.5840E-29 + 2886 0.2892E-01 0.5832E-29 + 2887 0.2888E-01 0.5824E-29 + 2888 0.2885E-01 0.5816E-29 + 2889 0.2881E-01 0.5807E-29 + 2890 0.2878E-01 0.5799E-29 + 2891 0.2874E-01 0.5791E-29 + 2892 0.2871E-01 0.5783E-29 + 2893 0.2867E-01 0.5775E-29 + 2894 0.2864E-01 0.5767E-29 + 2895 0.2861E-01 0.5759E-29 + 2896 0.2857E-01 0.5752E-29 + 2897 0.2854E-01 0.5744E-29 + 2898 0.2850E-01 0.5736E-29 + 2899 0.2847E-01 0.5728E-29 + 2900 0.2843E-01 0.5720E-29 + 2901 0.2840E-01 0.5712E-29 + 2902 0.2836E-01 0.5704E-29 + 2903 0.2833E-01 0.5696E-29 + 2904 0.2830E-01 0.5688E-29 + 2905 0.2826E-01 0.5681E-29 + 2906 0.2823E-01 0.5673E-29 + 2907 0.2819E-01 0.5665E-29 + 2908 0.2816E-01 0.5657E-29 + 2909 0.2813E-01 0.5649E-29 + 2910 0.2809E-01 0.5642E-29 + 2911 0.2806E-01 0.5634E-29 + 2912 0.2802E-01 0.5626E-29 + 2913 0.2799E-01 0.5618E-29 + 2914 0.2796E-01 0.5611E-29 + 2915 0.2792E-01 0.5603E-29 + 2916 0.2789E-01 0.5595E-29 + 2917 0.2786E-01 0.5588E-29 + 2918 0.2782E-01 0.5580E-29 + 2919 0.2779E-01 0.5572E-29 + 2920 0.2776E-01 0.5565E-29 + 2921 0.2772E-01 0.5557E-29 + 2922 0.2769E-01 0.5550E-29 + 2923 0.2766E-01 0.5542E-29 + 2924 0.2762E-01 0.5534E-29 + 2925 0.2759E-01 0.5527E-29 + 2926 0.2756E-01 0.5519E-29 + 2927 0.2752E-01 0.5512E-29 + 2928 0.2749E-01 0.5504E-29 + 2929 0.2746E-01 0.5497E-29 + 2930 0.2743E-01 0.5489E-29 + 2931 0.2739E-01 0.5482E-29 + 2932 0.2736E-01 0.5474E-29 + 2933 0.2733E-01 0.5467E-29 + 2934 0.2729E-01 0.5459E-29 + 2935 0.2726E-01 0.5452E-29 + 2936 0.2723E-01 0.5444E-29 + 2937 0.2720E-01 0.5437E-29 + 2938 0.2716E-01 0.5430E-29 + 2939 0.2713E-01 0.5422E-29 + 2940 0.2710E-01 0.5415E-29 + 2941 0.2707E-01 0.5408E-29 + 2942 0.2704E-01 0.5400E-29 + 2943 0.2700E-01 0.5393E-29 + 2944 0.2697E-01 0.5386E-29 + 2945 0.2694E-01 0.5378E-29 + 2946 0.2691E-01 0.5371E-29 + 2947 0.2687E-01 0.5364E-29 + 2948 0.2684E-01 0.5356E-29 + 2949 0.2681E-01 0.5349E-29 + 2950 0.2678E-01 0.5342E-29 + 2951 0.2675E-01 0.5335E-29 + 2952 0.2671E-01 0.5327E-29 + 2953 0.2668E-01 0.5320E-29 + 2954 0.2665E-01 0.5313E-29 + 2955 0.2662E-01 0.5306E-29 + 2956 0.2659E-01 0.5299E-29 + 2957 0.2656E-01 0.5291E-29 + 2958 0.2653E-01 0.5284E-29 + 2959 0.2649E-01 0.5277E-29 + 2960 0.2646E-01 0.5270E-29 + 2961 0.2643E-01 0.5263E-29 + 2962 0.2640E-01 0.5256E-29 + 2963 0.2637E-01 0.5249E-29 + 2964 0.2634E-01 0.5242E-29 + 2965 0.2631E-01 0.5235E-29 + 2966 0.2627E-01 0.5227E-29 + 2967 0.2624E-01 0.5220E-29 + 2968 0.2621E-01 0.5213E-29 + 2969 0.2618E-01 0.5206E-29 + 2970 0.2615E-01 0.5199E-29 + 2971 0.2612E-01 0.5192E-29 + 2972 0.2609E-01 0.5185E-29 + 2973 0.2606E-01 0.5178E-29 + 2974 0.2603E-01 0.5171E-29 + 2975 0.2600E-01 0.5165E-29 + 2976 0.2597E-01 0.5158E-29 + 2977 0.2593E-01 0.5151E-29 + 2978 0.2590E-01 0.5144E-29 + 2979 0.2587E-01 0.5137E-29 + 2980 0.2584E-01 0.5130E-29 + 2981 0.2581E-01 0.5123E-29 + 2982 0.2578E-01 0.5116E-29 + 2983 0.2575E-01 0.5109E-29 + 2984 0.2572E-01 0.5102E-29 + 2985 0.2569E-01 0.5096E-29 + 2986 0.2566E-01 0.5089E-29 + 2987 0.2563E-01 0.5082E-29 + 2988 0.2560E-01 0.5075E-29 + 2989 0.2557E-01 0.5068E-29 + 2990 0.2554E-01 0.5062E-29 + 2991 0.2551E-01 0.5055E-29 + 2992 0.2548E-01 0.5048E-29 + 2993 0.2545E-01 0.5041E-29 + 2994 0.2542E-01 0.5035E-29 + 2995 0.2539E-01 0.5028E-29 + 2996 0.2536E-01 0.5021E-29 + 2997 0.2533E-01 0.5015E-29 + 2998 0.2530E-01 0.5008E-29 + 2999 0.2527E-01 0.5001E-29 + 3000 0.2524E-01 0.4995E-29 + 3001 0.2521E-01 0.4988E-29 + 3002 0.2518E-01 0.4981E-29 + 3003 0.2515E-01 0.4975E-29 + 3004 0.2512E-01 0.4968E-29 + 3005 0.2509E-01 0.4961E-29 + 3006 0.2506E-01 0.4955E-29 + 3007 0.2504E-01 0.4948E-29 + 3008 0.2501E-01 0.4942E-29 + 3009 0.2498E-01 0.4935E-29 + 3010 0.2495E-01 0.4928E-29 + 3011 0.2492E-01 0.4922E-29 + 3012 0.2489E-01 0.4915E-29 + 3013 0.2486E-01 0.4909E-29 + 3014 0.2483E-01 0.4902E-29 + 3015 0.2480E-01 0.4896E-29 + 3016 0.2477E-01 0.4889E-29 + 3017 0.2474E-01 0.4883E-29 + 3018 0.2472E-01 0.4876E-29 + 3019 0.2469E-01 0.4870E-29 + 3020 0.2466E-01 0.4864E-29 + 3021 0.2463E-01 0.4857E-29 + 3022 0.2460E-01 0.4851E-29 + 3023 0.2457E-01 0.4844E-29 + 3024 0.2454E-01 0.4838E-29 + 3025 0.2451E-01 0.4831E-29 + 3026 0.2449E-01 0.4825E-29 + 3027 0.2446E-01 0.4819E-29 + 3028 0.2443E-01 0.4812E-29 + 3029 0.2440E-01 0.4806E-29 + 3030 0.2437E-01 0.4800E-29 + 3031 0.2434E-01 0.4793E-29 + 3032 0.2432E-01 0.4787E-29 + 3033 0.2429E-01 0.4781E-29 + 3034 0.2426E-01 0.4774E-29 + 3035 0.2423E-01 0.4768E-29 + 3036 0.2420E-01 0.4762E-29 + 3037 0.2417E-01 0.4756E-29 + 3038 0.2415E-01 0.4749E-29 + 3039 0.2412E-01 0.4743E-29 + 3040 0.2409E-01 0.4737E-29 + 3041 0.2406E-01 0.4731E-29 + 3042 0.2403E-01 0.4724E-29 + 3043 0.2401E-01 0.4718E-29 + 3044 0.2398E-01 0.4712E-29 + 3045 0.2395E-01 0.4706E-29 + 3046 0.2392E-01 0.4700E-29 + 3047 0.2390E-01 0.4693E-29 + 3048 0.2387E-01 0.4687E-29 + 3049 0.2384E-01 0.4681E-29 + 3050 0.2381E-01 0.4675E-29 + 3051 0.2379E-01 0.4669E-29 + 3052 0.2376E-01 0.4663E-29 + 3053 0.2373E-01 0.4657E-29 + 3054 0.2370E-01 0.4651E-29 + 3055 0.2368E-01 0.4644E-29 + 3056 0.2365E-01 0.4638E-29 + 3057 0.2362E-01 0.4632E-29 + 3058 0.2359E-01 0.4626E-29 + 3059 0.2357E-01 0.4620E-29 + 3060 0.2354E-01 0.4614E-29 + 3061 0.2351E-01 0.4608E-29 + 3062 0.2349E-01 0.4602E-29 + 3063 0.2346E-01 0.4596E-29 + 3064 0.2343E-01 0.4590E-29 + 3065 0.2340E-01 0.4584E-29 + 3066 0.2338E-01 0.4578E-29 + 3067 0.2335E-01 0.4572E-29 + 3068 0.2332E-01 0.4566E-29 + 3069 0.2330E-01 0.4560E-29 + 3070 0.2327E-01 0.4554E-29 + 3071 0.2324E-01 0.4548E-29 + 3072 0.2322E-01 0.4542E-29 + 3073 0.2319E-01 0.4537E-29 + 3074 0.2316E-01 0.4531E-29 + 3075 0.2314E-01 0.4525E-29 + 3076 0.2311E-01 0.4519E-29 + 3077 0.2308E-01 0.4513E-29 + 3078 0.2306E-01 0.4507E-29 + 3079 0.2303E-01 0.4501E-29 + 3080 0.2300E-01 0.4495E-29 + 3081 0.2298E-01 0.4490E-29 + 3082 0.2295E-01 0.4484E-29 + 3083 0.2293E-01 0.4478E-29 + 3084 0.2290E-01 0.4472E-29 + 3085 0.2287E-01 0.4466E-29 + 3086 0.2285E-01 0.4461E-29 + 3087 0.2282E-01 0.4455E-29 + 3088 0.2279E-01 0.4449E-29 + 3089 0.2277E-01 0.4443E-29 + 3090 0.2274E-01 0.4438E-29 + 3091 0.2272E-01 0.4432E-29 + 3092 0.2269E-01 0.4426E-29 + 3093 0.2266E-01 0.4420E-29 + 3094 0.2264E-01 0.4415E-29 + 3095 0.2261E-01 0.4409E-29 + 3096 0.2259E-01 0.4403E-29 + 3097 0.2256E-01 0.4398E-29 + 3098 0.2253E-01 0.4392E-29 + 3099 0.2251E-01 0.4386E-29 + 3100 0.2248E-01 0.4381E-29 + 3101 0.2246E-01 0.4375E-29 + 3102 0.2243E-01 0.4369E-29 + 3103 0.2241E-01 0.4364E-29 + 3104 0.2238E-01 0.4358E-29 + 3105 0.2236E-01 0.4352E-29 + 3106 0.2233E-01 0.4347E-29 + 3107 0.2230E-01 0.4341E-29 + 3108 0.2228E-01 0.4336E-29 + 3109 0.2225E-01 0.4330E-29 + 3110 0.2223E-01 0.4324E-29 + 3111 0.2220E-01 0.4319E-29 + 3112 0.2218E-01 0.4313E-29 + 3113 0.2215E-01 0.4308E-29 + 3114 0.2213E-01 0.4302E-29 + 3115 0.2210E-01 0.4297E-29 + 3116 0.2208E-01 0.4291E-29 + 3117 0.2205E-01 0.4286E-29 + 3118 0.2203E-01 0.4280E-29 + 3119 0.2200E-01 0.4275E-29 + 3120 0.2198E-01 0.4269E-29 + 3121 0.2195E-01 0.4264E-29 + 3122 0.2193E-01 0.4258E-29 + 3123 0.2190E-01 0.4253E-29 + 3124 0.2188E-01 0.4247E-29 + 3125 0.2185E-01 0.4242E-29 + 3126 0.2183E-01 0.4237E-29 + 3127 0.2180E-01 0.4231E-29 + 3128 0.2178E-01 0.4226E-29 + 3129 0.2175E-01 0.4220E-29 + 3130 0.2173E-01 0.4215E-29 + 3131 0.2171E-01 0.4210E-29 + 3132 0.2168E-01 0.4204E-29 + 3133 0.2166E-01 0.4199E-29 + 3134 0.2163E-01 0.4194E-29 + 3135 0.2161E-01 0.4188E-29 + 3136 0.2158E-01 0.4183E-29 + 3137 0.2156E-01 0.4178E-29 + 3138 0.2153E-01 0.4172E-29 + 3139 0.2151E-01 0.4167E-29 + 3140 0.2149E-01 0.4162E-29 + 3141 0.2146E-01 0.4156E-29 + 3142 0.2144E-01 0.4151E-29 + 3143 0.2141E-01 0.4146E-29 + 3144 0.2139E-01 0.4140E-29 + 3145 0.2136E-01 0.4135E-29 + 3146 0.2134E-01 0.4130E-29 + 3147 0.2132E-01 0.4125E-29 + 3148 0.2129E-01 0.4119E-29 + 3149 0.2127E-01 0.4114E-29 + 3150 0.2124E-01 0.4109E-29 + 3151 0.2122E-01 0.4104E-29 + 3152 0.2120E-01 0.4099E-29 + 3153 0.2117E-01 0.4093E-29 + 3154 0.2115E-01 0.4088E-29 + 3155 0.2113E-01 0.4083E-29 + 3156 0.2110E-01 0.4078E-29 + 3157 0.2108E-01 0.4073E-29 + 3158 0.2105E-01 0.4068E-29 + 3159 0.2103E-01 0.4062E-29 + 3160 0.2101E-01 0.4057E-29 + 3161 0.2098E-01 0.4052E-29 + 3162 0.2096E-01 0.4047E-29 + 3163 0.2094E-01 0.4042E-29 + 3164 0.2091E-01 0.4037E-29 + 3165 0.2089E-01 0.4032E-29 + 3166 0.2087E-01 0.4027E-29 + 3167 0.2084E-01 0.4021E-29 + 3168 0.2082E-01 0.4016E-29 + 3169 0.2080E-01 0.4011E-29 + 3170 0.2077E-01 0.4006E-29 + 3171 0.2075E-01 0.4001E-29 + 3172 0.2073E-01 0.3996E-29 + 3173 0.2070E-01 0.3991E-29 + 3174 0.2068E-01 0.3986E-29 + 3175 0.2066E-01 0.3981E-29 + 3176 0.2063E-01 0.3976E-29 + 3177 0.2061E-01 0.3971E-29 + 3178 0.2059E-01 0.3966E-29 + 3179 0.2057E-01 0.3961E-29 + 3180 0.2054E-01 0.3956E-29 + 3181 0.2052E-01 0.3951E-29 + 3182 0.2050E-01 0.3946E-29 + 3183 0.2047E-01 0.3941E-29 + 3184 0.2045E-01 0.3936E-29 + 3185 0.2043E-01 0.3931E-29 + 3186 0.2041E-01 0.3926E-29 + 3187 0.2038E-01 0.3921E-29 + 3188 0.2036E-01 0.3917E-29 + 3189 0.2034E-01 0.3912E-29 + 3190 0.2031E-01 0.3907E-29 + 3191 0.2029E-01 0.3902E-29 + 3192 0.2027E-01 0.3897E-29 + 3193 0.2025E-01 0.3892E-29 + 3194 0.2022E-01 0.3887E-29 + 3195 0.2020E-01 0.3882E-29 + 3196 0.2018E-01 0.3877E-29 + 3197 0.2016E-01 0.3873E-29 + 3198 0.2013E-01 0.3868E-29 + 3199 0.2011E-01 0.3863E-29 + 3200 0.2009E-01 0.3858E-29 + 3201 0.2007E-01 0.3853E-29 + 3202 0.2005E-01 0.3849E-29 + 3203 0.2002E-01 0.3844E-29 + 3204 0.2000E-01 0.3839E-29 + 3205 0.1998E-01 0.3834E-29 + 3206 0.1996E-01 0.3829E-29 + 3207 0.1993E-01 0.3825E-29 + 3208 0.1991E-01 0.3820E-29 + 3209 0.1989E-01 0.3815E-29 + 3210 0.1987E-01 0.3810E-29 + 3211 0.1985E-01 0.3806E-29 + 3212 0.1982E-01 0.3801E-29 + 3213 0.1980E-01 0.3796E-29 + 3214 0.1978E-01 0.3791E-29 + 3215 0.1976E-01 0.3787E-29 + 3216 0.1974E-01 0.3782E-29 + 3217 0.1971E-01 0.3777E-29 + 3218 0.1969E-01 0.3773E-29 + 3219 0.1967E-01 0.3768E-29 + 3220 0.1965E-01 0.3763E-29 + 3221 0.1963E-01 0.3758E-29 + 3222 0.1961E-01 0.3754E-29 + 3223 0.1958E-01 0.3749E-29 + 3224 0.1956E-01 0.3745E-29 + 3225 0.1954E-01 0.3740E-29 + 3226 0.1952E-01 0.3735E-29 + 3227 0.1950E-01 0.3731E-29 + 3228 0.1948E-01 0.3726E-29 + 3229 0.1946E-01 0.3721E-29 + 3230 0.1943E-01 0.3717E-29 + 3231 0.1941E-01 0.3712E-29 + 3232 0.1939E-01 0.3708E-29 + 3233 0.1937E-01 0.3703E-29 + 3234 0.1935E-01 0.3698E-29 + 3235 0.1933E-01 0.3694E-29 + 3236 0.1931E-01 0.3689E-29 + 3237 0.1928E-01 0.3685E-29 + 3238 0.1926E-01 0.3680E-29 + 3239 0.1924E-01 0.3676E-29 + 3240 0.1922E-01 0.3671E-29 + 3241 0.1920E-01 0.3667E-29 + 3242 0.1918E-01 0.3662E-29 + 3243 0.1916E-01 0.3658E-29 + 3244 0.1914E-01 0.3653E-29 + 3245 0.1912E-01 0.3649E-29 + 3246 0.1910E-01 0.3644E-29 + 3247 0.1907E-01 0.3640E-29 + 3248 0.1905E-01 0.3635E-29 + 3249 0.1903E-01 0.3631E-29 + 3250 0.1901E-01 0.3626E-29 + 3251 0.1899E-01 0.3622E-29 + 3252 0.1897E-01 0.3617E-29 + 3253 0.1895E-01 0.3613E-29 + 3254 0.1893E-01 0.3608E-29 + 3255 0.1891E-01 0.3604E-29 + 3256 0.1889E-01 0.3599E-29 + 3257 0.1887E-01 0.3595E-29 + 3258 0.1885E-01 0.3591E-29 + 3259 0.1883E-01 0.3586E-29 + 3260 0.1880E-01 0.3582E-29 + 3261 0.1878E-01 0.3577E-29 + 3262 0.1876E-01 0.3573E-29 + 3263 0.1874E-01 0.3569E-29 + 3264 0.1872E-01 0.3564E-29 + 3265 0.1870E-01 0.3560E-29 + 3266 0.1868E-01 0.3556E-29 + 3267 0.1866E-01 0.3551E-29 + 3268 0.1864E-01 0.3547E-29 + 3269 0.1862E-01 0.3543E-29 + 3270 0.1860E-01 0.3538E-29 + 3271 0.1858E-01 0.3534E-29 + 3272 0.1856E-01 0.3530E-29 + 3273 0.1854E-01 0.3525E-29 + 3274 0.1852E-01 0.3521E-29 + 3275 0.1850E-01 0.3517E-29 + 3276 0.1848E-01 0.3512E-29 + 3277 0.1846E-01 0.3508E-29 + 3278 0.1844E-01 0.3504E-29 + 3279 0.1842E-01 0.3500E-29 + 3280 0.1840E-01 0.3495E-29 + 3281 0.1838E-01 0.3491E-29 + 3282 0.1836E-01 0.3487E-29 + 3283 0.1834E-01 0.3483E-29 + 3284 0.1832E-01 0.3478E-29 + 3285 0.1830E-01 0.3474E-29 + 3286 0.1828E-01 0.3470E-29 + 3287 0.1826E-01 0.3466E-29 + 3288 0.1824E-01 0.3461E-29 + 3289 0.1822E-01 0.3457E-29 + 3290 0.1820E-01 0.3453E-29 + 3291 0.1818E-01 0.3449E-29 + 3292 0.1816E-01 0.3445E-29 + 3293 0.1814E-01 0.3440E-29 + 3294 0.1812E-01 0.3436E-29 + 3295 0.1810E-01 0.3432E-29 + 3296 0.1808E-01 0.3428E-29 + 3297 0.1806E-01 0.3424E-29 + 3298 0.1804E-01 0.3420E-29 + 3299 0.1802E-01 0.3415E-29 + 3300 0.1800E-01 0.3411E-29 + 3301 0.1799E-01 0.3407E-29 + 3302 0.1797E-01 0.3403E-29 + 3303 0.1795E-01 0.3399E-29 + 3304 0.1793E-01 0.3395E-29 + 3305 0.1791E-01 0.3391E-29 + 3306 0.1789E-01 0.3387E-29 + 3307 0.1787E-01 0.3383E-29 + 3308 0.1785E-01 0.3378E-29 + 3309 0.1783E-01 0.3374E-29 + 3310 0.1781E-01 0.3370E-29 + 3311 0.1779E-01 0.3366E-29 + 3312 0.1777E-01 0.3362E-29 + 3313 0.1775E-01 0.3358E-29 + 3314 0.1773E-01 0.3354E-29 + 3315 0.1772E-01 0.3350E-29 + 3316 0.1770E-01 0.3346E-29 + 3317 0.1768E-01 0.3342E-29 + 3318 0.1766E-01 0.3338E-29 + 3319 0.1764E-01 0.3334E-29 + 3320 0.1762E-01 0.3330E-29 + 3321 0.1760E-01 0.3326E-29 + 3322 0.1758E-01 0.3322E-29 + 3323 0.1756E-01 0.3318E-29 + 3324 0.1754E-01 0.3314E-29 + 3325 0.1753E-01 0.3310E-29 + 3326 0.1751E-01 0.3306E-29 + 3327 0.1749E-01 0.3302E-29 + 3328 0.1747E-01 0.3298E-29 + 3329 0.1745E-01 0.3294E-29 + 3330 0.1743E-01 0.3290E-29 + 3331 0.1741E-01 0.3286E-29 + 3332 0.1739E-01 0.3282E-29 + 3333 0.1738E-01 0.3278E-29 + 3334 0.1736E-01 0.3274E-29 + 3335 0.1734E-01 0.3270E-29 + 3336 0.1732E-01 0.3266E-29 + 3337 0.1730E-01 0.3263E-29 + 3338 0.1728E-01 0.3259E-29 + 3339 0.1726E-01 0.3255E-29 + 3340 0.1725E-01 0.3251E-29 + 3341 0.1723E-01 0.3247E-29 + 3342 0.1721E-01 0.3243E-29 + 3343 0.1719E-01 0.3239E-29 + 3344 0.1717E-01 0.3235E-29 + 3345 0.1715E-01 0.3231E-29 + 3346 0.1714E-01 0.3228E-29 + 3347 0.1712E-01 0.3224E-29 + 3348 0.1710E-01 0.3220E-29 + 3349 0.1708E-01 0.3216E-29 + 3350 0.1706E-01 0.3212E-29 + 3351 0.1704E-01 0.3208E-29 + 3352 0.1703E-01 0.3205E-29 + 3353 0.1701E-01 0.3201E-29 + 3354 0.1699E-01 0.3197E-29 + 3355 0.1697E-01 0.3193E-29 + 3356 0.1695E-01 0.3189E-29 + 3357 0.1694E-01 0.3185E-29 + 3358 0.1692E-01 0.3182E-29 + 3359 0.1690E-01 0.3178E-29 + 3360 0.1688E-01 0.3174E-29 + 3361 0.1686E-01 0.3170E-29 + 3362 0.1685E-01 0.3167E-29 + 3363 0.1683E-01 0.3163E-29 + 3364 0.1681E-01 0.3159E-29 + 3365 0.1679E-01 0.3155E-29 + 3366 0.1677E-01 0.3152E-29 + 3367 0.1676E-01 0.3148E-29 + 3368 0.1674E-01 0.3144E-29 + 3369 0.1672E-01 0.3140E-29 + 3370 0.1670E-01 0.3137E-29 + 3371 0.1669E-01 0.3133E-29 + 3372 0.1667E-01 0.3129E-29 + 3373 0.1665E-01 0.3125E-29 + 3374 0.1663E-01 0.3122E-29 + 3375 0.1661E-01 0.3118E-29 + 3376 0.1660E-01 0.3114E-29 + 3377 0.1658E-01 0.3111E-29 + 3378 0.1656E-01 0.3107E-29 + 3379 0.1654E-01 0.3103E-29 + 3380 0.1653E-01 0.3100E-29 + 3381 0.1651E-01 0.3096E-29 + 3382 0.1649E-01 0.3092E-29 + 3383 0.1647E-01 0.3089E-29 + 3384 0.1646E-01 0.3085E-29 + 3385 0.1644E-01 0.3081E-29 + 3386 0.1642E-01 0.3078E-29 + 3387 0.1641E-01 0.3074E-29 + 3388 0.1639E-01 0.3070E-29 + 3389 0.1637E-01 0.3067E-29 + 3390 0.1635E-01 0.3063E-29 + 3391 0.1634E-01 0.3060E-29 + 3392 0.1632E-01 0.3056E-29 + 3393 0.1630E-01 0.3052E-29 + 3394 0.1628E-01 0.3049E-29 + 3395 0.1627E-01 0.3045E-29 + 3396 0.1625E-01 0.3042E-29 + 3397 0.1623E-01 0.3038E-29 + 3398 0.1622E-01 0.3034E-29 + 3399 0.1620E-01 0.3031E-29 + 3400 0.1618E-01 0.3027E-29 + 3401 0.1616E-01 0.3024E-29 + 3402 0.1615E-01 0.3020E-29 + 3403 0.1613E-01 0.3017E-29 + 3404 0.1611E-01 0.3013E-29 + 3405 0.1610E-01 0.3010E-29 + 3406 0.1608E-01 0.3006E-29 + 3407 0.1606E-01 0.3003E-29 + 3408 0.1605E-01 0.2999E-29 + 3409 0.1603E-01 0.2996E-29 + 3410 0.1601E-01 0.2992E-29 + 3411 0.1600E-01 0.2988E-29 + 3412 0.1598E-01 0.2985E-29 + 3413 0.1596E-01 0.2981E-29 + 3414 0.1595E-01 0.2978E-29 + 3415 0.1593E-01 0.2975E-29 + 3416 0.1591E-01 0.2971E-29 + 3417 0.1589E-01 0.2968E-29 + 3418 0.1588E-01 0.2964E-29 + 3419 0.1586E-01 0.2961E-29 + 3420 0.1584E-01 0.2957E-29 + 3421 0.1583E-01 0.2954E-29 + 3422 0.1581E-01 0.2950E-29 + 3423 0.1580E-01 0.2947E-29 + 3424 0.1578E-01 0.2943E-29 + 3425 0.1576E-01 0.2940E-29 + 3426 0.1575E-01 0.2936E-29 + 3427 0.1573E-01 0.2933E-29 + 3428 0.1571E-01 0.2930E-29 + 3429 0.1570E-01 0.2926E-29 + 3430 0.1568E-01 0.2923E-29 + 3431 0.1566E-01 0.2919E-29 + 3432 0.1565E-01 0.2916E-29 + 3433 0.1563E-01 0.2913E-29 + 3434 0.1561E-01 0.2909E-29 + 3435 0.1560E-01 0.2906E-29 + 3436 0.1558E-01 0.2902E-29 + 3437 0.1557E-01 0.2899E-29 + 3438 0.1555E-01 0.2896E-29 + 3439 0.1553E-01 0.2892E-29 + 3440 0.1552E-01 0.2889E-29 + 3441 0.1550E-01 0.2886E-29 + 3442 0.1548E-01 0.2882E-29 + 3443 0.1547E-01 0.2879E-29 + 3444 0.1545E-01 0.2876E-29 + 3445 0.1544E-01 0.2872E-29 + 3446 0.1542E-01 0.2869E-29 + 3447 0.1540E-01 0.2866E-29 + 3448 0.1539E-01 0.2862E-29 + 3449 0.1537E-01 0.2859E-29 + 3450 0.1536E-01 0.2856E-29 + 3451 0.1534E-01 0.2852E-29 + 3452 0.1532E-01 0.2849E-29 + 3453 0.1531E-01 0.2846E-29 + 3454 0.1529E-01 0.2842E-29 + 3455 0.1528E-01 0.2839E-29 + 3456 0.1526E-01 0.2836E-29 + 3457 0.1524E-01 0.2833E-29 + 3458 0.1523E-01 0.2829E-29 + 3459 0.1521E-01 0.2826E-29 + 3460 0.1520E-01 0.2823E-29 + 3461 0.1518E-01 0.2819E-29 + 3462 0.1517E-01 0.2816E-29 + 3463 0.1515E-01 0.2813E-29 + 3464 0.1513E-01 0.2810E-29 + 3465 0.1512E-01 0.2806E-29 + 3466 0.1510E-01 0.2803E-29 + 3467 0.1509E-01 0.2800E-29 + 3468 0.1507E-01 0.2797E-29 + 3469 0.1506E-01 0.2794E-29 + 3470 0.1504E-01 0.2790E-29 + 3471 0.1503E-01 0.2787E-29 + 3472 0.1501E-01 0.2784E-29 + 3473 0.1499E-01 0.2781E-29 + 3474 0.1498E-01 0.2778E-29 + 3475 0.1496E-01 0.2774E-29 + 3476 0.1495E-01 0.2771E-29 + 3477 0.1493E-01 0.2768E-29 + 3478 0.1492E-01 0.2765E-29 + 3479 0.1490E-01 0.2762E-29 + 3480 0.1489E-01 0.2758E-29 + 3481 0.1487E-01 0.2755E-29 + 3482 0.1486E-01 0.2752E-29 + 3483 0.1484E-01 0.2749E-29 + 3484 0.1482E-01 0.2746E-29 + 3485 0.1481E-01 0.2743E-29 + 3486 0.1479E-01 0.2739E-29 + 3487 0.1478E-01 0.2736E-29 + 3488 0.1476E-01 0.2733E-29 + 3489 0.1475E-01 0.2730E-29 + 3490 0.1473E-01 0.2727E-29 + 3491 0.1472E-01 0.2724E-29 + 3492 0.1470E-01 0.2721E-29 + 3493 0.1469E-01 0.2718E-29 + 3494 0.1467E-01 0.2714E-29 + 3495 0.1466E-01 0.2711E-29 + 3496 0.1464E-01 0.2708E-29 + 3497 0.1463E-01 0.2705E-29 + 3498 0.1461E-01 0.2702E-29 + 3499 0.1460E-01 0.2699E-29 + 3500 0.1458E-01 0.2696E-29 + 3501 0.1457E-01 0.2693E-29 + 3502 0.1455E-01 0.2690E-29 + 3503 0.1454E-01 0.2687E-29 + 3504 0.1452E-01 0.2684E-29 + 3505 0.1451E-01 0.2681E-29 + 3506 0.1449E-01 0.2678E-29 + 3507 0.1448E-01 0.2674E-29 + 3508 0.1446E-01 0.2671E-29 + 3509 0.1445E-01 0.2668E-29 + 3510 0.1443E-01 0.2665E-29 + 3511 0.1442E-01 0.2662E-29 + 3512 0.1440E-01 0.2659E-29 + 3513 0.1439E-01 0.2656E-29 + 3514 0.1437E-01 0.2653E-29 + 3515 0.1436E-01 0.2650E-29 + 3516 0.1435E-01 0.2647E-29 + 3517 0.1433E-01 0.2644E-29 + 3518 0.1432E-01 0.2641E-29 + 3519 0.1430E-01 0.2638E-29 + 3520 0.1429E-01 0.2635E-29 + 3521 0.1427E-01 0.2632E-29 + 3522 0.1426E-01 0.2629E-29 + 3523 0.1424E-01 0.2626E-29 + 3524 0.1423E-01 0.2623E-29 + 3525 0.1421E-01 0.2620E-29 + 3526 0.1420E-01 0.2617E-29 + 3527 0.1418E-01 0.2614E-29 + 3528 0.1417E-01 0.2611E-29 + 3529 0.1416E-01 0.2608E-29 + 3530 0.1414E-01 0.2605E-29 + 3531 0.1413E-01 0.2602E-29 + 3532 0.1411E-01 0.2600E-29 + 3533 0.1410E-01 0.2597E-29 + 3534 0.1408E-01 0.2594E-29 + 3535 0.1407E-01 0.2591E-29 + 3536 0.1406E-01 0.2588E-29 + 3537 0.1404E-01 0.2585E-29 + 3538 0.1403E-01 0.2582E-29 + 3539 0.1401E-01 0.2579E-29 + 3540 0.1400E-01 0.2576E-29 + 3541 0.1398E-01 0.2573E-29 + 3542 0.1397E-01 0.2570E-29 + 3543 0.1396E-01 0.2567E-29 + 3544 0.1394E-01 0.2564E-29 + 3545 0.1393E-01 0.2562E-29 + 3546 0.1391E-01 0.2559E-29 + 3547 0.1390E-01 0.2556E-29 + 3548 0.1388E-01 0.2553E-29 + 3549 0.1387E-01 0.2550E-29 + 3550 0.1386E-01 0.2547E-29 + 3551 0.1384E-01 0.2544E-29 + 3552 0.1383E-01 0.2541E-29 + 3553 0.1381E-01 0.2539E-29 + 3554 0.1380E-01 0.2536E-29 + 3555 0.1379E-01 0.2533E-29 + 3556 0.1377E-01 0.2530E-29 + 3557 0.1376E-01 0.2527E-29 + 3558 0.1374E-01 0.2524E-29 + 3559 0.1373E-01 0.2522E-29 + 3560 0.1372E-01 0.2519E-29 + 3561 0.1370E-01 0.2516E-29 + 3562 0.1369E-01 0.2513E-29 + 3563 0.1368E-01 0.2510E-29 + 3564 0.1366E-01 0.2507E-29 + 3565 0.1365E-01 0.2505E-29 + 3566 0.1363E-01 0.2502E-29 + 3567 0.1362E-01 0.2499E-29 + 3568 0.1361E-01 0.2496E-29 + 3569 0.1359E-01 0.2493E-29 + 3570 0.1358E-01 0.2491E-29 + 3571 0.1357E-01 0.2488E-29 + 3572 0.1355E-01 0.2485E-29 + 3573 0.1354E-01 0.2482E-29 + 3574 0.1352E-01 0.2479E-29 + 3575 0.1351E-01 0.2477E-29 + 3576 0.1350E-01 0.2474E-29 + 3577 0.1348E-01 0.2471E-29 + 3578 0.1347E-01 0.2468E-29 + 3579 0.1346E-01 0.2466E-29 + 3580 0.1344E-01 0.2463E-29 + 3581 0.1343E-01 0.2460E-29 + 3582 0.1342E-01 0.2457E-29 + 3583 0.1340E-01 0.2455E-29 + 3584 0.1339E-01 0.2452E-29 + 3585 0.1338E-01 0.2449E-29 + 3586 0.1336E-01 0.2446E-29 + 3587 0.1335E-01 0.2444E-29 + 3588 0.1334E-01 0.2441E-29 + 3589 0.1332E-01 0.2438E-29 + 3590 0.1331E-01 0.2436E-29 + 3591 0.1329E-01 0.2433E-29 + 3592 0.1328E-01 0.2430E-29 + 3593 0.1327E-01 0.2427E-29 + 3594 0.1325E-01 0.2425E-29 + 3595 0.1324E-01 0.2422E-29 + 3596 0.1323E-01 0.2419E-29 + 3597 0.1322E-01 0.2417E-29 + 3598 0.1320E-01 0.2414E-29 + 3599 0.1319E-01 0.2411E-29 + 3600 0.1318E-01 0.2409E-29 + 3601 0.1316E-01 0.2406E-29 + 3602 0.1315E-01 0.2403E-29 + 3603 0.1314E-01 0.2401E-29 + 3604 0.1312E-01 0.2398E-29 + 3605 0.1311E-01 0.2395E-29 + 3606 0.1310E-01 0.2393E-29 + 3607 0.1308E-01 0.2390E-29 + 3608 0.1307E-01 0.2387E-29 + 3609 0.1306E-01 0.2385E-29 + 3610 0.1304E-01 0.2382E-29 + 3611 0.1303E-01 0.2379E-29 + 3612 0.1302E-01 0.2377E-29 + 3613 0.1301E-01 0.2374E-29 + 3614 0.1299E-01 0.2372E-29 + 3615 0.1298E-01 0.2369E-29 + 3616 0.1297E-01 0.2366E-29 + 3617 0.1295E-01 0.2364E-29 + 3618 0.1294E-01 0.2361E-29 + 3619 0.1293E-01 0.2358E-29 + 3620 0.1291E-01 0.2356E-29 + 3621 0.1290E-01 0.2353E-29 + 3622 0.1289E-01 0.2351E-29 + 3623 0.1288E-01 0.2348E-29 + 3624 0.1286E-01 0.2345E-29 + 3625 0.1285E-01 0.2343E-29 + 3626 0.1284E-01 0.2340E-29 + 3627 0.1282E-01 0.2338E-29 + 3628 0.1281E-01 0.2335E-29 + 3629 0.1280E-01 0.2333E-29 + 3630 0.1279E-01 0.2330E-29 + 3631 0.1277E-01 0.2327E-29 + 3632 0.1276E-01 0.2325E-29 + 3633 0.1275E-01 0.2322E-29 + 3634 0.1274E-01 0.2320E-29 + 3635 0.1272E-01 0.2317E-29 + 3636 0.1271E-01 0.2315E-29 + 3637 0.1270E-01 0.2312E-29 + 3638 0.1269E-01 0.2310E-29 + 3639 0.1267E-01 0.2307E-29 + 3640 0.1266E-01 0.2304E-29 + 3641 0.1265E-01 0.2302E-29 + 3642 0.1263E-01 0.2299E-29 + 3643 0.1262E-01 0.2297E-29 + 3644 0.1261E-01 0.2294E-29 + 3645 0.1260E-01 0.2292E-29 + 3646 0.1258E-01 0.2289E-29 + 3647 0.1257E-01 0.2287E-29 + 3648 0.1256E-01 0.2284E-29 + 3649 0.1255E-01 0.2282E-29 + 3650 0.1254E-01 0.2279E-29 + 3651 0.1252E-01 0.2277E-29 + 3652 0.1251E-01 0.2274E-29 + 3653 0.1250E-01 0.2272E-29 + 3654 0.1249E-01 0.2269E-29 + 3655 0.1247E-01 0.2267E-29 + 3656 0.1246E-01 0.2264E-29 + 3657 0.1245E-01 0.2262E-29 + 3658 0.1244E-01 0.2259E-29 + 3659 0.1242E-01 0.2257E-29 + 3660 0.1241E-01 0.2255E-29 + 3661 0.1240E-01 0.2252E-29 + 3662 0.1239E-01 0.2250E-29 + 3663 0.1238E-01 0.2247E-29 + 3664 0.1236E-01 0.2245E-29 + 3665 0.1235E-01 0.2242E-29 + 3666 0.1234E-01 0.2240E-29 + 3667 0.1233E-01 0.2237E-29 + 3668 0.1231E-01 0.2235E-29 + 3669 0.1230E-01 0.2232E-29 + 3670 0.1229E-01 0.2230E-29 + 3671 0.1228E-01 0.2228E-29 + 3672 0.1227E-01 0.2225E-29 + 3673 0.1225E-01 0.2223E-29 + 3674 0.1224E-01 0.2220E-29 + 3675 0.1223E-01 0.2218E-29 + 3676 0.1222E-01 0.2216E-29 + 3677 0.1221E-01 0.2213E-29 + 3678 0.1219E-01 0.2211E-29 + 3679 0.1218E-01 0.2208E-29 + 3680 0.1217E-01 0.2206E-29 + 3681 0.1216E-01 0.2204E-29 + 3682 0.1215E-01 0.2201E-29 + 3683 0.1213E-01 0.2199E-29 + 3684 0.1212E-01 0.2196E-29 + 3685 0.1211E-01 0.2194E-29 + 3686 0.1210E-01 0.2192E-29 + 3687 0.1209E-01 0.2189E-29 + 3688 0.1207E-01 0.2187E-29 + 3689 0.1206E-01 0.2184E-29 + 3690 0.1205E-01 0.2182E-29 + 3691 0.1204E-01 0.2180E-29 + 3692 0.1203E-01 0.2177E-29 + 3693 0.1202E-01 0.2175E-29 + 3694 0.1200E-01 0.2173E-29 + 3695 0.1199E-01 0.2170E-29 + 3696 0.1198E-01 0.2168E-29 + 3697 0.1197E-01 0.2166E-29 + 3698 0.1196E-01 0.2163E-29 + 3699 0.1194E-01 0.2161E-29 + 3700 0.1193E-01 0.2159E-29 + 3701 0.1192E-01 0.2156E-29 + 3702 0.1191E-01 0.2154E-29 + 3703 0.1190E-01 0.2152E-29 + 3704 0.1189E-01 0.2149E-29 + 3705 0.1187E-01 0.2147E-29 + 3706 0.1186E-01 0.2145E-29 + 3707 0.1185E-01 0.2142E-29 + 3708 0.1184E-01 0.2140E-29 + 3709 0.1183E-01 0.2138E-29 + 3710 0.1182E-01 0.2135E-29 + 3711 0.1181E-01 0.2133E-29 + 3712 0.1179E-01 0.2131E-29 + 3713 0.1178E-01 0.2129E-29 + 3714 0.1177E-01 0.2126E-29 + 3715 0.1176E-01 0.2124E-29 + 3716 0.1175E-01 0.2122E-29 + 3717 0.1174E-01 0.2119E-29 + 3718 0.1173E-01 0.2117E-29 + 3719 0.1171E-01 0.2115E-29 + 3720 0.1170E-01 0.2113E-29 + 3721 0.1169E-01 0.2110E-29 + 3722 0.1168E-01 0.2108E-29 + 3723 0.1167E-01 0.2106E-29 + 3724 0.1166E-01 0.2103E-29 + 3725 0.1165E-01 0.2101E-29 + 3726 0.1163E-01 0.2099E-29 + 3727 0.1162E-01 0.2097E-29 + 3728 0.1161E-01 0.2094E-29 + 3729 0.1160E-01 0.2092E-29 + 3730 0.1159E-01 0.2090E-29 + 3731 0.1158E-01 0.2088E-29 + 3732 0.1157E-01 0.2086E-29 + 3733 0.1156E-01 0.2083E-29 + 3734 0.1154E-01 0.2081E-29 + 3735 0.1153E-01 0.2079E-29 + 3736 0.1152E-01 0.2077E-29 + 3737 0.1151E-01 0.2074E-29 + 3738 0.1150E-01 0.2072E-29 + 3739 0.1149E-01 0.2070E-29 + 3740 0.1148E-01 0.2068E-29 + 3741 0.1147E-01 0.2066E-29 + 3742 0.1146E-01 0.2063E-29 + 3743 0.1144E-01 0.2061E-29 + 3744 0.1143E-01 0.2059E-29 + 3745 0.1142E-01 0.2057E-29 + 3746 0.1141E-01 0.2055E-29 + 3747 0.1140E-01 0.2052E-29 + 3748 0.1139E-01 0.2050E-29 + 3749 0.1138E-01 0.2048E-29 + 3750 0.1137E-01 0.2046E-29 + 3751 0.1136E-01 0.2044E-29 + 3752 0.1134E-01 0.2041E-29 + 3753 0.1133E-01 0.2039E-29 + 3754 0.1132E-01 0.2037E-29 + 3755 0.1131E-01 0.2035E-29 + 3756 0.1130E-01 0.2033E-29 + 3757 0.1129E-01 0.2031E-29 + 3758 0.1128E-01 0.2028E-29 + 3759 0.1127E-01 0.2026E-29 + 3760 0.1126E-01 0.2024E-29 + 3761 0.1125E-01 0.2022E-29 + 3762 0.1124E-01 0.2020E-29 + 3763 0.1123E-01 0.2018E-29 + 3764 0.1121E-01 0.2015E-29 + 3765 0.1120E-01 0.2013E-29 + 3766 0.1119E-01 0.2011E-29 + 3767 0.1118E-01 0.2009E-29 + 3768 0.1117E-01 0.2007E-29 + 3769 0.1116E-01 0.2005E-29 + 3770 0.1115E-01 0.2003E-29 + 3771 0.1114E-01 0.2001E-29 + 3772 0.1113E-01 0.1998E-29 + 3773 0.1112E-01 0.1996E-29 + 3774 0.1111E-01 0.1994E-29 + 3775 0.1110E-01 0.1992E-29 + 3776 0.1109E-01 0.1990E-29 + 3777 0.1107E-01 0.1988E-29 + 3778 0.1106E-01 0.1986E-29 + 3779 0.1105E-01 0.1984E-29 + 3780 0.1104E-01 0.1982E-29 + 3781 0.1103E-01 0.1979E-29 + 3782 0.1102E-01 0.1977E-29 + 3783 0.1101E-01 0.1975E-29 + 3784 0.1100E-01 0.1973E-29 + 3785 0.1099E-01 0.1971E-29 + 3786 0.1098E-01 0.1969E-29 + 3787 0.1097E-01 0.1967E-29 + 3788 0.1096E-01 0.1965E-29 + 3789 0.1095E-01 0.1963E-29 + 3790 0.1094E-01 0.1961E-29 + 3791 0.1093E-01 0.1959E-29 + 3792 0.1092E-01 0.1957E-29 + 3793 0.1091E-01 0.1955E-29 + 3794 0.1090E-01 0.1952E-29 + 3795 0.1089E-01 0.1950E-29 + 3796 0.1087E-01 0.1948E-29 + 3797 0.1086E-01 0.1946E-29 + 3798 0.1085E-01 0.1944E-29 + 3799 0.1084E-01 0.1942E-29 + 3800 0.1083E-01 0.1940E-29 + 3801 0.1082E-01 0.1938E-29 + 3802 0.1081E-01 0.1936E-29 + 3803 0.1080E-01 0.1934E-29 + 3804 0.1079E-01 0.1932E-29 + 3805 0.1078E-01 0.1930E-29 + 3806 0.1077E-01 0.1928E-29 + 3807 0.1076E-01 0.1926E-29 + 3808 0.1075E-01 0.1924E-29 + 3809 0.1074E-01 0.1922E-29 + 3810 0.1073E-01 0.1920E-29 + 3811 0.1072E-01 0.1918E-29 + 3812 0.1071E-01 0.1916E-29 + 3813 0.1070E-01 0.1914E-29 + 3814 0.1069E-01 0.1912E-29 + 3815 0.1068E-01 0.1910E-29 + 3816 0.1067E-01 0.1908E-29 + 3817 0.1066E-01 0.1906E-29 + 3818 0.1065E-01 0.1904E-29 + 3819 0.1064E-01 0.1902E-29 + 3820 0.1063E-01 0.1900E-29 + 3821 0.1062E-01 0.1898E-29 + 3822 0.1061E-01 0.1896E-29 + 3823 0.1060E-01 0.1894E-29 + 3824 0.1059E-01 0.1892E-29 + 3825 0.1058E-01 0.1890E-29 + 3826 0.1057E-01 0.1888E-29 + 3827 0.1056E-01 0.1886E-29 + 3828 0.1055E-01 0.1884E-29 + 3829 0.1054E-01 0.1882E-29 + 3830 0.1053E-01 0.1880E-29 + 3831 0.1052E-01 0.1878E-29 + 3832 0.1051E-01 0.1876E-29 + 3833 0.1050E-01 0.1874E-29 + 3834 0.1049E-01 0.1872E-29 + 3835 0.1048E-01 0.1870E-29 + 3836 0.1047E-01 0.1868E-29 + 3837 0.1046E-01 0.1866E-29 + 3838 0.1045E-01 0.1864E-29 + 3839 0.1044E-01 0.1863E-29 + 3840 0.1043E-01 0.1861E-29 + 3841 0.1042E-01 0.1859E-29 + 3842 0.1041E-01 0.1857E-29 + 3843 0.1040E-01 0.1855E-29 + 3844 0.1039E-01 0.1853E-29 + 3845 0.1038E-01 0.1851E-29 + 3846 0.1037E-01 0.1849E-29 + 3847 0.1036E-01 0.1847E-29 + 3848 0.1035E-01 0.1845E-29 + 3849 0.1034E-01 0.1843E-29 + 3850 0.1033E-01 0.1841E-29 + 3851 0.1032E-01 0.1839E-29 + 3852 0.1031E-01 0.1838E-29 + 3853 0.1030E-01 0.1836E-29 + 3854 0.1029E-01 0.1834E-29 + 3855 0.1028E-01 0.1832E-29 + 3856 0.1027E-01 0.1830E-29 + 3857 0.1026E-01 0.1828E-29 + 3858 0.1025E-01 0.1826E-29 + 3859 0.1024E-01 0.1824E-29 + 3860 0.1023E-01 0.1822E-29 + 3861 0.1022E-01 0.1820E-29 + 3862 0.1021E-01 0.1819E-29 + 3863 0.1021E-01 0.1817E-29 + 3864 0.1020E-01 0.1815E-29 + 3865 0.1019E-01 0.1813E-29 + 3866 0.1018E-01 0.1811E-29 + 3867 0.1017E-01 0.1809E-29 + 3868 0.1016E-01 0.1807E-29 + 3869 0.1015E-01 0.1805E-29 + 3870 0.1014E-01 0.1804E-29 + 3871 0.1013E-01 0.1802E-29 + 3872 0.1012E-01 0.1800E-29 + 3873 0.1011E-01 0.1798E-29 + 3874 0.1010E-01 0.1796E-29 + 3875 0.1009E-01 0.1794E-29 + 3876 0.1008E-01 0.1792E-29 + 3877 0.1007E-01 0.1791E-29 + 3878 0.1006E-01 0.1789E-29 + 3879 0.1005E-01 0.1787E-29 + 3880 0.1004E-01 0.1785E-29 + 3881 0.1003E-01 0.1783E-29 + 3882 0.1002E-01 0.1781E-29 + 3883 0.1002E-01 0.1780E-29 + 3884 0.1001E-01 0.1778E-29 + 3885 0.9996E-02 0.1776E-29 + 3886 0.9987E-02 0.1774E-29 + 3887 0.9978E-02 0.1772E-29 + 3888 0.9968E-02 0.1770E-29 + 3889 0.9959E-02 0.1769E-29 + 3890 0.9950E-02 0.1767E-29 + 3891 0.9940E-02 0.1765E-29 + 3892 0.9931E-02 0.1763E-29 + 3893 0.9922E-02 0.1761E-29 + 3894 0.9912E-02 0.1760E-29 + 3895 0.9903E-02 0.1758E-29 + 3896 0.9894E-02 0.1756E-29 + 3897 0.9885E-02 0.1754E-29 + 3898 0.9875E-02 0.1752E-29 + 3899 0.9866E-02 0.1751E-29 + 3900 0.9857E-02 0.1749E-29 + 3901 0.9848E-02 0.1747E-29 + 3902 0.9839E-02 0.1745E-29 + 3903 0.9829E-02 0.1743E-29 + 3904 0.9820E-02 0.1742E-29 + 3905 0.9811E-02 0.1740E-29 + 3906 0.9802E-02 0.1738E-29 + 3907 0.9793E-02 0.1736E-29 + 3908 0.9784E-02 0.1734E-29 + 3909 0.9775E-02 0.1733E-29 + 3910 0.9766E-02 0.1731E-29 + 3911 0.9756E-02 0.1729E-29 + 3912 0.9747E-02 0.1727E-29 + 3913 0.9738E-02 0.1726E-29 + 3914 0.9729E-02 0.1724E-29 + 3915 0.9720E-02 0.1722E-29 + 3916 0.9711E-02 0.1720E-29 + 3917 0.9702E-02 0.1719E-29 + 3918 0.9693E-02 0.1717E-29 + 3919 0.9684E-02 0.1715E-29 + 3920 0.9675E-02 0.1713E-29 + 3921 0.9666E-02 0.1712E-29 + 3922 0.9657E-02 0.1710E-29 + 3923 0.9648E-02 0.1708E-29 + 3924 0.9639E-02 0.1706E-29 + 3925 0.9630E-02 0.1705E-29 + 3926 0.9621E-02 0.1703E-29 + 3927 0.9612E-02 0.1701E-29 + 3928 0.9603E-02 0.1699E-29 + 3929 0.9595E-02 0.1698E-29 + 3930 0.9586E-02 0.1696E-29 + 3931 0.9577E-02 0.1694E-29 + 3932 0.9568E-02 0.1692E-29 + 3933 0.9559E-02 0.1691E-29 + 3934 0.9550E-02 0.1689E-29 + 3935 0.9541E-02 0.1687E-29 + 3936 0.9533E-02 0.1686E-29 + 3937 0.9524E-02 0.1684E-29 + 3938 0.9515E-02 0.1682E-29 + 3939 0.9506E-02 0.1680E-29 + 3940 0.9497E-02 0.1679E-29 + 3941 0.9489E-02 0.1677E-29 + 3942 0.9480E-02 0.1675E-29 + 3943 0.9471E-02 0.1674E-29 + 3944 0.9462E-02 0.1672E-29 + 3945 0.9454E-02 0.1670E-29 + 3946 0.9445E-02 0.1669E-29 + 3947 0.9436E-02 0.1667E-29 + 3948 0.9427E-02 0.1665E-29 + 3949 0.9419E-02 0.1664E-29 + 3950 0.9410E-02 0.1662E-29 + 3951 0.9401E-02 0.1660E-29 + 3952 0.9393E-02 0.1658E-29 + 3953 0.9384E-02 0.1657E-29 + 3954 0.9375E-02 0.1655E-29 + 3955 0.9367E-02 0.1653E-29 + 3956 0.9358E-02 0.1652E-29 + 3957 0.9349E-02 0.1650E-29 + 3958 0.9341E-02 0.1648E-29 + 3959 0.9332E-02 0.1647E-29 + 3960 0.9324E-02 0.1645E-29 + 3961 0.9315E-02 0.1643E-29 + 3962 0.9306E-02 0.1642E-29 + 3963 0.9298E-02 0.1640E-29 + 3964 0.9289E-02 0.1638E-29 + 3965 0.9281E-02 0.1637E-29 + 3966 0.9272E-02 0.1635E-29 + 3967 0.9264E-02 0.1634E-29 + 3968 0.9255E-02 0.1632E-29 + 3969 0.9247E-02 0.1630E-29 + 3970 0.9238E-02 0.1629E-29 + 3971 0.9230E-02 0.1627E-29 + 3972 0.9221E-02 0.1625E-29 + 3973 0.9213E-02 0.1624E-29 + 3974 0.9204E-02 0.1622E-29 + 3975 0.9196E-02 0.1620E-29 + 3976 0.9187E-02 0.1619E-29 + 3977 0.9179E-02 0.1617E-29 + 3978 0.9171E-02 0.1616E-29 + 3979 0.9162E-02 0.1614E-29 + 3980 0.9154E-02 0.1612E-29 + 3981 0.9145E-02 0.1611E-29 + 3982 0.9137E-02 0.1609E-29 + 3983 0.9129E-02 0.1607E-29 + 3984 0.9120E-02 0.1606E-29 + 3985 0.9112E-02 0.1604E-29 + 3986 0.9104E-02 0.1603E-29 + 3987 0.9095E-02 0.1601E-29 + 3988 0.9087E-02 0.1599E-29 + 3989 0.9079E-02 0.1598E-29 + 3990 0.9070E-02 0.1596E-29 + 3991 0.9062E-02 0.1595E-29 + 3992 0.9054E-02 0.1593E-29 + 3993 0.9045E-02 0.1591E-29 + 3994 0.9037E-02 0.1590E-29 + 3995 0.9029E-02 0.1588E-29 + 3996 0.9021E-02 0.1587E-29 + 3997 0.9012E-02 0.1585E-29 + 3998 0.9004E-02 0.1583E-29 + 3999 0.8996E-02 0.1582E-29 + 4000 0.8988E-02 0.1580E-29 + 4001 0.8980E-02 0.1579E-29 + 4002 0.8971E-02 0.1577E-29 + 4003 0.8963E-02 0.1576E-29 + 4004 0.8955E-02 0.1574E-29 + 4005 0.8947E-02 0.1572E-29 + 4006 0.8939E-02 0.1571E-29 + 4007 0.8931E-02 0.1569E-29 + 4008 0.8922E-02 0.1568E-29 + 4009 0.8914E-02 0.1566E-29 + 4010 0.8906E-02 0.1565E-29 + 4011 0.8898E-02 0.1563E-29 + 4012 0.8890E-02 0.1561E-29 + 4013 0.8882E-02 0.1560E-29 + 4014 0.8874E-02 0.1558E-29 + 4015 0.8866E-02 0.1557E-29 + 4016 0.8858E-02 0.1555E-29 + 4017 0.8850E-02 0.1554E-29 + 4018 0.8842E-02 0.1552E-29 + 4019 0.8834E-02 0.1551E-29 + 4020 0.8826E-02 0.1549E-29 + 4021 0.8818E-02 0.1548E-29 + 4022 0.8810E-02 0.1546E-29 + 4023 0.8802E-02 0.1544E-29 + 4024 0.8794E-02 0.1543E-29 + 4025 0.8786E-02 0.1541E-29 + 4026 0.8778E-02 0.1540E-29 + 4027 0.8770E-02 0.1538E-29 + 4028 0.8762E-02 0.1537E-29 + 4029 0.8754E-02 0.1535E-29 + 4030 0.8746E-02 0.1534E-29 + 4031 0.8738E-02 0.1532E-29 + 4032 0.8730E-02 0.1531E-29 + 4033 0.8722E-02 0.1529E-29 + 4034 0.8714E-02 0.1528E-29 + 4035 0.8706E-02 0.1526E-29 + 4036 0.8698E-02 0.1525E-29 + 4037 0.8691E-02 0.1523E-29 + 4038 0.8683E-02 0.1522E-29 + 4039 0.8675E-02 0.1520E-29 + 4040 0.8667E-02 0.1519E-29 + 4041 0.8659E-02 0.1517E-29 + 4042 0.8651E-02 0.1516E-29 + 4043 0.8644E-02 0.1514E-29 + 4044 0.8636E-02 0.1513E-29 + 4045 0.8628E-02 0.1511E-29 + 4046 0.8620E-02 0.1510E-29 + 4047 0.8612E-02 0.1508E-29 + 4048 0.8605E-02 0.1507E-29 + 4049 0.8597E-02 0.1505E-29 + 4050 0.8589E-02 0.1504E-29 + 4051 0.8581E-02 0.1502E-29 + 4052 0.8574E-02 0.1501E-29 + 4053 0.8566E-02 0.1499E-29 + 4054 0.8558E-02 0.1498E-29 + 4055 0.8550E-02 0.1496E-29 + 4056 0.8543E-02 0.1495E-29 + 4057 0.8535E-02 0.1493E-29 + 4058 0.8527E-02 0.1492E-29 + 4059 0.8520E-02 0.1490E-29 + 4060 0.8512E-02 0.1489E-29 + 4061 0.8504E-02 0.1487E-29 + 4062 0.8497E-02 0.1486E-29 + 4063 0.8489E-02 0.1485E-29 + 4064 0.8481E-02 0.1483E-29 + 4065 0.8474E-02 0.1482E-29 + 4066 0.8466E-02 0.1480E-29 + 4067 0.8458E-02 0.1479E-29 + 4068 0.8451E-02 0.1477E-29 + 4069 0.8443E-02 0.1476E-29 + 4070 0.8436E-02 0.1474E-29 + 4071 0.8428E-02 0.1473E-29 + 4072 0.8421E-02 0.1471E-29 + 4073 0.8413E-02 0.1470E-29 + 4074 0.8405E-02 0.1469E-29 + 4075 0.8398E-02 0.1467E-29 + 4076 0.8390E-02 0.1466E-29 + 4077 0.8383E-02 0.1464E-29 + 4078 0.8375E-02 0.1463E-29 + 4079 0.8368E-02 0.1461E-29 + 4080 0.8360E-02 0.1460E-29 + 4081 0.8353E-02 0.1459E-29 + 4082 0.8345E-02 0.1457E-29 + 4083 0.8338E-02 0.1456E-29 + 4084 0.8330E-02 0.1454E-29 + 4085 0.8323E-02 0.1453E-29 + 4086 0.8315E-02 0.1451E-29 + 4087 0.8308E-02 0.1450E-29 + 4088 0.8301E-02 0.1449E-29 + 4089 0.8293E-02 0.1447E-29 + 4090 0.8286E-02 0.1446E-29 + 4091 0.8278E-02 0.1444E-29 + 4092 0.8271E-02 0.1443E-29 + 4093 0.8264E-02 0.1441E-29 + 4094 0.8256E-02 0.1440E-29 + 4095 0.8249E-02 0.1439E-29 + 4096 0.8241E-02 0.1437E-29 + 4097 0.8234E-02 0.1436E-29 + 4098 0.8227E-02 0.1434E-29 + 4099 0.8219E-02 0.1433E-29 + 4100 0.8212E-02 0.1432E-29 + 4101 0.8205E-02 0.1430E-29 + 4102 0.8197E-02 0.1429E-29 + 4103 0.8190E-02 0.1427E-29 + 4104 0.8183E-02 0.1426E-29 + 4105 0.8175E-02 0.1425E-29 + 4106 0.8168E-02 0.1423E-29 + 4107 0.8161E-02 0.1422E-29 + 4108 0.8154E-02 0.1421E-29 + 4109 0.8146E-02 0.1419E-29 + 4110 0.8139E-02 0.1418E-29 + 4111 0.8132E-02 0.1416E-29 + 4112 0.8125E-02 0.1415E-29 + 4113 0.8117E-02 0.1414E-29 + 4114 0.8110E-02 0.1412E-29 + 4115 0.8103E-02 0.1411E-29 + 4116 0.8096E-02 0.1410E-29 + 4117 0.8089E-02 0.1408E-29 + 4118 0.8081E-02 0.1407E-29 + 4119 0.8074E-02 0.1405E-29 + 4120 0.8067E-02 0.1404E-29 + 4121 0.8060E-02 0.1403E-29 + 4122 0.8053E-02 0.1401E-29 + 4123 0.8046E-02 0.1400E-29 + 4124 0.8038E-02 0.1399E-29 + 4125 0.8031E-02 0.1397E-29 + 4126 0.8024E-02 0.1396E-29 + 4127 0.8017E-02 0.1395E-29 + 4128 0.8010E-02 0.1393E-29 + 4129 0.8003E-02 0.1392E-29 + 4130 0.7996E-02 0.1391E-29 + 4131 0.7989E-02 0.1389E-29 + 4132 0.7982E-02 0.1388E-29 + 4133 0.7974E-02 0.1386E-29 + 4134 0.7967E-02 0.1385E-29 + 4135 0.7960E-02 0.1384E-29 + 4136 0.7953E-02 0.1382E-29 + 4137 0.7946E-02 0.1381E-29 + 4138 0.7939E-02 0.1380E-29 + 4139 0.7932E-02 0.1378E-29 + 4140 0.7925E-02 0.1377E-29 + 4141 0.7918E-02 0.1376E-29 + 4142 0.7911E-02 0.1374E-29 + 4143 0.7904E-02 0.1373E-29 + 4144 0.7897E-02 0.1372E-29 + 4145 0.7890E-02 0.1371E-29 + 4146 0.7883E-02 0.1369E-29 + 4147 0.7876E-02 0.1368E-29 + 4148 0.7869E-02 0.1367E-29 + 4149 0.7862E-02 0.1365E-29 + 4150 0.7855E-02 0.1364E-29 + 4151 0.7848E-02 0.1363E-29 + 4152 0.7842E-02 0.1361E-29 + 4153 0.7835E-02 0.1360E-29 + 4154 0.7828E-02 0.1359E-29 + 4155 0.7821E-02 0.1357E-29 + 4156 0.7814E-02 0.1356E-29 + 4157 0.7807E-02 0.1355E-29 + 4158 0.7800E-02 0.1353E-29 + 4159 0.7793E-02 0.1352E-29 + 4160 0.7786E-02 0.1351E-29 + 4161 0.7780E-02 0.1350E-29 + 4162 0.7773E-02 0.1348E-29 + 4163 0.7766E-02 0.1347E-29 + 4164 0.7759E-02 0.1346E-29 + 4165 0.7752E-02 0.1344E-29 + 4166 0.7745E-02 0.1343E-29 + 4167 0.7739E-02 0.1342E-29 + 4168 0.7732E-02 0.1340E-29 + 4169 0.7725E-02 0.1339E-29 + 4170 0.7718E-02 0.1338E-29 + 4171 0.7711E-02 0.1337E-29 + 4172 0.7705E-02 0.1335E-29 + 4173 0.7698E-02 0.1334E-29 + 4174 0.7691E-02 0.1333E-29 + 4175 0.7684E-02 0.1332E-29 + 4176 0.7678E-02 0.1330E-29 + 4177 0.7671E-02 0.1329E-29 + 4178 0.7664E-02 0.1328E-29 + 4179 0.7657E-02 0.1326E-29 + 4180 0.7651E-02 0.1325E-29 + 4181 0.7644E-02 0.1324E-29 + 4182 0.7637E-02 0.1323E-29 + 4183 0.7631E-02 0.1321E-29 + 4184 0.7624E-02 0.1320E-29 + 4185 0.7617E-02 0.1319E-29 + 4186 0.7611E-02 0.1318E-29 + 4187 0.7604E-02 0.1316E-29 + 4188 0.7597E-02 0.1315E-29 + 4189 0.7591E-02 0.1314E-29 + 4190 0.7584E-02 0.1313E-29 + 4191 0.7577E-02 0.1311E-29 + 4192 0.7571E-02 0.1310E-29 + 4193 0.7564E-02 0.1309E-29 + 4194 0.7557E-02 0.1308E-29 + 4195 0.7551E-02 0.1306E-29 + 4196 0.7544E-02 0.1305E-29 + 4197 0.7538E-02 0.1304E-29 + 4198 0.7531E-02 0.1303E-29 + 4199 0.7524E-02 0.1301E-29 + 4200 0.7518E-02 0.1300E-29 + 4201 0.7511E-02 0.1299E-29 + 4202 0.7505E-02 0.1298E-29 + 4203 0.7498E-02 0.1296E-29 + 4204 0.7492E-02 0.1295E-29 + 4205 0.7485E-02 0.1294E-29 + 4206 0.7479E-02 0.1293E-29 + 4207 0.7472E-02 0.1291E-29 + 4208 0.7466E-02 0.1290E-29 + 4209 0.7459E-02 0.1289E-29 + 4210 0.7453E-02 0.1288E-29 + 4211 0.7446E-02 0.1287E-29 + 4212 0.7440E-02 0.1285E-29 + 4213 0.7433E-02 0.1284E-29 + 4214 0.7427E-02 0.1283E-29 + 4215 0.7420E-02 0.1282E-29 + 4216 0.7414E-02 0.1280E-29 + 4217 0.7407E-02 0.1279E-29 + 4218 0.7401E-02 0.1278E-29 + 4219 0.7394E-02 0.1277E-29 + 4220 0.7388E-02 0.1276E-29 + 4221 0.7382E-02 0.1274E-29 + 4222 0.7375E-02 0.1273E-29 + 4223 0.7369E-02 0.1272E-29 + 4224 0.7362E-02 0.1271E-29 + 4225 0.7356E-02 0.1270E-29 + 4226 0.7350E-02 0.1268E-29 + 4227 0.7343E-02 0.1267E-29 + 4228 0.7337E-02 0.1266E-29 + 4229 0.7330E-02 0.1265E-29 + 4230 0.7324E-02 0.1264E-29 + 4231 0.7318E-02 0.1262E-29 + 4232 0.7311E-02 0.1261E-29 + 4233 0.7305E-02 0.1260E-29 + 4234 0.7299E-02 0.1259E-29 + 4235 0.7292E-02 0.1258E-29 + 4236 0.7286E-02 0.1256E-29 + 4237 0.7280E-02 0.1255E-29 + 4238 0.7273E-02 0.1254E-29 + 4239 0.7267E-02 0.1253E-29 + 4240 0.7261E-02 0.1252E-29 + 4241 0.7255E-02 0.1251E-29 + 4242 0.7248E-02 0.1249E-29 + 4243 0.7242E-02 0.1248E-29 + 4244 0.7236E-02 0.1247E-29 + 4245 0.7229E-02 0.1246E-29 + 4246 0.7223E-02 0.1245E-29 + 4247 0.7217E-02 0.1244E-29 + 4248 0.7211E-02 0.1242E-29 + 4249 0.7204E-02 0.1241E-29 + 4250 0.7198E-02 0.1240E-29 + 4251 0.7192E-02 0.1239E-29 + 4252 0.7186E-02 0.1238E-29 + 4253 0.7180E-02 0.1237E-29 + 4254 0.7173E-02 0.1235E-29 + 4255 0.7167E-02 0.1234E-29 + 4256 0.7161E-02 0.1233E-29 + 4257 0.7155E-02 0.1232E-29 + 4258 0.7149E-02 0.1231E-29 + 4259 0.7143E-02 0.1230E-29 + 4260 0.7136E-02 0.1228E-29 + 4261 0.7130E-02 0.1227E-29 + 4262 0.7124E-02 0.1226E-29 + 4263 0.7118E-02 0.1225E-29 + 4264 0.7112E-02 0.1224E-29 + 4265 0.7106E-02 0.1223E-29 + 4266 0.7100E-02 0.1222E-29 + 4267 0.7093E-02 0.1220E-29 + 4268 0.7087E-02 0.1219E-29 + 4269 0.7081E-02 0.1218E-29 + 4270 0.7075E-02 0.1217E-29 + 4271 0.7069E-02 0.1216E-29 + 4272 0.7063E-02 0.1215E-29 + 4273 0.7057E-02 0.1214E-29 + 4274 0.7051E-02 0.1212E-29 + 4275 0.7045E-02 0.1211E-29 + 4276 0.7039E-02 0.1210E-29 + 4277 0.7033E-02 0.1209E-29 + 4278 0.7027E-02 0.1208E-29 + 4279 0.7021E-02 0.1207E-29 + 4280 0.7015E-02 0.1206E-29 + 4281 0.7009E-02 0.1204E-29 + 4282 0.7003E-02 0.1203E-29 + 4283 0.6997E-02 0.1202E-29 + 4284 0.6991E-02 0.1201E-29 + 4285 0.6985E-02 0.1200E-29 + 4286 0.6979E-02 0.1199E-29 + 4287 0.6973E-02 0.1198E-29 + 4288 0.6967E-02 0.1197E-29 + 4289 0.6961E-02 0.1196E-29 + 4290 0.6955E-02 0.1194E-29 + 4291 0.6949E-02 0.1193E-29 + 4292 0.6943E-02 0.1192E-29 + 4293 0.6937E-02 0.1191E-29 + 4294 0.6931E-02 0.1190E-29 + 4295 0.6925E-02 0.1189E-29 + 4296 0.6919E-02 0.1188E-29 + 4297 0.6913E-02 0.1187E-29 + 4298 0.6907E-02 0.1186E-29 + 4299 0.6901E-02 0.1184E-29 + 4300 0.6895E-02 0.1183E-29 + 4301 0.6889E-02 0.1182E-29 + 4302 0.6884E-02 0.1181E-29 + 4303 0.6878E-02 0.1180E-29 + 4304 0.6872E-02 0.1179E-29 + 4305 0.6866E-02 0.1178E-29 + 4306 0.6860E-02 0.1177E-29 + 4307 0.6854E-02 0.1176E-29 + 4308 0.6848E-02 0.1175E-29 + 4309 0.6843E-02 0.1173E-29 + 4310 0.6837E-02 0.1172E-29 + 4311 0.6831E-02 0.1171E-29 + 4312 0.6825E-02 0.1170E-29 + 4313 0.6819E-02 0.1169E-29 + 4314 0.6813E-02 0.1168E-29 + 4315 0.6808E-02 0.1167E-29 + 4316 0.6802E-02 0.1166E-29 + 4317 0.6796E-02 0.1165E-29 + 4318 0.6790E-02 0.1164E-29 + 4319 0.6784E-02 0.1163E-29 + 4320 0.6779E-02 0.1162E-29 + 4321 0.6773E-02 0.1160E-29 + 4322 0.6767E-02 0.1159E-29 + 4323 0.6761E-02 0.1158E-29 + 4324 0.6756E-02 0.1157E-29 + 4325 0.6750E-02 0.1156E-29 + 4326 0.6744E-02 0.1155E-29 + 4327 0.6738E-02 0.1154E-29 + 4328 0.6733E-02 0.1153E-29 + 4329 0.6727E-02 0.1152E-29 + 4330 0.6721E-02 0.1151E-29 + 4331 0.6716E-02 0.1150E-29 + 4332 0.6710E-02 0.1149E-29 + 4333 0.6704E-02 0.1148E-29 + 4334 0.6698E-02 0.1147E-29 + 4335 0.6693E-02 0.1146E-29 + 4336 0.6687E-02 0.1145E-29 + 4337 0.6681E-02 0.1143E-29 + 4338 0.6676E-02 0.1142E-29 + 4339 0.6670E-02 0.1141E-29 + 4340 0.6664E-02 0.1140E-29 + 4341 0.6659E-02 0.1139E-29 + 4342 0.6653E-02 0.1138E-29 + 4343 0.6648E-02 0.1137E-29 + 4344 0.6642E-02 0.1136E-29 + 4345 0.6636E-02 0.1135E-29 + 4346 0.6631E-02 0.1134E-29 + 4347 0.6625E-02 0.1133E-29 + 4348 0.6619E-02 0.1132E-29 + 4349 0.6614E-02 0.1131E-29 + 4350 0.6608E-02 0.1130E-29 + 4351 0.6603E-02 0.1129E-29 + 4352 0.6597E-02 0.1128E-29 + 4353 0.6591E-02 0.1127E-29 + 4354 0.6586E-02 0.1126E-29 + 4355 0.6580E-02 0.1125E-29 + 4356 0.6575E-02 0.1124E-29 + 4357 0.6569E-02 0.1123E-29 + 4358 0.6564E-02 0.1122E-29 + 4359 0.6558E-02 0.1121E-29 + 4360 0.6553E-02 0.1120E-29 + 4361 0.6547E-02 0.1118E-29 + 4362 0.6542E-02 0.1117E-29 + 4363 0.6536E-02 0.1116E-29 + 4364 0.6530E-02 0.1115E-29 + 4365 0.6525E-02 0.1114E-29 + 4366 0.6519E-02 0.1113E-29 + 4367 0.6514E-02 0.1112E-29 + 4368 0.6508E-02 0.1111E-29 + 4369 0.6503E-02 0.1110E-29 + 4370 0.6498E-02 0.1109E-29 + 4371 0.6492E-02 0.1108E-29 + 4372 0.6487E-02 0.1107E-29 + 4373 0.6481E-02 0.1106E-29 + 4374 0.6476E-02 0.1105E-29 + 4375 0.6470E-02 0.1104E-29 + 4376 0.6465E-02 0.1103E-29 + 4377 0.6459E-02 0.1102E-29 + 4378 0.6454E-02 0.1101E-29 + 4379 0.6448E-02 0.1100E-29 + 4380 0.6443E-02 0.1099E-29 + 4381 0.6438E-02 0.1098E-29 + 4382 0.6432E-02 0.1097E-29 + 4383 0.6427E-02 0.1096E-29 + 4384 0.6421E-02 0.1095E-29 + 4385 0.6416E-02 0.1094E-29 + 4386 0.6411E-02 0.1093E-29 + 4387 0.6405E-02 0.1092E-29 + 4388 0.6400E-02 0.1091E-29 + 4389 0.6395E-02 0.1090E-29 + 4390 0.6389E-02 0.1089E-29 + 4391 0.6384E-02 0.1088E-29 + 4392 0.6378E-02 0.1087E-29 + 4393 0.6373E-02 0.1086E-29 + 4394 0.6368E-02 0.1085E-29 + 4395 0.6362E-02 0.1084E-29 + 4396 0.6357E-02 0.1083E-29 + 4397 0.6352E-02 0.1082E-29 + 4398 0.6346E-02 0.1081E-29 + 4399 0.6341E-02 0.1080E-29 + 4400 0.6336E-02 0.1079E-29 + 4401 0.6330E-02 0.1078E-29 + 4402 0.6325E-02 0.1077E-29 + 4403 0.6320E-02 0.1076E-29 + 4404 0.6315E-02 0.1075E-29 + 4405 0.6309E-02 0.1074E-29 + 4406 0.6304E-02 0.1073E-29 + 4407 0.6299E-02 0.1073E-29 + 4408 0.6294E-02 0.1072E-29 + 4409 0.6288E-02 0.1071E-29 + 4410 0.6283E-02 0.1070E-29 + 4411 0.6278E-02 0.1069E-29 + 4412 0.6273E-02 0.1068E-29 + 4413 0.6267E-02 0.1067E-29 + 4414 0.6262E-02 0.1066E-29 + 4415 0.6257E-02 0.1065E-29 + 4416 0.6252E-02 0.1064E-29 + 4417 0.6246E-02 0.1063E-29 + 4418 0.6241E-02 0.1062E-29 + 4419 0.6236E-02 0.1061E-29 + 4420 0.6231E-02 0.1060E-29 + 4421 0.6226E-02 0.1059E-29 + 4422 0.6220E-02 0.1058E-29 + 4423 0.6215E-02 0.1057E-29 + 4424 0.6210E-02 0.1056E-29 + 4425 0.6205E-02 0.1055E-29 + 4426 0.6200E-02 0.1054E-29 + 4427 0.6194E-02 0.1053E-29 + 4428 0.6189E-02 0.1052E-29 + 4429 0.6184E-02 0.1051E-29 + 4430 0.6179E-02 0.1050E-29 + 4431 0.6174E-02 0.1049E-29 + 4432 0.6169E-02 0.1049E-29 + 4433 0.6164E-02 0.1048E-29 + 4434 0.6159E-02 0.1047E-29 + 4435 0.6153E-02 0.1046E-29 + 4436 0.6148E-02 0.1045E-29 + 4437 0.6143E-02 0.1044E-29 + 4438 0.6138E-02 0.1043E-29 + 4439 0.6133E-02 0.1042E-29 + 4440 0.6128E-02 0.1041E-29 + 4441 0.6123E-02 0.1040E-29 + 4442 0.6118E-02 0.1039E-29 + 4443 0.6113E-02 0.1038E-29 + 4444 0.6108E-02 0.1037E-29 + 4445 0.6102E-02 0.1036E-29 + 4446 0.6097E-02 0.1035E-29 + 4447 0.6092E-02 0.1034E-29 + 4448 0.6087E-02 0.1034E-29 + 4449 0.6082E-02 0.1033E-29 + 4450 0.6077E-02 0.1032E-29 + 4451 0.6072E-02 0.1031E-29 + 4452 0.6067E-02 0.1030E-29 + 4453 0.6062E-02 0.1029E-29 + 4454 0.6057E-02 0.1028E-29 + 4455 0.6052E-02 0.1027E-29 + 4456 0.6047E-02 0.1026E-29 + 4457 0.6042E-02 0.1025E-29 + 4458 0.6037E-02 0.1024E-29 + 4459 0.6032E-02 0.1023E-29 + 4460 0.6027E-02 0.1022E-29 + 4461 0.6022E-02 0.1022E-29 + 4462 0.6017E-02 0.1021E-29 + 4463 0.6012E-02 0.1020E-29 + 4464 0.6007E-02 0.1019E-29 + 4465 0.6002E-02 0.1018E-29 + 4466 0.5997E-02 0.1017E-29 + 4467 0.5992E-02 0.1016E-29 + 4468 0.5987E-02 0.1015E-29 + 4469 0.5982E-02 0.1014E-29 + 4470 0.5977E-02 0.1013E-29 + 4471 0.5973E-02 0.1012E-29 + 4472 0.5968E-02 0.1012E-29 + 4473 0.5963E-02 0.1011E-29 + 4474 0.5958E-02 0.1010E-29 + 4475 0.5953E-02 0.1009E-29 + 4476 0.5948E-02 0.1008E-29 + 4477 0.5943E-02 0.1007E-29 + 4478 0.5938E-02 0.1006E-29 + 4479 0.5933E-02 0.1005E-29 + 4480 0.5928E-02 0.1004E-29 + 4481 0.5924E-02 0.1003E-29 + 4482 0.5919E-02 0.1003E-29 + 4483 0.5914E-02 0.1002E-29 + 4484 0.5909E-02 0.1001E-29 + 4485 0.5904E-02 0.9998E-30 + 4486 0.5899E-02 0.9989E-30 + 4487 0.5894E-02 0.9981E-30 + 4488 0.5889E-02 0.9972E-30 + 4489 0.5885E-02 0.9963E-30 + 4490 0.5880E-02 0.9954E-30 + 4491 0.5875E-02 0.9945E-30 + 4492 0.5870E-02 0.9936E-30 + 4493 0.5865E-02 0.9927E-30 + 4494 0.5860E-02 0.9918E-30 + 4495 0.5856E-02 0.9910E-30 + 4496 0.5851E-02 0.9901E-30 + 4497 0.5846E-02 0.9892E-30 + 4498 0.5841E-02 0.9883E-30 + 4499 0.5836E-02 0.9874E-30 + 4500 0.5832E-02 0.9866E-30 + 4501 0.5827E-02 0.9857E-30 + 4502 0.5822E-02 0.9848E-30 + 4503 0.5817E-02 0.9839E-30 + 4504 0.5813E-02 0.9831E-30 + 4505 0.5808E-02 0.9822E-30 + 4506 0.5803E-02 0.9813E-30 + 4507 0.5798E-02 0.9805E-30 + 4508 0.5794E-02 0.9796E-30 + 4509 0.5789E-02 0.9787E-30 + 4510 0.5784E-02 0.9778E-30 + 4511 0.5779E-02 0.9770E-30 + 4512 0.5775E-02 0.9761E-30 + 4513 0.5770E-02 0.9753E-30 + 4514 0.5765E-02 0.9744E-30 + 4515 0.5760E-02 0.9735E-30 + 4516 0.5756E-02 0.9727E-30 + 4517 0.5751E-02 0.9718E-30 + 4518 0.5746E-02 0.9709E-30 + 4519 0.5742E-02 0.9701E-30 + 4520 0.5737E-02 0.9692E-30 + 4521 0.5732E-02 0.9684E-30 + 4522 0.5728E-02 0.9675E-30 + 4523 0.5723E-02 0.9667E-30 + 4524 0.5718E-02 0.9658E-30 + 4525 0.5714E-02 0.9649E-30 + 4526 0.5709E-02 0.9641E-30 + 4527 0.5704E-02 0.9632E-30 + 4528 0.5700E-02 0.9624E-30 + 4529 0.5695E-02 0.9615E-30 + 4530 0.5690E-02 0.9607E-30 + 4531 0.5686E-02 0.9598E-30 + 4532 0.5681E-02 0.9590E-30 + 4533 0.5676E-02 0.9582E-30 + 4534 0.5672E-02 0.9573E-30 + 4535 0.5667E-02 0.9565E-30 + 4536 0.5663E-02 0.9556E-30 + 4537 0.5658E-02 0.9548E-30 + 4538 0.5653E-02 0.9539E-30 + 4539 0.5649E-02 0.9531E-30 + 4540 0.5644E-02 0.9523E-30 + 4541 0.5640E-02 0.9514E-30 + 4542 0.5635E-02 0.9506E-30 + 4543 0.5630E-02 0.9497E-30 + 4544 0.5626E-02 0.9489E-30 + 4545 0.5621E-02 0.9481E-30 + 4546 0.5617E-02 0.9472E-30 + 4547 0.5612E-02 0.9464E-30 + 4548 0.5607E-02 0.9456E-30 + 4549 0.5603E-02 0.9447E-30 + 4550 0.5598E-02 0.9439E-30 + 4551 0.5594E-02 0.9431E-30 + 4552 0.5589E-02 0.9423E-30 + 4553 0.5585E-02 0.9414E-30 + 4554 0.5580E-02 0.9406E-30 + 4555 0.5576E-02 0.9398E-30 + 4556 0.5571E-02 0.9390E-30 + 4557 0.5567E-02 0.9381E-30 + 4558 0.5562E-02 0.9373E-30 + 4559 0.5558E-02 0.9365E-30 + 4560 0.5553E-02 0.9357E-30 + 4561 0.5549E-02 0.9348E-30 + 4562 0.5544E-02 0.9340E-30 + 4563 0.5540E-02 0.9332E-30 + 4564 0.5535E-02 0.9324E-30 + 4565 0.5531E-02 0.9316E-30 + 4566 0.5526E-02 0.9308E-30 + 4567 0.5522E-02 0.9299E-30 + 4568 0.5517E-02 0.9291E-30 + 4569 0.5513E-02 0.9283E-30 + 4570 0.5508E-02 0.9275E-30 + 4571 0.5504E-02 0.9267E-30 + 4572 0.5499E-02 0.9259E-30 + 4573 0.5495E-02 0.9251E-30 + 4574 0.5491E-02 0.9243E-30 + 4575 0.5486E-02 0.9234E-30 + 4576 0.5482E-02 0.9226E-30 + 4577 0.5477E-02 0.9218E-30 + 4578 0.5473E-02 0.9210E-30 + 4579 0.5468E-02 0.9202E-30 + 4580 0.5464E-02 0.9194E-30 + 4581 0.5460E-02 0.9186E-30 + 4582 0.5455E-02 0.9178E-30 + 4583 0.5451E-02 0.9170E-30 + 4584 0.5446E-02 0.9162E-30 + 4585 0.5442E-02 0.9154E-30 + 4586 0.5438E-02 0.9146E-30 + 4587 0.5433E-02 0.9138E-30 + 4588 0.5429E-02 0.9130E-30 + 4589 0.5424E-02 0.9122E-30 + 4590 0.5420E-02 0.9114E-30 + 4591 0.5416E-02 0.9106E-30 + 4592 0.5411E-02 0.9099E-30 + 4593 0.5407E-02 0.9091E-30 + 4594 0.5403E-02 0.9083E-30 + 4595 0.5398E-02 0.9075E-30 + 4596 0.5394E-02 0.9067E-30 + 4597 0.5390E-02 0.9059E-30 + 4598 0.5385E-02 0.9051E-30 + 4599 0.5381E-02 0.9043E-30 + 4600 0.5377E-02 0.9035E-30 + 4601 0.5372E-02 0.9028E-30 + 4602 0.5368E-02 0.9020E-30 + 4603 0.5364E-02 0.9012E-30 + 4604 0.5359E-02 0.9004E-30 + 4605 0.5355E-02 0.8996E-30 + 4606 0.5351E-02 0.8988E-30 + 4607 0.5346E-02 0.8981E-30 + 4608 0.5342E-02 0.8973E-30 + 4609 0.5338E-02 0.8965E-30 + 4610 0.5334E-02 0.8957E-30 + 4611 0.5329E-02 0.8949E-30 + 4612 0.5325E-02 0.8942E-30 + 4613 0.5321E-02 0.8934E-30 + 4614 0.5316E-02 0.8926E-30 + 4615 0.5312E-02 0.8918E-30 + 4616 0.5308E-02 0.8911E-30 + 4617 0.5304E-02 0.8903E-30 + 4618 0.5299E-02 0.8895E-30 + 4619 0.5295E-02 0.8888E-30 + 4620 0.5291E-02 0.8880E-30 + 4621 0.5287E-02 0.8872E-30 + 4622 0.5282E-02 0.8865E-30 + 4623 0.5278E-02 0.8857E-30 + 4624 0.5274E-02 0.8849E-30 + 4625 0.5270E-02 0.8842E-30 + 4626 0.5266E-02 0.8834E-30 + 4627 0.5261E-02 0.8826E-30 + 4628 0.5257E-02 0.8819E-30 + 4629 0.5253E-02 0.8811E-30 + 4630 0.5249E-02 0.8803E-30 + 4631 0.5245E-02 0.8796E-30 + 4632 0.5240E-02 0.8788E-30 + 4633 0.5236E-02 0.8781E-30 + 4634 0.5232E-02 0.8773E-30 + 4635 0.5228E-02 0.8766E-30 + 4636 0.5224E-02 0.8758E-30 + 4637 0.5219E-02 0.8750E-30 + 4638 0.5215E-02 0.8743E-30 + 4639 0.5211E-02 0.8735E-30 + 4640 0.5207E-02 0.8728E-30 + 4641 0.5203E-02 0.8720E-30 + 4642 0.5199E-02 0.8713E-30 + 4643 0.5195E-02 0.8705E-30 + 4644 0.5190E-02 0.8698E-30 + 4645 0.5186E-02 0.8690E-30 + 4646 0.5182E-02 0.8683E-30 + 4647 0.5178E-02 0.8675E-30 + 4648 0.5174E-02 0.8668E-30 + 4649 0.5170E-02 0.8660E-30 + 4650 0.5166E-02 0.8653E-30 + 4651 0.5162E-02 0.8646E-30 + 4652 0.5157E-02 0.8638E-30 + 4653 0.5153E-02 0.8631E-30 + 4654 0.5149E-02 0.8623E-30 + 4655 0.5145E-02 0.8616E-30 + 4656 0.5141E-02 0.8608E-30 + 4657 0.5137E-02 0.8601E-30 + 4658 0.5133E-02 0.8594E-30 + 4659 0.5129E-02 0.8586E-30 + 4660 0.5125E-02 0.8579E-30 + 4661 0.5121E-02 0.8572E-30 + 4662 0.5117E-02 0.8564E-30 + 4663 0.5113E-02 0.8557E-30 + 4664 0.5108E-02 0.8550E-30 + 4665 0.5104E-02 0.8542E-30 + 4666 0.5100E-02 0.8535E-30 + 4667 0.5096E-02 0.8528E-30 + 4668 0.5092E-02 0.8520E-30 + 4669 0.5088E-02 0.8513E-30 + 4670 0.5084E-02 0.8506E-30 + 4671 0.5080E-02 0.8498E-30 + 4672 0.5076E-02 0.8491E-30 + 4673 0.5072E-02 0.8484E-30 + 4674 0.5068E-02 0.8477E-30 + 4675 0.5064E-02 0.8469E-30 + 4676 0.5060E-02 0.8462E-30 + 4677 0.5056E-02 0.8455E-30 + 4678 0.5052E-02 0.8448E-30 + 4679 0.5048E-02 0.8440E-30 + 4680 0.5044E-02 0.8433E-30 + 4681 0.5040E-02 0.8426E-30 + 4682 0.5036E-02 0.8419E-30 + 4683 0.5032E-02 0.8412E-30 + 4684 0.5028E-02 0.8404E-30 + 4685 0.5024E-02 0.8397E-30 + 4686 0.5020E-02 0.8390E-30 + 4687 0.5016E-02 0.8383E-30 + 4688 0.5012E-02 0.8376E-30 + 4689 0.5008E-02 0.8369E-30 + 4690 0.5004E-02 0.8362E-30 + 4691 0.5000E-02 0.8354E-30 + 4692 0.4996E-02 0.8347E-30 + 4693 0.4992E-02 0.8340E-30 + 4694 0.4989E-02 0.8333E-30 + 4695 0.4985E-02 0.8326E-30 + 4696 0.4981E-02 0.8319E-30 + 4697 0.4977E-02 0.8312E-30 + 4698 0.4973E-02 0.8305E-30 + 4699 0.4969E-02 0.8298E-30 + 4700 0.4965E-02 0.8291E-30 + 4701 0.4961E-02 0.8284E-30 + 4702 0.4957E-02 0.8277E-30 + 4703 0.4953E-02 0.8269E-30 + 4704 0.4949E-02 0.8262E-30 + 4705 0.4945E-02 0.8255E-30 + 4706 0.4942E-02 0.8248E-30 + 4707 0.4938E-02 0.8241E-30 + 4708 0.4934E-02 0.8234E-30 + 4709 0.4930E-02 0.8227E-30 + 4710 0.4926E-02 0.8220E-30 + 4711 0.4922E-02 0.8213E-30 + 4712 0.4918E-02 0.8206E-30 + 4713 0.4914E-02 0.8200E-30 + 4714 0.4910E-02 0.8193E-30 + 4715 0.4907E-02 0.8186E-30 + 4716 0.4903E-02 0.8179E-30 + 4717 0.4899E-02 0.8172E-30 + 4718 0.4895E-02 0.8165E-30 + 4719 0.4891E-02 0.8158E-30 + 4720 0.4887E-02 0.8151E-30 + 4721 0.4884E-02 0.8144E-30 + 4722 0.4880E-02 0.8137E-30 + 4723 0.4876E-02 0.8130E-30 + 4724 0.4872E-02 0.8123E-30 + 4725 0.4868E-02 0.8117E-30 + 4726 0.4864E-02 0.8110E-30 + 4727 0.4861E-02 0.8103E-30 + 4728 0.4857E-02 0.8096E-30 + 4729 0.4853E-02 0.8089E-30 + 4730 0.4849E-02 0.8082E-30 + 4731 0.4845E-02 0.8075E-30 + 4732 0.4842E-02 0.8069E-30 + 4733 0.4838E-02 0.8062E-30 + 4734 0.4834E-02 0.8055E-30 + 4735 0.4830E-02 0.8048E-30 + 4736 0.4826E-02 0.8041E-30 + 4737 0.4823E-02 0.8035E-30 + 4738 0.4819E-02 0.8028E-30 + 4739 0.4815E-02 0.8021E-30 + 4740 0.4811E-02 0.8014E-30 + 4741 0.4808E-02 0.8008E-30 + 4742 0.4804E-02 0.8001E-30 + 4743 0.4800E-02 0.7994E-30 + 4744 0.4796E-02 0.7987E-30 + 4745 0.4793E-02 0.7981E-30 + 4746 0.4789E-02 0.7974E-30 + 4747 0.4785E-02 0.7967E-30 + 4748 0.4781E-02 0.7960E-30 + 4749 0.4778E-02 0.7954E-30 + 4750 0.4774E-02 0.7947E-30 + 4751 0.4770E-02 0.7940E-30 + 4752 0.4766E-02 0.7934E-30 + 4753 0.4763E-02 0.7927E-30 + 4754 0.4759E-02 0.7920E-30 + 4755 0.4755E-02 0.7914E-30 + 4756 0.4752E-02 0.7907E-30 + 4757 0.4748E-02 0.7900E-30 + 4758 0.4744E-02 0.7894E-30 + 4759 0.4740E-02 0.7887E-30 + 4760 0.4737E-02 0.7880E-30 + 4761 0.4733E-02 0.7874E-30 + 4762 0.4729E-02 0.7867E-30 + 4763 0.4726E-02 0.7861E-30 + 4764 0.4722E-02 0.7854E-30 + 4765 0.4718E-02 0.7847E-30 + 4766 0.4715E-02 0.7841E-30 + 4767 0.4711E-02 0.7834E-30 + 4768 0.4707E-02 0.7828E-30 + 4769 0.4704E-02 0.7821E-30 + 4770 0.4700E-02 0.7815E-30 + 4771 0.4696E-02 0.7808E-30 + 4772 0.4693E-02 0.7801E-30 + 4773 0.4689E-02 0.7795E-30 + 4774 0.4685E-02 0.7788E-30 + 4775 0.4682E-02 0.7782E-30 + 4776 0.4678E-02 0.7775E-30 + 4777 0.4674E-02 0.7769E-30 + 4778 0.4671E-02 0.7762E-30 + 4779 0.4667E-02 0.7756E-30 + 4780 0.4664E-02 0.7749E-30 + 4781 0.4660E-02 0.7743E-30 + 4782 0.4656E-02 0.7736E-30 + 4783 0.4653E-02 0.7730E-30 + 4784 0.4649E-02 0.7723E-30 + 4785 0.4646E-02 0.7717E-30 + 4786 0.4642E-02 0.7711E-30 + 4787 0.4638E-02 0.7704E-30 + 4788 0.4635E-02 0.7698E-30 + 4789 0.4631E-02 0.7691E-30 + 4790 0.4628E-02 0.7685E-30 + 4791 0.4624E-02 0.7678E-30 + 4792 0.4620E-02 0.7672E-30 + 4793 0.4617E-02 0.7666E-30 + 4794 0.4613E-02 0.7659E-30 + 4795 0.4610E-02 0.7653E-30 + 4796 0.4606E-02 0.7646E-30 + 4797 0.4603E-02 0.7640E-30 + 4798 0.4599E-02 0.7634E-30 + 4799 0.4595E-02 0.7627E-30 + 4800 0.4592E-02 0.7621E-30 + 4801 0.4588E-02 0.7615E-30 + 4802 0.4585E-02 0.7608E-30 + 4803 0.4581E-02 0.7602E-30 + 4804 0.4578E-02 0.7596E-30 + 4805 0.4574E-02 0.7589E-30 + 4806 0.4571E-02 0.7583E-30 + 4807 0.4567E-02 0.7577E-30 + 4808 0.4564E-02 0.7570E-30 + 4809 0.4560E-02 0.7564E-30 + 4810 0.4556E-02 0.7558E-30 + 4811 0.4553E-02 0.7552E-30 + 4812 0.4549E-02 0.7545E-30 + 4813 0.4546E-02 0.7539E-30 + 4814 0.4542E-02 0.7533E-30 + 4815 0.4539E-02 0.7526E-30 + 4816 0.4535E-02 0.7520E-30 + 4817 0.4532E-02 0.7514E-30 + 4818 0.4528E-02 0.7508E-30 + 4819 0.4525E-02 0.7502E-30 + 4820 0.4521E-02 0.7495E-30 + 4821 0.4518E-02 0.7489E-30 + 4822 0.4515E-02 0.7483E-30 + 4823 0.4511E-02 0.7477E-30 + 4824 0.4508E-02 0.7470E-30 + 4825 0.4504E-02 0.7464E-30 + 4826 0.4501E-02 0.7458E-30 + 4827 0.4497E-02 0.7452E-30 + 4828 0.4494E-02 0.7446E-30 + 4829 0.4490E-02 0.7440E-30 + 4830 0.4487E-02 0.7433E-30 + 4831 0.4483E-02 0.7427E-30 + 4832 0.4480E-02 0.7421E-30 + 4833 0.4476E-02 0.7415E-30 + 4834 0.4473E-02 0.7409E-30 + 4835 0.4470E-02 0.7403E-30 + 4836 0.4466E-02 0.7397E-30 + 4837 0.4463E-02 0.7390E-30 + 4838 0.4459E-02 0.7384E-30 + 4839 0.4456E-02 0.7378E-30 + 4840 0.4452E-02 0.7372E-30 + 4841 0.4449E-02 0.7366E-30 + 4842 0.4446E-02 0.7360E-30 + 4843 0.4442E-02 0.7354E-30 + 4844 0.4439E-02 0.7348E-30 + 4845 0.4435E-02 0.7342E-30 + 4846 0.4432E-02 0.7336E-30 + 4847 0.4429E-02 0.7330E-30 + 4848 0.4425E-02 0.7324E-30 + 4849 0.4422E-02 0.7318E-30 + 4850 0.4418E-02 0.7312E-30 + 4851 0.4415E-02 0.7306E-30 + 4852 0.4412E-02 0.7300E-30 + 4853 0.4408E-02 0.7294E-30 + 4854 0.4405E-02 0.7287E-30 + 4855 0.4402E-02 0.7281E-30 + 4856 0.4398E-02 0.7275E-30 + 4857 0.4395E-02 0.7270E-30 + 4858 0.4391E-02 0.7264E-30 + 4859 0.4388E-02 0.7258E-30 + 4860 0.4385E-02 0.7252E-30 + 4861 0.4381E-02 0.7246E-30 + 4862 0.4378E-02 0.7240E-30 + 4863 0.4375E-02 0.7234E-30 + 4864 0.4371E-02 0.7228E-30 + 4865 0.4368E-02 0.7222E-30 + 4866 0.4365E-02 0.7216E-30 + 4867 0.4361E-02 0.7210E-30 + 4868 0.4358E-02 0.7204E-30 + 4869 0.4355E-02 0.7198E-30 + 4870 0.4351E-02 0.7192E-30 + 4871 0.4348E-02 0.7186E-30 + 4872 0.4345E-02 0.7180E-30 + 4873 0.4341E-02 0.7175E-30 + 4874 0.4338E-02 0.7169E-30 + 4875 0.4335E-02 0.7163E-30 + 4876 0.4331E-02 0.7157E-30 + 4877 0.4328E-02 0.7151E-30 + 4878 0.4325E-02 0.7145E-30 + 4879 0.4322E-02 0.7139E-30 + 4880 0.4318E-02 0.7133E-30 + 4881 0.4315E-02 0.7128E-30 + 4882 0.4312E-02 0.7122E-30 + 4883 0.4308E-02 0.7116E-30 + 4884 0.4305E-02 0.7110E-30 + 4885 0.4302E-02 0.7104E-30 + 4886 0.4299E-02 0.7098E-30 + 4887 0.4295E-02 0.7093E-30 + 4888 0.4292E-02 0.7087E-30 + 4889 0.4289E-02 0.7081E-30 + 4890 0.4286E-02 0.7075E-30 + 4891 0.4282E-02 0.7069E-30 + 4892 0.4279E-02 0.7064E-30 + 4893 0.4276E-02 0.7058E-30 + 4894 0.4273E-02 0.7052E-30 + 4895 0.4269E-02 0.7046E-30 + 4896 0.4266E-02 0.7041E-30 + 4897 0.4263E-02 0.7035E-30 + 4898 0.4260E-02 0.7029E-30 + 4899 0.4256E-02 0.7023E-30 + 4900 0.4253E-02 0.7018E-30 + 4901 0.4250E-02 0.7012E-30 + 4902 0.4247E-02 0.7006E-30 + 4903 0.4243E-02 0.7001E-30 + 4904 0.4240E-02 0.6995E-30 + 4905 0.4237E-02 0.6989E-30 + 4906 0.4234E-02 0.6983E-30 + 4907 0.4231E-02 0.6978E-30 + 4908 0.4227E-02 0.6972E-30 + 4909 0.4224E-02 0.6966E-30 + 4910 0.4221E-02 0.6961E-30 + 4911 0.4218E-02 0.6955E-30 + 4912 0.4215E-02 0.6949E-30 + 4913 0.4211E-02 0.6944E-30 + 4914 0.4208E-02 0.6938E-30 + 4915 0.4205E-02 0.6932E-30 + 4916 0.4202E-02 0.6927E-30 + 4917 0.4199E-02 0.6921E-30 + 4918 0.4195E-02 0.6915E-30 + 4919 0.4192E-02 0.6910E-30 + 4920 0.4189E-02 0.6904E-30 + 4921 0.4186E-02 0.6899E-30 + 4922 0.4183E-02 0.6893E-30 + 4923 0.4180E-02 0.6887E-30 + 4924 0.4176E-02 0.6882E-30 + 4925 0.4173E-02 0.6876E-30 + 4926 0.4170E-02 0.6871E-30 + 4927 0.4167E-02 0.6865E-30 + 4928 0.4164E-02 0.6860E-30 + 4929 0.4161E-02 0.6854E-30 + 4930 0.4158E-02 0.6848E-30 + 4931 0.4154E-02 0.6843E-30 + 4932 0.4151E-02 0.6837E-30 + 4933 0.4148E-02 0.6832E-30 + 4934 0.4145E-02 0.6826E-30 + 4935 0.4142E-02 0.6821E-30 + 4936 0.4139E-02 0.6815E-30 + 4937 0.4136E-02 0.6810E-30 + 4938 0.4133E-02 0.6804E-30 + 4939 0.4129E-02 0.6799E-30 + 4940 0.4126E-02 0.6793E-30 + 4941 0.4123E-02 0.6788E-30 + 4942 0.4120E-02 0.6782E-30 + 4943 0.4117E-02 0.6777E-30 + 4944 0.4114E-02 0.6771E-30 + 4945 0.4111E-02 0.6766E-30 + 4946 0.4108E-02 0.6760E-30 + 4947 0.4105E-02 0.6755E-30 + 4948 0.4102E-02 0.6749E-30 + 4949 0.4098E-02 0.6744E-30 + 4950 0.4095E-02 0.6738E-30 + 4951 0.4092E-02 0.6733E-30 + 4952 0.4089E-02 0.6728E-30 + 4953 0.4086E-02 0.6722E-30 + 4954 0.4083E-02 0.6717E-30 + 4955 0.4080E-02 0.6711E-30 + 4956 0.4077E-02 0.6706E-30 + 4957 0.4074E-02 0.6700E-30 + 4958 0.4071E-02 0.6695E-30 + 4959 0.4068E-02 0.6690E-30 + 4960 0.4065E-02 0.6684E-30 + 4961 0.4062E-02 0.6679E-30 + 4962 0.4059E-02 0.6673E-30 + 4963 0.4056E-02 0.6668E-30 + 4964 0.4053E-02 0.6663E-30 + 4965 0.4050E-02 0.6657E-30 + 4966 0.4046E-02 0.6652E-30 + 4967 0.4043E-02 0.6647E-30 + 4968 0.4040E-02 0.6641E-30 + 4969 0.4037E-02 0.6636E-30 + 4970 0.4034E-02 0.6631E-30 + 4971 0.4031E-02 0.6625E-30 + 4972 0.4028E-02 0.6620E-30 + 4973 0.4025E-02 0.6615E-30 + 4974 0.4022E-02 0.6609E-30 + 4975 0.4019E-02 0.6604E-30 + 4976 0.4016E-02 0.6599E-30 + 4977 0.4013E-02 0.6593E-30 + 4978 0.4010E-02 0.6588E-30 + 4979 0.4007E-02 0.6583E-30 + 4980 0.4004E-02 0.6577E-30 + 4981 0.4001E-02 0.6572E-30 + 4982 0.3998E-02 0.6567E-30 + 4983 0.3995E-02 0.6562E-30 + 4984 0.3992E-02 0.6556E-30 + 4985 0.3989E-02 0.6551E-30 + 4986 0.3986E-02 0.6546E-30 + 4987 0.3983E-02 0.6541E-30 + 4988 0.3980E-02 0.6535E-30 + 4989 0.3977E-02 0.6530E-30 + 4990 0.3974E-02 0.6525E-30 + 4991 0.3971E-02 0.6520E-30 + 4992 0.3969E-02 0.6514E-30 + 4993 0.3966E-02 0.6509E-30 + 4994 0.3963E-02 0.6504E-30 + 4995 0.3960E-02 0.6499E-30 + 4996 0.3957E-02 0.6494E-30 + 4997 0.3954E-02 0.6488E-30 + 4998 0.3951E-02 0.6483E-30 + 4999 0.3948E-02 0.6478E-30 + 5000 0.3945E-02 0.6473E-30 diff --git a/tools/AeroTab/koehler.f b/tools/AeroTab/koehler.f new file mode 100644 index 0000000000..945dc86ac1 --- /dev/null +++ b/tools/AeroTab/koehler.f @@ -0,0 +1,154 @@ + subroutine koehler (d, imax, r, vsi, vbci, voci, vombg, vbcbg, + $ rh, f, fm, itot, faq, kcomp, iopt, xbc, xdst, xoc, xs, xa, xss, + $ rhda, rhca, rhdss, rhcss) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c solves the koehler equation to find wet/dry particle radii for +c a given relative humidity, rh. + + implicit none + +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + INTEGER i, i1, imax, imaxx, j, jstep, irh, ia, itot, + $ jtest, irtest, kcomp, iopt, koehlerplot, jxbound, jmaxf + REAL rhow, sigm, Rg, rh, rhum, rhumg, T, ai, e, pi, + $ Mw, d, drdrh, drhdr0, drdr0, dfdr0, rad, vbcrad, frr0, x, + $ rk(0:500), r(0:100), vsi(0:100), vbci(0:100), voci(0:100), + $ vsk(0:500), vbck(0:500), vock(0:500), f(-1:100), + $ fk(-1:500), fm(-1:100), fmk(-1:500), radm, scmax(500), + $ faq + REAL xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss + REAL vombg, vbcbg + +c Matemathical constants + DATA e, pi / 2.71828182845905e0, 3.141592654e0 / +c Physical constants + DATA sigm, Rg / 7.6e-2, 8.3143 / +c Temperature in the koehler calculations + DATA T / 2.7315e2 / +c Molecular weight and mass density of water + DATA Mw, rhow / 1.8016e1, 1.0e3 / + +c define a 10 times finer r-grid + imaxx=10*imax + do i=0,imaxx + rk(i)=10.0**(0.1*d*(i-10)-3.0) + enddo + + if(rh.lt.0.05.or.iopt.eq.0) then +c we assume that the growth factor = 1 for RH < 5% +c and also for iopt=0 (it will then not be used) + do i=0,imax + f(i)=1.0 + fm(i)=1.0 + enddo + endif + if(rh.lt.0.05) goto 99 + +c find interpolated dry vulume fractions for the new grid + do i=1,imaxx + i1=int(0.1*i) + if(i1.eq.0) then + vsk(i)=vsi(1) + vbck(i)=vbci(1) + vock(i)=voci(1) + elseif(i1.ge.1.and.i1.lt.imax) then + vsk(i)=vsi(i1)+(vsi(i1+1)-vsi(i1))*0.1*(i-10*i1) + vbck(i)=vbci(i1)+(vbci(i1+1)-vbci(i1))*0.1*(i-10*i1) + vock(i)=voci(i1)+(voci(i1+1)-voci(i1))*0.1*(i-10*i1) + else + vsk(i)=vsi(imax) + vbck(i)=vbci(imax) + vock(i)=voci(imax) + endif +ctest +c vsk(i)=0.0 +c vbck(i)=0.0 +c vock(i)=0.0 +ctest +c write(113,*) rk(i), vsk(i) +c write(114,*) rk(i), vock(i) +c write(115,*) rk(i), vbck(i) + enddo + + if(iopt.eq.1) then ! for hygroscopic growth calculations + +c calculate wet radii rad(i)=r(rh), such that f(rh)=rad(i)/rk(j), +c i.e. given a dry radius rk, the wet radius rad is found by +c solving the Koehler equation + jstep=10 + do j=jstep,imaxx-jstep,jstep ! dry radius index + i=j + rhum=0.0 + jxbound=0 + do while(rhum.lt.rh.and.j.le.imaxx-jstep.and.i.le.imaxx-1) + i=i+1 ! wet radius index + frr0=rk(i)/rk(j) +c mixsub calculates hygroscopic properties (given by x) +c for an internally mixed aerosol + call mixsub (frr0, itot, faq, Mw, rhow, + $ j, vsk, vbck, vock, vombg, vbcbg, x, rh, kcomp, + $ xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss) + rhumg=rhum +c the Koehler equation + rhum=e**(2e3*Mw*sigm/(Rg*T*rhow*rk(i)) + $ -x/((rk(i)/rk(j))**3-1.0)) + if(i.eq.imaxx.and.rhum.lt.rh) jxbound=jxbound+1 + if(jxbound.eq.1) jmaxf=j-jstep +c if(j.eq.410) write(251,*) j, i, rhum + enddo +c if rad < rk(imaxx) then use result from koehler formula + if(jxbound.eq.0) then + rad=((rk(i)-rk(i-1))*rh+rk(i-1)*rhum-rk(i)*rhumg) + $ /(rhum-rhumg) + fk(j)=rad/rk(j) +c but if rad > rk(imaxx), then use result for the largest +c rad < rk(imaxx) in stead (a fair approximation) + else + fk(j)=fk(jmaxf) + endif + enddo + fk(imaxx)=fk(imaxx-jstep) + +c calculate also fm(i)=radm/rk(i), given a wet radius radm + do i=jstep,imaxx,jstep ! wet radius index + j=i + rhum=0.0 + do while(rhum.lt.rh.and.j.ge.1) + j=j-1 ! dry radius index + frr0=rk(i)/rk(j) +c mixsub calculates hygroscopic properties (given by x) +c for an internally mixed aerosol + call mixsub (frr0, itot, faq, Mw, rhow, + $ j, vsk, vbck, vock, vombg, vbcbg, x, rh, kcomp, + $ xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss) + rhumg=rhum +c the Koehler equation + rhum=e**(2e3*Mw*sigm/(Rg*T*rhow*rk(i)) + $ -x/((rk(i)/rk(j))**3-1.0)) + enddo + radm=((rk(j+1)-rk(j))*rh+rk(j)*rhumg-rk(j+1)*rhum) + $ /(rhumg-rhum) + fmk(i)=rk(i)/radm + enddo + +c remap f and fm to the original resolution + i=0 + do j=jstep,imaxx,jstep + i=i+1 + f(i)=fk(j) + fm(i)=fmk(j) + if(i.gt.imax-2) f(i)=f(imax-2) + if(i.gt.imax-2) fm(i)=fm(imax-2) +c write(110,*) r(i), fm(i) +c write(111,*) r(i), f(i) + enddo + + endif ! iopt + + 99 return + end + diff --git a/tools/AeroTab/makdep.c b/tools/AeroTab/makdep.c new file mode 100644 index 0000000000..2bbb517b43 --- /dev/null +++ b/tools/AeroTab/makdep.c @@ -0,0 +1,506 @@ +/* Purpose: Build dependency lists for compilers + History: Written by someone (Rosinski?) at NCAR for CSM project + Mods by C. Zender: Add more command line options to support separate build/object/depend directories + NB: This tool is the top level of the build chain and may need to be compiled + by hand if nothing else will build. + Fortunately this is easy since it is pure ANSI C + Usage: + cc -o ${MY_BIN_DIR}/makdep makdep.c */ + +/* +** Print to stdout a dependency list for input file specified on the command +** line. A dependency is anything that is referenced by a "#include"' or +** f90 "use" statement. In addition to these dependencies, write a dependency +** rule of "file.d" for each "file.F" or "file.c". This is to accomodate the +** default "make" procedure for CCM. +** +** The name of the module being "use"d is assumed to be case sensitive even +** though the Fortran language is not. In addition, Fortran source files are +** assumed to end in .F. For example, the statement "use Xxx" will translate +** into a dependency of Xxx.o, and the file searched for will be Xxx.F. +** +** Only files which exist in at least one directory named in the current +** directory or one or more "-I" command line arguments will be considered. +** +** An ANSI C compiler is required to build this code. +*/ + +#include /* isspace, isalnum, tolower */ +#include /* printf, puts */ +#include /* malloc, getopt */ +#include /* strcpy */ +#include /* access */ + +#define MAXLEN 256 +#define TRUE 1 +#define FALSE 0 + +/* +** Linked list struct used for directories to search, and filenames already +** found. +*/ + +struct node { + char *name; + struct node *next; +}; + +/* +** lists of dependencies already found: prevents duplicates. +*/ + +static struct node *list = NULL; /* For #include */ +static struct node *uselist = NULL; /* For use */ +static struct node *suffix_list; /* List of Fortran suffixes to look for */ + +/* +** Function prototypes +*/ + +static void check (char *, struct node *, char *, int); +static int already_found (char *, struct node *); + +char *my_dpn_dir=NULL; /* [sng] Directory for dependency (*.d) files */ +char *my_obj_dir=NULL; /* [sng] Directory for object (*.o) files */ + +int main (int argc, char **argv) +{ + int lastdot; /* points to the last . in fname */ + int c; /* return from getopt */ + int recursive = FALSE; /* flag asks for recursive check: + ** i.e. check the thing being #included for #includes */ + FILE *fpFname; + + char line[MAXLEN]; /* line read from input file */ + char doto[MAXLEN]; /* name of .o file (from input file) */ + char dotd[MAXLEN]; /* name of .o file (from input file) */ + char fullpath[MAXLEN]; /* full pathname to potential dependency for .F files */ + char depnam[MAXLEN]; /* dependency name (from #include or use) */ + char srcfile[MAXLEN]; /* source file .F name from "use" */ + char *lptr; /* points into line */ + char *fname; /* input file name from command line */ + char *fptr; /* pointer to copy into depnam */ + char *relpath; /* input file name or path to it */ + + /* 20030308: Explicitly declare optarg, optind */ + extern char *optarg; + extern int optind; + + struct node *dirlist; /* list of directories to search */ + struct node *dirptr; /* loop through dirlist */ + struct node *newnode; /* malloc'd node */ + struct node *last=NULL; /* last entry in #include list of found dependencies */ + struct node *uselast=NULL; /* last entry in "use" list of found dependencies */ + struct node *sptr; /* pointer into suffix_list */ + + /* + ** Always put "." first in Filepath since gnumake will put "." first + ** regardless of whether it is specified in VPATH + */ + + dirlist = dirptr = (struct node *) malloc (sizeof (struct node)); + dirptr->name = (char *) malloc (2); + strcpy (dirptr->name, "."); + dirptr->next = NULL; + + /* + ** Always look for .F and .F90 files. List can be augmented via "-s" cmd line arg(s). + */ + + suffix_list = (struct node *) malloc (sizeof (struct node)); + suffix_list-> name = (char *) malloc (3); + strcpy (suffix_list->name, ".F"); + + suffix_list->next = (struct node *) malloc (sizeof (struct node)); + sptr = suffix_list->next; + sptr->name = (char *) malloc (5); + strcpy (sptr->name, ".F90"); + sptr->next = NULL; + + while ((c = getopt (argc, argv, "I:rs:fO:D:")) != -1) { + + switch(c) { + + case 'f': /* this arg is for backward compatibility */ + break; + case 'D': + my_dpn_dir=(char *)strdup(optarg); /* [sng] Directory for dependency (*.d) files */ + break; + case 'O': + my_obj_dir=(char *)strdup(optarg); /* [sng] Directory for object (*.o) files */ + break; + case 'I': + dirptr->next = (struct node *) malloc (sizeof (struct node)); + dirptr = dirptr->next; + dirptr->name = (char *) malloc (strlen (optarg) + 1); + strcpy (dirptr->name, optarg); + dirptr->next = NULL; + break; + case 's': + sptr->next = (struct node *) malloc (sizeof (struct node)); + sptr = sptr->next; + sptr->name = (char *) malloc (strlen (optarg) + 2); + strcpy (sptr->name, "."); + strcat (sptr->name, optarg); + sptr->next = NULL; + break; + case 'r': + recursive = TRUE; + break; + case '?': /* Unknown option */ + fprintf (stderr, "%s: Unknown option encountered\n", argv[0]); + } + } + + if (argc == optind+1) { + relpath = argv[optind]; + + } else { + + fprintf (stderr, "Usage: %s [-D dpn_dir] [-O obj_dir] [-Idir] [-r] [-s suffix] file\n", argv[0]); + exit (-1); + } + + /* + ** Retain only the filename of the input file for which dependencies are + ** being generated. + */ + + fname = relpath + strlen (relpath) - 1; + while (*fname != '/' && fname > relpath) fname--; + if (*fname == '/') fname++; + + /* + ** Define the .o file by changing tail to ".o" + */ + + strcpy (doto, fname); + for (lastdot = strlen (fname) - 1; doto[lastdot] != '.' && lastdot > 0; + lastdot--); + + if (lastdot == 0) { + fprintf (stderr, "Input file %s needs a head\n", fname); + exit (1); + } + + doto[lastdot] = '\0'; + strcpy (dotd, doto); + strcat (doto, ".o "); + strcat (dotd, ".d "); + + /* Append trailing slash if necessary */ + if(my_dpn_dir != NULL){ + if(my_dpn_dir[strlen(my_dpn_dir)-1] != '/'){ + int my_dpn_dir_usr_lng_orig; /* [nbr] Original length of user-specified my_dpn_dir */ + /* Basing offset on original length is less confusing and runs faster */ + my_dpn_dir_usr_lng_orig=strlen(my_dpn_dir); /* [nbr] Original length of user-specified my_dpn_dir */ + my_dpn_dir=(char *)realloc((void *)my_dpn_dir,my_dpn_dir_usr_lng_orig+2); /* [sng] Directory for dependency (*.d) files */ + /* Add trailing slash */ + my_dpn_dir[my_dpn_dir_usr_lng_orig]='/'; /* [sng] Directory for dependency (*.d) files */ + /* NUL-terminate */ + my_dpn_dir[my_dpn_dir_usr_lng_orig+1]='\0'; /* [sng] Directory for dependency (*.d) files */ + } /* endif */ + } /* endif */ + + /* Append trailing slash if necessary */ + if(my_obj_dir != NULL){ + /* Append trailing slash if directory does not already have one */ + if(my_obj_dir[strlen(my_obj_dir)-1] != '/'){ + int my_obj_dir_usr_lng_orig; /* [nbr] Original length of user-specified my_obj_dir */ + /* Basing offset on original length is less confusing and runs faster */ + my_obj_dir_usr_lng_orig=strlen(my_obj_dir); /* [nbr] Original length of user-specified my_obj_dir */ + my_obj_dir=(char *)realloc((void *)my_obj_dir,my_obj_dir_usr_lng_orig+2); /* [sng] Directory for object (*.o) files */ + /* Add trailing slash */ + my_obj_dir[my_obj_dir_usr_lng_orig]='/'; /* [sng] Directory for object (*.o) files */ + /* NUL-terminate */ + my_obj_dir[my_obj_dir_usr_lng_orig+1]='\0'; /* [sng] Directory for object (*.o) files */ + } /* endif */ + } /* endif */ + + /* + ** write the blah.o blah.d: blah.F (or .c or whatever) dependency to stdout + */ + + if(my_obj_dir != NULL) fputs(my_obj_dir,stdout); /* [sng] Directory for object (*.o) files */ + fputs (doto , stdout); + if(my_dpn_dir != NULL) fputs(my_dpn_dir,stdout); /* [sng] Directory for dependency (*.d) files */ + fputs (dotd , stdout); + fputs (": " , stdout); + fputs (fname , stdout); + + fputs ("\n" , stdout); + + if ((fpFname = fopen (relpath, "r")) == NULL) { + fprintf (stderr, "Can't open file %s\n", relpath); + exit (1); + } + + while (fgets (line, MAXLEN, fpFname) != NULL) { + + /* + ** Check for dependencies of the cpp "include" variety. Allow for lines + ** of the form "# include" + */ + + if (line[0] == '#') { + for (lptr = line+1; isspace ((int)*lptr); lptr++); + if (strncmp (lptr, "include ", 8) == 0) { + for (lptr += 8; *lptr != '<' && *lptr != '"' && *lptr != '\0'; lptr++); + + if (*lptr == '\0') + break; /* Bad input line: ignore */ + + /* + ** Fill in depnam with the dependency (i.e. the thing being + ** #included. Syntax check is not perfect. + */ + + for (fptr = depnam; *++lptr != '>' && *lptr != '"' && *lptr != '\0'; + fptr++) + *fptr = *lptr; + + if (*lptr == '\0') + break; /* Bad input line: ignore */ + + *fptr = '\0'; + + if ( ! already_found (depnam, list)) { /* Skip any duplicates */ + + /* + ** Include only dependencies which are specified by -Ixxx on the + ** command line. These directories are defined by the linked list + ** pointed to by dirlist. + */ + + for (dirptr = dirlist; dirptr != NULL; dirptr = dirptr->next) { + strcpy (fullpath, dirptr->name); + strcat (fullpath, "/"); + strcat (fullpath, depnam); + + /* + ** If the file exists and is readable, add an entry to the "found" + ** list, then write a dependency rule to stdout. + */ + + if (access (fullpath, R_OK) == 0) { + newnode = malloc (sizeof (struct node)); + newnode->name = malloc (strlen (depnam) + 1); + strcpy (newnode->name, depnam); + newnode->next = NULL; + + if (list == NULL) + list = newnode; + else + last->next = newnode; + + last = newnode; + if(my_obj_dir != NULL) fputs(my_obj_dir,stdout); /* [sng] Directory for object (*.o) files */ + fputs (doto , stdout); + fputs (": " , stdout); + fputs (depnam, stdout); + fputs ("\n" , stdout); + + /* + ** Check for nested #include's if flag was set + */ + + if (recursive) check (fullpath, dirlist, doto, 0); + + break; /* Dependency found: process next line */ + } + } + } + } + + } else { + + /* + ** Check for dependencies of the f90 "use" variety. To strictly adhere + ** to fortran std, should allow for spaces between chars of "use". + */ + + for (lptr = line; isspace ((int)*lptr); lptr++); + if (tolower ((int) lptr[0]) == 'u' && + tolower ((int) lptr[1]) == 's' && + tolower ((int) lptr[2]) == 'e') { + + for (lptr += 3; isspace ((int)*lptr); lptr++); + + /* + ** Fill in depnam with the dependency (i.e. the thing being "use"d. + ** Strictly speaking, should disallow numeric starting character. + */ + + for (fptr = depnam; isalnum ((int)*lptr) || *lptr == '_'; (fptr++, lptr++)) + *fptr = *lptr; + *fptr = '\0'; + + /* + ** srcfile is the source file name from which the dependency is + ** generated. Note case sensitivity of depnam. + */ + + if ( ! already_found (depnam, uselist)) { /* Skip any duplicates */ + + /* + ** Loop through suffix list + */ + + for (sptr = suffix_list; sptr != NULL; sptr = sptr->next) { + + strcpy (srcfile, depnam); + strcat (srcfile, sptr->name); + + /* + ** Include only dependencies which are specified by -Ixxx on the + ** command line. These directories are defined by the linked list + ** pointed to by dirlist. + */ + + for (dirptr = dirlist; dirptr != NULL; dirptr = dirptr->next) { + strcpy (fullpath, dirptr->name); + strcat (fullpath, "/"); + strcat (fullpath, srcfile); + + /* + ** If the file exists and is readable, add an entry to the "found" + ** list, then write a dependency rule to stdout. + */ + + if (access (fullpath, R_OK) == 0) { + newnode = malloc (sizeof (struct node)); + newnode->name = malloc (strlen (srcfile) + 1); + strcpy (newnode->name, depnam); + newnode->next = NULL; + + if (uselist == NULL) + uselist = newnode; + else + uselast->next = newnode; + + uselast = newnode; + + if(my_obj_dir != NULL) fputs(my_obj_dir,stdout); /* [sng] Directory for object (*.o) files */ + fputs (doto , stdout); + fputs (": " , stdout); + /* fputs (" \\\n " , stdout);*/ + if(my_obj_dir != NULL) fputs(my_obj_dir,stdout); /* [sng] Directory for object (*.o) files */ + fputs (depnam, stdout); + fputs (".o" , stdout); + fputs ("\n" , stdout); + + goto read_next_line; /* Dependency found: process next line */ + + } /* if (access (fullpath... */ + + } /* loop through linked list of directories from Filepath */ + } /* loop through linked list of suffixes */ + } /* if ( ! already_found (srcfile... */ + } /* if (lptr points to "use " */ + } /* else branch of if (line[0] == '#') */ + read_next_line: + continue; + } /* Looping over lines in the file */ + + fclose (fpFname); + return (0); +} + +void check (char *file, struct node *dirlist, char *doto, int recurse_level) +{ + FILE *fpFile; + + char line[MAXLEN], fullpath[MAXLEN]; + char depnam[MAXLEN]; + char *lptr, *fptr; + + struct node *dirptr; + + /* + ** Don't bother checking beyond 3 levels of recursion + */ + + if (recurse_level > 3) { + fprintf (stderr, "More than 3 levels of recursion detected: bailing out\n"); + return; + } + + if ((fpFile = fopen (file, "r")) == NULL) { + fprintf (stderr, "Can't open file %s\n", file); + exit (1); + } + + while (fgets (line, MAXLEN, fpFile) != NULL) { + + /* + ** Check for dependencies of the cpp "include" variety. Allow for lines + ** of the form "# include" + */ + + if (line[0] == '#') { + for (lptr = line+1; isspace ((int)*lptr); lptr++); + if (strncmp (lptr, "include ", 8) == 0) { + for (lptr += 8; *lptr != '<' && *lptr != '"' && *lptr != '\0'; lptr++); + + if (*lptr == '\0') + break; /* Bad input line: ignore */ + + /* + ** Fill in depnam with the dependency (i.e. the thing being + ** #included. Syntax check is not perfect. + */ + + for (fptr = depnam; *++lptr != '>' && *lptr != '"' && *lptr != '\0'; fptr++) + *fptr = *lptr; + + if (*lptr == '\0') + break; /* Bad input line: ignore */ + + *fptr = '\0'; + + /* + ** Don't include dependencies which are not in the Filepath + */ + + for (dirptr = dirlist; dirptr != NULL; dirptr = dirptr->next) { + strcpy (fullpath, dirptr->name); + strcat (fullpath, "/"); + strcat (fullpath, depnam); + + /* + ** If the file exists and is readable, add an entry to the "found" + ** list, then write a dependency rule to stdout. + */ + + if (access (fullpath, R_OK) == 0) { + + if(my_obj_dir != NULL) fputs(my_obj_dir,stdout); /* [sng] Directory for object (*.o) files */ + fputs (doto , stdout); + fputs (": " , stdout); + fputs (depnam, stdout); + fputs ("\n" , stdout); + + /* + ** Check for nested #include's + */ + + check (fullpath, dirlist, doto, recurse_level+1); + break; + } + } + } + } + } + fclose (fpFile); + return; +} + +int already_found (char *name, struct node *list) +{ + struct node *ptr; + + for (ptr = list; ptr != NULL; ptr = ptr->next) { + if (strcmp (ptr->name, name) == 0) return (1); + } + return (0); +} diff --git a/tools/AeroTab/miev0.f b/tools/AeroTab/miev0.f new file mode 100644 index 0000000000..b98e53d5d1 --- /dev/null +++ b/tools/AeroTab/miev0.f @@ -0,0 +1,1631 @@ + + SUBROUTINE MIEV0 ( XX, CREFIN, PERFCT, MIMCUT, ANYANG, + $ NUMANG, XMU, NMOM, IPOLZN, MOMDIM, PRNT, + $ QEXT, QSCA, GQSC, PMOM, SFORW, SBACK, S1, + $ S2, TFORW, TBACK, SPIKE ) + +c Author: Dr. Warren J. Wiscombe (wiscombe@climate.gsfc.nasa.gov) +c NASA Goddard Space Flight Center +c Code 913 +c Greenbelt, MD 20771 +c +c REFERENCES: +c ---------- +c (1) Wiscombe, W., 1979: Mie Scattering Calculations--Advances +c in Technique And Fast, Vector-Speed Computer Codes, +c Ncar Tech Note Tn-140+Str, National Center For +c Atmospheric Research, Boulder, Colorado (NCAR no +c longer distributes this, so contact the author or +c NTIS for a copy) +c (2) Wiscombe, W., 1980: Improved Mie Scattering Algorithms, +c Appl. Opt. 19, 1505-1509 +c (3) Dave, J.V., 1970a: Coefficients of the Legendre and +c Fourier Series for the Scattering Functions of +c Spherical Particles, Appl. Opt. 9, 1888-1896 +c (4) Dave, J.V., 1970b: Intensity and Polarization of the +c Radiation Emerging from a Plane-Parallel Atmosphere +c Containing Monodisperse Aerosols, Appl. Opt. 9, 2673-84 +c (5) Van De Hulst, 1957, 1982: Light Scattering by Small +c Particles, Dover Press, New York. +c (6) Bohren, C. and D. Huffman, Absorption and Scattering of +c Light by Small Particles, Wiley, New York. (has a +c Mie program in the back of the book) +c +c For more info, see MIEV-documentation.txt. +c +c ********************************************************************************** +c Modified for use in sizmie.f by Alf KirkevÃ¥g. +c ********************************************************************************** + +cak NB! jeg har endret MAXTRM for aa kunne bruke fordelinger med +cak store radier (opp til 100 mikrometer). +cak Paa grunn at de samme subrutinene blir brukt i straalingstransportmodellen, +cak har jeg her skiftet navn paa disse: +cak errmsg til errmsga (nytt navn) +cak wrtbad wrtbada +cak wrtdim wrtdima +cak tstbad tstbada + +C COMPUTES MIE SCATTERING AND EXTINCTION EFFICIENCIES; ASYMMETRY +C FACTOR; FORWARD- AND BACKSCATTER AMPLITUDE; SCATTERING +C AMPLITUDES VS. SCATTERING ANGLE FOR INCIDENT POLARIZATION PARALLEL +C AND PERPENDICULAR TO THE PLANE OF SCATTERING; +C COEFFICIENTS IN THE LEGENDRE POLYNOMIAL EXPANSIONS OF EITHER THE +C UNPOLARIZED PHASE FUNCTION OR THE POLARIZED PHASE MATRIX; +C SOME QUANTITIES NEEDED IN POLARIZED RADIATIVE TRANSFER; AND +C INFORMATION ABOUT WHETHER OR NOT A RESONANCE HAS BEEN HIT. +C +C INPUT AND OUTPUT VARIABLES ARE DESCRIBED IN FILE MIEV.DOC +C +C ROUTINES CALLED : BIGA, CKINMI, SMALL1, SMALL2, TESTMI, +C MIPRNT, LPCOEF, ERRMSG +C +C I N T E R N A L V A R I A B L E S +C ----------------------------------- +C +C AN,BN MIE COEFFICIENTS LITTLE-A-SUB-N, LITTLE-B-SUB-N +C ( REF. 1, EQ. 16 ) +C ANM1,BNM1 MIE COEFFICIENTS LITTLE-A-SUB-(N-1), +C LITTLE-B-SUB-(N-1); USED IN -GQSC- SUM +C ANP COEFFS. IN S+ EXPANSION ( REF. 2, P. 1507 ) +C BNP COEFFS. IN S- EXPANSION ( REF. 2, P. 1507 ) +C ANPM COEFFS. IN S+ EXPANSION ( REF. 2, P. 1507 ) +C WHEN MU IS REPLACED BY - MU +C BNPM COEFFS. IN S- EXPANSION ( REF. 2, P. 1507 ) +C ( REF. 1, P. 11 FF. ) +C RBIGA(N) BESSEL FUNCTION RATIO CAPITAL-A-SUB-N (REF. 2, EQ. 2) +C ( REAL VERSION, FOR WHEN IMAG REFRAC INDEX = 0 ) +C RIORIV 1 / MRE +C RN 1 / N +C RTMP (REAL) TEMPORARY VARIABLE +C SP(J) S+ FOR J-TH ANGLE ( REF. 2, P. 1507 ) +C SM(J) S- FOR J-TH ANGLE ( REF. 2, P. 1507 ) +C SPS(J) S+ FOR (NUMANG+1-J)-TH ANGLE ( ANYANG=FALSE ) +C SMS(J) S- FOR (NUMANG+1-J)-TH ANGLE ( ANYANG=FALSE ) +C TAUN ANGULAR FUNCTION LITTLE-TAU-SUB-N ( REF. 2, EQ. 4 ) +C AT J-TH ANGLE +C TCOEF N ( N+1 ) ( 2N+1 ) (FOR SUMMING TFORW,TBACK SERIES) +C TWONP1 2N + 1 +C YESANG TRUE IF SCATTERING AMPLITUDES ARE TO BE CALCULATED +C ZETNM1 RICATTI-BESSEL FUNCTION ZETA-SUB-(N-1) OF ARGUMENT +C -XX- ( REF. 2, EQ. 17 ) +C ZETN RICATTI-BESSEL FUNCTION ZETA-SUB-N OF ARGUMENT -XX- +C +C ---------------------------------------------------------------------- +C -------- I / O SPECIFICATIONS FOR SUBROUTINE MIEV0 ----------------- +C ---------------------------------------------------------------------- + LOGICAL ANYANG, PERFCT, PRNT(*) + INTEGER IPOLZN, MOMDIM, NUMANG, NMOM, i + REAL GQSC, MIMCUT, PMOM( 0:MOMDIM, * ), QEXT, QSCA, SPIKE, + $ XMU(*), XX, radius, pi, lambda + COMPLEX CREFIN, SFORW, SBACK, S1(*), S2(*), TFORW(*), TBACK(*) +C ---------------------------------------------------------------------- +C + PARAMETER ( MAXANG = 501, MXANG2 = MAXANG/2 + 1 ) +C +C ** NOTE -- MAXTRM = 10100 IS NECES- +C ** SARY TO DO SOME OF THE TEST PROBS, +C ** BUT 1100 IS SUFFICIENT FOR MOST +C ** CONCEIVABLE APPLICATIONS + PARAMETER ( MAXTRM = 10100 ) ! A.K. +c PARAMETER ( MAXTRM = 1100 ) + PARAMETER ( ONETHR = 1./3. ) +C + LOGICAL CALCMO(4), NOABS, OK, PASS1, YESANG + INTEGER NPQUAN + REAL MIM, MRE, MM, NP1DN + REAL RBIGA( MAXTRM ), PIN( MAXANG ), PINM1( MAXANG ) + COMPLEX AN, BN, ANM1, BNM1, ANP, BNP, ANPM, BNPM, + $ CDENAN, CDENBN, CIOR, CIORIV, CTMP, ZET, ZETNM1, ZETN + COMPLEX CBIGA( MAXTRM ), LITA( MAXTRM ), LITB( MAXTRM ), + $ SP( MAXANG ), SM( MAXANG ), SPS( MXANG2 ), SMS( MXANG2 ) + SAVE PASS1 + SQ( CTMP ) = REAL( CTMP )**2 + AIMAG( CTMP )**2 + DATA PASS1 / .TRUE. / +C +C +C ** SAVE SOME INPUT VARIABLES AND REPLACE THEM +C ** WITH VALUES NEEDED TO DO THE SELF-TEST + IF ( PASS1 ) + $ CALL TESTMI( .FALSE., XX, CREFIN, MIMCUT, PERFCT, ANYANG, + $ NMOM, IPOLZN, NUMANG, XMU, QEXT, QSCA, GQSC, + $ SFORW, SBACK, S1, S2, TFORW, TBACK, PMOM, + $ MOMDIM ) +C ** CHECK INPUT AND CALCULATE +C ** CERTAIN VARIABLES FROM INPUT +C + 10 CALL CKINMI( NUMANG, MAXANG, XX, PERFCT, CREFIN, MOMDIM, + $ NMOM, IPOLZN, ANYANG, XMU, CALCMO, NPQUAN ) +C + IF ( PERFCT .AND. XX .LE. 0.1 ) THEN +C ** USE TOTALLY-REFLECTING +C ** SMALL-PARTICLE LIMIT +C + CALL SMALL1 ( XX, NUMANG, XMU, QEXT, QSCA, GQSC, SFORW, + $ SBACK, S1, S2, TFORW, TBACK, LITA, LITB ) + NTRM = 2 + GO TO 200 + END IF +C + IF ( .NOT.PERFCT ) THEN +C + CIOR = CREFIN + IF ( AIMAG( CIOR ) .GT. 0.0 ) CIOR = CONJG( CIOR ) + MRE = REAL( CIOR ) + MIM = - AIMAG( CIOR ) + NOABS = MIM .LE. MIMCUT + CIORIV = 1.0 / CIOR + RIORIV = 1.0 / MRE +C + IF ( XX * AMAX1( 1.0, CABS(CIOR) ) .LE. 0.1 ) THEN +C +C ** USE GENERAL-REFRACTIVE-INDEX +C ** SMALL-PARTICLE LIMIT +C ** ( REF. 2, P. 1508 ) +C + CALL SMALL2 ( XX, CIOR, .NOT.NOABS, NUMANG, XMU, QEXT, + $ QSCA, GQSC, SFORW, SBACK, S1, S2, TFORW, + $ TBACK, LITA, LITB ) + NTRM = 2 + GO TO 200 + END IF +C + END IF +C + NANGD2 = ( NUMANG + 1 ) / 2 + YESANG = NUMANG .GT. 0 +C ** ESTIMATE NUMBER OF TERMS IN MIE SERIES +C ** ( REF. 2, P. 1508 ) + IF ( XX.LE.8.0 ) THEN + NTRM = XX + 4. * XX**ONETHR + 1. + ELSE IF ( XX.LT.4200. ) THEN + NTRM = XX + 4.05 * XX**ONETHR + 2. + ELSE + NTRM = XX + 4. * XX**ONETHR + 2. + END IF + IF ( NTRM+1 .GT. MAXTRM ) + $ CALL ERRMSGA( 'MIEV0--PARAMETER MAXTRM TOO SMALL', .TRUE. ) +C +C ** CALCULATE LOGARITHMIC DERIVATIVES OF +C ** J-BESSEL-FCN., BIG-A-SUB-(1 TO NTRM) + IF ( .NOT.PERFCT ) + $ CALL BIGA( CIOR, XX, NTRM, NOABS, YESANG, RBIGA, CBIGA ) +C +C ** INITIALIZE RICATTI-BESSEL FUNCTIONS +C ** (PSI,CHI,ZETA)-SUB-(0,1) FOR UPWARD +C ** RECURRENCE ( REF. 1, EQ. 19 ) + XINV = 1.0 / XX + PSINM1 = SIN( XX ) + CHINM1 = COS( XX ) + PSIN = PSINM1 * XINV - CHINM1 + CHIN = CHINM1 * XINV + PSINM1 + ZETNM1 = CMPLX( PSINM1, CHINM1 ) + ZETN = CMPLX( PSIN, CHIN ) +C ** INITIALIZE PREVIOUS COEFFI- +C ** CIENTS FOR -GQSC- SERIES + ANM1 = ( 0.0, 0.0 ) + BNM1 = ( 0.0, 0.0 ) +C ** INITIALIZE ANGULAR FUNCTION LITTLE-PI +C ** AND SUMS FOR S+, S- ( REF. 2, P. 1507 ) + IF ( ANYANG ) THEN + DO 60 J = 1, NUMANG + PINM1( J ) = 0.0 + PIN( J ) = 1.0 + SP ( J ) = ( 0.0, 0.0 ) + SM ( J ) = ( 0.0, 0.0 ) + 60 CONTINUE + ELSE + DO 70 J = 1, NANGD2 + PINM1( J ) = 0.0 + PIN( J ) = 1.0 + SP ( J ) = ( 0.0, 0.0 ) + SM ( J ) = ( 0.0, 0.0 ) + SPS( J ) = ( 0.0, 0.0 ) + SMS( J ) = ( 0.0, 0.0 ) + 70 CONTINUE + END IF +C ** INITIALIZE MIE SUMS FOR EFFICIENCIES, ETC. + QSCA = 0.0 + GQSC = 0.0 + SFORW = ( 0., 0. ) + SBACK = ( 0., 0. ) + TFORW( 1 ) = ( 0., 0. ) + TBACK( 1 ) = ( 0., 0. ) +C +C +C --------- LOOP TO SUM MIE SERIES ----------------------------------- +C + MM = + 1.0 + SPIKE = 1.0 + DO 100 N = 1, NTRM +C ** COMPUTE VARIOUS NUMERICAL COEFFICIENTS + FN = N + RN = 1.0 / FN + NP1DN = 1.0 + RN + TWONP1 = 2 * N + 1 + COEFF = TWONP1 / ( FN * ( N + 1 ) ) + TCOEF = TWONP1 * ( FN * ( N + 1 ) ) +C +C ** CALCULATE MIE SERIES COEFFICIENTS + IF ( PERFCT ) THEN +C ** TOTALLY-REFLECTING CASE +C + AN = ( ( FN*XINV ) * PSIN - PSINM1 ) / + $ ( ( FN*XINV ) * ZETN - ZETNM1 ) + BN = PSIN / ZETN +C + ELSE IF ( NOABS ) THEN +C ** NO-ABSORPTION CASE +C + CDENAN = ( RIORIV*RBIGA(N) + ( FN*XINV ) ) * ZETN - ZETNM1 + AN = ( ( RIORIV*RBIGA(N) + ( FN*XINV ) ) * PSIN - PSINM1 ) + $ / CDENAN + CDENBN = ( MRE * RBIGA(N) + ( FN*XINV ) ) * ZETN - ZETNM1 + BN = ( ( MRE * RBIGA(N) + ( FN*XINV ) ) * PSIN - PSINM1 ) + $ / CDENBN + ELSE +C ** ABSORPTIVE CASE +C + CDENAN = ( CIORIV * CBIGA(N) + ( FN*XINV ) ) * ZETN - ZETNM1 + CDENBN = ( CIOR * CBIGA(N) + ( FN*XINV ) ) * ZETN - ZETNM1 + AN = ( ( CIORIV * CBIGA(N) + ( FN*XINV ) ) * PSIN - PSINM1 ) + $ / CDENAN + BN = ( ( CIOR * CBIGA(N) + ( FN*XINV ) ) * PSIN - PSINM1 ) + $ / CDENBN + QSCA = QSCA + TWONP1 * ( SQ( AN ) + SQ( BN ) ) +C + END IF +C ** SAVE MIE COEFFICIENTS FOR *PMOM* CALCULATION + LITA( N ) = AN + LITB( N ) = BN +C + IF ( .NOT.PERFCT .AND. N.GT.XX ) THEN +C ** FLAG RESONANCE SPIKES + DENAN = CABS( CDENAN ) + DENBN = CABS( CDENBN ) + RATIO = DENAN / DENBN + IF( RATIO.LE.0.2 .OR. RATIO.GE.5.0 ) + $ SPIKE = AMIN1( SPIKE, DENAN, DENBN ) + END IF +C ** INCREMENT MIE SUMS FOR NON-ANGLE- +C ** DEPENDENT QUANTITIES +C + SFORW = SFORW + TWONP1 * ( AN + BN ) + TFORW( 1 ) = TFORW( 1 ) + TCOEF * ( AN - BN ) + SBACK = SBACK + ( MM * TWONP1 ) * ( AN - BN ) + TBACK( 1 ) = TBACK( 1 ) + ( MM * TCOEF ) * ( AN + BN ) + GQSC = GQSC + ( FN - RN ) * REAL( ANM1 * CONJG( AN ) + $ + BNM1 * CONJG( BN ) ) + $ + COEFF * REAL( AN * CONJG( BN ) ) +C + IF ( YESANG ) THEN +C ** PUT MIE COEFFICIENTS IN FORM +C ** NEEDED FOR COMPUTING S+, S- +C ** ( REF. 2, P. 1507 ) + ANP = COEFF * ( AN + BN ) + BNP = COEFF * ( AN - BN ) +C ** INCREMENT MIE SUMS FOR S+, S- +C ** WHILE UPWARD RECURSING +C ** ANGULAR FUNCTIONS LITTLE PI +C ** AND LITTLE TAU + IF ( ANYANG ) THEN +C ** ARBITRARY ANGLES +C +C ** VECTORIZABLE LOOP + DO 80 J = 1, NUMANG + RTMP = ( XMU( J ) * PIN( J ) ) - PINM1( J ) + TAUN = FN * RTMP - PINM1( J ) + SP( J ) = SP( J ) + ANP * ( PIN( J ) + TAUN ) + SM( J ) = SM( J ) + BNP * ( PIN( J ) - TAUN ) + PINM1( J ) = PIN( J ) + PIN( J ) = ( XMU( J ) * PIN( J ) ) + NP1DN * RTMP + 80 CONTINUE +C + ELSE +C ** ANGLES SYMMETRIC ABOUT 90 DEGREES + ANPM = MM * ANP + BNPM = MM * BNP +C ** VECTORIZABLE LOOP + DO 90 J = 1, NANGD2 + RTMP = ( XMU( J ) * PIN( J ) ) - PINM1( J ) + TAUN = FN * RTMP - PINM1( J ) + SP ( J ) = SP ( J ) + ANP * ( PIN( J ) + TAUN ) + SMS( J ) = SMS( J ) + BNPM * ( PIN( J ) + TAUN ) + SM ( J ) = SM ( J ) + BNP * ( PIN( J ) - TAUN ) + SPS( J ) = SPS( J ) + ANPM * ( PIN( J ) - TAUN ) + PINM1( J ) = PIN( J ) + PIN( J ) = ( XMU( J ) * PIN( J ) ) + NP1DN * RTMP + 90 CONTINUE +C + END IF + END IF +C ** UPDATE RELEVANT QUANTITIES FOR NEXT +C ** PASS THROUGH LOOP + MM = - MM + ANM1 = AN + BNM1 = BN +C ** UPWARD RECURRENCE FOR RICATTI-BESSEL +C ** FUNCTIONS ( REF. 1, EQ. 17 ) +C + ZET = ( TWONP1 * XINV ) * ZETN - ZETNM1 + ZETNM1 = ZETN + ZETN = ZET + PSINM1 = PSIN + PSIN = REAL( ZETN ) + 100 CONTINUE +C +C ---------- END LOOP TO SUM MIE SERIES -------------------------------- +C +C + QEXT = 2. / XX**2 * REAL( SFORW ) + IF ( PERFCT .OR. NOABS ) THEN + QSCA = QEXT + ELSE + QSCA = 2. / XX**2 * QSCA + END IF +C + GQSC = 4. / XX**2 * GQSC + SFORW = 0.5 * SFORW + SBACK = 0.5 * SBACK + TFORW( 2 ) = 0.5 * ( SFORW + 0.25 * TFORW( 1 ) ) + TFORW( 1 ) = 0.5 * ( SFORW - 0.25 * TFORW( 1 ) ) + TBACK( 2 ) = 0.5 * ( SBACK + 0.25 * TBACK( 1 ) ) + TBACK( 1 ) = 0.5 * ( - SBACK + 0.25 * TBACK( 1 ) ) +C + IF ( YESANG ) THEN +C ** RECOVER SCATTERING AMPLITUDES +C ** FROM S+, S- ( REF. 1, EQ. 11 ) + IF ( ANYANG ) THEN +C ** VECTORIZABLE LOOP + DO 110 J = 1, NUMANG + S1( J ) = 0.5 * ( SP( J ) + SM( J ) ) + S2( J ) = 0.5 * ( SP( J ) - SM( J ) ) + 110 CONTINUE +C + ELSE +C ** VECTORIZABLE LOOP + DO 120 J = 1, NANGD2 + S1( J ) = 0.5 * ( SP( J ) + SM( J ) ) + S2( J ) = 0.5 * ( SP( J ) - SM( J ) ) + 120 CONTINUE +C ** VECTORIZABLE LOOP + DO 130 J = 1, NANGD2 + S1( NUMANG+1 - J ) = 0.5 * ( SPS( J ) + SMS( J ) ) + S2( NUMANG+1 - J ) = 0.5 * ( SPS( J ) - SMS( J ) ) + 130 CONTINUE + END IF +C + END IF +C ** CALCULATE LEGENDRE MOMENTS + 200 IF ( NMOM.GT.0 ) + $ CALL LPCOEF ( NTRM, NMOM, IPOLZN, MOMDIM, CALCMO, NPQUAN, + $ LITA, LITB, PMOM ) +C + IF ( AIMAG(CREFIN) .GT. 0.0 ) THEN +C ** TAKE COMPLEX CONJUGATES +C ** OF SCATTERING AMPLITUDES + SFORW = CONJG( SFORW ) + SBACK = CONJG( SBACK ) + DO 210 I = 1, 2 + TFORW( I ) = CONJG( TFORW(I) ) + TBACK( I ) = CONJG( TBACK(I) ) + 210 CONTINUE +C + DO 220 J = 1, NUMANG + S1( J ) = CONJG( S1(J) ) + S2( J ) = CONJG( S2(J) ) + 220 CONTINUE +C + END IF +C + IF ( PASS1 ) THEN +C ** COMPARE TEST CASE RESULTS WITH +C ** CORRECT ANSWERS AND ABORT IF BAD; +C ** OTHERWISE RESTORE USER INPUT AND PROCEED +C + CALL TESTMI ( .TRUE., XX, CREFIN, MIMCUT, PERFCT, ANYANG, + $ NMOM, IPOLZN, NUMANG, XMU, QEXT, QSCA, GQSC, + $ SFORW, SBACK, S1, S2, TFORW, TBACK, PMOM, + $ MOMDIM ) + PASS1 = .FALSE. + GO TO 10 +C + END IF +C + IF ( PRNT(1) .OR. PRNT(2) ) + $ CALL MIPRNT( PRNT, XX, PERFCT, CREFIN, NUMANG, XMU, QEXT, + $ QSCA, GQSC, NMOM, IPOLZN, MOMDIM, CALCMO, + $ PMOM, SFORW, SBACK, TFORW, TBACK, S1, S2 ) +C + RETURN +C + END + SUBROUTINE CKINMI( NUMANG, MAXANG, XX, PERFCT, CREFIN, MOMDIM, + $ NMOM, IPOLZN, ANYANG, XMU, CALCMO, NPQUAN ) +C +C CHECK FOR BAD INPUT TO 'MIEV0' AND CALCULATE -CALCMO,NPQUAN- +C +C ROUTINES CALLED : ERRMSGA, WRTBADA +C + LOGICAL WRTBADA, WRTDIMA + LOGICAL PERFCT, ANYANG, CALCMO(*) + INTEGER NUMANG, MAXANG, MOMDIM, NMOM, IPOLZN, NPQUAN + REAL XX, XMU(*) + COMPLEX CREFIN +C + CHARACTER*4 STRING + LOGICAL INPERR +C +C + INPERR = .FALSE. + IF ( NUMANG.GT.MAXANG ) INPERR = WRTDIMA( 'MAXANG', NUMANG ) + IF ( NUMANG.LT.0 ) INPERR = WRTBADA( 'NUMANG' ) + IF ( XX.LT.0. ) INPERR = WRTBADA( 'XX' ) + IF ( .NOT.PERFCT .AND. REAL(CREFIN).LE.0. ) + $ INPERR = WRTBADA( 'CREFIN' ) + IF ( MOMDIM.LT.1 ) INPERR = WRTBADA( 'MOMDIM' ) +C + IF ( NMOM.NE.0 ) THEN + IF ( NMOM.LT.0 .OR. NMOM.GT.MOMDIM ) INPERR = WRTBADA('NMOM') + IF ( IABS(IPOLZN).GT.4444 ) INPERR = WRTBADA( 'IPOLZN' ) + NPQUAN = 0 + DO 5 L = 1, 4 + CALCMO( L ) = .FALSE. + 5 CONTINUE + IF ( IPOLZN.NE.0 ) THEN +C ** PARSE OUT -IPOLZN- INTO ITS DIGITS +C ** TO FIND WHICH PHASE QUANTITIES ARE +C ** TO HAVE THEIR MOMENTS CALCULATED +C + WRITE( STRING, '(I4)' ) IABS(IPOLZN) + DO 10 J = 1, 4 + IP = ICHAR( STRING(J:J) ) - ICHAR( '0' ) + IF ( IP.GE.1 .AND. IP.LE.4 ) CALCMO( IP ) = .TRUE. + IF ( IP.EQ.0 .OR. (IP.GE.5 .AND. IP.LE.9) ) + $ INPERR = WRTBADA( 'IPOLZN' ) + NPQUAN = MAX0( NPQUAN, IP ) + 10 CONTINUE + END IF + END IF +C + IF ( ANYANG ) THEN +C ** ALLOW FOR SLIGHT IMPERFECTIONS IN +C ** COMPUTATION OF COSINE + DO 20 I = 1, NUMANG + IF ( XMU(I).LT.-1.00001 .OR. XMU(I).GT.1.00001 ) + $ INPERR = WRTBADA( 'XMU' ) + 20 CONTINUE + ELSE + DO 22 I = 1, ( NUMANG + 1 ) / 2 + IF ( XMU(I).LT.-0.00001 .OR. XMU(I).GT.1.00001 ) + $ INPERR = WRTBADA( 'XMU' ) + 22 CONTINUE + END IF +C + IF ( INPERR ) + $ CALL ERRMSGA( 'MIEV0--INPUT ERROR(S). ABORTING...', .TRUE. ) +C + IF ( XX.GT.20000.0 .OR. REAL(CREFIN).GT.10.0 .OR. + $ ABS( AIMAG(CREFIN) ).GT.10.0 ) CALL ERRMSGA( + $ 'MIEV0--XX OR CREFIN OUTSIDE TESTED RANGE', .FALSE. ) +C + RETURN + END + SUBROUTINE LPCOEF ( NTRM, NMOM, IPOLZN, MOMDIM, CALCMO, NPQUAN, + $ A, B, PMOM ) +C +C CALCULATE LEGENDRE POLYNOMIAL EXPANSION COEFFICIENTS (ALSO +C CALLED MOMENTS) FOR PHASE QUANTITIES ( REF. 5 FORMULATION ) +C +C INPUT: NTRM NUMBER TERMS IN MIE SERIES +C NMOM, IPOLZN, MOMDIM 'MIEV0' ARGUMENTS +C CALCMO FLAGS CALCULATED FROM -IPOLZN- +C NPQUAN DEFINED IN 'MIEV0' +C A, B MIE SERIES COEFFICIENTS +C +C OUTPUT: PMOM LEGENDRE MOMENTS ('MIEV0' ARGUMENT) +C +C ROUTINES CALLED : ERRMSGA, LPCO1T, LPCO2T +C +C *** NOTES *** +C +C (1) EQS. 2-5 ARE IN ERROR IN DAVE, APPL. OPT. 9, +C 1888 (1970). EQ. 2 REFERS TO M1, NOT M2; EQ. 3 REFERS TO +C M2, NOT M1. IN EQS. 4 AND 5, THE SUBSCRIPTS ON THE SECOND +C TERM IN SQUARE BRACKETS SHOULD BE INTERCHANGED. +C +C (2) THE GENERAL-CASE LOGIC IN THIS SUBROUTINE WORKS CORRECTLY +C IN THE TWO-TERM MIE SERIES CASE, BUT SUBROUTINE 'LPCO2T' +C IS CALLED INSTEAD, FOR SPEED. +C +C (3) SUBROUTINE 'LPCO1T', TO DO THE ONE-TERM CASE, IS NEVER +C CALLED WITHIN THE CONTEXT OF 'MIEV0', BUT IS INCLUDED FOR +C COMPLETE GENERALITY. +C +C (4) SOME IMPROVEMENT IN SPEED IS OBTAINABLE BY COMBINING THE +C 310- AND 410-LOOPS, IF MOMENTS FOR BOTH THE THIRD AND FOURTH +C PHASE QUANTITIES ARE DESIRED, BECAUSE THE THIRD PHASE QUANTITY +C IS THE REAL PART OF A COMPLEX SERIES, WHILE THE FOURTH PHASE +C QUANTITY IS THE IMAGINARY PART OF THAT VERY SAME SERIES. BUT +C MOST USERS ARE NOT INTERESTED IN THE FOURTH PHASE QUANTITY, +C WHICH IS RELATED TO CIRCULAR POLARIZATION, SO THE PRESENT +C SCHEME IS USUALLY MORE EFFICIENT. +C + LOGICAL CALCMO(*) + INTEGER IPOLZN, MOMDIM, NMOM, NTRM, NPQUAN + REAL PMOM( 0:MOMDIM, * ) + COMPLEX A(*), B(*) +C +C ** SPECIFICATION OF LOCAL VARIABLES +C +C AM(M) NUMERICAL COEFFICIENTS A-SUB-M-SUPER-L +C IN DAVE, EQS. 1-15, AS SIMPLIFIED IN REF. 5. +C +C BI(I) NUMERICAL COEFFICIENTS B-SUB-I-SUPER-L +C IN DAVE, EQS. 1-15, AS SIMPLIFIED IN REF. 5. +C +C BIDEL(I) 1/2 BI(I) TIMES FACTOR CAPITAL-DEL IN DAVE +C +C CM,DM() ARRAYS C AND D IN DAVE, EQS. 16-17 (MUELLER FORM), +C CALCULATED USING RECURRENCE DERIVED IN REF. 5 +C +C CS,DS() ARRAYS C AND D IN REF. 4, EQS. A5-A6 (SEKERA FORM), +C CALCULATED USING RECURRENCE DERIVED IN REF. 5 +C +C C,D() EITHER -CM,DM- OR -CS,DS-, DEPENDING ON -IPOLZN- +C +C EVENL TRUE FOR EVEN-NUMBERED MOMENTS; FALSE OTHERWISE +C +C IDEL 1 + LITTLE-DEL IN DAVE +C +C MAXTRM MAX. NO. OF TERMS IN MIE SERIES +C +C MAXMOM MAX. NO. OF NON-ZERO MOMENTS +C +C NUMMOM NUMBER OF NON-ZERO MOMENTS +C +C RECIP(K) 1 / K +C + PARAMETER ( MAXTRM = 1102, MAXMOM = 2*MAXTRM, MXMOM2 = MAXMOM/2, + $ MAXRCP = 4*MAXTRM + 2 ) + REAL AM( 0:MAXTRM ), BI( 0:MXMOM2 ), BIDEL( 0:MXMOM2 ), + $ RECIP( MAXRCP ) + COMPLEX CM( MAXTRM ), DM( MAXTRM ), CS( MAXTRM ), DS( MAXTRM ), + $ C( MAXTRM ), D( MAXTRM ) + EQUIVALENCE ( C, CM ), ( D, DM ) + LOGICAL PASS1, EVENL + SAVE PASS1, RECIP + DATA PASS1 / .TRUE. / +C +C + IF ( PASS1 ) THEN +C + DO 1 K = 1, MAXRCP + RECIP( K ) = 1.0 / K + 1 CONTINUE + PASS1 = .FALSE. +C + END IF +C + DO 5 J = 1, MAX0( 1, NPQUAN ) + DO 5 L = 0, NMOM + PMOM( L, J ) = 0.0 + 5 CONTINUE +C + IF ( NTRM.EQ.1 ) THEN + CALL LPCO1T ( NMOM, IPOLZN, MOMDIM, CALCMO, A, B, PMOM ) + RETURN + ELSE IF ( NTRM.EQ.2 ) THEN + CALL LPCO2T ( NMOM, IPOLZN, MOMDIM, CALCMO, A, B, PMOM ) + RETURN + END IF +C + IF ( NTRM+2 .GT. MAXTRM ) + $ CALL ERRMSGA( 'LPCOEF--PARAMETER MAXTRM TOO SMALL', .TRUE. ) +C +C ** CALCULATE MUELLER C, D ARRAYS + CM( NTRM+2 ) = ( 0., 0. ) + DM( NTRM+2 ) = ( 0., 0. ) + CM( NTRM+1 ) = ( 1. - RECIP( NTRM+1 ) ) * B( NTRM ) + DM( NTRM+1 ) = ( 1. - RECIP( NTRM+1 ) ) * A( NTRM ) + CM( NTRM ) = ( RECIP(NTRM) + RECIP(NTRM+1) ) * A( NTRM ) + $ + ( 1. - RECIP(NTRM) ) * B( NTRM-1 ) + DM( NTRM ) = ( RECIP(NTRM) + RECIP(NTRM+1) ) * B( NTRM ) + $ + ( 1. - RECIP(NTRM) ) * A( NTRM-1 ) +C + DO 10 K = NTRM-1, 2, -1 + CM( K ) = CM( K+2 ) - ( 1. + RECIP(K+1) ) * B( K+1 ) + $ + ( RECIP(K) + RECIP(K+1) ) * A( K ) + $ + ( 1. - RECIP(K) ) * B( K-1 ) + DM( K ) = DM( K+2 ) - ( 1. + RECIP(K+1) ) * A( K+1 ) + $ + ( RECIP(K) + RECIP(K+1) ) * B( K ) + $ + ( 1. - RECIP(K) ) * A( K-1 ) + 10 CONTINUE + CM( 1 ) = CM( 3 ) + 1.5 * ( A( 1 ) - B( 2 ) ) + DM( 1 ) = DM( 3 ) + 1.5 * ( B( 1 ) - A( 2 ) ) +C + IF ( IPOLZN.GE.0 ) THEN +C + DO 20 K = 1, NTRM + 2 + C( K ) = ( 2*K - 1 ) * CM( K ) + D( K ) = ( 2*K - 1 ) * DM( K ) + 20 CONTINUE +C + ELSE +C ** COMPUTE SEKERA C AND D ARRAYS + CS( NTRM+2 ) = ( 0., 0. ) + DS( NTRM+2 ) = ( 0., 0. ) + CS( NTRM+1 ) = ( 0., 0. ) + DS( NTRM+1 ) = ( 0., 0. ) +C + DO 30 K = NTRM, 1, -1 + CS( K ) = CS( K+2 ) + ( 2*K + 1 ) * ( CM( K+1 ) - B( K ) ) + DS( K ) = DS( K+2 ) + ( 2*K + 1 ) * ( DM( K+1 ) - A( K ) ) + 30 CONTINUE +C + DO 40 K = 1, NTRM + 2 + C( K ) = ( 2*K - 1 ) * CS( K ) + D( K ) = ( 2*K - 1 ) * DS( K ) + 40 CONTINUE +C + END IF +C +C + IF( IPOLZN.LT.0 ) NUMMOM = MIN0( NMOM, 2*NTRM - 2 ) + IF( IPOLZN.GE.0 ) NUMMOM = MIN0( NMOM, 2*NTRM ) + IF ( NUMMOM .GT. MAXMOM ) + $ CALL ERRMSGA( 'LPCOEF--PARAMETER MAXTRM TOO SMALL', .TRUE. ) +C +C ** LOOP OVER MOMENTS + DO 500 L = 0, NUMMOM + LD2 = L / 2 + EVENL = MOD( L,2 ) .EQ. 0 +C ** CALCULATE NUMERICAL COEFFICIENTS +C ** A-SUB-M AND B-SUB-I IN DAVE +C ** DOUBLE-SUMS FOR MOMENTS + IF( L.EQ.0 ) THEN +C + IDEL = 1 + DO 60 M = 0, NTRM + AM( M ) = 2.0 * RECIP( 2*M + 1 ) + 60 CONTINUE + BI( 0 ) = 1.0 +C + ELSE IF( EVENL ) THEN +C + IDEL = 1 + DO 70 M = LD2, NTRM + AM( M ) = ( 1. + RECIP( 2*M-L+1 ) ) * AM( M ) + 70 CONTINUE + DO 75 I = 0, LD2-1 + BI( I ) = ( 1. - RECIP( L-2*I ) ) * BI( I ) + 75 CONTINUE + BI( LD2 ) = ( 2. - RECIP( L ) ) * BI( LD2-1 ) +C + ELSE +C + IDEL = 2 + DO 80 M = LD2, NTRM + AM( M ) = ( 1. - RECIP( 2*M+L+2 ) ) * AM( M ) + 80 CONTINUE + DO 85 I = 0, LD2 + BI( I ) = ( 1. - RECIP( L+2*I+1 ) ) * BI( I ) + 85 CONTINUE +C + END IF +C ** ESTABLISH UPPER LIMITS FOR SUMS +C ** AND INCORPORATE FACTOR CAPITAL- +C ** DEL INTO B-SUB-I + MMAX = NTRM - IDEL + IF( IPOLZN.GE.0 ) MMAX = MMAX + 1 + IMAX = MIN0( LD2, MMAX - LD2 ) + IF( IMAX.LT.0 ) GO TO 600 + DO 90 I = 0, IMAX + BIDEL( I ) = BI( I ) + 90 CONTINUE + IF( EVENL ) BIDEL( 0 ) = 0.5 * BIDEL( 0 ) +C +C ** PERFORM DOUBLE SUMS JUST FOR +C ** PHASE QUANTITIES DESIRED BY USER + IF( IPOLZN.EQ.0 ) THEN +C + DO 110 I = 0, IMAX +C ** VECTORIZABLE LOOP (CRAY) + SUM = 0.0 + DO 100 M = LD2, MMAX - I + SUM = SUM + AM( M ) * + $ ( REAL( C(M-I+1) * CONJG( C(M+I+IDEL) ) ) + $ + REAL( D(M-I+1) * CONJG( D(M+I+IDEL) ) ) ) + 100 CONTINUE + PMOM( L,1 ) = PMOM( L,1 ) + BIDEL( I ) * SUM + 110 CONTINUE + PMOM( L,1 ) = 0.5 * PMOM( L,1 ) + GO TO 500 +C + END IF +C + IF ( CALCMO(1) ) THEN + DO 160 I = 0, IMAX +C ** VECTORIZABLE LOOP (CRAY) + SUM = 0.0 + DO 150 M = LD2, MMAX - I + SUM = SUM + AM( M ) * + $ REAL( C(M-I+1) * CONJG( C(M+I+IDEL) ) ) + 150 CONTINUE + PMOM( L,1 ) = PMOM( L,1 ) + BIDEL( I ) * SUM + 160 CONTINUE + END IF +C +C + IF ( CALCMO(2) ) THEN + DO 210 I = 0, IMAX +C ** VECTORIZABLE LOOP (CRAY) + SUM = 0.0 + DO 200 M = LD2, MMAX - I + SUM = SUM + AM( M ) * + $ REAL( D(M-I+1) * CONJG( D(M+I+IDEL) ) ) + 200 CONTINUE + PMOM( L,2 ) = PMOM( L,2 ) + BIDEL( I ) * SUM + 210 CONTINUE + END IF +C +C + IF ( CALCMO(3) ) THEN + DO 310 I = 0, IMAX +C ** VECTORIZABLE LOOP (CRAY) + SUM = 0.0 + DO 300 M = LD2, MMAX - I + SUM = SUM + AM( M ) * + $ ( REAL( C(M-I+1) * CONJG( D(M+I+IDEL) ) ) + $ + REAL( C(M+I+IDEL) * CONJG( D(M-I+1) ) ) ) + 300 CONTINUE + PMOM( L,3 ) = PMOM( L,3 ) + BIDEL( I ) * SUM + 310 CONTINUE + PMOM( L,3 ) = 0.5 * PMOM( L,3 ) + END IF +C +C + IF ( CALCMO(4) ) THEN + DO 410 I = 0, IMAX +C ** VECTORIZABLE LOOP (CRAY) + SUM = 0.0 + DO 400 M = LD2, MMAX - I + SUM = SUM + AM( M ) * + $ ( AIMAG( C(M-I+1) * CONJG( D(M+I+IDEL) ) ) + $ + AIMAG( C(M+I+IDEL) * CONJG( D(M-I+1) ) ) ) + 400 CONTINUE + PMOM( L,4 ) = PMOM( L,4 ) + BIDEL( I ) * SUM + 410 CONTINUE + PMOM( L,4 ) = - 0.5 * PMOM( L,4 ) + END IF +C + 500 CONTINUE +C +C + 600 RETURN + END + SUBROUTINE LPCO1T ( NMOM, IPOLZN, MOMDIM, CALCMO, A, B, PMOM ) +C +C CALCULATE LEGENDRE POLYNOMIAL EXPANSION COEFFICIENTS (ALSO +C CALLED MOMENTS) FOR PHASE QUANTITIES IN SPECIAL CASE WHERE +C NO. TERMS IN MIE SERIES = 1 +C +C INPUT: NMOM, IPOLZN, MOMDIM 'MIEV0' ARGUMENTS +C CALCMO FLAGS CALCULATED FROM -IPOLZN- +C A(1), B(1) MIE SERIES COEFFICIENTS +C +C OUTPUT: PMOM LEGENDRE MOMENTS +C + LOGICAL CALCMO(*) + INTEGER IPOLZN, MOMDIM, NMOM + REAL PMOM( 0:MOMDIM, * ) + COMPLEX A(*), B(*), CTMP, A1B1C + SQ( CTMP ) = REAL( CTMP )**2 + AIMAG( CTMP )**2 +C +C + A1SQ = SQ( A(1) ) + B1SQ = SQ( B(1) ) + A1B1C = A(1) * CONJG( B(1) ) +C + IF( IPOLZN.LT.0 ) THEN +C + IF( CALCMO(1) ) PMOM( 0,1 ) = 2.25 * B1SQ + IF( CALCMO(2) ) PMOM( 0,2 ) = 2.25 * A1SQ + IF( CALCMO(3) ) PMOM( 0,3 ) = 2.25 * REAL( A1B1C ) + IF( CALCMO(4) ) PMOM( 0,4 ) = 2.25 *AIMAG( A1B1C ) +C + ELSE +C + NUMMOM = MIN0( NMOM, 2 ) +C ** LOOP OVER MOMENTS + DO 100 L = 0, NUMMOM +C + IF( IPOLZN.EQ.0 ) THEN + IF( L.EQ.0 ) PMOM( L,1 ) = 1.5 * ( A1SQ + B1SQ ) + IF( L.EQ.1 ) PMOM( L,1 ) = 1.5 * REAL( A1B1C ) + IF( L.EQ.2 ) PMOM( L,1 ) = 0.15 * ( A1SQ + B1SQ ) + GO TO 100 + END IF +C + IF( CALCMO(1) ) THEN + IF( L.EQ.0 ) PMOM( L,1 ) = 2.25 * ( A1SQ + B1SQ / 3. ) + IF( L.EQ.1 ) PMOM( L,1 ) = 1.5 * REAL( A1B1C ) + IF( L.EQ.2 ) PMOM( L,1 ) = 0.3 * B1SQ + END IF +C + IF( CALCMO(2) ) THEN + IF( L.EQ.0 ) PMOM( L,2 ) = 2.25 * ( B1SQ + A1SQ / 3. ) + IF( L.EQ.1 ) PMOM( L,2 ) = 1.5 * REAL( A1B1C ) + IF( L.EQ.2 ) PMOM( L,2 ) = 0.3 * A1SQ + END IF +C + IF( CALCMO(3) ) THEN + IF( L.EQ.0 ) PMOM( L,3 ) = 3.0 * REAL( A1B1C ) + IF( L.EQ.1 ) PMOM( L,3 ) = 0.75 * ( A1SQ + B1SQ ) + IF( L.EQ.2 ) PMOM( L,3 ) = 0.3 * REAL( A1B1C ) + END IF +C + IF( CALCMO(4) ) THEN + IF( L.EQ.0 ) PMOM( L,4 ) = - 1.5 * AIMAG( A1B1C ) + IF( L.EQ.1 ) PMOM( L,4 ) = 0.0 + IF( L.EQ.2 ) PMOM( L,4 ) = 0.3 * AIMAG( A1B1C ) + END IF +C + 100 CONTINUE +C + END IF +C + RETURN + END + SUBROUTINE LPCO2T ( NMOM, IPOLZN, MOMDIM, CALCMO, A, B, PMOM ) +C +C CALCULATE LEGENDRE POLYNOMIAL EXPANSION COEFFICIENTS (ALSO +C CALLED MOMENTS) FOR PHASE QUANTITIES IN SPECIAL CASE WHERE +C NO. TERMS IN MIE SERIES = 2 +C +C INPUT: NMOM, IPOLZN, MOMDIM 'MIEV0' ARGUMENTS +C CALCMO FLAGS CALCULATED FROM -IPOLZN- +C A(1-2), B(1-2) MIE SERIES COEFFICIENTS +C +C OUTPUT: PMOM LEGENDRE MOMENTS +C + LOGICAL CALCMO(*) + INTEGER IPOLZN, MOMDIM, NMOM + REAL PMOM( 0:MOMDIM, * ) + COMPLEX A(*), B(*) + COMPLEX A2C, B2C, CTMP, CA, CAC, CAT, CB, CBC, CBT, CG, CH + SQ( CTMP ) = REAL( CTMP )**2 + AIMAG( CTMP )**2 +C +C + CA = 3. * A(1) - 5. * B(2) + CAT= 3. * B(1) - 5. * A(2) + CAC = CONJG( CA ) + A2SQ = SQ( A(2) ) + B2SQ = SQ( B(2) ) + A2C = CONJG( A(2) ) + B2C = CONJG( B(2) ) +C + IF( IPOLZN.LT.0 ) THEN +C ** LOOP OVER SEKERA MOMENTS + NUMMOM = MIN0( NMOM, 2 ) + DO 50 L = 0, NUMMOM +C + IF( CALCMO(1) ) THEN + IF( L.EQ.0 ) PMOM( L,1 ) = 0.25 * ( SQ(CAT) + + $ (100./3.) * B2SQ ) + IF( L.EQ.1 ) PMOM( L,1 ) = (5./3.) * REAL( CAT * B2C ) + IF( L.EQ.2 ) PMOM( L,1 ) = (10./3.) * B2SQ + END IF +C + IF( CALCMO(2) ) THEN + IF( L.EQ.0 ) PMOM( L,2 ) = 0.25 * ( SQ(CA) + + $ (100./3.) * A2SQ ) + IF( L.EQ.1 ) PMOM( L,2 ) = (5./3.) * REAL( CA * A2C ) + IF( L.EQ.2 ) PMOM( L,2 ) = (10./3.) * A2SQ + END IF +C + IF( CALCMO(3) ) THEN + IF( L.EQ.0 ) PMOM( L,3 ) = 0.25 * REAL( CAT*CAC + + $ (100./3.)*B(2)*A2C ) + IF( L.EQ.1 ) PMOM( L,3 ) = 5./6. * REAL( B(2)*CAC + + $ CAT*A2C ) + IF( L.EQ.2 ) PMOM( L,3 ) = 10./3. * REAL( B(2) * A2C ) + END IF +C + IF( CALCMO(4) ) THEN + IF( L.EQ.0 ) PMOM( L,4 ) = -0.25 * AIMAG( CAT*CAC + + $ (100./3.)*B(2)*A2C ) + IF( L.EQ.1 ) PMOM( L,4 ) = -5./6. * AIMAG( B(2)*CAC + + $ CAT*A2C ) + IF( L.EQ.2 ) PMOM( L,4 ) = -10./3. * AIMAG( B(2) * A2C ) + END IF +C + 50 CONTINUE +C + ELSE +C + CB = 3. * B(1) + 5. * A(2) + CBT= 3. * A(1) + 5. * B(2) + CBC = CONJG( CB ) + CG = ( CBC*CBT + 10.*( CAC*A(2) + B2C*CAT) ) / 3. + CH = 2.*( CBC*A(2) + B2C*CBT ) +C +C ** LOOP OVER MUELLER MOMENTS + NUMMOM = MIN0( NMOM, 4 ) + DO 100 L = 0, NUMMOM +C + IF( IPOLZN.EQ.0 .OR. CALCMO(1) ) THEN + IF( L.EQ.0 ) PM1 = 0.25 * SQ(CA) + SQ(CB) / 12. + $ + (5./3.) * REAL(CA*B2C) + 5.*B2SQ + IF( L.EQ.1 ) PM1 = REAL( CB * ( CAC/6. + B2C ) ) + IF( L.EQ.2 ) PM1 = SQ(CB)/30. + (20./7.) * B2SQ + $ + (2./3.) * REAL( CA * B2C ) + IF( L.EQ.3 ) PM1 = (2./7.) * REAL( CB * B2C ) + IF( L.EQ.4 ) PM1 = (40./63.) * B2SQ + IF ( CALCMO(1) ) PMOM( L,1 ) = PM1 + END IF +C + IF( IPOLZN.EQ.0 .OR. CALCMO(2) ) THEN + IF( L.EQ.0 ) PM2 = 0.25*SQ(CAT) + SQ(CBT) / 12. + $ + (5./3.) * REAL(CAT*A2C) + 5.*A2SQ + IF( L.EQ.1 ) PM2 = REAL( CBT * ( CONJG(CAT)/6. + A2C) ) + IF( L.EQ.2 ) PM2 = SQ(CBT)/30. + (20./7.) * A2SQ + $ + (2./3.) * REAL( CAT * A2C ) + IF( L.EQ.3 ) PM2 = (2./7.) * REAL( CBT * A2C ) + IF( L.EQ.4 ) PM2 = (40./63.) * A2SQ + IF ( CALCMO(2) ) PMOM( L,2 ) = PM2 + END IF +C + IF( IPOLZN.EQ.0 ) THEN + PMOM( L,1 ) = 0.5 * ( PM1 + PM2 ) + GO TO 100 + END IF +C + IF( CALCMO(3) ) THEN + IF( L.EQ.0 ) PMOM( L,3 ) = 0.25 * REAL( CAC*CAT + CG + + $ 20.*B2C*A(2) ) + IF( L.EQ.1 ) PMOM( L,3 ) = REAL( CAC*CBT + CBC*CAT + + $ 3.*CH ) / 12. + IF( L.EQ.2 ) PMOM( L,3 ) = 0.1 * REAL( CG + (200./7.) * + $ B2C * A(2) ) + IF( L.EQ.3 ) PMOM( L,3 ) = REAL( CH ) / 14. + IF( L.EQ.4 ) PMOM( L,3 ) = 40./63. * REAL( B2C * A(2) ) + END IF +C + IF( CALCMO(4) ) THEN + IF( L.EQ.0 ) PMOM( L,4 ) = 0.25 * AIMAG( CAC*CAT + CG + + $ 20.*B2C*A(2) ) + IF( L.EQ.1 ) PMOM( L,4 ) = AIMAG( CAC*CBT + CBC*CAT + + $ 3.*CH ) / 12. + IF( L.EQ.2 ) PMOM( L,4 ) = 0.1 * AIMAG( CG + (200./7.) * + $ B2C * A(2) ) + IF( L.EQ.3 ) PMOM( L,4 ) = AIMAG( CH ) / 14. + IF( L.EQ.4 ) PMOM( L,4 ) = 40./63. * AIMAG( B2C * A(2) ) + END IF +C + 100 CONTINUE +C + END IF +C + RETURN + END + SUBROUTINE BIGA( CIOR, XX, NTRM, NOABS, YESANG, RBIGA, CBIGA ) +C +C CALCULATE LOGARITHMIC DERIVATIVES OF J-BESSEL-FUNCTION +C +C INPUT : CIOR, XX, NTRM, NOABS, YESANG (DEFINED IN 'MIEV0') +C +C OUTPUT : RBIGA OR CBIGA (DEFINED IN 'MIEV0') +C +C ROUTINES CALLED : CONFRA +C +C INTERNAL VARIABLES : +C +C CONFRA VALUE OF LENTZ CONTINUED FRACTION FOR -CBIGA(NTRM)-, +C USED TO INITIALIZE DOWNWARD RECURRENCE. +C DOWN = TRUE, USE DOWN-RECURRENCE. FALSE, DO NOT. +C F1,F2,F3 ARITHMETIC STATEMENT FUNCTIONS USED IN DETERMINING +C WHETHER TO USE UP- OR DOWN-RECURRENCE +C ( REF. 2, EQS. 6-8 ) +C MRE REAL REFRACTIVE INDEX +C MIM IMAGINARY REFRACTIVE INDEX +C REZINV 1 / ( MRE * XX ); TEMPORARY VARIABLE FOR RECURRENCE +C ZINV 1 / ( CIOR * XX ); TEMPORARY VARIABLE FOR RECURRENCE +C + LOGICAL DOWN, NOABS, YESANG + INTEGER NTRM + REAL MRE, MIM, RBIGA(*), XX, REZINV, RTMP + COMPLEX CIOR, CTMP, CONFRA, CBIGA(*), ZINV + F1( MRE ) = - 8.0 + MRE**2 * ( 26.22 + MRE * ( - 0.4474 + $ + MRE**3 * ( 0.00204 - 0.000175 * MRE ) ) ) + F2( MRE ) = 3.9 + MRE * ( - 10.8 + 13.78 * MRE ) + F3( MRE ) = - 15.04 + MRE * ( 8.42 + 16.35 * MRE ) +C +C ** DECIDE WHETHER 'BIGA' CAN BE +C ** CALCULATED BY UP-RECURRENCE + MRE = REAL( CIOR ) + MIM = ABS( AIMAG( CIOR ) ) + IF ( MRE.LT.1.0 .OR. MRE.GT.10.0 .OR. MIM.GT.10.0 ) THEN + DOWN = .TRUE. + ELSE IF ( YESANG ) THEN + DOWN = .TRUE. + IF ( MIM*XX .LT. F2( MRE ) ) DOWN = .FALSE. + ELSE + DOWN = .TRUE. + IF ( MIM*XX .LT. F1( MRE ) ) DOWN = .FALSE. + END IF +C + ZINV = 1.0 / ( CIOR * XX ) + REZINV = 1.0 / ( MRE * XX ) +C + IF ( DOWN ) THEN +C ** COMPUTE INITIAL HIGH-ORDER 'BIGA' USING +C ** LENTZ METHOD ( REF. 1, PP. 17-20 ) +C + CTMP = CONFRA( NTRM, ZINV ) +C +C *** DOWNWARD RECURRENCE FOR 'BIGA' +C *** ( REF. 1, EQ. 22 ) + IF ( NOABS ) THEN +C ** NO-ABSORPTION CASE + RBIGA( NTRM ) = REAL( CTMP ) + DO 25 N = NTRM, 2, - 1 + RBIGA( N-1 ) = (N*REZINV) + $ - 1.0 / ( (N*REZINV) + RBIGA( N ) ) + 25 CONTINUE +C + ELSE +C ** ABSORPTIVE CASE + CBIGA( NTRM ) = CTMP + DO 30 N = NTRM, 2, - 1 + CBIGA( N-1 ) = (N*ZINV) - 1.0 / ( (N*ZINV) + CBIGA( N ) ) + 30 CONTINUE +C + END IF +C + ELSE +C *** UPWARD RECURRENCE FOR 'BIGA' +C *** ( REF. 1, EQS. 20-21 ) + IF ( NOABS ) THEN +C ** NO-ABSORPTION CASE + RTMP = SIN( MRE*XX ) + RBIGA( 1 ) = - REZINV + $ + RTMP / ( RTMP*REZINV - COS( MRE*XX ) ) + DO 40 N = 2, NTRM + RBIGA( N ) = - ( N*REZINV ) + $ + 1.0 / ( ( N*REZINV ) - RBIGA( N-1 ) ) + 40 CONTINUE +C + ELSE +C ** ABSORPTIVE CASE + CTMP = CEXP( - (0.,2.) * CIOR * XX ) + CBIGA( 1 ) = - ZINV + (1.-CTMP) / + $ ( ZINV * (1.-CTMP) - (0.,1.)*(1.+CTMP) ) + DO 50 N = 2, NTRM + CBIGA( N ) = - (N*ZINV) + 1.0 / ((N*ZINV) - CBIGA( N-1 )) + 50 CONTINUE + END IF +C + END IF +C + RETURN + END + COMPLEX FUNCTION CONFRA( N, ZINV ) +C +C COMPUTE BESSEL FUNCTION RATIO CAPITAL-A-SUB-N FROM ITS +C CONTINUED FRACTION USING LENTZ METHOD ( REF. 1, PP. 17-20 ) +C +C ZINV = RECIPROCAL OF ARGUMENT OF CAPITAL-A +C +C I N T E R N A L V A R I A B L E S +C ------------------------------------ +C +C CAK TERM IN CONTINUED FRACTION EXPANSION OF CAPITAL-A +C ( REF. 1, EQ. 25 ) +C CAPT FACTOR USED IN LENTZ ITERATION FOR CAPITAL-A +C ( REF. 1, EQ. 27 ) +C CDENOM DENOMINATOR IN -CAPT- ( REF. 1, EQ. 28B ) +C CNUMER NUMERATOR IN -CAPT- ( REF. 1, EQ. 28A ) +C CDTD PRODUCT OF TWO SUCCESSIVE DENOMINATORS OF -CAPT- +C FACTORS ( REF. 1, EQ. 34C ) +C CNTN PRODUCT OF TWO SUCCESSIVE NUMERATORS OF -CAPT- +C FACTORS ( REF. 1, EQ. 34B ) +C EPS1 ILL-CONDITIONING CRITERION +C EPS2 CONVERGENCE CRITERION +C KK SUBSCRIPT K OF -CAK- ( REF. 1, EQ. 25B ) +C KOUNT ITERATION COUNTER ( USED ONLY TO PREVENT RUNAWAY ) +C MAXIT MAX. ALLOWED NO. OF ITERATIONS +C MM + 1 AND - 1, ALTERNATELY +C + INTEGER N + COMPLEX ZINV + COMPLEX CAK, CAPT, CDENOM, CDTD, CNUMER, CNTN + DATA EPS1 / 1.E - 2 /, EPS2 / 1.E - 8 / + DATA MAXIT / 10000 / +C +C *** REF. 1, EQS. 25A, 27 + CONFRA = ( N + 1 ) * ZINV + MM = - 1 + KK = 2 * N + 3 + CAK = ( MM * KK ) * ZINV + CDENOM = CAK + CNUMER = CDENOM + 1.0 / CONFRA + KOUNT = 1 +C + 20 KOUNT = KOUNT + 1 + IF ( KOUNT.GT.MAXIT ) + $ CALL ERRMSGA( 'CONFRA--ITERATION FAILED TO CONVERGE$', .TRUE.) +C +C *** REF. 2, EQ. 25B + MM = - MM + KK = KK + 2 + CAK = ( MM * KK ) * ZINV +C *** REF. 2, EQ. 32 + IF ( CABS( CNUMER/CAK ).LE.EPS1 + $ .OR. CABS( CDENOM/CAK ).LE.EPS1 ) THEN +C +C ** ILL-CONDITIONED CASE -- STRIDE +C ** TWO TERMS INSTEAD OF ONE +C +C *** REF. 2, EQS. 34 + CNTN = CAK * CNUMER + 1.0 + CDTD = CAK * CDENOM + 1.0 + CONFRA = ( CNTN / CDTD ) * CONFRA +C *** REF. 2, EQ. 25B + MM = - MM + KK = KK + 2 + CAK = ( MM * KK ) * ZINV +C *** REF. 2, EQS. 35 + CNUMER = CAK + CNUMER / CNTN + CDENOM = CAK + CDENOM / CDTD + KOUNT = KOUNT + 1 + GO TO 20 +C + ELSE +C ** WELL-CONDITIONED CASE +C +C *** REF. 2, EQS. 26, 27 + CAPT = CNUMER / CDENOM + CONFRA = CAPT * CONFRA +C ** CHECK FOR CONVERGENCE +C ** ( REF. 2, EQ. 31 ) +C + IF ( ABS( REAL (CAPT) - 1.0 ).GE.EPS2 + $ .OR. ABS( AIMAG(CAPT) ) .GE.EPS2 ) THEN +C +C *** REF. 2, EQS. 30A-B + CNUMER = CAK + 1.0 / CNUMER + CDENOM = CAK + 1.0 / CDENOM + GO TO 20 + END IF + END IF +C + RETURN +C + END + SUBROUTINE MIPRNT( PRNT, XX, PERFCT, CREFIN, NUMANG, XMU, + $ QEXT, QSCA, GQSC, NMOM, IPOLZN, MOMDIM, + $ CALCMO, PMOM, SFORW, SBACK, TFORW, TBACK, + $ S1, S2 ) +C +C PRINT SCATTERING QUANTITIES OF A SINGLE PARTICLE +C + LOGICAL PERFCT, PRNT(*), CALCMO(*) + INTEGER IPOLZN, MOMDIM, NMOM, NUMANG + REAL GQSC, PMOM( 0:MOMDIM, * ), QEXT, QSCA, XX, XMU(*) + COMPLEX CREFIN, SFORW, SBACK, TFORW(*), TBACK(*), S1(*), S2(*) + CHARACTER*22 FMT +C +C + IF ( PERFCT ) WRITE ( *, '(''1'',10X,A,1P,E11.4)' ) + $ 'PERFECTLY CONDUCTING CASE, SIZE PARAMETER =', XX +cak IF ( .NOT.PERFCT ) WRITE ( *, '(''1'',10X,3(A,1P,E11.4))' ) +cak $ 'REFRACTIVE INDEX: REAL ', REAL(CREFIN), +cak $ ' IMAG ', AIMAG(CREFIN), ', SIZE PARAMETER =', XX +C + IF ( PRNT(1) .AND. NUMANG.GT.0 ) THEN +C + WRITE ( *, '(/,A)' ) + $ ' COS(ANGLE) ------- S1 --------- ------- S2 ---------'// + $ ' --- S1*CONJG(S2) --- I1=S1**2 I2=S2**2 (I1+I2)/2'// + $ ' DEG POLZN' + DO 10 I = 1, NUMANG + FI1 = REAL( S1(I) ) **2 + AIMAG( S1(I) )**2 + FI2 = REAL( S2(I) ) **2 + AIMAG( S2(I) )**2 + WRITE( *, '( I4, F10.6, 1P,10E11.3 )' ) + $ I, XMU(I), S1(I), S2(I), S1(I)*CONJG(S2(I)), + $ FI1, FI2, 0.5*(FI1+FI2), (FI2-FI1)/(FI2+FI1) + 10 CONTINUE +C + END IF +C +C + IF ( PRNT(2) ) THEN +C +cak WRITE ( *, '(/,A,9X,A,17X,A,17X,A,/,(0P,F7.2, 1P,6E12.3) )' ) +cak $ ' ANGLE', 'S-SUB-1', 'T-SUB-1', 'T-SUB-2', +cak $ 0.0, SFORW, TFORW(1), TFORW(2), +cak $ 180., SBACK, TBACK(1), TBACK(2) +cak WRITE ( *, '(/,4(A,1P,E11.4))' ) +cak $ ' EFFICIENCY FACTORS, EXTINCTION:', QEXT, +cak $ ' SCATTERING:', QSCA, +cak $ ' ABSORPTION:', QEXT-QSCA, +cak $ ' RAD. PRESSURE:', QEXT-GQSC +C + IF ( NMOM.GT.0 ) THEN +C + WRITE( *, '(/,A)' ) ' NORMALIZED MOMENTS OF :' + IF ( IPOLZN.EQ.0 ) WRITE ( *, '(''+'',27X,A)' ) 'PHASE FCN' + IF ( IPOLZN.GT.0 ) WRITE ( *, '(''+'',33X,A)' ) + $ 'M1 M2 S21 D21' + IF ( IPOLZN.LT.0 ) WRITE ( *, '(''+'',33X,A)' ) + $ 'R1 R2 R3 R4' +C + FNORM = 4. / ( XX**2 * QSCA ) + DO 20 M = 0, NMOM + WRITE ( *, '(A,I4)' ) ' MOMENT NO.', M + DO 20 J = 1, 4 + IF( CALCMO(J) ) THEN + WRITE( FMT, 98 ) 24 + (J-1)*13 + WRITE ( *,FMT ) FNORM * PMOM(M,J) + END IF + 20 CONTINUE + END IF +C + END IF +C + RETURN +C + 98 FORMAT( '( ''+'', T', I2, ', 1P,E13.4 )' ) + END + SUBROUTINE SMALL1 ( XX, NUMANG, XMU, QEXT, QSCA, GQSC, SFORW, + $ SBACK, S1, S2, TFORW, TBACK, A, B ) +C +C SMALL-PARTICLE LIMIT OF MIE QUANTITIES IN TOTALLY REFLECTING +C LIMIT ( MIE SERIES TRUNCATED AFTER 2 TERMS ) +C +C A,B FIRST TWO MIE COEFFICIENTS, WITH NUMERATOR AND +C DENOMINATOR EXPANDED IN POWERS OF -XX- ( A FACTOR +C OF XX**3 IS MISSING BUT IS RESTORED BEFORE RETURN +C TO CALLING PROGRAM ) ( REF. 2, P. 1508 ) +C + INTEGER NUMANG + REAL GQSC, QEXT, QSCA, XX, XMU(*) + COMPLEX A(*), B(*), SFORW, SBACK, S1(*), S2(*), + $ TFORW(*), TBACK(*) +C + PARAMETER ( TWOTHR = 2./3., FIVTHR = 5./3., FIVNIN = 5./9. ) + COMPLEX CTMP + SQ( CTMP ) = REAL( CTMP )**2 + AIMAG( CTMP )**2 +C +C + A( 1 ) = CMPLX ( 0., TWOTHR * ( 1. - 0.2 * XX**2 ) ) + $ / CMPLX ( 1. - 0.5 * XX**2, TWOTHR * XX**3 ) +C + B( 1 ) = CMPLX ( 0., - ( 1. - 0.1 * XX**2 ) / 3. ) + $ / CMPLX ( 1. + 0.5 * XX**2, - XX**3 / 3. ) +C + A( 2 ) = CMPLX ( 0., XX**2 / 30. ) + B( 2 ) = CMPLX ( 0., - XX**2 / 45. ) +C + QSCA = 6. * XX**4 * ( SQ( A(1) ) + SQ( B(1) ) + $ + FIVTHR * ( SQ( A(2) ) + SQ( B(2) ) ) ) + QEXT = QSCA + GQSC = 6. * XX**4 * REAL( A(1) * CONJG( A(2) + B(1) ) + $ + ( B(1) + FIVNIN * A(2) ) * CONJG( B(2) ) ) +C + RTMP = 1.5 * XX**3 + SFORW = RTMP * ( A(1) + B(1) + FIVTHR * ( A(2) + B(2) ) ) + SBACK = RTMP * ( A(1) - B(1) - FIVTHR * ( A(2) - B(2) ) ) + TFORW( 1 ) = RTMP * ( B(1) + FIVTHR * ( 2.*B(2) - A(2) ) ) + TFORW( 2 ) = RTMP * ( A(1) + FIVTHR * ( 2.*A(2) - B(2) ) ) + TBACK( 1 ) = RTMP * ( B(1) - FIVTHR * ( 2.*B(2) + A(2) ) ) + TBACK( 2 ) = RTMP * ( A(1) - FIVTHR * ( 2.*A(2) + B(2) ) ) +C + DO 10 J = 1, NUMANG + S1( J ) = RTMP * ( A(1) + B(1) * XMU(J) + FIVTHR * + $ ( A(2) * XMU(J) + B(2) * ( 2.*XMU(J)**2 - 1. )) ) + S2( J ) = RTMP * ( B(1) + A(1) * XMU(J) + FIVTHR * + $ ( B(2) * XMU(J) + A(2) * ( 2.*XMU(J)**2 - 1. )) ) + 10 CONTINUE +C ** RECOVER ACTUAL MIE COEFFICIENTS + A( 1 ) = XX**3 * A( 1 ) + A( 2 ) = XX**3 * A( 2 ) + B( 1 ) = XX**3 * B( 1 ) + B( 2 ) = XX**3 * B( 2 ) +C + RETURN + END + SUBROUTINE SMALL2 ( XX, CIOR, CALCQE, NUMANG, XMU, QEXT, QSCA, + $ GQSC, SFORW, SBACK, S1, S2, TFORW, TBACK, + $ A, B ) +C +C SMALL-PARTICLE LIMIT OF MIE QUANTITIES FOR GENERAL REFRACTIVE +C INDEX ( MIE SERIES TRUNCATED AFTER 2 TERMS ) +C +C A,B FIRST TWO MIE COEFFICIENTS, WITH NUMERATOR AND +C DENOMINATOR EXPANDED IN POWERS OF -XX- ( A FACTOR +C OF XX**3 IS MISSING BUT IS RESTORED BEFORE RETURN +C TO CALLING PROGRAM ) ( REF. 2, P. 1508 ) +C +C CIORSQ SQUARE OF REFRACTIVE INDEX +C + LOGICAL CALCQE + INTEGER NUMANG + REAL GQSC, QEXT, QSCA, XX, XMU(*) + COMPLEX A(*), B(*), CIOR, SFORW, SBACK, S1(*), S2(*), + $ TFORW(*), TBACK(*) +C + PARAMETER ( TWOTHR = 2./3., FIVTHR = 5./3. ) + COMPLEX CTMP, CIORSQ + SQ( CTMP ) = REAL( CTMP )**2 + AIMAG( CTMP )**2 +C +C + CIORSQ = CIOR**2 + CTMP = CMPLX( 0., TWOTHR ) * ( CIORSQ - 1.0 ) + A(1) = CTMP * ( 1.0 - 0.1 * XX**2 + (CIORSQ/350. + 1./280.)*XX**4) + $ / ( CIORSQ + 2.0 + ( 1.0 - 0.7 * CIORSQ ) * XX**2 + $ - ( CIORSQ**2/175. - 0.275 * CIORSQ + 0.25 ) * XX**4 + $ + XX**3 * CTMP * ( 1.0 - 0.1 * XX**2 ) ) +C + B(1) = (XX**2/30.) * CTMP * ( 1.0 + (CIORSQ/35. - 1./14.) *XX**2 ) + $ / ( 1.0 - ( CIORSQ/15. - 1./6. ) * XX**2 ) +C + A(2) = ( 0.1 * XX**2 ) * CTMP * ( 1.0 - XX**2 / 14. ) + $ / ( 2. * CIORSQ + 3. - ( CIORSQ/7. - 0.5 ) * XX**2 ) +C + QSCA = 6. * XX**4 * ( SQ(A(1)) + SQ(B(1)) + FIVTHR * SQ(A(2)) ) + GQSC = 6. * XX**4 * REAL( A(1) * CONJG( A(2) + B(1) ) ) + QEXT = QSCA + IF ( CALCQE ) QEXT = 6. * XX * REAL( A(1) + B(1) + FIVTHR * A(2) ) +C + RTMP = 1.5 * XX**3 + SFORW = RTMP * ( A(1) + B(1) + FIVTHR * A(2) ) + SBACK = RTMP * ( A(1) - B(1) - FIVTHR * A(2) ) + TFORW( 1 ) = RTMP * ( B(1) - FIVTHR * A(2) ) + TFORW( 2 ) = RTMP * ( A(1) + 2. * FIVTHR * A(2) ) + TBACK( 1 ) = TFORW( 1 ) + TBACK( 2 ) = RTMP * ( A(1) - 2. * FIVTHR * A(2) ) +C + DO 10 J = 1, NUMANG + S1( J ) = RTMP * ( A(1) + ( B(1) + FIVTHR * A(2) ) * XMU(J) ) + S2( J ) = RTMP * ( B(1) + A(1) * XMU(J) + FIVTHR * A(2) + $ * ( 2. * XMU(J)**2 - 1. ) ) + 10 CONTINUE +C ** RECOVER ACTUAL MIE COEFFICIENTS + A( 1 ) = XX**3 * A( 1 ) + A( 2 ) = XX**3 * A( 2 ) + B( 1 ) = XX**3 * B( 1 ) + B( 2 ) = ( 0., 0. ) +C + RETURN + END + SUBROUTINE TESTMI ( COMPAR, XX, CREFIN, MIMCUT, PERFCT, ANYANG, + $ NMOM, IPOLZN, NUMANG, XMU, QEXT, QSCA, GQSC, + $ SFORW, SBACK, S1, S2, TFORW, TBACK, PMOM, + $ MOMDIM ) +C +C SET UP TO RUN TEST CASE WHEN COMPAR = FALSE; WHEN = TRUE, +C COMPARE MIE CODE TEST CASE RESULTS WITH CORRECT ANSWERS +C AND ABORT IF EVEN ONE RESULT IS INACCURATE. +C +C THE TEST CASE IS : MIE SIZE PARAMETER = 10 +C REFRACTIVE INDEX = 1.5 - 0.1 I +C SCATTERING ANGLE = 140 DEGREES +C 1 SEKERA MOMENT +C +C RESULTS FOR THIS CASE MAY BE FOUND AMONG THE TEST CASES +C AT THE END OF REFERENCE (1). +C +C *** NOTE *** WHEN RUNNING ON SOME COMPUTERS, ESP. IN SINGLE +C PRECISION, THE 'ACCUR' CRITERION BELOW MAY HAVE TO BE RELAXED. +C HOWEVER, IF 'ACCUR' MUST BE SET LARGER THAN 10**-3 FOR SOME +C SIZE PARAMETERS, YOUR COMPUTER IS PROBABLY NOT ACCURATE +C ENOUGH TO DO MIE COMPUTATIONS FOR THOSE SIZE PARAMETERS. +C +C ROUTINES CALLED : ERRMSGA, MIPRNT, TSTBADA +C + LOGICAL TSTBADA + LOGICAL COMPAR, ANYANG, PERFCT + INTEGER IPOLZN, MOMDIM, NUMANG, NMOM + REAL MIMCUT, QEXT, QSCA, GQSC, PMOM( 0:MOMDIM, * ), XMU(*), XX + COMPLEX CREFIN, SFORW, SBACK, S1(*), S2(*), TFORW(*), TBACK(*) +C + LOGICAL ANYSAV, PERSAV, CALCMO(4), PRNT(2), OK, WRONG + REAL ACCUR, MIMSAV, TESTQE, TESTQS, TESTGQ, TESTPM( 0:1 ) + COMPLEX CRESAV, TESTSF, TESTSB, TESTS1, TESTS2, TESTTF( 2 ), + $ TESTTB( 2 ) + SAVE XXSAV, CRESAV, MIMSAV, PERSAV, ANYSAV, NMOSAV, IPOSAV, + $ NUMSAV, XMUSAV + DATA TESTQE / 2.459791 /, TESTQS / 1.235144 /, + $ TESTGQ / 1.139235 /, TESTSF / ( 61.49476, -3.177994 ) /, + $ TESTSB / ( 1.493434, 0.2963657 ) /, + $ TESTS1 / ( -0.1548380, -1.128972) /, + $ TESTS2 / ( 0.05669755, 0.5425681) /, + $ TESTTF / ( 12.95238, -136.6436 ), ( 48.54238, 133.4656 ) /, + $ TESTTB / ( 41.88414, -15.57833 ), ( 43.37758, -15.28196 )/, + $ TESTPM / 227.1975, 183.6898 / + DATA ACCUR / 1.E-4 / + WRONG( CALC, EXACT ) = ABS( (CALC - EXACT) / EXACT ) .GT. ACCUR +C +C + IF ( .NOT.COMPAR ) THEN +C ** SAVE CERTAIN USER INPUT VALUES + XXSAV = XX + CRESAV = CREFIN + MIMSAV = MIMCUT + PERSAV = PERFCT + ANYSAV = ANYANG + NMOSAV = NMOM + IPOSAV = IPOLZN + NUMSAV = NUMANG + XMUSAV = XMU(1) +C ** RESET INPUT VALUES FOR TEST CASE + XX = 10.0 + CREFIN = ( 1.5, - 0.1 ) + MIMCUT = 0.0 + PERFCT = .FALSE. + ANYANG = .TRUE. + NMOM = 1 + IPOLZN = - 1 + NUMANG = 1 + XMU(1) = - 0.7660444 +C + ELSE +C ** COMPARE TEST CASE RESULTS WITH +C ** CORRECT ANSWERS AND ABORT IF BAD + OK = .TRUE. + IF ( WRONG( QEXT,TESTQE ) ) + $ OK = TSTBADA( 'QEXT', ABS((QEXT - TESTQE) / TESTQE) ) + IF ( WRONG( QSCA,TESTQS ) ) + $ OK = TSTBADA( 'QSCA', ABS((QSCA - TESTQS) / TESTQS) ) + IF ( WRONG( GQSC,TESTGQ ) ) + $ OK = TSTBADA( 'GQSC', ABS((GQSC - TESTGQ) / TESTGQ) ) +C + IF ( WRONG( REAL(SFORW), REAL(TESTSF) ) .OR. + $ WRONG( AIMAG(SFORW), AIMAG(TESTSF) ) ) + $ OK = TSTBADA( 'SFORW', CABS((SFORW - TESTSF) / TESTSF) ) +C + IF ( WRONG( REAL(SBACK), REAL(TESTSB) ) .OR. + $ WRONG( AIMAG(SBACK), AIMAG(TESTSB) ) ) + $ OK = TSTBADA( 'SBACK', CABS((SBACK - TESTSB) / TESTSB) ) +C + IF ( WRONG( REAL(S1(1)), REAL(TESTS1) ) .OR. + $ WRONG( AIMAG(S1(1)), AIMAG(TESTS1) ) ) + $ OK = TSTBADA( 'S1', CABS((S1(1) - TESTS1) / TESTS1) ) +C + IF ( WRONG( REAL(S2(1)), REAL(TESTS2) ) .OR. + $ WRONG( AIMAG(S2(1)), AIMAG(TESTS2) ) ) + $ OK = TSTBADA( 'S2', CABS((S2(1) - TESTS2) / TESTS2) ) +C + DO 20 N = 1, 2 + IF ( WRONG( REAL(TFORW(N)), REAL(TESTTF(N)) ) .OR. + $ WRONG( AIMAG(TFORW(N)), AIMAG(TESTTF(N)) ) ) + $ OK = TSTBADA( 'TFORW', CABS( (TFORW(N) - TESTTF(N)) / + $ TESTTF(N) ) ) + IF ( WRONG( REAL(TBACK(N)), REAL(TESTTB(N)) ) .OR. + $ WRONG( AIMAG(TBACK(N)), AIMAG(TESTTB(N)) ) ) + $ OK = TSTBADA( 'TBACK', CABS( (TBACK(N) - TESTTB(N)) / + $ TESTTB(N) ) ) + 20 CONTINUE +C + DO 30 M = 0, 1 + IF ( WRONG( PMOM(M,1), TESTPM(M) ) ) + $ OK = TSTBADA( 'PMOM', ABS( (PMOM(M,1)-TESTPM(M)) / + $ TESTPM(M) ) ) + 30 CONTINUE +C + IF ( .NOT. OK ) THEN + PRNT(1) = .TRUE. + PRNT(2) = .TRUE. + CALCMO(1) = .TRUE. + CALCMO(2) = .FALSE. + CALCMO(3) = .FALSE. + CALCMO(4) = .FALSE. + CALL MIPRNT( PRNT, XX, PERFCT, CREFIN, NUMANG, XMU, QEXT, + $ QSCA, GQSC, NMOM, IPOLZN, MOMDIM, CALCMO, + $ PMOM, SFORW, SBACK, TFORW, TBACK, S1, S2 ) + CALL ERRMSGA( 'MIEV0 -- SELF-TEST FAILED', .TRUE. ) + END IF +C ** RESTORE USER INPUT VALUES + XX = XXSAV + CREFIN = CRESAV + MIMCUT = MIMSAV + PERFCT = PERSAV + ANYANG = ANYSAV + NMOM = NMOSAV + IPOLZN = IPOSAV + NUMANG = NUMSAV + XMU(1) = XMUSAV +C + END IF +C + RETURN + END + LOGICAL FUNCTION WRTBADA ( VARNAM ) +C +C WRITE NAMES OF ERRONEOUS VARIABLES AND RETURN 'TRUE' +C +C INPUT : VARNAM = NAME OF ERRONEOUS VARIABLE TO BE WRITTEN +C ( CHARACTER, ANY LENGTH ) +C ---------------------------------------------------------------------- + CHARACTER*(*) VARNAM + INTEGER MAXMSG, NUMMSG + SAVE NUMMSG, MAXMSG + DATA NUMMSG / 0 /, MAXMSG / 50 / +C +C + WRTBADA = .TRUE. + NUMMSG = NUMMSG + 1 + WRITE ( *, '(3A)' ) ' **** INPUT VARIABLE ', VARNAM, + $ ' IN ERROR ****' + IF ( NUMMSG.EQ.MAXMSG ) + $ CALL ERRMSGA ( 'TOO MANY INPUT ERRORS. ABORTING...$', .TRUE. ) + RETURN + END + LOGICAL FUNCTION WRTDIMA ( DIMNAM, MINVAL ) +C +C WRITE NAME OF TOO-SMALL SYMBOLIC DIMENSION AND +C THE VALUE IT SHOULD BE INCREASED TO; RETURN 'TRUE' +C +C INPUT : DIMNAM = NAME OF SYMBOLIC DIMENSION WHICH IS TOO SMALL +C ( CHARACTER, ANY LENGTH ) +C MINVAL = VALUE TO WHICH THAT DIMENSION SHOULD BE +C INCREASED (AT LEAST) +C ---------------------------------------------------------------------- + CHARACTER*(*) DIMNAM + INTEGER MINVAL +C +C + WRITE ( *, '(3A,I7)' ) ' **** SYMBOLIC DIMENSION ', DIMNAM, + $ ' SHOULD BE INCREASED TO AT LEAST ', MINVAL + WRTDIMA = .TRUE. + RETURN + END + LOGICAL FUNCTION TSTBADA( VARNAM, RELERR ) +C +C WRITE NAME (-VARNAM-) OF VARIABLE FAILING SELF-TEST AND ITS +C PERCENT ERROR FROM THE CORRECT VALUE; RETURN 'FALSE'. +C + CHARACTER*(*) VARNAM + REAL RELERR +C +C + TSTBADA = .FALSE. + WRITE( *, '(/,3A,1P,E11.2,A)' ) + $ ' OUTPUT VARIABLE ', VARNAM,' DIFFERED BY', 100.*RELERR, + $ ' PER CENT FROM CORRECT VALUE. SELF-TEST FAILED.' + RETURN + END + SUBROUTINE ERRMSGA( MESSAG, FATAL ) +C +C PRINT OUT A WARNING OR ERROR MESSAGE; ABORT IF ERROR +C + LOGICAL FATAL, ONCE + CHARACTER*(*) MESSAG + INTEGER MAXMSG, NUMMSG + SAVE MAXMSG, NUMMSG, ONCE + DATA NUMMSG / 0 /, MAXMSG / 100 /, ONCE / .FALSE. / +C +C + IF ( FATAL ) THEN + WRITE ( *, '(2A)' ) ' ******* ERROR >>>>>> ', MESSAG + STOP + END IF +C + NUMMSG = NUMMSG + 1 + IF ( NUMMSG.GT.MAXMSG ) THEN + IF ( .NOT.ONCE ) WRITE ( *,99 ) + ONCE = .TRUE. + ELSE + WRITE ( *, '(2A)' ) ' ******* WARNING >>>>>> ', MESSAG + ENDIF +C + RETURN +C + 99 FORMAT( ///,' >>>>>> TOO MANY WARNING MESSAGES -- ', + $ 'THEY WILL NO LONGER BE PRINTED <<<<<<<', /// ) + END + + + diff --git a/tools/AeroTab/mixsub.f b/tools/AeroTab/mixsub.f new file mode 100644 index 0000000000..bbfe10264f --- /dev/null +++ b/tools/AeroTab/mixsub.f @@ -0,0 +1,71 @@ + subroutine mixsub (frr0, itot, faq, Mw, rhow, + $ i, vsk, vbck, vock, vombg, vbcbg, x, rh, kcomp, + $ xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Mixsub calculates hygroscopic properties (given by x) for an internal mixture +c of aerosol components with different hygroscopicity (x*). +c Internal mixture of two constituents in the background aerosol for kcomp = 4 +c and new kcomp = 1 (including SOA nucleation) is now taken into account. + + implicit none + + INTEGER itot, i, kcomp + REAL rhow, rhosl, ai, Mw, Ms, frh, frr0, x, xws, xss, xbc, xoc, + $ xs, xa, xm, rh, vsk(0:10000), vbck(0:10000), vock(0:10000), + $ xwaso, xdst, xbg, faq + REAL rhda, rhca, rhdss, rhcss + REAL vombg, vbcbg + +c Set the hygroscopicity of the background aerosol + if(kcomp.eq.1) then +c Sulfuric acid internally mixed with OM (as SOA) (using volume mixing approximation): + xbg=xs*(1-vombg)+xoc*vombg +ct xbg=xs ! this is the correct value for H2SO4 +ct xbg=xa ! this gives hygroscopicity for ammonium sulfate instead of H2SO4 (just for testing & plotting purposes) + elseif(kcomp.eq.2) then +c Hydrophobic BC: + xbg=xbc + elseif(kcomp.eq.3) then +c Organic Carbon: + xbg=xoc + elseif(kcomp.eq.4) then +c Organic Carbon: + xbg=xoc*(1-vbcbg)+xbc*vbcbg + elseif(kcomp.eq.5) then +c Sulfuric acid: + xbg=xs ! this is the correct value for H2SO4 +ct xbg=xa ! this gives hygroscopicity for ammonium sulfate instead of H2SO4 (just for testing & plotting purposes) + elseif(kcomp.eq.6.or.kcomp.eq.7) then +c Mineral dust: + xbg=xdst + elseif(kcomp.eq.8.or.kcomp.eq.9.or.kcomp.eq.10) then +c Sea-salt: + xbg=xss + endif + +c Hygroscopicity x for internally mixed aerosol is calculated by using the +c volume mixing assumprion, based on background aerosol, sulfate, soot and oc. +c note: internally mixed sulphate is here assumed to be ammoniumsulfate, +c except for mode 1-4, where all SO4 is H2SO4 instead. + if(kcomp.ge.1.and.kcomp.le.10) then + if(itot.eq.0) then + x=xbg + else ! internal mixture Prøv med coating-antakelser her! + x=(1.0-vsk(i)-vbck(i)-vock(i))*xbg + $ +vsk(i)*(faq*xa+(1.0-faq)*xs)+vbck(i)*xbc+vock(i)*xoc + endif +c only sulfate or soot: + else + write(*,*) 'kcomp = 1-10 only' + stop + endif + +c write(117,*), i, x, rh + + return + end + diff --git a/tools/AeroTab/modepar.f b/tools/AeroTab/modepar.f new file mode 100644 index 0000000000..9d920b304e --- /dev/null +++ b/tools/AeroTab/modepar.f @@ -0,0 +1,212 @@ +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + subroutine modepar(kcomp, ksol, imini, Nnat, rk, logsk, + $ rhosv, rhob, frombg, frbcbg, catot, catote, relh, + $ frac, frabc, fraq, alpha) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Prescribed dry lognormal number size distributions, accomodation coefficients +c alpha, and hygroscopic swelling index (ksol=1 implies call of subroutine rhsub) +c for the clean background and for externally mixed SO4, BC and OC. +c The index imini determines smallest radius used in the Mie calculations. +c We here also define the gridded concentrations of SO4+BC+OC for the tables, +c catot/catote, since this is different for each background mode kcomp, as well +c as the gridded values for relh, frac, frabc and fraq which are independent +c on background mode number. Unit for catot and catote is ug/m^3 (per particle/cm^3) + +c May 2016: +c Recalibrated cate and cate (in modepar.f) to allow for more/less maximum added +c mass on each background mode, due to large changes since the first AeroTab +c version, since there is now in general more added mass per background particle. +c The cat and cate arrays have also been changed so that their values (for varying +c icat and icate) can be calculated based on the min and max array values... + +c October 201: recalibrated cate for kcomp=2 due to ca. doubling in background size + + use commondefinitions + + implicit none + + INTEGER imini, kcomp, ksol, icat + REAL Nnat, rk, r0, rbcn, logsk, logs0, alpha + REAL rhobc, rhooc, rhosv, rhob + REAL catot(6), frac(6), frabc(6), fraq(6), relh(10) + REAL frombg(6), frbcbg(6) + REAL catote(16) + + Nnat=1.0 ! cm^(-3) normalized size distribution + + if(kcomp.ge.5) then ! dummy array (defined but not used) + catote=(/ 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, + $ 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10 /) + endif + if(kcomp.ge.1.and.kcomp.le.4) then ! dummy array (defined but not used) + catot=(/ 1e-10, 1e-10, 1e-10, 1e-10, 1e-10, 1e-10 /) + catot(1)=1.e-10 + endif + catote(1)=1.e-10 + catot(1)=1.e-10 + +c Median radius and log10(standard deviation) for the modes that are defined in CAM5-Oslo +c (for those that do not exist there, the values given below counts) + rk=originalNumberMedianRadius(kcomp)*1.e6 + logsk=log10(originalSigma(kcomp)) + if(kcomp.eq.1) then +c write(*,*) 'SO4(A/n), H2SO4 background for cond. of H2SO4 and SOA' + alpha=1.0 + ksol=1 + rhob=rhosv + imini=1 +co catote=(/ 1e-10, 1e-5, 2e-5, 4e-5, 8e-5, 1.5e-4, 3e-4, +co $ 6e-4, 1.2e-3, 2.5e-3, 5e-3, 1e-2, 2e-2, 4e-2, 8e-2, 0.15 /) + do icat=2,16 + catote(icat)=10**((icat-1)/3.0-6.222) + enddo + elseif(kcomp.eq.2) then +c write(*,*) 'BC(A/n), BC background for cond. of H2SO4' + alpha=0.3 + ksol=1 + rhob=aerosol_type_density(2) + imini=1 +co catote=(/ 1e-10, 1e-5, 2e-5, 4e-5, 8e-5, 1.5e-4, 3e-4, +co $ 6e-4, 1.2e-3, 2.5e-3, 5e-3, 1e-2, 2e-2, 4e-2, 8e-2, 0.15 /) + do icat=2,16 +co catote(icat)=10**((icat-1)/3.0-6.523) + catote(icat)=10**((icat-1)/3.0-6.222) + enddo + elseif(kcomp.eq.3) then ! this mode is not defined/used in CAM-Oslo +c write(*,*) 'OC(A/n), OC background for cond. of H2SO4' + alpha=0.7 + ksol=1 + rk=originalNumberMedianRadius(14)*1.e6 + logsk=log10(originalSigma(14)) + rhob=aerosol_type_density(3) + imini=1 +co catote=(/ 1e-10, 1e-4, 2e-4, 4e-4, 8e-4, 1.5e-3, 3e-3, +co $ 6e-3, 1.2e-2, 2.5e-2, 5e-2, 0.1, 2e-1, 0.4, 0.8, 1.5 /) + do icat=2,16 +c catote(icat)=10**((icat-1)/3.0-4.301) + catote(icat)=1.e-10 ! not used anyway + enddo + elseif(kcomp.eq.4) then +c write(*,*) 'OC&BC(A/n), OC&BC background for cond. of H2SO4,' +c write(*,*) 'assuming OC is the basis for added BC and SO4' + alpha=0.5 ! between 0.3 for BC and 0.7 for OC + ksol=1 + rhob=aerosol_type_density(3) + imini=1 +co catote=(/ 1e-10, 0.01, 0.05, 0.1, 0.2, 0.4, 0.7, 1.0, ! std +co $ 1.5, 2.5, 5., 10., 25., 50., 100., 500. /)*1.904e-3 ! std + do icat=2,16 + catote(icat)=10**((icat-1)/3.0-4.301) + enddo + elseif(kcomp.eq.5) then +c write(*,*) 'SO4("Ait75"), H2SO4 background for cond/coag/Aq.' + alpha=1.0 + ksol=1 + rhob=rhosv + imini=13 +co catot=(/ 1.e-10, 5.e-4, 2.e-3, 0.01, 0.04, 0.15 /) + do icat=2,6 + catot(icat)=10**((icat-1)/1.0-3.824) + enddo + elseif(kcomp.eq.6) then +c write(*,*) ' MINACC, from AEROCOM' + alpha=0.3 + ksol=1 + rhob=aerosol_type_density(4) + imini=18 +co catot=(/ 1.e-10, 0.01, 0.05, 0.2, 0.8, 4.0 /) + do icat=2,6 + catot(icat)=10**((icat-1)/1.0-3.523) + enddo + elseif(kcomp.eq.7) then +c write(*,*) ' MINCOA, from AEROCOM' + alpha=0.3 + ksol=1 + rhob=aerosol_type_density(4) + imini=20 +co catot=(/ 1.e-10, 0.02, 0.1, 0.5, 2.0, 8.0 /) + do icat=2,6 +c catot(icat)=10**((icat-1)/1.0-2.921) ! ble litt for stort -> ustabilt... + catot(icat)=10**((icat-1)/1.0-3.699) + enddo + elseif(kcomp.eq.8) then +c write(*,*) ' SSAIT, from AEROCOM' + alpha=1.0 + ksol=1 + rhob=aerosol_type_density(5) + imini=1 +co catot=(/ 1.e-10, 5.e-4, 2.e-3, 0.01, 0.04, 0.15 /) ! as for kcomp=5 + catot(1)=1.e-10 + do icat=2,6 + catot(icat)=10**((icat-1)/1.0-4.921) + enddo + elseif(kcomp.eq.9) then +c write(*,*) ' SSACC, from AEROCOM' + alpha=1.0 + ksol=1 + rhob=aerosol_type_density(5) + imini=15 +co catot=(/ 1.e-10, 0.01, 0.05, 0.2, 0.8, 4.0 /) ! as for kcomp=6 + do icat=2,6 + catot(icat)=10**((icat-1)/1.0-3.301) + enddo + elseif(kcomp.eq.10) then +c write(*,*) ' SSCOA, from AEROCOM' + alpha=1.0 + ksol=1 + rhob=aerosol_type_density(5) + imini=20 +co catot=(/ 1.e-10, 0.02, 0.1, 0.5, 2.0, 8.0 /) + do icat=2,6 +ct catot(icat)=2*10**((icat-1)/1.0-3.0) +c catot(icat)=10**((icat-1)/1.0-3.0) ! ble litt for stort -> ustabilt... + catot(icat)=10**((icat-1)/1.0-3.699) + enddo +c kcomp = 11, 12 and 14 are not used in CAM4-Oslo, just used for +c testing against kcomp = 1, 2 and 3 without condensate + elseif(kcomp.eq.0) then +c write(*,*) ' soot (BC), fractal a-mode' + alpha=0.3 + ksol=0 + rk=originalNumberMedianRadius(0)*1.e6 + logsk=log10(originalSigma(0)) + rhob=aerosol_type_density(2) ! dummy, rhobcax used instead + imini=1 + else + write(*,*) 'modes 0 through 10 only' + stop + endif + +c define grid for tabulated optical parameters and CCN: +c relative humidity, RH + relh =(/ 0.0, 0.37, 0.47, 0.65, 0.75, 0.80, + $ 0.85, 0.90, 0.95, 0.995 /) +c the mass fraction OC/(OC + H2SO4) for the background aerosol of kcomp=1 +co frombg=(/ 0.0, 0.1, 0.3, 0.5, 0.7, 0.999 /) + frombg=(/ 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) +c the mass fraction BC/(BC + OC) for the background aerosol of kcomp=4 +co frbcbg=(/ 0.0, 0.1, 0.3, 0.5, 0.7, 0.999 /) + frbcbg(1)=1.e-10 + do icat=2,6 + frbcbg(icat)=10**((icat-1)/4.0-1.25) + enddo +c the fraction (internally mixed BC+OC)/(internally mixed BC+OC+SO4) (from coag. and cond.) +co frac=(/ 0.0, 0.1, 0.3, 0.5, 0.7, 0.999 /) + frac=(/ 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) +c the fraction (internally mixed BC)/(internally mixed BC+OC) (from coag.) +co frabc=(/ 0.0, 0.01, 0.1, 0.3, 0.7, 0.999 /) + frabc(1)=1.e-10 + do icat=2,6 + frabc(icat)=10**((icat-1)/4.0-1.25) + enddo +c the fraction (internally mixed (NH4)2SO4 from cloud processing)/(all internally mixed +c H2SO4 and (NH4)2SO4 from cloud processing, coag. and cond.) +co fraq=(/ 0.0, 0.25, 0.50, 0.75, 0.85, 1.0 /) + fraq=(/ 0.0, 0.2, 0.4, 0.6, 0.8, 1.0 /) + + return + end diff --git a/tools/AeroTab/modetilp.f b/tools/AeroTab/modetilp.f new file mode 100644 index 0000000000..d3e7a55162 --- /dev/null +++ b/tools/AeroTab/modetilp.f @@ -0,0 +1,375 @@ + subroutine modetilp(pi,imax,d,r,dndlrkny,dndlrk, + $ cat,fac,fabc,faq,kcomp) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c This subroutine produces look-up tables of modal parameters for +c lognormal size distrubutions with best fit to the modified size +c distributions from the code in conteq.f. + +cc 3/9-2013: Even if it is optimized w.r.t. conserving aerosol volume, the +c number is much better conserved (very well) than volume (not so well). +c Even for no added internally mixed aerosol from condensation etc. +c (ictot or icatot=1), estimated volume for adapted log-normal size +c distribution is about 6% larger than the volume before lognormal +c adaptation. This should be unnecessary. To begin improving the code, +c allow for better resolution in the r and σ grid! +cc +cc 28/7-2014: Increased resolution (dres=sres=1.e4 instead of 1.e3) has +c been tested for some modes and some added concentrations), only +c giving much improved solutions for near zero added condensate/ +c coagulate onto the background aerosols. The original resolution has +c therefore been kept as it was. However, the linearly interpolated +c dndklrny below (nlin) has now been changed with an exponentially +c interpolated function for radii<19um, which improves the solutions +c significantly! For ictot or icatot=1, the estimated volume for the +c adapted log-normal size distribution is now only 1% smaller to 1% +c larger than the volume before lognormal adaptation. +cc +cc 19/8-2014: After finding rks and logsks from the method above, we seek +c a new logsks that no longer fulfills least square method requirements +c (minimum ss), but which preserves volume (since number is already well +c conserved and does not change with logsks). This means that the CAM5- +c Oslo code can be simplified (Massratio=1, no need to be calculated). +cc +cc 28/8-2014: This code is not very robust: small changes may ause the code +c to stop working for some cases. Presently the code crashes for kcomp=8 +c when trying to find the fine solution. The coarse solution method works, +c and has been used in this last version, but only for kcomp=8. +cc +c Note that the dry lognormal fitted size parameters do not depend +c on the mass fraction fombc for kcomp=1, nor fbcbg for kcomp=4. + + implicit none + + INTEGER i, ir, ilog, imax, j, jmin, jmax, jstep, kcomp + INTEGER irmin, irmax, ilogmin, ilogmax, ilog1, ilog2 + REAL r(0:100), dndlrkny(0:100), dndlrktilp(0:100) + REAL rlin(20000), nlin(20000), nlintilp(20000) + REAL pi, d, nk, rk, rks, logsk, logsks, s, ss, + $ a, b, eps, nmin, nsum, nsummod, nsumtilp, + $ vsum, vsummod, vsumtilp, fact, logsksold + REAL cat, fac, fabc, faq + REAL dres, invdres, sres, invsres + REAL const, deltan, deltav, deltavnew + INTEGER j1nm, j19um, j20um, istep, isteps, jsteps + REAL dndlrk(0:100), nsumorig + +c Due to coarse resolution for large radii it is necessary to +c evaluate interpolated dndlrk and dndlrktilp for linear r-grid: +c (to avoid that small sizes get weighted more than larger sizes) +c Note: j=1 and 20000 corresponds to 0.001 and 20 um radius for +c dres=1.0e3. For testing with higher resolution solutions, using +c dres=sres=1.0e4 arrays sizes for rlin, nlin and nlintilp must +c be increased accordingly). A key formula for understanding the +c code below is: +c r(i)=10**(d(i-1)-3), where i=1,1+int(4.3/d), see constsize.f. + dres=1.e3 ! r resolution (number of values within 1 um: only 1.e3 well tested) + invdres=1.0/dres ! width of each radius bin (dr) + j20um=int(20*dres) + j19um=int(19*dres) + j1nm=int(0.001*dres) +c write(*,*) 'j1nm =', j1nm + do j=j1nm,j19um + rlin(j)=invdres*j + i=1+int((3+log10(1.0*j)+log10(invdres))/d) + a=(log(dndlrkny(i+1))-log(dndlrkny(i)))/(r(i+1)-r(i)) + b=(r(i+1)*log(dndlrkny(i))-r(i) + $ *log(dndlrkny(i+1)))/(r(i+1)-r(i)) + nlin(j)=exp(a*rlin(j)+b) ! exponentially interpolated dndklrny +c write(888,*) i, r(i) +c write(887,*) j,i,a,b,nlin(j) +c write(*,*) rlin(j),nlin(j) +c write(889,*) rlin(j),nlin(j) + enddo + do j=j19um+1,j20um + rlin(j)=invdres*j + i=1+int((3+log10(1.0*j)+log10(invdres))/d) + a=(dndlrkny(i+1)-dndlrkny(i))/(r(i+1)-r(i)) + b=dndlrkny(i)-a*r(i) + nlin(j)=a*rlin(j)+b ! linearly interpolated dndklrny +c write(888,*) i, r(i) +c write(887,*) j,i,a,b,nlin(j) +c write(*,*) rlin(j),nlin(j) +c write(889,*) rlin(j),nlin(j) + enddo + +c Narrow down the search area for adapted modal radii (rks) +c Find smallest rlin (rmin=r(jmin)) for which nlin*r**2>1.e-10? +c eps=1.e-4 + eps=1.e-10 + nmin=1.e-10 ! initialverdi + j=0 + do while (nmin*rlin(j)**2.lt.eps.and.j.lt.j20um) + j=j+1 + jmin=j + nmin=nlin(j) + enddo +c write(*,*) 'rmin, nlinmin =', rlin(jmin), nlin(jmin)*rlin(jmin)**2 +c Find largest rlin (rmin=r(jmax)) for which nlin*r**2>1.e-4? + eps=1.e-4 ! 1.e-8 gir problemer (krasj) + nmin=1.e-10 ! initialverdi + j=j20um +c do while (nmin.lt.eps.and.j.gt.1) + do while (nmin*rlin(j)**2.lt.eps.and.j.gt.j1nm) + j=j-1 + jmax=j + nmin=nlin(j) + enddo +c write(*,*) 'rmax, nlinmax =', rlin(jmax), nlin(jmax)*rlin(jmax)**2 + +c Calculate best lognormal fitted dndlrkny, dndlrktilp: + +c Calculate rks, logsk and deviation ss for first estimate (coarse r and logs resolution) + sres=1.e3 ! sigma resolution (number of values within 0-1: only 1.e3 well tested) + invsres=1.0/sres ! width of each sigma bin + istep=4 ! step value for i (istep>1 for saving some CPU time) + ss=1.e6 ! arbitrary large (enough) number + ilog1=int(0.04*sres) ! ilog for assumed low limit sigma + ilog2=int(0.4*sres) ! ilog for assumed high limit sigma +c if(kcomp.eq.8) then +c ilog1=1 ! this fine SS mode may get very sharp due to large growth +c ilog1=int(0.001*sres) ! this fine SS mode may get very sharp due to large growth +c ilog2=int(0.6*sres) ! this fine SS mode may get very wide due to cloud processing +c endif +c logs-loop + do ilog=ilog1,ilog2,istep + logsk=invsres*ilog +c r-loop + do ir=jmin,jmax + rk=rlin(ir) + jstep=int(0.05*dres*rk)+1 ! larger step values for large radii to save CPU time + s=0.0 + do j=jmin,jmax,jstep + nk=(1.0/logsk)*exp(-0.5*(log10(rlin(j)/rk)/logsk)**2) + nlintilp(j)=nk/sqrt(2*pi) ! log-normal distribution +c s=s+rlin(j)**4*(nlintilp(j)-nlin(j))**2 ! least squares method + s=s+rlin(j)**2*abs(nlintilp(j)-nlin(j)) ! deviation w.r.t volume: r**2 due to linear r-axis and dN/dlogr=log10(e)*r*dN/dr + enddo + if(s.lt.ss) then + ss=s + rks=rk + logsks=logsk +c write(*,*) 'rks, logsks, ss =', rks, logsks, ss + isteps=istep + jsteps=jstep + endif + enddo + enddo +c write(*,*) 'rks1, logsks1 =', rks, logsks +c terminate if outside (on the edge of) interval + if(rks.le.1e-2.or.rks.ge.19e-0) then + write(*,*) 'Error: rks.le.1e-2.or.rks.ge.19e-0' + stop + endif + if(logsks.le.ilog1*invsres.or.logsks.ge.ilog2*invsres) then + write(*,*) 'Error: logsks outside interval -> modify the code!' + write(*,*) '(e.g. by increasing the [logmin,logmax]) range)' + write(*,*) 'logmin,logsks,logmax =', + $ ilog1*invsres,logsks,ilog2*invsres + stop + endif + +c Range of rk and logsk (*0.5 to *2) for finer resolution solution +c irmin=max(jmin,int(500*rks)) +c irmax=min(jmax,int(2000*rks)) +c ilogmin=max(ilog1,int(500*logsks)) +c ilogmax=min(ilog2,int(2000*logsks)) +c Range of rk and logsk) for finer resolution solution + irmin=max(jmin,int(dres*rks)-5*jsteps) + irmax=min(jmax,int(dres*rks)+5*jsteps) + ilogmin=max(ilog1,int(sres*logsks)-10*isteps) + ilogmax=min(ilog2,int(sres*logsks)+10*isteps) + if(kcomp.eq.4.or.kcomp.eq.8) then ! special treatment for these fine modes + irmin=1 + ilogmin=ilog1 + ilogmax=ilog2 + endif +ctest +c if(kcomp.eq.8) then ! special treatment for the fine SS mode +c irmin=j1nm +c irmax=j20um +c ilog1=int(0.01*sres) ! ilog for assumed low limit sigma +c ilog2=int(0.5*sres) ! ilog for assumed high limit sigma +c ilogmin=ilog1 +c ilogmax=ilog2 +c endif +ctest +c write(*,*) 'rmin, rmax =', irmin*invdres, irmax*invdres +c write(*,*) 'logmin, logmax =', ilogmin*invsres, ilogmax*invsres + +c Calculate rks, logsk and deviation for final estimate + ss=1.e6 +c logs-loop + do ilog=ilogmin,ilogmax + logsk=invsres*ilog +c r-loop + do ir=irmin,irmax + rk=rlin(ir) + jstep=int(0.01*dres*rk)+1 ! larger step values for large radii to save CPU time +c jstep=1 ! testet for kcomp=2: gir samme svar for alle pÃ¥legg + s=0.0 + do j=jmin,jmax,jstep + nk=(1.0/logsk)*exp(-0.5*(log10(rlin(j)/rk)/logsk)**2) + nlintilp(j)=nk/sqrt(2*pi) ! log-normal distribution +c s=s+rlin(j)**4*(nlintilp(j)-nlin(j))**2 ! least squares method + s=s+rlin(j)**2*abs(nlintilp(j)-nlin(j)) ! deviation w.r.t volume: r**2 due to linear r-axis and dN/dlogr=log10(e)*r*dN/dr + enddo + if(s.lt.ss) then + ss=s + rks=rk + logsks=logsk +c write(*,*) 'rks, logsks, ss =', rks, logsks, ss + isteps=istep + jsteps=jstep + endif + enddo + enddo +cjfr+ beregner ogsÃ¥ ss for initialverdiene for rks og logsks: +c rks=0.0118 +c logsks=0.2553 +c s=0.0 +c do j=jmin,jmax +c nk=(1.0/logsks)*exp(-0.5*(log10(rlin(j)/rks)/logsks)**2) +c nlintilp(j)=nk/sqrt(2*pi) ! log-normal distribution +cc s=s+rlin(j)**4*(nlintilp(j)-nlin(j))**2 ! least squares method +c s=s+rlin(j)**2*abs(nlintilp(j)-nlin(j)) ! deviation w.r.t volume: r**2 due to linear r-axis and dN/dlogr=log(e)*r*dN/dr +c enddo +c write(*,*) 'jfr. rks, logsks, ss =', rks, logsks, s +cjfr- +c write(*,*) 'rks, logsks, ss =', rks, logsks, ss + +c terminate if outside (on the edge of) interval + if(rks.le.irmin*invdres.or.rks.ge.irmax*invdres) then + write(*,*) 'Error: rks outside interval -> modify the code!' + write(*,*) '(e.g. by increasing the [rmin,rmax] range)' + write(*,*) 'rmin, rks, rmax =',irmin*invdres, rks,irmax*invdres + stop + endif + if(logsks.le.ilogmin*invsres.or.logsks.ge.ilogmax*invsres) then + write(*,*) 'Error: logsks outside interval -> modify the code!' + write(*,*) '(e.g. by increasing the [logmin,logmax]) range)' + write(*,*) 'logmin,logsks,logmax =', + $ ilogmin*invsres,logsks,ilogmax*invsres + stop + endif + +c when logsks and rks are found, calculate fitted log-normal distribution +c and testing normality (integrated number = 1)************************** +c nsum=0.0 + 123 do i=j1nm,j20um + nk=(1.0/logsks)*exp(-0.5*(log10(rlin(i)/rks)/logsks)**2) + nlintilp(i)=nk/sqrt(2*pi) +c write(890,*) rlin(i), max(1.e-50,nlintilp(i)) +c nsum=nsum+nlintilp(i)/rlin(i) +c nsum=nsum+nlintilp(i)*rlin(i)**2 + enddo +c write(*,*) 'rks, logsks, ss, nsum =', rks, logsks, ss, nsum +c write(*,*) 'kcomp, rks, logsks =', kcomp, rks, logsks + nsum=0.0 + vsum=0.0 + do i=1,imax + nk=dndlrkny(i) + vsum=vsum+nk*r(i)**3 ! volum + nsum=nsum+nk + enddo + nsummod=0.1*nsum + vsummod=0.1*vsum +c+ alternative estimate (gives somewhat larger deviations nsumtilp/nsummod-1) +c vsum=0.0 +c do j=j1nm,j20um +c vsum=vsum+nlin(j)*rlin(j)**3 ! w.r.t. volume (r**3 due to logarithmic r axis again) +c enddo +c vsummod=(invdres/d)*vsum +c- +c write(*,*) 'vsummod =', 0.1*vsum + nsum=0.0 + vsum=0.0 + do i=1,imax + nk=(1.0/logsks)*exp(-0.5*(log10(r(i)/rks)/logsks)**2)/sqrt(2*pi) + vsum=vsum+nk*r(i)**3 ! w.r.t. volume (r**3 due to logarithmic r axis again) + nsum=nsum+nk + enddo + nsumtilp=d*nsum + vsumtilp=d*vsum +c write(*,*) 'nsumtilp =', nsumtilp +c write(*,*) 'nsumtilp/nsummod =', nsumtilp/nsummod +c write(*,*) 'vsumtilp/vsummod =', vsumtilp/vsummod +c write(*,*) 'rks, logsks =', rks, logsks + logsksold=logsks +cc****************************************************************************** +c Recalculating logsks by assuming conserved volume and no change in rks: +c const=2.0/(3.0*(log(10.0))**2) +c logsks=sqrt(logsks**2-const*log(vsumtilp/vsummod)) ! overkompanserer: feil formel!? + +c Finding new logsks that no longer fulfills least square method requirements +c (minimum ss) but which preserves volume (since number is already well conserved +c and does not change with logsks) + deltav=vsumtilp/vsummod-1.0 + if(deltav.lt.0.0) then + fact=1.001 + else + fact=0.999 + endif + deltavnew=deltav + do while (deltavnew/deltav.gt.0.0) + logsks=logsks*fact +c write(*,*) 'rks, logsksny=', rks, logsks + + nsum=0.0 + vsum=0.0 + do i=1,imax + nk=(1.0/logsks)*exp(-0.5*(log10(r(i)/rks)/logsks)**2)/sqrt(2*pi) + vsum=vsum+nk*r(i)**3 ! w.r.t. volume (r**3 due to logarithmic r axis again) + nsum=nsum+nk + enddo + nsumtilp=d*nsum + vsumtilp=d*vsum + deltavnew=vsumtilp/vsummod-1.0 + enddo +c write(*,*) 'nsumtilp =', nsumtilp +c write(*,*) 'nsumtilp/nsummod mod=', nsumtilp/nsummod +c write(*,*) 'vsumtilp/vsummod mod=', vsumtilp/vsummod +c write(*,*) 'rks, logsksny=', rks, logsks +c write(900,*) kcomp, rks, logsksold, logsks, nsumtilp/nsummod, +c $ vsumtilp/vsummod +Ct Compared to original size distribution + nsum=0.0 + do i=1,imax + nk=dndlrk(i) + nsum=nsum+nk + enddo + nsumorig=d*nsum +c write(*,*) 'nsumtilp/nsumorig =', nsumtilp/nsumorig +c write(*,*) 'nsumtilp/nsummod =', nsumtilp/nsummod +c write(*,*) 'vsumtilp/vsummod =', vsumtilp/vsummod +c write(901,*) cat, fac, fabc, faq, nsumtilp/nsumorig, +c $ nsumtilp/nsummod, vsumtilp/vsummod +Ct +cc****************************************************************************** + +c +c Here comes the logntilp*.out look-up tables: +c + if(kcomp.ge.1.and.kcomp.le.3) then + write(9003,150) kcomp, cat, fac, rks, logsks + elseif(kcomp.eq.4) then + write(9003,200) kcomp, cat, fac, faq, rks, logsks + elseif(kcomp.ge.5.and.kcomp.le.10) then + write(9003,300) kcomp, cat, fac, fabc, faq, rks, logsks + write(*,300) kcomp, cat, fac, fabc, faq, rks, logsks + else + write(*,*) 'Only calculations for modes 1-10 are necessary' + stop + endif + + 100 format(I3,3(x,e12.5)) + 150 format(I3,4(x,e12.5)) + 200 format(I3,5(x,e12.5)) + 300 format(I3,6(x,e12.5)) + + return + end + diff --git a/tools/AeroTab/openfiles.f b/tools/AeroTab/openfiles.f new file mode 100644 index 0000000000..450930670b --- /dev/null +++ b/tools/AeroTab/openfiles.f @@ -0,0 +1,263 @@ + subroutine openfiles(kcomp,iopt,ib) + +c ********************************************************************************** +c Opening files for use as input to NorESM (only for kcomp=0-10). nkcomp*.out +c (full modified size distributions) are presently not used in NorESM. +c +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + + integer kcomp, iopt, ib + + if(iopt.eq.1) then + + if(ib.eq.31) then ! SW aerocom optics only + if(kcomp.eq.1) then + call system('mv aerocomk1.out aerocomk1_old.out') + open(9500, file='aerocomk1.out') + elseif(kcomp.eq.2) then + call system('mv aerocomk2.out aerocomk2_old.out') + open(9500, file='aerocomk2.out') + elseif(kcomp.eq.3) then + call system('mv aerocomk3.out aerocomk3_old.out') + open(9500, file='aerocomk3.out') + elseif(kcomp.eq.4) then + call system('mv aerocomk4.out aerocomk4_old.out') + open(9500, file='aerocomk4.out') + elseif(kcomp.eq.5) then + call system('mv aerocomk5.out aerocomk5_old.out') + open(9500, file='aerocomk5.out') + elseif(kcomp.eq.6) then + call system('mv aerocomk6.out aerocomk6_old.out') + open(9500, file='aerocomk6.out') + elseif(kcomp.eq.7) then + call system('mv aerocomk7.out aerocomk7_old.out') + open(9500, file='aerocomk7.out') + elseif(kcomp.eq.8) then + call system('mv aerocomk8.out aerocomk8_old.out') + open(9500, file='aerocomk8.out') + elseif(kcomp.eq.9) then + call system('mv aerocomk9.out aerocomk9_old.out') + open(9500, file='aerocomk9.out') + elseif(kcomp.eq.10) then + call system('mv aerocomk10.out aerocomk10_old.out') + open(9500, file='aerocomk10.out') + elseif(kcomp.eq.0) then + call system('mv aerocomk0.out aerocomk0_old.out') + open(9500, file='aerocomk0.out') + endif + if(kcomp.eq.1) then + call system('mv aerodryk1.out aerodryk1_old.out') + open(9600, file='aerodryk1.out') + elseif(kcomp.eq.2) then + call system('mv aerodryk2.out aerodryk2_old.out') + open(9600, file='aerodryk2.out') + elseif(kcomp.eq.3) then + call system('mv aerodryk3.out aerodryk3_old.out') + open(9600, file='aerodryk3.out') + elseif(kcomp.eq.4) then + call system('mv aerodryk4.out aerodryk4_old.out') + open(9600, file='aerodryk4.out') + elseif(kcomp.eq.5) then + call system('mv aerodryk5.out aerodryk5_old.out') + open(9600, file='aerodryk5.out') + elseif(kcomp.eq.6) then + call system('mv aerodryk6.out aerodryk6_old.out') + open(9600, file='aerodryk6.out') + elseif(kcomp.eq.7) then + call system('mv aerodryk7.out aerodryk7_old.out') + open(9600, file='aerodryk7.out') + elseif(kcomp.eq.8) then + call system('mv aerodryk8.out aerodryk8_old.out') + open(9600, file='aerodryk8.out') + elseif(kcomp.eq.9) then + call system('mv aerodryk9.out aerodryk9_old.out') + open(9600, file='aerodryk9.out') + elseif(kcomp.eq.10) then + call system('mv aerodryk10.out aerodryk10_old.out') + open(9600, file='aerodryk10.out') + elseif(kcomp.eq.0) then + call system('mv aerodryk0.out aerodryk0_old.out') + open(9600, file='aerodryk0.out') + endif + endif ! ib=31 + + if(ib.ne.19) then ! SW CAM optics only + if(kcomp.eq.1) then + call system('mv kcomp1.out kcomp1_old.out') + open(9000, file='kcomp1.out') + elseif(kcomp.eq.2) then + call system('mv kcomp2.out kcomp2_old.out') + open(9000, file='kcomp2.out') + elseif(kcomp.eq.3) then + call system('mv kcomp3.out kcomp3_old.out') + open(9000, file='kcomp3.out') + elseif(kcomp.eq.4) then + call system('mv kcomp4.out kcomp4_old.out') + open(9000, file='kcomp4.out') + elseif(kcomp.eq.5) then + call system('mv kcomp5.out kcomp5_old.out') + open(9000, file='kcomp5.out') + elseif(kcomp.eq.6) then + call system('mv kcomp6.out kcomp6_old.out') + open(9000, file='kcomp6.out') + elseif(kcomp.eq.7) then + call system('mv kcomp7.out kcomp7_old.out') + open(9000, file='kcomp7.out') + elseif(kcomp.eq.8) then + call system('mv kcomp8.out kcomp8_old.out') + open(9000, file='kcomp8.out') + elseif(kcomp.eq.9) then + call system('mv kcomp9.out kcomp9_old.out') + open(9000, file='kcomp9.out') + elseif(kcomp.eq.10) then + call system('mv kcomp10.out kcomp10_old.out') + open(9000, file='kcomp10.out') + elseif(kcomp.eq.0) then + call system('mv kcomp0.out kcomp0_old.out') + open(9000, file='kcomp0.out') + endif + endif + + if(kcomp.eq.1) then + call system('mv nkcomp1.out nkcomp1_old.out') + open(9001, file='nkcomp1.out') + elseif(kcomp.eq.2) then + call system('mv nkcomp2.out nkcomp2_old.out') + open(9001, file='nkcomp2.out') + elseif(kcomp.eq.3) then + call system('mv nkcomp3.out nkcomp3_old.out') + open(9001, file='nkcomp3.out') + elseif(kcomp.eq.4) then + call system('mv nkcomp4.out nkcomp4_old.out') + open(9001, file='nkcomp4.out') + elseif(kcomp.eq.5) then + call system('mv nkcomp5.out nkcomp5_old.out') + open(9001, file='nkcomp5.out') + elseif(kcomp.eq.6) then + call system('mv nkcomp6.out nkcomp6_old.out') + open(9001, file='nkcomp6.out') + elseif(kcomp.eq.7) then + call system('mv nkcomp7.out nkcomp7_old.out') + open(9001, file='nkcomp7.out') + elseif(kcomp.eq.8) then + call system('mv nkcomp8.out nkcomp8_old.out') + open(9001, file='nkcomp8.out') + elseif(kcomp.eq.9) then + call system('mv nkcomp9.out nkcomp9_old.out') + open(9001, file='nkcomp9.out') + elseif(kcomp.eq.10) then + call system('mv nkcomp10.out nkcomp10_old.out') + open(9001, file='nkcomp10.out') + elseif(kcomp.eq.0) then + call system('mv nkcomp0.out nkcomp0_old.out') + open(9001, file='nkcomp0.out') + endif + + if(ib.eq.19) then ! LW optics only + if(kcomp.eq.1) then + call system('mv lwkcomp1.out lwkcomp1_old.out') + open(9009, file='lwkcomp1.out') + elseif(kcomp.eq.2) then + call system('mv lwkcomp2.out lwkcomp2_old.out') + open(9009, file='lwkcomp2.out') + elseif(kcomp.eq.3) then + call system('mv lwkcomp3.out lwkcomp3_old.out') + open(9009, file='lwkcomp3.out') + elseif(kcomp.eq.4) then + call system('mv lwkcomp4.out lwkcomp4_old.out') + open(9009, file='lwkcomp4.out') + elseif(kcomp.eq.5) then + call system('mv lwkcomp5.out lwkcomp5_old.out') + open(9009, file='lwkcomp5.out') + elseif(kcomp.eq.6) then + call system('mv lwkcomp6.out lwkcomp6_old.out') + open(9009, file='lwkcomp6.out') + elseif(kcomp.eq.7) then + call system('mv lwkcomp7.out lwkcomp7_old.out') + open(9009, file='lwkcomp7.out') + elseif(kcomp.eq.8) then + call system('mv lwkcomp8.out lwkcomp8_old.out') + open(9009, file='lwkcomp8.out') + elseif(kcomp.eq.9) then + call system('mv lwkcomp9.out lwkcomp9_old.out') + open(9009, file='lwkcomp9.out') + elseif(kcomp.eq.10) then + call system('mv lwkcomp10.out lwkcomp10_old.out') + open(9009, file='lwkcomp10.out') + elseif(kcomp.eq.0) then + call system('mv lwkcomp0.out lwkcomp0_old.out') + open(9009, file='lwkcomp0.out') + endif + endif ! ib=19 + + else ! iopt=0 + + if(kcomp.eq.1) then + call system('mv nkcomp1.out nkcomp1_old.out') + open(9001, file='nkcomp1.out') + elseif(kcomp.eq.2) then + call system('mv nkcomp2.out nkcomp2_old.out') + open(9001, file='nkcomp2.out') + elseif(kcomp.eq.3) then + call system('mv nkcomp3.out nkcomp3_old.out') + open(9001, file='nkcomp3.out') + elseif(kcomp.eq.4) then + call system('mv nkcomp4.out nkcomp4_old.out') + open(9001, file='nkcomp4.out') + elseif(kcomp.eq.5) then + call system('mv nkcomp5.out nkcomp5_old.out') + open(9001, file='nkcomp5.out') + elseif(kcomp.eq.6) then + call system('mv nkcomp6.out nkcomp6_old.out') + open(9001, file='nkcomp6.out') + elseif(kcomp.eq.7) then + call system('mv nkcomp7.out nkcomp7_old.out') + open(9001, file='nkcomp7.out') + elseif(kcomp.eq.8) then + call system('mv nkcomp8.out nkcomp8_old.out') + open(9001, file='nkcomp8.out') + elseif(kcomp.eq.9) then + call system('mv nkcomp9.out nkcomp9_old.out') + open(9001, file='nkcomp9.out') + elseif(kcomp.eq.10) then + call system('mv nkcomp10.out nkcomp10_old.out') + open(9001, file='nkcomp10.out') + endif + + if(kcomp.eq.1) then + call system('mv logntilp1.out logntilp1_old.out') + open(9003, file='logntilp1.out') + elseif(kcomp.eq.2) then + call system('mv logntilp2.out logntilp2_old.out') + open(9003, file='logntilp2.out') + elseif(kcomp.eq.3) then + call system('mv logntilp3.out logntilp3_old.out') + open(9003, file='logntilp3.out') + elseif(kcomp.eq.4) then + call system('mv logntilp4.out logntilp4_old.out') + open(9003, file='logntilp4.out') + elseif(kcomp.eq.5) then + call system('mv logntilp5.out logntilp5_old.out') + open(9003, file='logntilp5.out') + elseif(kcomp.eq.6) then + call system('mv logntilp6.out logntilp6_old.out') + open(9003, file='logntilp6.out') + elseif(kcomp.eq.7) then + call system('mv logntilp7.out logntilp7_old.out') + open(9003, file='logntilp7.out') + elseif(kcomp.eq.8) then + call system('mv logntilp8.out logntilp8_old.out') + open(9003, file='logntilp8.out') + elseif(kcomp.eq.9) then + call system('mv logntilp9.out logntilp9_old.out') + open(9003, file='logntilp9.out') + elseif(kcomp.eq.10) then + call system('mv logntilp10.out logntilp10_old.out') + open(9003, file='logntilp10.out') + endif + + endif ! iopt + + return + end diff --git a/tools/AeroTab/refind.f b/tools/AeroTab/refind.f new file mode 100644 index 0000000000..958cab3b91 --- /dev/null +++ b/tools/AeroTab/refind.f @@ -0,0 +1,111 @@ + + subroutine refind (lambda, i, ib, iband, cref, crin, kcomp, +csoa $ vbcsol, vocsol, vssol, vasol, vw, fki, r, rbcn, fracdim) + $ vbcsol, vocsol, vssol, vasol, vw, vombg, vbcbg, + $ fki, r, rbcn, fracdim) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Wavelength dependent complex rafractive indices (crin) for +c internal mixing is computed according to the volume mixing +c approximation for relatively nonabsorbing components (sulfate +c oc, sea-salt, dust and water), and Maxwell Garnetts mixing rule +c between the soot/BC and other components. + + implicit none + + integer i, ib, iband, j, kcomp + real lambda, vbcsol(0:100), vocsol(0:100), vssol(0:100), + $ vasol(0:100), vw(0:100), vbc12(0:100), vbcmix(0:100), + $ fki(-1:100), r(0:101), fracdim(0:100), rbcn + complex cref(5,31), crin, crin0, crin2, crina +csoa + real vombg, vbcbg + complex crefbg +c +c Take into account that the bacground aerosol (1) can be an internal mixture of two constituents: + if(kcomp.eq.1) then + crefbg=cref(1,iband)*(1-vombg)+cref(5,iband)*vombg ! H2SO4 and OM (as SOA) internally mixed +csoa elseif(kcomp.eq.4) then +csoa crefbg=cref(1,iband) ! NB! hadde glemt Ã¥ ta hensyn til BC-delen her!!! +c crefbg=cref(1,iband)*(1-vbcbg)+cref(3,iband)*vbcbg ! mÃ¥ dele opp annerledes nÃ¥r BC er i bakgr., se under + else + crefbg=cref(1,iband) + endif +csoa + if(kcomp.ge.1.and.kcomp.le.10) then ! BC in background should also be treated with MG! +c Internal mixture of sulfate, soot/bc, oc and water with the background +c component (SO4, OC, BC, mineral or seasalt), where (tabrefind.f): +c 1=background, 2=sulfate, 3=BC, 4=water, 5=OC + if(kcomp.eq.2) then ! Aitken mode BC background + crin0=(vssol(i)*cref(2,iband)+vocsol(i)*cref(5,iband) ! All internally mixed constituents except BC: + $ +vw(i)*cref(4,iband)) ! using the + $ /(vssol(i)+vocsol(i)+vw(i)) ! volume mixing rule. +csoa crina=cref(1,iband) ! BC in the background. + crina=crefbg ! (only) BC in the background + crin2=crin0*crin0*(crina*crina+2*crin0*crin0 ! All internally mixed constituents: + $ +2*vasol(i)*(crina*crina-crin0*crin0)) ! using the + $ /(crina*crina+2*crin0*crin0-vasol(i) ! Maxwell Garnett + $ *(crina*crina-crin0*crin0)) ! mixing rule. +csoa + elseif(kcomp.eq.4) then ! Aitken mode OM&BC background + crin0=(vssol(i)*cref(2,iband)+vocsol(i)*cref(5,iband) ! All internally mixed constituents except BC: + $ +vasol(i)*(1.0-vbcbg)*cref(5,iband) ! (non-BC background contribution) + $ +vw(i)*cref(4,iband)) ! using the + $ /(vssol(i)+vocsol(i)+vasol(i)*(1.0-vbcbg)+vw(i)) ! volume mixing rule. + crina=cref(3,iband) ! BC (only in the background) + crin2=crin0*crin0*(crina*crina+2*crin0*crin0 ! All internally mixed constituents: + $ +2*vasol(i)*vbcbg*(crina*crina-crin0*crin0)) ! using the + $ /(crina*crina+2*crin0*crin0-vasol(i)*vbcbg ! Maxwell Garnett + $ *(crina*crina-crin0*crin0)) ! mixing rule. +csoa + else ! non-BC background constituents + crin0=(vssol(i)*cref(2,iband)+vocsol(i)*cref(5,iband) ! All internally mixed constituents except BC: +csoa $ +vasol(i)*cref(1,iband)+vw(i)*cref(4,iband)) ! using the + $ +vasol(i)*crefbg+vw(i)*cref(4,iband)) ! using the + $ /(vssol(i)+vocsol(i)+vasol(i)+vw(i)) ! volume mixing rule. + crina=cref(3,iband) ! Added BC (not BC in the background). + crin2=crin0*crin0*(crina*crina+2*crin0*crin0 ! All internally mixed constituents: + $ +2*vbcsol(i)*(crina*crina-crin0*crin0)) ! using the + $ /(crina*crina+2*crin0*crin0-vbcsol(i) ! Maxwell Garnett + $ *(crina*crina-crin0*crin0)) ! mixing rule. + endif + crin=csqrt(crin2) +ctest testing volume mixing for kcomp=4: +c if(kcomp.eq.4) then +c crin = (vssol(i)*cref(2,iband)+vocsol(i)*cref(5,iband) +c $ + vasol(i)*(1.0-vbcbg)*cref(5,iband) +c $ + vasol(i)*vbcbg*cref(3,iband) +c $ + vw(i)*cref(4,iband)) +c $ /(vssol(i)+vocsol(i)+vasol(i)+vw(i)) +c endif +ctest +c if(lambda.eq.0.5) then +c write(36,*) r(i), real(crin0) +c write(37,*) r(i), aimag(crin0) +c write(38,*) r(i), real(crin) +c write(39,*) r(i), aimag(crin) +c endif + elseif(kcomp.eq.0) then +c Internal mixture of soot and air within the fractal a-mode soot/BC + if(r(i).le.rbcn) then + vbcmix(i)=1.0 + else + vbcmix(i)=(rbcn/r(i))**(3.0-fracdim(i)) + endif + crina=cref(3,iband) + crin0=(1,0) + crin2=crin0*crin0*(crina*crina+2*crin0*crin0 + $ +2*vbcmix(i)*(crina*crina-crin0*crin0)) + $ /(crina*crina+2*crin0*crin0-vbcmix(i) + $ *(crina*crina-crin0*crin0)) + crin=csqrt(crin2) +cvol crin=vbcmix(i)*crina+(1.0-vbcmix(i))*crin0 ! volume mixing + endif + + + return + end + diff --git a/tools/AeroTab/rhsub.f b/tools/AeroTab/rhsub.f new file mode 100644 index 0000000000..241d8bc9e3 --- /dev/null +++ b/tools/AeroTab/rhsub.f @@ -0,0 +1,204 @@ + + subroutine rhsub (imax, rh, d, r, rp, dndlrkny, vsi, vbci, voci, + $ fombg, fbcbg, vombg, vbcbg, vssol, vbcsol, vocsol, vasol, vw, + $ fki, itot, rhos, rhosv, rhobc, rhooc, rhob, rhow, Ctot, kcomp, + $ ismolarh, cat, fac, fabc, faq, iopt, + $ xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Hygroscopic growth is taken into account, either for the given +c relative humidity (if iopt=1). New number and mass concentrations +c and volume fractions are calculated. + + implicit none + + INTEGER i, imax, j, jmax, itot, kcomp, ismolarh, iopt + REAL Ctot, dCtot, rhos, rhosv, rhobc, rhooc, rhob, rhow, + $ fmax, rny, rh, d, cat, fac, fabc, faq, pi + REAL xbc, xdst, xoc, xs, xa, xss, rhda, rhca, rhdss, rhcss + REAL fombg, fbcbg, vombg, vbcbg + REAL dninc(0:100), dip(0:100), dndlrkny(0:100), dncny(0:100), + $ r(0:100), rp(0:100), vbci(0:100), voci(0:100), vsi(0:100), + $ vssol(0:100), vbcsol(0:100), vocsol(0:100), vasol(0:100), + $ vw(0:100) + REAL vssolub(100), vbcsolub(100), vocsolub(100), vasolub(100) + REAL fki(-1:100), f(-1:100), fm(-1:100) + + PARAMETER (pi=3.141592654) + +c Initializing local arrays + do i=-1,100 + f(i)=0.0 + fm(i)=0.0 + fki(i)=0.0 + enddo + do i=0,100 + dncny(i)=0.0 + dninc(i)=0.0 + dip(i)=0.0 + vssol(i)=0.0 + vbcsol(i)=0.0 + vocsol(i)=0.0 + vasol(i)=0.0 + vw(i)=0.0 + enddo + do i=1,100 + vssolub(i)=0.0 + vbcsolub(i)=0.0 + vocsolub(i)=0.0 + vasolub(i)=0.0 + enddo + +c Initialize wet volume fractions for sulfate, vssol, soot, vbcsol, +c and background aerosol, vasol. Note that the background aerosol +c consists of an internal mixture of two constituents for kcomp=1 +c (Sulfate and OM) and kcomp=4 (OM and BC) + do i=1,imax + vssol(i)=vsi(i) ! non-background sulfate + vbcsol(i)=vbci(i) ! non-background BC + vocsol(i)=voci(i) ! non-background OC + vasol(i)=max(1.0-vsi(i)-vbci(i)-voci(i),0.0) ! background (sulfate, OC, BC, SS or DU, or a mixture of two if kcomp=1 or 4) + enddo + +c subroutine koehler solves the koehler equation to find wet particle +c radii for a given relative humidity, rh. + call koehler (d, imax, r, vsi, vbci, voci, vombg, vbcbg, + $ rh, f, fm, itot, faq, kcomp, iopt, xbc, xdst, xoc, xs, xa, xss, + $ rhda, rhca, rhdss, rhcss) + + do i=-1,imax + if(i.le.0) then + f(i)=1.0 + fm(i)=1.0 + endif +c fki is for use in sub-routine refind + fki(i)=f(i) +c if(i.eq.12) write(90,*) rh, fki(i) ! r=0.0118 (ca) mode 1 & 2 +c if(i.eq.14) write(90,*) rh, fki(i) ! r=0.022 (ca) mode 8 +c if(i.eq.17) write(90,*) rh, fki(i) ! r=0.04 (ca) mode 4 +c if(i.eq.20) write(90,*) rh, fki(i) ! r=0.075 (ca) mode 5 +c if(i.eq.21) write(90,*) rh, fki(i) ! r=0.1 (ca) +c if(i.eq.22) write(90,*) rh, fki(i) ! r=0.13 (ca) mode 9 +c if(i.eq.24) write(90,*) rh, fki(i) ! r=0.22 (ca) mode 6 +c if(i.eq.29) write(90,*) rh, fki(i) ! r=0.63 (ca) mode 7 +c if(i.eq.30) write(90,*) rh, fki(i) ! r=0.74 (ca) mode 10 +c if(i.eq.43) write(90,*) rh, fki(i) +c if(i.eq.30) write(91,*) rh, fm(i) ! test 4nov2014 (ikke bruk denne) + enddo +c write(90,*) rh, f(10) +c write(94,*) rh, f(44) +c write(95,*) rh, fm(10) +c write(99,*) rh, fm(44) + fmax=1.0 + do i=1,imax + if(fm(i).gt.fmax) then + fmax=fm(i) + endif + enddo + +c the total iteration number jmax must be sufficiently large to +c satisfy the stability criterium for the continuity equation. + jmax=int(log10(fmax)/d)+1 +C Noe feil her: uten utskrift et eller annet sted, kan vi fÃ¥ NaN optikk...!!?? + write(*,*) 'fmax, jmax =', fmax, jmax + +c determine the increment of log(r/um) at r=rp, i.e. in the center of +c the size bin, dip (chosen to be the same for every time step). + dip(0)=0.0 + do i=1,imax + if(i.eq.imax) then + dip(i)=log10(fm(i))/jmax + else + dip(i)=log10(0.5*(fm(i)+fm(i+1)))/jmax + endif + enddo + +c solve the continuity equations (with a simple upwind advection scheme, +c or with corrective anti-diffusive steps from the Smolarkiewicz scheme) +c using jmax time steps/iterations for the size distribution, dndlrkny. +c Process specific wet volume fractions and mass concentrations are +c determined directly from the growth factor and the dry values + + do j=1,jmax + + do i=1,imax + dninc(i)=-(dndlrkny(i)*dip(i)-dndlrkny(i-1)*dip(i-1))/d + enddo + do i=1,imax + dndlrkny(i)=dndlrkny(i)+dninc(i) + enddo + + do i=1,imax + rny=r(i)*fm(i)**(-1.0/real(jmax)) + if(i.eq.1) then + vssolub(i)=vssol(i) + vbcsolub(i)=vbcsol(i) + vocsolub(i)=vocsol(i) + vasolub(i)=vasol(i) + else + vssolub(i)=(vssol(i-1)*log10(r(i)/rny) + $ +vssol(i)*log10(rny/r(i-1)))/d + vbcsolub(i)=(vbcsol(i-1)*log10(r(i)/rny) + $ +vbcsol(i)*log10(rny/r(i-1)))/d + vocsolub(i)=(vocsol(i-1)*log10(r(i)/rny) + $ +vocsol(i)*log10(rny/r(i-1)))/d + vasolub(i)=(vasol(i-1)*log10(r(i)/rny) + $ +vasol(i)*log10(rny/r(i-1)))/d + endif + enddo + do i=1,imax + vssol(i)=vssolub(i)*fm(i)**(-3.0/real(jmax)) + vbcsol(i)=vbcsolub(i)*fm(i)**(-3.0/real(jmax)) + vocsol(i)=vocsolub(i)*fm(i)**(-3.0/real(jmax)) + vasol(i)=vasolub(i)*fm(i)**(-3.0/real(jmax)) + vw(i)=1.0-min(vssol(i)+vbcsol(i)+vocsol(i)+vasol(i),1.0) + enddo + + if(ismolarh.gt.0) then +c Smolarkiewicz-scheme with ismolar corrective steps + do i=1,imax + dncny(i)=dndlrkny(i) + enddo + call smolar (ismolarh, imax, d, dncny, dip) + do i=1,imax +co dndlrkny(i)=max(1.e-80,dncny(i)) !test + dndlrkny(i)=max(1.e-50,dncny(i)) !test + enddo + endif + + enddo ! j-loop + +c volume fractions for sulfate, vssol, soot, vbcsol, oc, vocsol, +c background aerosol, vasol, and water, vw, after hygroscopic growth. +c Here vssol+vbcsol+vocsol+vasol+vw=1. +c do i=1,imax +c write(132,100) r(i), vssol(i) ! hjelper !!?? +c write(133,100) r(i), vbcsol(i) +c write(134,100) r(i), vocsol(i) +c write(135,100) r(i), vasol(i) +c write(136,100) r(i), vw(i) +c vssol(i)=max(0.0,min(vssol(i),1.0)) ! hjelper ogsÃ¥ +c vbcsol(i)=max(0.0,min(vbcsol(i),1.0)) +c vocsol(i)=max(0.0,min(vocsol(i),1.0)) +c vasol(i)=max(0.0,min(vasol(i),1.0)) +c vw(i)=max(0.0,min(vw(i),1.0)) +c enddo + +c condensed water contribution, dCtot, to the total aerosol +c concentration, Ctot (ug/m**-3) + do i=1,imax + dCtot=1.0e-3*(4.0*pi/3.0)*r(i)**3.0 + $ *(rhow*vw(i)*dndlrkny(i))*d + Ctot=Ctot+dCtot + enddo +c write(*,*) 'wet Ctot =', Ctot + + + 100 format(2(x,e10.4)) + + return + end + diff --git a/tools/AeroTab/shr_kind_mod.F90 b/tools/AeroTab/shr_kind_mod.F90 new file mode 100644 index 0000000000..b5bee6383f --- /dev/null +++ b/tools/AeroTab/shr_kind_mod.F90 @@ -0,0 +1,18 @@ +MODULE shr_kind_mod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real + integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real + integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real + integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer + integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer + integer,parameter :: SHR_KIND_IN = kind(1) ! native integer + integer,parameter :: SHR_KIND_CS = 80 ! short char + integer,parameter :: SHR_KIND_CL = 256 ! long char + integer,parameter :: SHR_KIND_CX = 512 ! extra-long char + integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char + +END MODULE shr_kind_mod diff --git a/tools/AeroTab/sizemie.f b/tools/AeroTab/sizemie.f new file mode 100644 index 0000000000..bfd042eead --- /dev/null +++ b/tools/AeroTab/sizemie.f @@ -0,0 +1,693 @@ + subroutine sizemie (imin, imax, r, rbcn, d, vsi, vbci, voci, vai, + $ vombg, fombg, vbcbg, fbcbg, dndlrk, dndlrkny, kcomp, itot, ib, + $ vssol, vbcsol, vocsol, vasol, vw, fki, rh, Ctot, Nnat, catot, + $ fac, fabc, faq, fracdim, xlam, xlami, xlamb, xlame, + $ fband, fb, cref, omega, gass, bext, kext) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Sizemie: determines the spectral aerosol gross optical parameters by +c calling the Mie code for each particle size (with subsequent integration +c over the size distribution), and writes the result to file. + + implicit none + + LOGICAL ANYANG, PERFCT, PRNT(2) + INTEGER IPOLZN(4,2), NUMMOM, i, imax, j, k, ntype, kcomp, + $ itot, iband, ib, imin, numang, nmom, MAXANG, MOMDIM + real pi, e, lam + real xlam(31), xlami(32), xlamb(31), xlame(31) + PARAMETER (MAXANG=40, MOMDIM=10, pi=3.141592654, e=2.718281828) + REAL MIMCUT, PMOM(0:MOMDIM,4), XMU(MAXANG), XX(2), Cdry, + $ SPIKE, rmax, lambda1, lmax, betas, betae, dba, + $ dbs, dbe, qsca, qext, qabs, gqsc, ssaltot, gtot, gbetas, + $ dgbs, d, rbcn, ga, catot, rh, faq, fabc, fac, Ctot, Nnat, + $ dbebg, bebg(31),dbabg, babg(31), dbebc, bebc(31), dbabc, + $ babc(31), dbeoc, beoc(31), dbaoc, baoc(31), dbesu, + $ besu(31), dbasu, basu(31), dbewa, bewa(31), dbawa, + $ bawa(31), bebggt1, bebglt1, be, bcgt1, bebcgt1, bebclt1, + $ beocgt1, beoclt1, besugt1, besult1, bewagt1, bewalt1 + real omega(31), gass(31), bext(31), babs(31), kext(31), + $ fband(31), omch(16), gch(16), bch(16), fb(16) + real p_phase, p_phaseint, lamrat, dbacksc, backsc + real angext, angabs + real r(0:100), dndlrk(0:100), dndlrkny(0:100), vsi(0:100), + $ vbci(0:100), voci(0:100), fki(-1:100), fracdim(0:100), + $ vai(0:100), vssol(0:100), vbcsol(0:100), vocsol(0:100), + $ vasol(0:100), vw(0:100) + COMPLEX CREFIN(2), SFORW, SBACK, S1(MAXANG), S2(MAXANG), + $ TFORW(2), TBACK(2), crin, cref(5,31) + LOGICAL iband11, iband16, iband440, iband500, iband670, iband870 + LOGICAL iband550 + REAL fombg, vombg, vbcbg, fbcbg + + perfct =.false. + mimcut=1.0e-6 + anyang =.false. + numang=0 + nmom=0 + ipolzn(1,1)=0 + prnt(1)=.true. + prnt(2)=.true. +ctest +c anyang =.true. +c numang=21 +c do j=1,21 +c xmu(j)=real(j-1)/10.0-1.0 +c enddo +ctest + +c initializing optical parameters + do iband = 1, 31 + omega(iband)= 0.0 + gass(iband) = 0.0 + bext(iband) = 0.0 + kext(iband) = 0.0 + babs(iband) = 0.0 + bebg(iband) = 0.0 + babg(iband) = 0.0 + bebc(iband) = 0.0 + babc(iband) = 0.0 + beoc(iband) = 0.0 + baoc(iband) = 0.0 + besu(iband) = 0.0 + basu(iband) = 0.0 + enddo + + do iband = 1, ib + iband11=.false. + iband16=.false. + if (ib.eq.29.and.iband.eq.11) then + iband11=.true. + elseif (ib.eq.29.and.iband.eq.16) then + iband16=.true. + endif + +c logical variables for specific AeroCom calculations (if .true.) + iband440=.false. + iband500=.false. + iband550=.false. ! 20nov08 + iband670=.false. + iband870=.false. + if (ib.eq.31.and.iband.eq.9) then + iband440=.true. ! 440 nm band + elseif (ib.eq.31.and.iband.eq.11) then + iband500=.true. ! 500 nm band + elseif (ib.eq.31.and.iband.eq.12) then ! 20nov08 + iband550=.true. ! 550 nm band ! 20nov08 + elseif (ib.eq.31.and.iband.eq.15) then + iband670=.true. ! 670 nm band + elseif (ib.eq.31.and.iband.eq.18) then + iband870=.true. ! 870 nm band + endif + + betas=0.0 + betae=0.0 + gbetas=0.0 + if(iband.eq.1) then + bebglt1=0.0 + bebclt1=0.0 + beoclt1=0.0 + besult1=0.0 + endif + if(iband.eq.12) then + backsc=0.0 + endif + + lamrat=(xlam(iband)/(2*pi))**2 + +c the gross optical parameters for an aerosol mode is found by +c integrating over all particle radii (for each wavelength) +c write(*,*) 'imin, imax =', imin, imax +ctest do 1000 i=20,20 + do 1000 i=imin,imax ! intergration over size + + xx(1)=2*pi*r(i)/xlam(iband) + +c wavelength dependent complex rafractive indices (crin) are +c found from linear interpolation of tabulated values for each +c aerosol component in subroutine refind + call refind (xlam(iband), i, ib, iband, cref, crin, kcomp, + $ vbcsol, vocsol, vssol, vasol, vw, vombg, vbcbg, fki, r, + $ rbcn, fracdim) + + crefin(1)=crin +c write(*,*) 'xx=', xx(1) +c write(*,*) 'n=', crefin(1) + +c Mie calculations with size parameter xx as input + call MIEV0 ( XX, CREFIN, PERFCT, MIMCUT, ANYANG, + $ NUMANG, XMU, NMOM, IPOLZN, MOMDIM, PRNT, + $ QEXT, QSCA, GQSC, PMOM, SFORW, SBACK, S1, + $ S2, TFORW, TBACK, SPIKE ) + ga=gqsc/qsca + +ctest +c if(iband.eq.8) then +c p_phaseint=0.0 +c do j=1,20 +c normalisert fasefunksjon (P/2) +c p_phase=2.0*((cabs(S1(j)))**2+(cabs(S2(j)))**2) +c $ /(XX(1)*XX(1)*QSCA) +c write(500,*) XMU(j), p_phase +c p_phaseint=p_phaseint+p_phase*0.1 +c enddo +c write(502,*) 'S1(21), S2(1), SBACK =', S1(21), S2(1), SBACK +c endif +c write(*,*) 'p_phaseint =', p_phaseint +c write(*,*) 'CABS(SBACK)**2 =', CABS(SBACK)**2 +c dbe=pi*r(i)**2*(qext*dndlrkny(i))*d +c backsc=lamrat*CABS(SBACK)**2*dndlrkny(i)*d +c write(*,*) 'backsc =', backsc +c write(*,*) 'S =', dbe/backsc +ctest + + if(itot.eq.0) then + dbe=pi*r(i)**2*(qext*dndlrk(i))*d + betae=betae+dbe + dbs=pi*r(i)**2*(qsca*dndlrk(i))*d + betas=betas+dbs + dgbs=pi*r(i)**2*(qsca*ga*dndlrk(i))*d + gbetas=gbetas+dgbs + if(iband11.or.iband16.or.iband440.or.iband500 + $ .or.iband550.or.iband670.or.iband870) then +c AeroCom-calculations. + dbebg=dbe*1.e-3 + bebg(iband)=bebg(iband)+dbebg + dba=dbe-dbs + dbabg=dba*1.e-3 + babg(iband)=babg(iband)+dbabg + if(i.lt.28.and.iband11) bebglt1=bebglt1+dbebg + if(i.lt.28.and.iband550) bebglt1=bebglt1+dbebg + endif +c Size integrated backscatter at 180 deg. (s. 54 i permXXIII) (CABS = complex ABS) + if(iband550) then + dbacksc=1.e-3*lamrat*CABS(SBACK)**2*dndlrk(i)*d + backsc=backsc+dbacksc + endif + else ! itot = 1 + dbe=pi*r(i)**2*(qext*dndlrkny(i))*d + betae=betae+dbe + dbs=pi*r(i)**2*(qsca*dndlrkny(i))*d + betas=betas+dbs + dgbs=pi*r(i)**2*(qsca*ga*dndlrkny(i))*d + gbetas=gbetas+dgbs + if(iband11.or.iband16.or.iband440.or.iband500 + $ .or.iband550.or.iband670.or.iband870) then +c AeroCom-calculations (TI): use v*dry but dndlrkny wet, i.e. r wet, +c so that the sum of extinctions for each species, except water, equals +c the total extiction, including water. But, this method yield SSA for +c each component which doesn't take into account the species refractive +c index. Must be a flaw!!! Still.... + dba=dbe-dbs + + dbebg=dbe*vai(i)*1.e-3 + bebg(iband)=bebg(iband)+dbebg + dbabg=dba*vai(i)*1.e-3 + babg(iband)=babg(iband)+dbabg + if(i.lt.28.and.iband11) bebglt1=bebglt1+dbebg + if(i.lt.28.and.iband550) bebglt1=bebglt1+dbebg + + dbebc=dbe*vbci(i)*1.e-3 + bebc(iband)=bebc(iband)+dbebc + dbabc=dba*vbci(i)*1.e-3 + babc(iband)=babc(iband)+dbabc + if(i.lt.28.and.iband11) bebclt1=bebclt1+dbebc + if(i.lt.28.and.iband550) bebclt1=bebclt1+dbebc + + dbeoc=dbe*voci(i)*1.e-3 + beoc(iband)=beoc(iband)+dbeoc + dbaoc=dba*voci(i)*1.e-3 + baoc(iband)=baoc(iband)+dbaoc + if(i.lt.28.and.iband11) beoclt1=beoclt1+dbeoc + if(i.lt.28.and.iband550) beoclt1=beoclt1+dbeoc + + dbesu=dbe*vsi(i)*1.e-3 + besu(iband)=besu(iband)+dbesu + dbasu=dba*vsi(i)*1.e-3 + basu(iband)=basu(iband)+dbasu + if(i.lt.28.and.iband11) besult1=besult1+dbesu + if(i.lt.28.and.iband550) besult1=besult1+dbesu + + endif ! AeroCom specific bands + if(iband550) then + dbacksc=1.e-3*lamrat*CABS(SBACK)**2*dndlrkny(i)*d + backsc=backsc+dbacksc + endif + endif ! itot (0 or 1) + + 1000 continue ! intergration over size + +c write(100,*) xlam(iband), real(crin) +c write(101,*) xlam(iband), aimag(crin) + +c if(iband550) then +c write(*,*) 'betae, backsc =', betae, backsc +c write(*,*) 'S =', betae*1.e-3/backsc +c write(*,*) 'SBACK, CABS(SBACK) =', SBACK, CABS(SBACK) +c endif + +c size integrated values of the single scattering albedo, +c ssaltot, and asymmetry factor, gtot: + ssaltot=betas/betae + gtot=gbetas/betas +c write(*,2000) lambda1, ssaltot, gtot, betae/Ctot + omega(iband)=ssaltot + gass(iband) =gtot + bext(iband) =betae*1.e-3 + kext(iband) =betae/Ctot + babs(iband) =(1.0-omega(iband))*bext(iband) +c write(40,3000) xlam(iband), omega(iband) +c write(41,3000) xlam(iband), gass(iband) +c write(42,3000) xlam(iband), bext(iband) +c write(43,3000) xlam(iband), kext(iband) +c if(iband.eq.12) then +c write(*,*) iband, xlam(iband), omega(iband) +c write(*,*) iband, kext(iband), kext(iband)*(1.0-omega(iband)) +c endif + + enddo ! iband + + +c The AEROCOM specific optics look-up tables are made below, by +c writing the results to file (unit=9500) +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + if(ib.eq.31) then ! xlam(9)=0.44, xlam(11)=0.50, xlam(12)=0.55, xlam(15)=0.67 and xlam(18)=0.87 um + + bebggt1=bebg(12)-bebglt1 + bebcgt1=bebc(12)-bebclt1 + beocgt1=beoc(12)-beoclt1 + besugt1=besu(12)-besult1 +c +c Here comes the aerocomk*.out look-up tables: +c + if(kcomp.eq.0) then + write(9500,7100) kcomp, rh, + $ bebg(9), babg(9), bebg(11), babg(11), babg(12), + $ bebg(15), babg(15), bebg(18), babg(18), + $ bebglt1, bebggt1, backsc +c write(*,*) 'bext(12) =', bext(12) +c write(*,*) 'bext12sum=', bebglt1+bebggt1 +c write(*,*) 'backsc=', backsc +c write(*,*) 'S* =', bext(12)/backsc + elseif(kcomp.eq.1) then + write(9500,8600) kcomp, rh, fombg, catot, fac, + $ bext(9), bext(11), bext(15), bext(18), + $ bebg(9), bebg(11), bebg(15), bebg(18), + $ bebc(9), bebc(11), bebc(15), bebc(18), + $ beoc(9), beoc(11), beoc(15), beoc(18), + $ besu(9), besu(11), besu(15), besu(18), + $ babs(9), babs(11), babs(12), babs(15), babs(18), + $ bebglt1, bebggt1, bebclt1, bebcgt1, + $ beoclt1, beocgt1, besult1, besugt1, backsc, + $ babg(12), babc(12), baoc(12), basu(12) + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(9500,8200) kcomp, rh, catot, fac, + $ bext(9), bext(11), bext(15), bext(18), + $ bebg(9), bebg(11), bebg(15), bebg(18), + $ bebc(9), bebc(11), bebc(15), bebc(18), + $ beoc(9), beoc(11), beoc(15), beoc(18), + $ besu(9), besu(11), besu(15), besu(18), + $ babs(9), babs(11), babs(12), babs(15), babs(18), + $ bebglt1, bebggt1, bebclt1, bebcgt1, + $ beoclt1, beocgt1, besult1, besugt1, backsc, + $ babg(12), babc(12), baoc(12), basu(12) +c write(*,*) 'bext(12) =', bext(12) +c write(*,*) 'bext12sum=', bebglt1+bebggt1+bebclt1+bebcgt1 +c $ +beoclt1+beocgt1+besult1+besugt1 +c write(*,*) 'backsc=', backsc +c write(*,*) 'S* =', bext(12)/backsc +c write(9500,8100) kcomp, rh, catot, +c $ bext(9), bext(11), bext(15), bext(18), +c $ bebg(9), bebg(11), bebg(15), bebg(18), +c $ bebc(9), bebc(11), bebc(15), bebc(18), +c $ beoc(9), beoc(11), beoc(15), beoc(18), +c $ besu(9), besu(11), besu(15), besu(18), +c $ babs(9), babs(11), babs(12), babs(15), babs(18), +c $ bebglt1, bebggt1, bebclt1, bebcgt1, +c $ beoclt1, beocgt1, besult1, besugt1, backsc, +c $ babg(12), babc(12), baoc(12), basu(12) +cc write(*,*) 'bext(12) =', bext(12) +cc write(*,*) 'bext12sum=', bebglt1+bebggt1+bebclt1+bebcgt1 +cc $ +beoclt1+beocgt1+besult1+besugt1 +cc write(*,*) 'backsc=', backsc +cc write(*,*) 'S* =', bext(12)/backsc +c endif + elseif(kcomp.eq.4) then + write(9500,6100) kcomp, rh, fbcbg, catot, fac, faq, + $ bext(9), bext(11), bext(15), bext(18), + $ bebg(9), bebg(11), bebg(15), bebg(18), + $ bebc(9), bebc(11), bebc(15), bebc(18), + $ beoc(9), beoc(11), beoc(15), beoc(18), + $ besu(9), besu(11), besu(15), besu(18), + $ babs(9), babs(11), babs(12), babs(15), babs(18), + $ bebglt1, bebggt1, bebclt1, bebcgt1, + $ beoclt1, beocgt1, besult1, besugt1, backsc, + $ babg(12), babc(12), baoc(12), basu(12) +c write(*,*) 'bext(12) =', bext(12) +c write(*,*) 'bext12sum=', bebglt1+bebggt1+bebclt1+bebcgt1 +c $ +beoclt1+beocgt1+besult1+besugt1 +c write(*,*) 'backsc=', backsc +c write(*,*) 'S* =', bext(12)/backsc + else ! kcomp = 5, 6, 7, 8, 9 or 10 + write(9500,6100) kcomp, rh, catot, fac, fabc, faq, + $ bext(9), bext(11), bext(15), bext(18), + $ bebg(9), bebg(11), bebg(15), bebg(18), + $ bebc(9), bebc(11), bebc(15), bebc(18), + $ beoc(9), beoc(11), beoc(15), beoc(18), + $ besu(9), besu(11), besu(15), besu(18), + $ babs(9), babs(11), babs(12), babs(15), babs(18), + $ bebglt1, bebggt1, bebclt1, bebcgt1, + $ beoclt1, beocgt1, besult1, besugt1, backsc, + $ babg(12), babc(12), baoc(12), basu(12) +ctest ok +c write(*,*) 'bext(12) =', bext(12) +c write(*,*) 'bext12sum=', bebglt1+bebggt1+bebclt1+bebcgt1 +c $ +beoclt1+beocgt1+besult1+besugt1 +c write(*,*) 'k, besu(12) =', kcomp, besu(12) +c write(*,*) 'k, besu12sum=', kcomp, besult1+besugt1 +c write(*,*) 'backsc=', backsc +c write(*,*) 'S* =', bext(12)/backsc +ctest + endif ! kcomp +cANG+ some extra angstrom diagnostics +c xlam(9)=0.44, xlam(11)=0.50, xlam(12)=0.55, xlam(15)=0.67 and xlam(18)=0.87 um +c angext = -log(bext(18)/bext(9))/log(xlam(18)/xlam(9)) +c angabs = -log((babs(18)+1.e-50)/(babs(9)+1.e-50)) +c $ /log(xlam(18)/xlam(9)) +c write(111,*) rh, angext, kcomp, catot, fac, fabc, faq +c write(112,*) rh, angabs, kcomp, catot, fac, fabc, faq +cANG- + +c find Chandrasekhar-averaged optical parameters for the wide bands +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + call chandrav (ib, xlam, xlamb, xlame, fband, fb, + $ omega, gass, bext, omch, gch, bch) + +c convert from ib=31 to the usual ib=14 for input to CAM5 + do iband=1,9 + omega(iband) = omch(iband) + gass(iband) = gch(iband) + bext(iband) = bch(iband) + kext(iband) = 1.e3*bch(iband)/Ctot + enddo + do iband = 10,14 + omega(iband) = omega(iband+17) + gass(iband) = gass(iband+17) + bext(iband) = bext(iband+17) + kext(iband) = kext(iband+17) + enddo +c do iband = 1,14 +c if(iband.eq.1) then +c lam = 0.2315 +c elseif(iband.eq.2) then +c lam = 0.304 +c elseif(iband.eq.3) then +c lam = 0.3935 +c elseif(iband.eq.4) then +c lam = 0.5335 +c elseif(iband.eq.5) then +c lam = 0.7015 +c elseif(iband.eq.6) then +c lam = 1.01 +c elseif(iband.eq.7) then +c lam = 1.2705 +c elseif(iband.eq.8) then +c lam = 1.4625 +c elseif(iband.eq.9) then +c lam = 1.784 +c elseif(iband.gt.9) then +c lam = xlam(iband+17) +c endif +c write(50,3000) lam, omega(iband) +c write(51,3000) lam, gass(iband) +c write(52,3000) lam, bext(iband) +c write(53,3000) lam, kext(iband) +c write(54,3000) lam, kext(iband)*Ctot/Cdry +c write(55,3000) lam, kext(iband)*(1.0-omega(iband)) +c write(*,*) iband, lam +c enddo + +c***************************************************************** + + elseif(ib.eq.19) then ! xlam(16)=24.2855, xlam(17)=45, xlam(18)=60, xlam(19)=85 + +c no AEROCOM look-up tables needed here... +c find Chandrasekhar-averaged optical parameters for the wide bands +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + call chandrav (ib, xlam, xlamb, xlame, fband, fb, + $ omega, gass, bext, omch, gch, bch) + +c convert from ib=19 to the usual ib=16 for input to CAM5 + do iband=1,15 + omega(iband) = omega(iband) + gass(iband) = gass(iband) + bext(iband) = bext(iband) + kext(iband) = kext(iband) + enddo + do iband=16,16 + omega(iband) = omch(iband) + gass(iband) = gch(iband) + bext(iband) = bch(iband) + kext(iband) = 1.e3*bch(iband)/Ctot + enddo + +c do iband = 1,16 +c if(iband.lt.15) then +c lam = xlam(iband) +c elseif(iband.eq.16) then +c lam = 64.3 ! midband of 28.571-100 +c endif +c write(50,3000) lam, omega(iband) +c write(51,3000) lam, gass(iband) +c write(52,3000) lam, bext(iband) +c write(53,3000) lam, kext(iband) +c write(54,3000) lam, kext(iband)*Ctot/Cdry +c write(*,*) iband, lam +c enddo + +c***************************************************************** + + elseif(ib.eq.29) then ! xlam(11)=0.55 and xlam(16)=0.865 + + bebggt1=bebg(11)-bebglt1 + bebcgt1=bebc(11)-bebclt1 + beocgt1=beoc(11)-beoclt1 + besugt1=besu(11)-besult1 + +c Note: aerocomk*.out for ib=29 is not used any more. +c if(itot.eq.1) then +c if(kcomp.le.3) then +c write(9500,8000) kcomp, rh, catot, +c $ bext(11), babs(11), bext(16), babs(16), +c $ bebg(11), babg(11), bebg(16), babg(16), +c $ bebc(11), babc(11), bebc(16), babc(16), +c $ beoc(11), baoc(11), beoc(16), baoc(16), +c $ besu(11), basu(11), besu(16), basu(16), +c $ bebglt1, bebggt1, bebclt1, bebcgt1, +c $ beoclt1, beocgt1, besult1, besugt1 +c elseif(kcomp.eq.4) then +c write(9500,8500) kcomp, rh, catot, fac, faq, +c $ bext(11), babs(11), bext(16), babs(16), +c $ bebg(11), babg(11), bebg(16), babg(16), +c $ bebc(11), babc(11), bebc(16), babc(16), +c $ beoc(11), baoc(11), beoc(16), baoc(16), +c $ besu(11), basu(11), besu(16), basu(16), +c $ bebglt1, bebggt1, bebclt1, bebcgt1, +c $ beoclt1, beocgt1, besult1, besugt1 +c else +c write(9500,6000) kcomp, rh, catot, fac, fabc, faq, +c $ bext(11), babs(11), bext(16), babs(16), +c $ bebg(11), babg(11), bebg(16), babg(16), +c $ bebc(11), babc(11), bebc(16), babc(16), +c $ beoc(11), baoc(11), beoc(16), baoc(16), +c $ besu(11), basu(11), besu(16), basu(16), +c $ bebglt1, bebggt1, bebclt1, bebcgt1, +c $ beoclt1, beocgt1, besult1, besugt1 +c endif +c elseif(itot.eq.0) then +c write(9500,7000) kcomp, rh, +c $ bebg(11), babg(11), bebg(16), babg(16), bebglt1, bebggt1 +c endif + +c find Chandrasekhar-averaged optical parameters for the wide bands +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + call chandrav (ib, xlam, xlamb, xlame, fband, fb, + $ omega, gass, bext, omch, gch, bch) + +c convert from ib=29 to the usual ib=12 for input to CAM + omega(8) = omch(8) + gass(8) = gch(8) + bext(8) = bch(8) + kext(8) = 1.e3*bch(8)/Ctot + omega(9) = omega(13) + gass(9) = gass(13) + bext(9) = bext(13) + kext(9) = kext(13) + do iband = 10,12 + omega(iband) = omch(iband) + gass(iband) = gch(iband) + bext(iband) = bch(iband) + kext(iband) = 1.e3*bch(iband)/Ctot + enddo + do iband = 13,29 + omega(iband) = 0.0 + gass(iband) = 0.0 + bext(iband) = 0.0 + kext(iband) = 0.0 + enddo + do iband = 1,12 + if(iband.lt.8) then + lam = xlam(iband) + elseif(iband.eq.8) then + lam = 0.495 + elseif(iband.eq.9) then + lam = 0.665 + elseif(iband.eq.10) then + lam = 0.94 + elseif(iband.eq.11) then + lam = 1.785 + else + lam = 3.19 + endif +c write(50,3000) lam, omega(iband) +c write(51,3000) lam, gass(iband) +c write(52,3000) lam, bext(iband) +c write(53,3000) lam, kext(iband) +c write(54,3000) lam, kext(iband)*Ctot/Cdry +c write(*,*) iband, lam + enddo + + endif ! ib=29 or ib=31 + + +c The CAM-RT / RRTMG optics look-up tables are made below, by writing +c the results to file (unit=9000 for SW, unit=9001 for LW) +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + if(ib.eq.31) then ! RRTMG SW +c +c Here comes the kcomp*.out look-up tables: +c + if(kcomp.eq.0) then + do iband = 1, 14 + write(9000,4000) kcomp, iband, rh, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(kcomp.eq.1) then + do iband = 1, 14 + write(9000,9500) kcomp, iband, rh, fombg, catot, fac, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(kcomp.eq.2.or.kcomp.eq.3) then + do iband = 1, 14 + write(9000,9100) kcomp, iband, rh, catot, fac, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(kcomp.eq.4) then + do iband = 1, 14 + write(9000,5000) kcomp, iband, rh, fbcbg, catot, fac, faq, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + do iband = 1, 14 + write(9000,5000) kcomp, iband, rh, catot, fac, fabc, faq, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + endif +c +c19/11-2013: + elseif(ib.eq.19) then ! RRTMG LW +c trenger bare (1-omega)*kext her til slutt (masse faas fra SW-tabellene) + if(kcomp.eq.0) then + do iband = 1, 16 + write(9009,4010) kcomp, iband, rh, + $ (1.0-omega(iband))*kext(iband) + enddo + elseif(kcomp.eq.1) then + do iband = 1, 16 + write(9009,9510) kcomp, iband, rh, fombg, catot, fac, + $ (1.0-omega(iband))*kext(iband) + enddo + elseif(kcomp.eq.2.or.kcomp.eq.3) then + do iband = 1, 16 + write(9009,9110) kcomp, iband, rh, catot, fac, + $ (1.0-omega(iband))*kext(iband) + enddo + elseif(kcomp.eq.4) then + do iband = 1, 16 + write(9009,5010) kcomp, iband, rh, fbcbg, catot, fac, faq, + $ (1.0-omega(iband))*kext(iband) + enddo + else ! kcomp=5-10 + do iband = 1, 16 + write(9009,5010) kcomp, iband, rh, catot, fac, fabc, faq, + $ (1.0-omega(iband))*kext(iband) + enddo + endif +c8/11-2013: +c + elseif(ib.eq.29) then ! CAM-RT SW + + if(itot.eq.0.and.ib.ge.12) then + do iband = 1, 12 + write(9000,4000) kcomp, iband, rh, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(itot.eq.1.and.ib.ge.12) then + if(kcomp.eq.1) then + do iband = 1, 12 + write(9000,9500) kcomp, iband, rh, fombg, catot, fac, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(kcomp.eq.2.or.kcomp.eq.3) then + do iband = 1, 12 + write(9000,9100) kcomp, iband, rh, catot, fac, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + elseif(kcomp.eq.4) then + do iband = 1, 12 + write(9000,5000) kcomp, iband, rh, fbcbg, catot, fac, faq, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + else ! kcomp=6-10 + do iband = 1, 12 + write(9000,5000) kcomp, iband, rh, catot, fac, fabc, faq, + $ omega(iband), gass(iband), bext(iband), kext(iband) + enddo + endif + endif + + endif + + 2000 format(4(x,e12.5)) + 3000 format(2(x,e12.5)) + 4000 format(2I3,f8.3,4(x,e12.5)) + 4010 format(2I3,f8.3,x,e12.5) + 5000 format(2I3,f8.3,3(x,e10.3),f7.2,4(x,e12.5)) + 5010 format(2I3,f8.3,3(x,e10.3),f7.2,x,e12.5) + 6000 format(I2,f6.3,3e10.3,f5.2,28e10.3) + 6100 format(I2,f6.3,3e10.3,f5.2,38e10.3) + 7000 format(I2,f5.2,6e11.4) + 7100 format(I2,f6.3,12e11.4) + 8000 format(I2,f6.3,e10.3,28e10.3) + 8100 format(I2,f6.3,e10.3,38e10.3) + 8200 format(I2,f6.3,2e10.3,38e10.3) + 8500 format(I2,f6.3,3e10.3,28e10.3) + 8600 format(I2,f6.3,3e10.3,38e10.3) + 9000 format(2I3,f8.3,x,e10.3,4(x,e12.5)) + 9100 format(2I3,f8.3,2(x,e10.3),4(x,e12.5)) + 9110 format(2I3,f8.3,2(x,e10.3),x,e12.5) + 9500 format(2I3,f8.3,3(x,e10.3),4(x,e12.5)) + 9510 format(2I3,f8.3,3(x,e10.3),x,e12.5) + + end + + + + + + diff --git a/tools/AeroTab/smolar.f b/tools/AeroTab/smolar.f new file mode 100644 index 0000000000..f0160dddc8 --- /dev/null +++ b/tools/AeroTab/smolar.f @@ -0,0 +1,39 @@ + subroutine smolar (ismolar, imax, d, dncny, dip) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + + implicit none + + INTEGER i, imax, ismolar, it + REAL d, eps, dip(0:100), dad(0:100), + $ dncny(0:100), dncinc(100) + PARAMETER (eps=1.e-50) + + do i=0,imax + dad(i)=dip(i) + enddo + + do it=1,ismolar + + do i=0,imax + dad(i)=(abs(dad(i))-dad(i)*dad(i)/d) + $ *(dncny(i+1)-dncny(i)) + $ /(dncny(i)+dncny(i+1)+eps) + enddo + dad(imax)=0.0 + do i=1,imax + dncinc(i)=-(dncny(i)*(dad(i)+abs(dad(i))) + $ +dncny(i+1)*(dad(i)-abs(dad(i))) + $ -dncny(i-1)*(dad(i-1)+abs(dad(i-1))) + $ -dncny(i)*(dad(i-1)-abs(dad(i-1))))/(2.0*d) + enddo + do i=1,imax + dncny(i)=dncny(i)+dncinc(i) + enddo + + enddo ! it + + return + end diff --git a/tools/AeroTab/specbands.f b/tools/AeroTab/specbands.f new file mode 100644 index 0000000000..6a22dfe2fe --- /dev/null +++ b/tools/AeroTab/specbands.f @@ -0,0 +1,511 @@ + subroutine specbands(ib, xlami, xlam, xlamb, xlame, fband, fb, + $ ibcam) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Define spectral bands and calculate fractional fluxes in bands that +c are to be used in Chandrasekhar averaging of optical parameters + + implicit none + + INTEGER ib, iband, ibm, ibmb, ibme, i, ibcam + REAL xlami(32), xlam(31), xlamb(31), xlame(31), fband(31), + $ flux(5000), fb(16) + REAL Fplanck, Fpint, temp + +ccccc6ccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc +c define wavelength intervals, depending on desired number of bands +c (=ib-1). xlami marks the beginning of the band (um), while xlam (um) +c is the center, where Mie calculations are to be performed. + +c19/9-2013: From rrsw_aer.f90 +c! rrtmg_sw 14 spectral intervals (microns): +c! 3.846 - 3.077 +c! 3.077 - 2.500 +c! 2.500 - 2.150 +c! 2.150 - 1.942 +c! 1.942 - 1.626 +c! 1.626 - 1.299 +c! 1.299 - 1.242 +c! 1.242 - 0.7782 +c! 0.7782- 0.6250 +c! 0.6250- 0.4415 +c! 0.4415- 0.3448 +c! 0.3448- 0.2632 +c! 0.2632- 0.2000 +c! 12.195 - 3.846 +c5/11-2013: From radconstants.F90 (in CAM5.3) +c real(r8),parameter :: wavenum_low(nbndsw) = & ! in cm^-1 +c (/2600._r8, 3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, & +c 8050._r8,12850._r8,16000._r8,22650._r8,29000._r8,38000._r8, 820._r8/) +c real(r8),parameter :: wavenum_high(nbndsw) = & ! in cm^-1 +c (/3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, 8050._r8, & +c 12850._r8,16000._r8,22650._r8,29000._r8,38000._r8,50000._r8, 2600._r8/) + if(ib.eq.31) then ! Chandrasekhar-averaging -> CAM4/5-Oslo SW bands (+ CAM4-Oslo AEROCOM) + xlami(1) = 0.2 ! 1' begins + xlami(2) = 0.24 ! + xlami(3) = 0.263 ! 2' + xlami(4) = 0.29 ! + xlami(5) = 0.32 ! + xlami(6) = 0.345 ! 3' + xlami(7) = 0.376 ! + xlami(8) = 0.407 ! + xlami(9) = 0.438 ! + xlami(10)= 0.442 ! 4' + xlami(11)= 0.48 ! + xlami(12)= 0.52 ! + xlami(13)= 0.58 ! + xlami(14)= 0.625 ! 5' + xlami(15)= 0.64 ! + xlami(16)= 0.70 ! + xlami(17)= 0.74 ! + xlami(18)= 0.778 ! 6' + xlami(19)= 0.962 ! + xlami(20)= 1.078 ! + xlami(21)= 1.16 ! + xlami(22)= 1.242 ! 7' + xlami(23)= 1.299 ! 8' + xlami(24)= 1.46 ! + xlami(25)= 1.626 ! 9' + xlami(26)= 1.784 ! + xlami(27)= 1.942 ! 10' + xlami(28)= 2.15 ! 11' + xlami(29)= 2.5 ! 12' + xlami(30)= 3.077 ! 13' + xlami(31)= 3.846 ! 14' + xlami(32)= 12.195 ! + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) +c write(*,*) iband, xlam(iband) +c write(*,*) iband, xlami(iband), xlami(iband+1) + enddo + ibcam=14 + elseif(ib.eq.19) then ! CAM5-Oslo LW bands +c7/11-2013: From radconstants.F90 (in CAM5.3) +c real(r8), parameter :: wavenumber1_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) +c (/ 10._r8, 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, & +c 1180._r8, 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2390._r8, 2600._r8 /) +c real(r8), parameter :: wavenumber2_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) +c (/ 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, 1180._r8, & +c 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2390._r8, 2600._r8, 3250._r8 /) + xlami(1) = 3.077 ! = SW xlami(30) + xlami(2) = 3.846 ! = SW xlami(31) + xlami(3) = 4.184 + xlami(4) = 4.444 + xlami(5) = 4.808 + xlami(6) = 5.556 + xlami(7) = 6.757 + xlami(8) = 7.194 + xlami(9) = 8.475 + xlami(10)= 9.259 + xlami(11)= 10.204 + xlami(12)= 12.195 ! = SW xlami(32) + xlami(13)= 14.286 + xlami(14)= 15.873 + xlami(15)= 20.0 +c xlami(16)= 28.571 ! 1' (starting from 1 to avoid resizing the fb array) + xlami(16)= 28.571 ! 16' + xlami(17)= 40.0 + xlami(18)= 50.0 + xlami(19)= 70.0 + xlami(20)= 100.0 ! cf. 1000 in CAM5: very little energy left at these wavelengths + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) +c write(*,*) iband, xlam(iband) +c write(*,*) iband, xlami(iband), xlami(iband+1) + enddo + ibcam=16 + elseif(ib.eq.16) then ! CAM5-Oslo LW bands (without Chandrasekhar averaging) + xlami(1) = 3.077 ! = SW xlami(30) + xlami(2) = 3.846 ! = SW xlami(31) + xlami(3) = 4.184 + xlami(4) = 4.444 + xlami(5) = 4.808 + xlami(6) = 5.556 + xlami(7) = 6.757 + xlami(8) = 7.194 + xlami(9) = 8.475 + xlami(10)= 9.259 + xlami(11)= 10.204 + xlami(12)= 12.195 ! = SW xlami(32) + xlami(13)= 14.286 + xlami(14)= 15.873 + xlami(15)= 20.0 + xlami(16)= 28.571 +c xlami(17)= 1000.0 ! as defined in CAM5 + xlami(17)= 45.0 ! redefined based on the "Planck function" discussion below + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) + write(*,*) iband, xlam(iband) +c write(*,*) iband, xlami(iband), xlami(iband+1) + enddo +ctest Planck function (W m-2 m-1) for black body emissivity (temp=300 gives Fig. 1.8 of Seinfeld & Pandis, OK). +c We use the equivalent black body temperature T=255 (K), and wavelength is given in units um below: +c temp=255.0 +c Fpint=0.0 +c do i=1,1000 +c Fplanck=(3.74e8/((real(i))**5)) +c $ /(2.718281828**(1.44e4/(temp*real(i)))-1.0) +c write(77,*) i, Fplanck +c wavelength integrated energy in iband=16 is 45.7 (cf. 239 for the whole spectrum, i.e. 19%): +c if(i.ge.1) then +c if(i.ge.28) then +c Fpint=Fpint+Fplanck +c write(78,*) i, Fpint +c endif +c enddo +c half of the energy found in the last band (22.8) is found for i<~37um, which we +c therefore redefine as mid-band, giving xlami(17)=45.0 instead of 1000. E.g., we do +c not perform any Chandrasekhar averaging here (due to the small absoption at these +c long wavelengths). +ctest + elseif(ib.eq.14) then ! CAM3/4-Oslo/CAM3/4 SW bands + xlami(1) = 0.2 + xlami(2) = 0.263 + xlami(3) = 0.345 + xlami(4) = 0.442 + xlami(5) = 0.625 + xlami(6) = 0.778 + xlami(7) = 1.242 + xlami(8) = 1.299 + xlami(9) = 1.626 + xlami(10)= 1.942 + xlami(11)= 2.15 + xlami(12)= 2.5 + xlami(13)= 3.077 + xlami(14)= 3.846 + xlami(15)= 12.195 + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) +c write(*,*) iband, xlam(iband) +c write(*,*) iband, xlami(iband), xlami(iband+1) + enddo + elseif(ib.eq.29) then ! Chandrasekhar-averaging -> CAM3/4-Oslo SW bands + xlami(1) = 0.2 ! 1' begins + xlami(2) = 0.245 ! 2' + xlami(3) = 0.265 ! 3' + xlami(4) = 0.275 ! 4' + xlami(5) = 0.285 ! 5' + xlami(6) = 0.295 ! 6' + xlami(7) = 0.305 ! 7' + xlami(8) = 0.35 ! 8' + xlami(9) = 0.4 ! + xlami(10)= 0.47 ! + xlami(11)= 0.53 ! + xlami(12)= 0.57 ! + xlami(13)= 0.64 ! 9' + xlami(14)= 0.69 ! 10' + xlami(15)= 0.76 ! + xlami(16)= 0.83 ! + xlami(17)= 0.9 ! + xlami(18)= 0.98 ! + xlami(19)= 1.08 ! + xlami(20)= 1.19 ! 11' + xlami(21)= 1.39 ! + xlami(22)= 1.59 ! + xlami(23)= 1.79 ! + xlami(24)= 1.99 ! + xlami(25)= 2.19 ! + xlami(26)= 2.38 ! 12' + xlami(27)= 2.7 ! + xlami(28)= 3.1 ! + xlami(29)= 3.5 ! + xlami(30)= 4.0 ! + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) + enddo + elseif(ib.eq.12) then ! CAM(3)-Oslo SW bands + xlami(1) = 0.2 + xlami(2) = 0.245 + xlami(3) = 0.265 + xlami(4) = 0.275 + xlami(5) = 0.285 + xlami(6) = 0.295 + xlami(7) = 0.305 + xlami(8) = 0.35 + xlami(9) = 0.64 + xlami(10)= 0.69 + xlami(11)= 1.19 + xlami(12)= 2.38 + xlami(13)= 4.0 + do iband = 1,ib + xlam(iband)=0.5*(xlami(iband)+xlami(iband+1)) + enddo + do iband=ib+1,29 + xlami(iband) = 0.0 + xlam(iband) = 0.0 + enddo + else + write(*,*) 'Not programmed for this number of bands' + stop + endif + +c start and end-band wavelengths in nm + do iband=1,ib + xlamb(iband)=1000*xlami(iband)+1 + xlame(iband)=1000*xlami(iband+1) + enddo + + + if(ib.eq.29.or.ib.eq.31) then + +c Open and read solar fluxes at TOA from xtspec.dat + + open(11,file='input/xtspec.dat', status='old') + + i=0 + do while(i.lt.5000) + read(11,*) i, flux(i) + enddo + + endif + +c Calculate spectral fluxes in the broad bands (ibm) + + if(ib.eq.31) then + + close(11) + +c initialize spectral parameters + do iband = 1, 31 + fband(iband)= 0.0 + enddo + do ibm = 1,9 + fb(ibm) = 0.0 + enddo + +c calculate band solar fluxes + do iband = 1, 31 + do i = int(xlamb(iband)), int(xlame(iband)) + fband(iband) = fband(iband) + flux(i) + enddo + enddo + +c for iband' =ibm = 1 (iband=1-2) + ibm = 1 + ibmb= 1 + ibme= 2 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 2 (iband=3-5) + ibm = 2 + ibmb= 3 + ibme= 5 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 3 (iband=6-9) + ibm = 3 + ibmb= 6 + ibme= 9 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 4 (iband=10-13) + ibm = 4 + ibmb= 10 + ibme= 13 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 5 (iband=14-17) + ibm = 5 + ibmb= 14 + ibme= 17 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 6 (iband=18-21) + ibm = 6 + ibmb= 18 + ibme= 21 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 7 (iband=22) +c ibm = 7 +c ibmb= 22 +c ibme= 22 +c do iband = ibmb, ibme +c do i = int(xlamb(iband)), int(xlame(iband)) +c fb(ibm) = fb(ibm) + flux(i) +c enddo +c enddo +c for iband' = ibm = 8 (iband=23-24) + ibm = 8 + ibmb= 23 + ibme= 24 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +c for iband' = ibm = 9 (iband=25-26) + ibm = 9 + ibmb= 25 + ibme= 26 + do iband = ibmb, ibme + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo +! do ibm=1,9 +! write(*,*) 'ibm, fb =', ibm, fb(ibm) +! enddo + + elseif(ib.eq.29) then + +c rewind 11 +c for iband' = ibm = 8 (iband=8-12) + ibm = 8 + ibmb= 8 + ibme= 12 +c call fsum(ibm,ibmb,ibme,xlamb,xlame) +c rewind 11 +c for iband' = ibm = 10 (iband=14-19) + ibm = 10 + ibmb= 14 + ibme= 19 +c call fsum(ibm,ibmb,ibme,xlamb,xlame) +c rewind 11 +c for iband' = ibm = 11 (iband=20-25) + ibm = 11 + ibmb= 20 + ibme= 25 +c call fsum(ibm,ibmb,ibme,xlamb,xlame) +c rewind 11 +c for iband' = ibm = 12 (iband=26-29) + ibm = 12 + ibmb= 26 + ibme= 29 +c call fsum(ibm,ibmb,ibme,xlamb,xlame) + + close(11) + +c initialize spectral parameters + do iband = 1, 29 + fband(iband)= 0.0 + enddo + do ibm = 8,12 + fb(ibm) = 0.0 + enddo + +c calculate band solar fluxes + do iband = 1, 29 + do i = int(xlamb(iband)), int(xlame(iband)) + fband(iband) = fband(iband) + flux(i) + enddo + enddo + +c band 8'=8-12 + ibm=8 + do iband = 8, 12 + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo + +c band 10'=14-19 + ibm=10 + do iband = 14, 19 + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo + +c band 11'=20-25 + ibm=11 + do iband = 20, 25 + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo + +c band 12'=26-29 + ibm=12 + do iband = 26, 29 + do i = int(xlamb(iband)), int(xlame(iband)) + fb(ibm) = fb(ibm) + flux(i) + enddo + enddo + + endif ! ib=29or31 + + if(ib.eq.19) then + +c initialize spectral parameters + do iband = 1, 31 + fband(iband)= 0.0 + enddo +c do ibm = 1,12 + do ibm = 1,16 + fb(ibm) = 0.0 + enddo + +c Calculate approximate LW flux (in one wide band) from the Planck function (W m-2 m-1) for the +c black body emissivity (temp=300 gives Fig. 1.8 of Seinfeld & Pandis, OK). We use the equivalent +c black body temperature T=255 (K), and wavelength 'i' is given in units um below: + temp=255.0 + ibm=16 ! (ibmb=16, ibme=19) + do i=int(xlami(16)),int(xlami(20)) ! i=28-100, i.e. integrating over ib = 16 - 19 + flux(i)=(3.74e8/((real(i))**5)) + $ /(2.718281828**(1.44e4/(temp*real(i)))-1.0) + fb(ibm)=fb(ibm)+flux(i) + enddo +c write(*,*) fb(ibm) + + do iband = 16, 19 + do i = int(xlami(iband)), int(xlami(iband+1))-1 + fband(iband) = fband(iband) + flux(i) + enddo +c write(*,*) iband, fband(iband) + enddo + + endif ! ib=19 + + + return + end + + +c******************************************************************** + + subroutine fsum (ibm,ibmb,ibme,xlamb,xlame) + + implicit none + + INTEGER ibm, ibmb, ibme, i + REAL xlamb(31), xlame(31), fsol(31), flux, fsolar + + fsol(ibm)=0.0 + fsolar=0.0 + i=0 + + do while(i.lt.5000) + read(11,*) i, flux + fsolar=fsolar+flux + if(real(i).ge.xlamb(ibmb).and.real(i).le.xlame(ibme)) then + fsol(ibm)=fsol(ibm)+flux + endif + enddo + write(*,*) 'fsol(ibm)/fsolar =', fsol(ibm)/fsolar + + return + end + +c******************************************************************** diff --git a/tools/AeroTab/tableinfo.f b/tools/AeroTab/tableinfo.f new file mode 100644 index 0000000000..548871ec9d --- /dev/null +++ b/tools/AeroTab/tableinfo.f @@ -0,0 +1,362 @@ + subroutine tableinfo (kcomp, xbc, xdst, xoc, xs, xa, xss, relh, + $ fombg, fbcbg, catote, catot, fac, fbc, faq, ib, ibcam, itilp) + +c ********************************************************************************** +c Adding header information for the opened look-up table (LUT) files, both as an +c explanation what the files contain, and to facilitate checking important input- +c info assumed in AeroTab against CAM5-Oslo (to make sure that this particular +c LUT is compatible with the CAM5-Oslo version which is being used). +c +c Created by Alf KirkevÃ¥g April 2015. Updated for new SOA treatment July 2015. +c ********************************************************************************** +c Note tha dry lognormal the fitted size parameters do not depend +c on the mass fraction fombc for kcomp=1, nor on fbcbg for kcomp=4. +c ********************************************************************************** + + use commondefinitions + + implicit none + + INTEGER kcomp, ib, ibcam, itilp, i, iu, iumax, iunr(3) + REAL xbc, xoc, xs, xa, xss, xdst + REAL relh(10), catote(16), catot(6), fac(6), fbc(6), faq(6), + $ fombg(6), fbcbg(6) + + if(itilp.eq.1) then + if(kcomp.eq.0) return ! no logntilp0.out needed (constant r and logsigma) + iumax=1 + iunr(1)=9003 ! logntilp*.out + elseif(itilp.eq.0.and.(ib.eq.31.or.ib.eq.19)) then + iumax=3 + if(ib.eq.31) then + iunr(1)=9000 ! kcomp*.out + else + iunr(1)=9009 ! lwkcomp*.put + endif + iunr(2)=9500 ! aerocomk*.out + iunr(3)=9600 ! aerodryk*.out + endif + + do i=1,iumax + iu=iunr(i) + + if(iu.eq.9000) then +c Adding LUT header info for kcomp*.out: + + write(iu,*) 'This look-up table (LUT) contains the following ', + $ 'SW gross optical properties for a normalized aerosol size ', + $ 'distribution (N=1/cm3):' + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'kcomp, iband, rh, ' + elseif(kcomp.eq.1) then + write(iu,*) 'kcomp, iband, rh, fombg, catot, fac, ' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'kcomp, iband, rh, catot, fac, ' + elseif(kcomp.eq.4) then + write(iu,*) 'kcomp, iband, rh, fbcbg, catot, fac, faq, ' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'kcomp, iband, rh, catot, fac, fbc, faq, ' + endif ! kcomp + write(iu,*) 'omega(iband), gass(iband), bext(iband), kext(iband)' + write(iu,*) '' + write(iu,*) 'Here omega is the single scattering albedo (1),', + $ 'gass is the asymmetry factor (1), bext is the extiction ', + $ '(1/km), and kext is the specific extinction (m2/g)' + + elseif(iu.eq.9003) then +c Adding LUT header info for logntilp*.out: + write(iu,*) 'This look-up table (LUT) contains the following ', + $ 'fitted lognormal mode parameters for the ' + write(iu,*) 'modified (dry, generally non-lognormal) ', + $ 'aerosol size distribution (normalized so that N=1/cm3):' + write(iu,*) '' + if(kcomp.eq.1) then + write(iu,*) 'kcomp, catot, fac, r, logsigma,' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'kcomp, catot, fac, r, logsigma,' + elseif(kcomp.eq.4) then + write(iu,*) 'kcomp, catot, fac, faq, r, logsigma' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'kcomp, catot, fac, fbc, faq, r, logsigma' + endif + write(iu,*) '' + write(iu,*) 'where r and logsigma are dry modal median radius ', + $ 'and logarithm (base 10) of the standard deviation, ' + + elseif(iu.eq.9009) then +c Adding LUT header info for lwkcomp*.out: + write(iu,*) 'This look-up table (LUT) contains the following ', + $ 'LW gross optical properties for a normalized aerosol size ', + $ 'distribution (N=1/cm3):' + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'kcomp, iband, rh, ' + elseif(kcomp.eq.1) then + write(iu,*) 'kcomp, iband, rh, fombg, catot, fac, ' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'kcomp, iband, rh, catot, fac, ' + elseif(kcomp.eq.4) then + write(iu,*) 'kcomp, iband, rh, fbcbg, catot, fac, faq, ' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'kcomp, iband, rh, catot, fac, fbc, faq, ' + endif + write(iu,*) 'kabs(iband)' + write(iu,*) '' + write(iu,*) 'Here kabs is the specific absorption (m2/g),', + $ 'i.e. kabs(iband)=(1.0-omega(iband))*kext(iband)' + + elseif(iu.eq.9500) then +c Adding LUT header info for aerocomk*.out: + write(iu,*) 'This look-up table (LUT) contains the following ', + $ 'SW gross optical properties for a normalized aerosol size ', + $ 'distribution (N=1/cm3):' + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'kcomp, rh, ', + $ 'bebg(440), babg(440), bebg(500), babg(500), babg(550), ', + $ 'bebg(670), babg(670), bebg(870), babg(870), ', + $ 'bebglt1, bebggt1, backsc ' + elseif(kcomp.eq.1) then + write(iu,*) 'kcomp, rh, fombg, catot, fac, ' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'kcomp, rh, catot, fac, ' + elseif(kcomp.eq.4) then + write(iu,*) 'kcomp, rh, fbcbg, catot, fac, faq, ' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'kcomp, rh, catot, fac, fbc, faq, ' + endif ! kcomp + if(kcomp.ne.0) then + write(iu,*) 'bext(440), bext(500), bext(670), bext(870), ', + $ 'bebg(440), bebg(500), bebg(670), bebg(870), ', + $ 'bebc(440), bebc(500), bebc(670), bebc(870), ' + write(iu,*) 'beoc(440), beoc(500), beoc(670), beoc(870), ', + $ 'besu(440), besu(500), besu(670), besu(870), ', + $ 'babs(440), babs(500), babs(550), babs(670), babs(870), ' + write(iu,*) 'bebglt1, bebggt1, bebclt1, bebcgt1, ', + $ 'beoclt1, beocgt1, besult1, besugt1, backsc, ', + $ 'babg(550), babc(550), baoc(550), basu(550)' + endif ! kcomp + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'Here bebg and babg are the total extinction and ', + $ 'absorption coefficients (1/km) for the ' + write(iu,*) 'background aerosol ', + $ '(which is the total aerosol for this kcomp)' + else ! (kcomp = 1 - 10) + write(iu,*) 'Here bext and babs are the total extinction and ', + $ 'absorption coefficients (1/km), ' + write(iu,*) 'bebg and babg are the corresponding extinction ', + $ 'and absorption for the background aerosol, ' + write(iu,*) 'and similarly for the internally mixed ', + $ 'BC (bebc and babc), OC (beoc and baoc), and sulfate (besu ', + $ 'and basu), ' + endif ! kcomp + if(kcomp.eq.0) then + write(iu,*) 'all for the wavelengths (nm) given inside ', + $ 'the brackets. bebglt1 and bebggt1 are bebg(550) for ' + write(iu,*) 'particle diameters d < 1 um and d > 1 um, ', + $ 'respectively. ' + else ! (kcomp = 1 - 10) + write(iu,*) 'all for the wavelengths (nm) given inside ', + $ 'the brackets. bebglt1 and bebggt1 are bebg(550) for ' + write(iu,*) 'particle diameters d < 1 um and d > 1 um, ', + $ 'respectively, and similarly for the contribution' + write(iu,*) 'of internally mixed BC (bebc*1), OC (beoc*1) ', + $ 'and sulfate (besu*1). ' + endif + write(iu,*) 'backsc is the 550 nm backscatter coefficient ', + $ '(1/sr/km) at 180 degrees' + + elseif(iu.eq.9600) then +c Adding LUT header info for aerodryk*.out: + write(iu,*) 'This look-up table (LUT) contains the following ', + $ 'size integrated constituent mass and total area and volume ' + write(iu,*) 'concentrations for the modified, dry ', + $ 'aerosol size distribution (normalized so that N=1/cm3):' + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'kcomp, cintbg, cintbg05, cintbg125, ', + $ 'aaeros, aaerol, vaeros, vaerol' + elseif(kcomp.eq.1) then + write(iu,*) 'kcomp, fombg, catot, fac, ' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'kcomp, catot, fac, ' + elseif(kcomp.eq.4) then + write(iu,*) 'kcomp, fbcbg, catot, fac, faq, ' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'kcomp, catot, fac, fbc, faq, ' + endif ! kcomp + if(kcomp.ne.0) then + write(iu,*) 'cintbg, cintbg05, cintbg125, cintbc, cintbc05, ', + $ 'cintbc125,' + write(iu,*) 'cintoc, cintoc05, cintoc125, cintsc, cintsc05, ', + $ 'cintsc125,' + write(iu,*) 'cintsa, cintsa05, cintsa125, ', + $ 'aaeros, aaerol, vaeros, vaerol' + endif ! kcomp + write(iu,*) '' + if(kcomp.eq.0) then + write(iu,*) 'Here cintbg, cintbg05 and cintbg125 are ', + $ 'size-integrated dry mass concentrations intergrated over ' + write(iu,*) 'all radii r, r<0.5um and r>1.25um of the ', + $ 'background aerosol ', + $ '(which is the total aerosol for this kcomp)' + else ! (kcomp = 1 - 10) + write(iu,*) 'Here cintbg, cintbg05 and cintbg125 are ', + $ 'size-integrated dry mass concentrations intergrated over ' + write(iu,*) 'all radii r, r<0.5um and r>1.25um of the ', + $ 'background aerosol, and similarly (whether present or not for ', + $ 'this mode) ' + write(iu,*) 'cint*, cint*05 and cint*125 denote the ', + $ 'size-integrals for internally mixed ', + $ 'BC (bc), OC (oc), and sulfate ' + write(iu,*) 'in the form of H2SO4 (sc) and as (NH4)2SO4 (sa)' + endif ! kcomp + write(iu,*) 'aaeros and aaerol are size-integrated aerosol ', + $ 'areas for radii r<0.5um and r>0.5um, ' + write(iu,*) 'and vaeros and vaerol are size-integrated aerosol ', + $ 'volumes for radii r<0.5um and r>0.5um ' + + endif ! iu + + + if(iu.eq.9000.or.iu.eq.9009.or.iu.eq.9500) then ! for kcomp*.out, lwkcomp*.out or aerocomk*.out + write(iu,*) 'kcomp is the aerosol size mode number, ', + $ 'iband is the wavelength band number, rh is RH(%)/100 ' + else + write(iu,*) 'kcomp is the aerosol size mode number ' + endif + + if(kcomp.eq.0) then + write(iu,*) '(no added internally mixed mass to be taken ', + $ 'into account for this mode)' + elseif(kcomp.eq.1) then + write(iu,*) 'catot is total added internally mixed mass ', + $ '(ug/m3), fac is the OC (SOA) mass fraction ', + $ 'of catot (OC & H2SO4) ' + write(iu,*) 'and fombg is the mass fraction of OC (as SOA) ', + $ 'in the internally mixed background (of H2SO4 and SOA)' + if(iu.eq.9003) then + write(iu,*) '(Note: r and logsigma do not depend on fombg) ' + endif + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'catot is total added internally mixed mass ', + $ '(ug/m3), fac is the OC (SOA) mass fraction ', + $ 'of catot (OC & H2SO4) ' + elseif(kcomp.eq.4) then + write(iu,*) 'catot is total added internally mixed mass ', + $ '(ug/m3) as H2SO4 and (NH4)2SO4, fac is the mass fraction ', + $ 'of added SOA/(SOA+Sulfate) ' + write(iu,*) 'faq is the mass fraction of wet phase sulfate, ', + $ 'as (NH4)2SO4, of total added sulfate (catot), and' + write(iu,*) 'fbcbg is the mass mass fraction of BC ', + $ 'in the internally mixed background of OC and BC ' + if(iu.eq.9003) then + write(iu,*) '(Note: r and logsigma do not depend on fbcbg) ' + endif + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'catot is total added internally mixed mass ', + $ '(ug/m3), fac is the OC & BC mass fraction of catot, ', + $ 'fbc is BC fraction of that OC & BC ' + write(iu,*) 'and faq is the mass fraction of wet ', + $ 'phase sufate, as (NH4)2SO4, of total added sulfate' + endif ! kcomp + write(iu,*) '' + +c++++ Part with values for checking against CAM5-Oslo (X-CHECK...) +c This part can be used for all LUT, except RH, hygroscopicity and +c wavelength info, whis is not written out for dry aerosol tables +c (logntilp*.out and aerodryk*.out). + + write(iu,*) 'This LUT is made with an AeroTab version ', + $ 'with the following input parameters, to be checked ' + write(iu,*) 'against CAM5-Oslo (producing error messages on ', + $ 'inconsistencies):' + if(iu.eq.9000.or.iu.eq.9009.or.iu.eq.9500) then + write(iu,*) 'Discrete input-values of' + write(iu,*) 'X-CHECK relh =' + write(iu,500) relh + endif ! iu + if(kcomp.eq.0) then + write(iu,*) '(catot, fac, fbc, faq: not used)' + elseif(kcomp.eq.1) then + if(iu.ne.9003) then + write(iu,*) 'X-CHECK fombg =' + write(iu,400) fombg + endif + write(iu,*) 'X-CHECK catot =' + write(iu,300) catote + write(iu,*) 'X-CHECK fac =' + write(iu,400) fac + write(iu,*) '(fbc, faq: not used)' + elseif(kcomp.eq.2.or.kcomp.eq.3) then + write(iu,*) 'X-CHECK catot =' + write(iu,300) catote + write(iu,*) 'X-CHECK fac =' + write(iu,400) fac + write(iu,*) '(fombg, fbc, faq: not used)' + elseif(kcomp.eq.4) then + if(iu.ne.9003) then + write(iu,*) 'X-CHECK fbcbg =' + write(iu,400) fbcbg + endif + write(iu,*) 'X-CHECK catot =' + write(iu,300) catote + write(iu,*) 'X-CHECK fac =' + write(iu,400) fac + write(iu,*) '(fbc, faq: not used)' + else ! (kcomp = 5, 6, 7, 8, 9 or 10) + write(iu,*) 'X-CHECK catot =' + write(iu,400) catot + write(iu,*) 'X-CHECK fac =' + write(iu,400) fac + write(iu,*) 'X-CHECK fbc =' + write(iu,400) fbc + write(iu,*) 'X-CHECK faq =' + write(iu,400) faq + endif ! kcomp + + write(iu,*) 'Modal median dry radius (m) at point of emission ' + write(iu,*) 'X-CHECK originalNumberMedianRadius =' + write(iu,200) originalNumberMedianRadius(kcomp) + write(iu,*) 'and corresponding standard deviation ' + write(iu,*) 'X-CHECK originalSigma =' + write(iu,200) originalSigma(kcomp) + write(iu,*) 'Aerosol type mass densities (kg/m3) for ', + $ 'ammonium sulfate, BC, OC, dust and sea-salt ' + write(iu,*) 'X-CHECK aerosol_type_density =' + write(iu,100) aerosol_type_density + if(iu.eq.9000.or.iu.eq.9009.or.iu.eq.9500) then ! for kcomp*.out, lwkcomp*.out or aerocomk*.out + write(iu,*) 'and their corresponding hygroscopicities ', + $ 'at RH~100%' + write(iu,*) 'X-CHECK hygroscopicities =' + write(iu,100) xa, xbc, xoc, xdst, xss + write(iu,*) 'Number of wavelength bands in AeroTab ', + $ '(before Chandrasekhar averaging) ' + write(iu,*) 'X-CHECK ib =' + write(iu,50) ib + write(iu,*) 'and the number of wavelength bands used ', + $ 'in CAM5-Oslo:' + write(iu,*) 'X-CHECK ibcam =' + write(iu,50) ibcam + endif ! iu + +c Finally, the table values to be used for look-ups and interpolations in CAM5-Oslo: + write(iu,*) '' + write(iu,*) 'X-CHECK LUT: table values to be used ', + $ 'for look-ups and interpolations in CAM5-Oslo:' +c---- + + enddo ! i (iu value) + + + 50 format(x,i2) + 100 format(5(x,e11.5)) + 200 format(x,e11.5) + 300 format(16(x,e10.4)) + 400 format(6(x,e10.4)) + 500 format(10(x,e9.3)) + + return + end diff --git a/tools/AeroTab/tabrefind.f b/tools/AeroTab/tabrefind.f new file mode 100644 index 0000000000..a9e6366571 --- /dev/null +++ b/tools/AeroTab/tabrefind.f @@ -0,0 +1,97 @@ + subroutine tabrefind (kcomp, ib, xlam, cref) + +c ********************************************************************************** +c Created by Alf KirkevÃ¥g. +c ********************************************************************************** + +c Here wavelength dependent complex rafractive indices (cref) +c are found from tabulated values for each aerosol component. + + implicit none + + INTEGER j, kcomp, ib, iband + REAL xlam(31), lam, lamg, nr, nrg, ni, nig + COMPLEX crin, cref(5,31) + +c initializing cref-array: + do iband = 1, 31 + do j=1,5 + cref(j,iband) = 0.0 + enddo + enddo + + do iband = 1, ib + + do 300 j=1,5 + +c refractive indices for background aerosol +c Here bacground aerosol does not take into account internal mixing, +c so this must be taken into account separately in refind.f for modes +c which have internal mixtures of two constituents! + if(j.eq.1) then + if(kcomp.eq.1.or.kcomp.eq.5) then + open(10, file='input/suso_gads.inp', status='old') + elseif(kcomp.eq.2) then +cbc open(10, file='input/sot_janzen.inp', status='old') + open(10, file='input/sot_bond.inp', status='old') + elseif(kcomp.eq.3.or.kcomp.eq.4) then + open(10, file='input/waso_gads.inp', status='old') + elseif(kcomp.eq.6.or.kcomp.eq.7) then +!orig open(10, file='input/mineral_mix.inp', status='old') + open(10, file='input/mineral_gads.inp', status='old') + elseif(kcomp.eq.8.or.kcomp.eq.9.or.kcomp.eq.10) then + open(10, file='input/ss_gads.inp', status='old') + else + goto 300 + endif +c refractive indices for components to be internally mixed +c with the background aerosol + elseif(j.eq.2) then + open(10, file='input/suso_gads.inp', status='old') + elseif(j.eq.3) then +cbc open(10, file='input/sot_janzen.inp', status='old') + open(10, file='input/sot_bond.inp', status='old') + elseif(j.eq.4) then + open(10, file='input/water_gads.inp', status='old') + elseif(j.eq.5) then ! assumed OC refractive index + open(10, file='input/waso_gads.inp', status='old') + endif + + lamg=0 + nrg=0 + nig=0 + + read(10,*) + read(10,*) + read(10,*) + read(10,*) + read(10,*) + 100 read(10,*) lam, nr, ni + if(lam.gt.xlam(iband)) then + cref(j,iband)= + $ (1e0,0e0)*(xlam(iband)*(nr-nrg)+(nrg*lam-nr*lamg))/(lam-lamg) + $ -(0e0,1e0)*(xlam(iband)*(ni-nig)+(nig*lam-ni*lamg))/(lam-lamg) + goto 200 + else + lamg=lam + nrg=nr + nig=ni + goto 100 + endif + 200 close(10) + + 300 continue + + enddo ! iband + + end + + + + + + + + + + diff --git a/tools/aerocom/createaerocom.sh b/tools/aerocom/createaerocom.sh new file mode 100755 index 0000000000..06e2997267 --- /dev/null +++ b/tools/aerocom/createaerocom.sh @@ -0,0 +1,203 @@ +#!/bin/bash + +LL=29 +MODELNAME=CAM53-Oslo +#AVAILABLEYEARS=(0003 0004 0005 0006 0007 0008 0009 0010 0011 0012) +AVAILABLEYEARS=(0015 0016 0017 0018 0019) +AVAILABLEMONTHS=(01 02 03 04 05 06 07 08 09 10 11 12) +INPUTDIRECTORY=/projects/NS2345K/noresm/cases +#EXPERIMENTNAME=PD_MG15MegVadSOA +EXPERIMENTNAME=PDaug16UVPSndg +FULLEXPERIMENTNAME=6b76dca_MG15CLM45_22aug2016AK_${EXPERIMENTNAME} +OUTPUTDIRECTORY=/projects/NS2345K/CAM-Oslo/DO_AEROCOM/${MODELNAME}_${FULLEXPERIMENTNAME}/renamed +coordinateType="" #Just for initialization , leave this +PERIOD=9999 +FREQUENCY="monthly" +#converts from sulfuric acid (H2SO4) to SO4 (96/98 MW) +SF1="0.9796f" +#converts from ammonium sulfate (NH4_2SO4) to SO4 (96/134 MW) +SF2="0.7273f" + +#Function to get Level coordinate +#This is just needed since I think is cleaner to use +#abbreviations for this in the variable-array below +function getVariableCoordinateString() +{ + local __input=$1 + if [ $__input = "M" ];then + coordinateType="ModelLevel" + elif [ $__input = "S" ];then + coordinateType="Surface" + elif [ $__input = "C" ];then + coordinateType="Column" + elif [ $__input = "SS" ];then + coordinateType="SurfaceAtStations" + elif [ $__input = "MS" ];then + coordinateType="ModelLevelAtStations" + else + coordinateType="INVALIDCOORDINATETYPE" + fi +} + +#Create output directory if it does not exist +if [ ! -d "$OUTPUTDIRECTORY" ];then + echo CREATING OUTPUT DIR $OUTPUTDIRECTORY + mkdir -p $OUTPUTDIRECTORY +fi + +#ARRAY HAS SYNTAX: +#AEROCOMNAME&CAMOSLONAME(OR FORMULA)&UNIT&CoordinateType +ARRAY=("area&GRIDAREA&m2&S" + "landf&LANDFRAC&1&S" + "ps&PS&Pa&S" + "od550csaer&CDOD550/(CLDFREE+1.e-4f)&1&C" + "od440csaer&CDOD440/(CLDFREE+1.e-4f)&1&C" + "od870csaer&CDOD870/(CLDFREE+1.e-4f)&1&C" + "od550aer&DOD550&1&C" + "od440aer&DOD440&1&C" + "od550aer&DOD500&1&C" + "od670aer&DOD670&1&C" + "od870aer&DOD870&1&C" + "abs440aer&ABS440&1&C" + "abs500aer&ABS500&1&C" + "abs670aer&ABS670&1&C" + "abs870aer&ABS870&1&C" + "abs550aer&ABS550AL&1&C" + "abs550bc&A550_BC&1&C" + "abs550dust&A550_DU&1&C" + "abs550oa&A550_POM&1&C" + "abs550so4&A550_SO4&1&C" + "abs550ss&A550_SS&1&C" + "od550so4&D550_SO4&1&C" + "od550bc&D550_BC&1&C" + "od550oa&D550_POM&1&C" + "od550ss&D550_SS&1&C" + "od550dust&D550_DU&1&C" + "od550lt1dust&DLT_DUST&1&C" + "abs440aercs&CDOD550/(CLDFREE+1.e-4f)&1&C" + "od550lt1aer&DLT_SS+DLT_DUST+DLT_SO4+DLT_BC+DLT_POM&1&C" + "od550aerh2o&DOD550-OD550DRY&1&C" + "emiso2&SFSO2+SO2_CLXF&kg m-2 s-1&S" + "emidms&SFDMS&kg m-2 s-1&S" + "emidust&SFDST_A2+SFDST_A3&kg m-2 s-1&S" + "emiss&SFSS_A1+SFSS_A2+SFSS_A3&kg m-2 s-1&S" + "emibc&SFBC_A+SFBC_AX+SFBC_AC+SFBC_N+SFBC_NI+SFBC_AI+BC_N_CLXF+BC_NI_CLXF+BC_AX_CLXF&kg m-2 s-1&S" + "emioa&SFOM_AC+SFOM_AI+SFOM_NI+OM_NI_CLXF&kg m-2 s-1&S" + "emiso4&$SF1*(SFSO4_A1+${SF2}/${SF1}*SFSO4_A2+SFSO4_AC+SFSO4_NA+SFSO4_PR+SO4_PR_CLXF)&kg m-2 s-1&S" + "chepso2&(GS_SO2-SO2_CLXF)-GS_H2SO4&kg m-2 s-1&S" + "chegpso4&$SF1*GS_H2SO4&kg m-2 s-1&S" + "cheaqpso4&$SF2*AQ_SO4_A2_OCW&kg m-2 s-1&S" + "wetdms&WD_A_DMS&kg m-2 s-1&S" + "wetso2&WD_A_SO2&kg m-2 s-1&S" + "wetoa&-1.0f*(OM_ACSFWET+OM_AISFWET+OM_NISFWET+SOA_A1SFWET+SOA_NASFWET+OM_AC_OCWSFWET+OM_AI_OCWSFWET+OM_NI_OCWSFWET+SOA_NA_OCWSFWET+SOA_A1_OCWSFWET)&kg m-1 s-1&S" + "wetbc&-1.0f*(BC_ASFWET+BC_AISFWET+BC_AXSFWET+BC_ACSFWET+BC_NSFWET+BC_NISFWET+BC_A_OCWSFWET+BC_AI_OCWSFWET+BC_AC_OCWSFWET+BC_N_OCWSFWET+BC_NI_OCWSFWET)&kg m-2 s-1&S" + "wetdust&-1.0f*(DST_A2SFWET+DST_A3SFWET+DST_A2_OCWSFWET+DST_A3_OCWSFWET)&kg m-2 s-1&S" + "wetss&-1.0*(SS_A1SFWET+SS_A2SFWET+SS_A3SFWET+SS_A1_OCWSFWET+SS_A2_OCWSFWET+SS_A3_OCWSFWET)&kg m-2 s-1&S" + "wetso4&-1.0f*$SF1*(SO4_ACSFWET+SO4_A1SFWET+${SF2}/${SF1}*SO4_A2SFWET+SO4_PRSFWET+SO4_NASFWET+SO4_ACSFWET+SO4_A1_OCWSFWET+${SF2}/${SF1}*SO4_A2_OCWSFWET+SO4_PR_OCWSFWET+SO4_NA_OCWSFWET)&kg m-2 s-1&S" + "dryoa&-1.0*(OM_ACDDF+OM_NIDDF+OM_AIDDF+SOA_NADDF+SOA_A1DDF+OM_AC_OCWDDF+OM_NI_OCWDDF+OM_AI_OCWDDF+SOA_NA_OCWDDF+SOA_A1_OCWDDF)&kg m-2 s-1&S" + "drybc&-1.0f*(BC_ADDF+BC_AIDDF+BC_ACDDF+BC_AXDDF+BC_NDDF+BC_NIDDF+BC_A_OCWDDF+BC_AI_OCWDDF+BC_AC_OCWDDF+BC_N_OCWDDF+BC_NI_OCWDDF)&kg m-2 s-1&S" + "dryss&-1.0f*(SS_A1DDF+SS_A2DDF+SS_A3DDF+SS_A1_OCWDDF+SS_A2_OCWDDF+SS_A3_OCWDDF)&kg m-2 s-1&S" + "drydust&-1.0f*(DST_A2DDF+DST_A3DDF+DST_A2_OCWDDF+DST_A3_OCWDDF)&kg m-2 s-1&S" + "dryso4&-1.0f*$SF1*(SO4_A1DDF+${SF2}/${SF1}*SO4_A2DDF+SO4_NADDF+SO4_PRDDF+SO4_ACDDF+SO4_A1_OCWDDF+${SF2}/${SF1}*SO4_A2_OCWDDF+SO4_NA_OCWDDF+SO4_PR_OCWDDF+SO4_AC_OCWDDF)&kg m-2 s-1&S" + "dryso2&DF_SO2&kg m-2 s-1&S" + "drydms&DF_DMS&kg m-2 s-1&S" + "loadoa&cb_OM+cb_OM_NI_OCW+cb_OM_AI_OCW+cb_OM_AC_OCW+cb_SOA_NA_OCW+cb_SOA_A1_OCW&kg m-2&C" + "loadbc&cb_BC+cb_BC_NI_OCW+cb_BC_N_OCW+cb_BC_A_OCW+cb_BC_AI_OCW+cb_BC_AC_OCW&kg m-2&C" + "loadss&cb_SALT+cb_SS_A1_OCW+cb_SS_A2_OCW+cb_SS_A3_OCW&kg m-2&C" + "loaddust&cb_DUST+cb_DST_A2_OCW+cb_DST_A3_OCW&kg m-2&C" + "loadso2&cb_SO2&kg m-2&C" + "loadso4&$SF1*(cb_SO4_A1+${SF2}/${SF1}*cb_SO4_A2+cb_SO4_NA+cb_SO4_PR+cb_SO4_AC+cb_SO4_A1_OCW+${SF2}/${SF1}*cb_SO4_A2_OCW+cb_SO4_AC_OCW+cb_SO4_NA_OCW+cb_SO4_PR_OCW)&kg m-2&C" + "loaddms&cb_DMS&kg m-2&C" + "clt&CLDTOT&1&C" + "rsdt&SOLIN&W m-2&S" + "rsds&FSDS&W m-2&S" + "rsut&FSUTOA&W m-2&S" + "rsus&FSDS-FSNS&W m-2&S" + "rsdscs&FSDSC&W m-2&S" + "rlutcs&FLUTC&W m-2&C" + "rlut&FLUT&W m-2&C" + "rlds&FLDS&W m-2&C" + "rlus&FLDS-FLNS&W m-2&C" + "orog&PHIS/9.81f&m&S" + "precip&(PRECC+PRECL)*1.e3f&kg m-2 s-1&M" + "temp&T&K&M" + "hus&Q&K&M" + "airmass&AIRMASS&kg m-3&M" + "ec5503Daer&EC550AER&m-1&M" + "ec550dryaer&ECDRYAER&m-1&M" + "abs550dryaer&ABSDRYAE&m-1&M" + "abs5503Daer&ABS550_A&m-1&M" + "bc5503Daer&BS550AER&m-1 sr-1&M" + "cl3D&CLOUD&1&M" + "asy3Daer&ASYMMVIS&1&M" + "mmraerh2o&MMR_AH2O&kg kg-1&M" + "vmrso2&SO2/64.066f*28.97f&kg kg-1&M" + "vmrdms&DMS/62.13f*28.97f&kg kg-1&M" + "mmrso4&$SF1*(SO4_A1+${SF2}/${SF1}*SO4_A2+SO4_AC+SO4_NA+SO4_PR+SO4_A1_OCW+${SF2}/${SF1}*SO4_A2_OCW+SO4_AC_OCW+SO4_NA_OCW+SO4_PR_OCW)&kg kg-1&M" + "mmroa&OM_AC+OM_AI+OM_NI+SOA_NA+SOA_A1+OM_AC_OCW+OM_AI_OCW+OM_NI_OCW+SOA_NA_OCW+SOA_A1_OCW&kg kg-1&M" + "mmrbc&BC_A+BC_AC+BC_AX+BC_N+BC_NI+BC_AI+BC_A_OCW+BC_AC_OCW+BC_N_OCW+BC_NI_OCW+BC_AI_OCW&kg kg-1&M" + "mmrss&SS_A1+SS_A2+SS_A3+SS_A1_OCW+SS_A2_OCW+SS_A3_OCW&kg kg-1&M" + "mmrdu&DST_A2+DST_A3+DST_A2_OCW+DST_A3_OCW&kg kg-1&M" + "pressure[time,lev,lat,lon]&float(P0*hyam+PS*hybm)&Pa&M" + "sconcso4[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*$SF1*(SO4_A1(:,$LL,:,:)+${SF2}/${SF1}*SO4_A2(:,$LL,:,:)+SO4_PR(:,$LL,:,:)+SO4_NA(:,$LL,:,:)+SO4_A1_OCW(:,$LL,:,:)+${SF2}/${SF1}*SO4_A2_OCW(:,$LL,:,:)+SO4_PR_OCW(:,$LL,:,:)+SO4_NA_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcso2[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*SO2(:,$LL,:,:)*1.e9f&ug m-3&S" + "sconcdms[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*DMS(:,$LL,:,:)*1.e9f&ug m-3&S" + "sconcss[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(SS_A1(:,$LL,:,:)+SS_A2(:,$LL,:,:)+SS_A3(:,$LL,:,:)+SS_A1_OCW(:,$LL,:,:)+SS_A2_OCW(:,$LL,:,:)+SS_A3_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcdust[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(DST_A2(:,$LL,:,:)+DST_A3(:,$LL,:,:)+DST_A2_OCW(:,$LL,:,:)+DST_A3_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcbc[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(BC_A(:,$LL,:,:)+BC_AC(:,$LL,:,:)+BC_AX(:,$LL,:,:)+BC_N(:,$LL,:,:)+BC_NI(:,$LL,:,:)+BC_AI(:,$LL,:,:)+BC_A_OCW(:,$LL,:,:)+BC_AC_OCW(:,$LL,:,:)+BC_N_OCW(:,$LL,:,:)+BC_NI_OCW(:,$LL,:,:)+BC_AI_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcoa[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(OM_AC(:,$LL,:,:)+OM_AI(:,$LL,:,:) +OM_NI(:,$LL,:,:)+SOA_NA(:,$LL,:,:)+SOA_A1(:,$LL,:,:)+OM_AC_OCW(:,$LL,:,:)+OM_AI_OCW(:,$LL,:,:)+OM_NI_OCW(:,$LL,:,:)+SOA_NA_OCW(:,$LL,:,:)+SOA_A1_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + ) + + +#For each month ==> do an ensemble average of the variables in question +for aMonth in ${AVAILABLEMONTHS[@]};do + fileList="" + for aYear in ${AVAILABLEYEARS[@]}; do + echo $aYear $aMonth + fileList+="$INPUTDIRECTORY/$EXPERIMENTNAME/atm/hist/$EXPERIMENTNAME.cam.h0.$aYear-$aMonth.nc" + fileList+=" " + #echo $fileList + done + echo Will perform ncea for month $aMonth $fileList $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_$aMonth.nc + ncea -O $fileList $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_$aMonth.nc + echo $fileList +done +#Now that we have an enesmble for each month ==> merge them with ncrcat! +TMPOUTPUTFILE=$OUTPUTDIRECTORY/${EXPERIMENTNAME}_MONTHLY.nc +ncrcat -O $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_*.nc $TMPOUTPUTFILE + +#The rest of the script operates on the ensemble average file + +#Go through all entries and apply formulas as specified by table +for entry in "${ARRAY[@]}"; do + #VARIABLE TO CREATE + KEY=${entry%%&*} #This is Aerocom-name (including dimensions if needed by ncap2) + UNITKEY=${KEY%%[*} #This is Aerocom-name (skip anything following "[") + TMPVALUE=${entry#*&} #This is the formula to be used (AND UNITS AND COORDINATES) + #VALUE TO EXTRACT + VALUE=${TMPVALUE%%&*} #This is the formula to be used (REMOVED UNITS) + #UNIT OF OUTPUT VALUE + TMPUNIT=${TMPVALUE#*&} #These are the units AND MODEL COORDINATE + + UNIT=${TMPUNIT%%&*} + TMPCOORD=${TMPUNIT#*&} + + getVariableCoordinateString $TMPCOORD + + #BASED ON VARIABLE NAME, THIS IS OUTPUT FILE + OUTFILE=$OUTPUTDIRECTORY/aerocom3_${MODELNAME}_${FULLEXPERIMENTNAME}_${UNITKEY}_${coordinateType}_${PERIOD}_${FREQUENCY}.nc + echo "...extracting ${KEY} using formula " $KEY "=" $VALUE " , unit= " $UNIT + ncap2 -O -v -s "$KEY=$VALUE" $TMPOUTPUTFILE $OUTFILE + #Add some more variables to final output file + ncks -A -v gw,time_bnds $TMPOUTPUTFILE $OUTFILE + #Make sure unit is correct + #echo "...changing unit for ${UNITKEY} " + ncatted -O -a units,${UNITKEY},o,c,"${UNIT}" ${OUTFILE} +done + +#Clean up and make sure anyone can read this.. +chmod -R a+r $OUTPUTDIRECTORY +rm $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_??.nc +rm $OUTPUTDIRECTORY/${EXPERIMENTNAME}_MONTHLY.nc + +exit diff --git a/tools/aerocom/createaerocomCAM6-Oslo.sh b/tools/aerocom/createaerocomCAM6-Oslo.sh new file mode 100755 index 0000000000..b4e10f7862 --- /dev/null +++ b/tools/aerocom/createaerocomCAM6-Oslo.sh @@ -0,0 +1,242 @@ +#!/bin/bash + +#LL=29 +LL=31 +#MODELNAME=CAM53-Oslo +MODELNAME=CAM6-Oslo + +#AVAILABLEYEARS=(2003 2004 2005 2006 2007 2008 2009 2010 2011 2012) +#AVAILABLEYEARS=(2006 2007 2008 2009 2010 2011 2012 2013 2014) +AVAILABLEYEARS=(2010) +#AVAILABLEYEARS=(0030) +#AVAILABLEYEARS=(0003 0004 0005 0006 0007 0008 0009 0010 0011 0012 0013 0014 0015 0016 0017 0018 0019 0020 0021 0022 0023 0024 0025 0026 0027 0028 0029 0030) +#AVAILABLEYEARS=(0020 0021 0022 0023 0024 0025 0026 0027 0028 0029 0030) +AVAILABLEMONTHS=(01 02 03 04 05 06 07 08 09 10 11 12) + +#INPUTDIRECTORY=/projects/NS2345K/noresm/cases/aeroCAM53Ref/ +#INPUTDIRECTORY=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNucl-all/ +#INPUTDIRECTORY=/projects/NS2345K/noresm/cases/NF2k2rosc1dp/ +#INPUTDIRECTORY=/projects/NS9560K/noresm/cases/NF1850norbc_aer2014_f19_20190727/ +#INPUTDIRECTORY=/projects/NS9560K/noresm/cases/ +#INPUTDIRECTORY=/projects/NS2345K/noresm/cases/divClim4aerosoldiag/ +INPUTDIRECTORY=/projects/NS2345K/noresm/cases/divClim4aerosoldiag/NHIST_f19_tn14_20190710_yr2010/nc3/ + +#EXPERIMENTNAME=7310AMIP20002 +#EXPERIMENTNAME=F2000ERF +#EXPERIMENTNAME=NF2kNucl +#EXPERIMENTNAME=NF2k2rosc1dp +#EXPERIMENTNAME=NF1850norbc_aer2014_f19_20190727 +#EXPERIMENTNAME=altRHpiclimaer +EXPERIMENTNAME=NHIST_f19_tn14_20190710 + +#EXPERIMENTNAME2=PD_ERA_2001-2015 +#FULLEXPERIMENTNAME=CAM53-Oslo_7310_MG15CLM45_5feb2017IHK +#FULLEXPERIMENTNAME=NF2k2rosc1dp_7sep2018AK +#FULLEXPERIMENTNAME=NF1850norbc_aer2014_f19_20190727 +#FULLEXPERIMENTNAME=altRHpiclimaer +FULLEXPERIMENTNAME=NHIST_f19_tn14_20190710 + +#can chose final directory below, or just cp there later after checking the results: +#OUTPUTDIRECTORY=/projects/NS2345K/CAM-Oslo/DO_AEROCOM/${MODELNAME}_${FULLEXPERIMENTNAME}/renamed +#OUTPUTDIRECTORY=/scratch/kirkevag/NF2k2rosc1dp/ +#OUTPUTDIRECTORY=/scratch/kirkevag/NF1850norbc_aer2014_f19_20190727/ +OUTPUTDIRECTORY=/scratch/kirkevag/NHIST_f19_tn14_20190710/Oct24Version/ + +coordinateType="" #Just for initialization , leave this +#PERIOD=9999 +PERIOD=2010 +FREQUENCY="monthly" +#converts from sulfuric acid (H2SO4) to SO4 (96/98 MW) +SF1="0.9796f" +#converts from ammonium sulfate (NH4_2SO4) to SO4 (96/134 MW) +SF2="0.7273f" + +#Function to get Level coordinate +#This is just needed since I think is cleaner to use +#abbreviations for this in the variable-array below +function getVariableCoordinateString() +{ + local __input=$1 + if [ $__input = "M" ];then + coordinateType="ModelLevel" + elif [ $__input = "S" ];then + coordinateType="Surface" + elif [ $__input = "C" ];then + coordinateType="Column" + elif [ $__input = "SS" ];then + coordinateType="SurfaceAtStations" + elif [ $__input = "MS" ];then + coordinateType="ModelLevelAtStations" + else + coordinateType="INVALIDCOORDINATETYPE" + fi +} + +#Create output directory if it does not exist +if [ ! -d "$OUTPUTDIRECTORY" ];then + echo CREATING OUTPUT DIR $OUTPUTDIRECTORY + mkdir -p $OUTPUTDIRECTORY +fi + +#ARRAY HAS SYNTAX: +#AEROCOMNAME&CAMOSLONAME(OR FORMULA)&UNIT&CoordinateType +ARRAY=("area&GRIDAREA&m2&S" + "landf&LANDFRAC&1&S" + "ps&PS&Pa&S" + "od550csaer&CDOD550/(CLDFREE+1.e-4f)&1&C" + "od440csaer&CDOD440/(CLDFREE+1.e-4f)&1&C" + "od870csaer&CDOD870/(CLDFREE+1.e-4f)&1&C" + "od550aer&DOD550&1&C" + "od440aer&DOD440&1&C" + "od500aer&DOD500&1&C" + "od670aer&DOD670&1&C" + "od870aer&DOD870&1&C" + "abs440aer&ABS440&1&C" + "abs500aer&ABS500&1&C" + "abs670aer&ABS670&1&C" + "abs870aer&ABS870&1&C" + "abs550aer&ABS550AL&1&C" + "abs550bc&A550_BC&1&C" + "abs550dust&A550_DU&1&C" + "abs550oa&A550_POM&1&C" + "abs550so4&A550_SO4&1&C" + "abs550ss&A550_SS&1&C" + "od550so4&D550_SO4&1&C" + "od550bc&D550_BC&1&C" + "od550oa&D550_POM&1&C" + "od550ss&D550_SS&1&C" + "od550dust&D550_DU&1&C" + "od550lt1dust&DLT_DUST&1&C" + "abs550aercs&CABS550/(CLDFREE+1.e-4f)&1&C" + "od550lt1aer&DLT_SS+DLT_DUST+DLT_SO4+DLT_BC+DLT_POM&1&C" + "od550gt1aer&DOD550-DLT_SS-DLT_DUST-DLT_SO4-DLT_BC-DLT_POM&1&C" + "od550aerh2o&DOD550-OD550DRY&1&C" + "emiso2&SFSO2+SO2_CMXF&kg m-2 s-1&S" + "emidms&SFDMS&kg m-2 s-1&S" + "emidust&SFDST_A2+SFDST_A3&kg m-2 s-1&S" + "emiss&SFSS_A1+SFSS_A2+SFSS_A3&kg m-2 s-1&S" + "emibc&SFBC_A+SFBC_AX+SFBC_AC+SFBC_N+SFBC_NI+SFBC_AI+BC_N_CMXF+BC_NI_CMXF+BC_AX_CMXF&kg m-2 s-1&S" + "emioa&SFOM_AC+SFOM_AI+SFOM_NI+OM_NI_CMXF&kg m-2 s-1&S" + "emiso4&$SF1*(SFSO4_A1+${SF2}/${SF1}*SFSO4_A2+SFSO4_AC+SFSO4_NA+SFSO4_PR+SO4_PR_CMXF)&kg m-2 s-1&S" + "chepso2&(GS_SO2-SO2_CMXF)-GS_H2SO4&kg m-2 s-1&S" + "chegpso4&$SF1*GS_H2SO4&kg m-2 s-1&S" + "cheaqpso4&$SF2*AQ_SO4_A2_OCW&kg m-2 s-1&S" + "wetdms&WD_A_DMS&kg m-2 s-1&S" + "wetso2&WD_A_SO2&kg m-2 s-1&S" + "wetoa&-1.0f*(OM_ACSFWET+OM_AISFWET+OM_NISFWET+SOA_A1SFWET+SOA_NASFWET+OM_AC_OCWSFWET+OM_AI_OCWSFWET+OM_NI_OCWSFWET+SOA_NA_OCWSFWET+SOA_A1_OCWSFWET)&kg m-1 s-1&S" + "wetbc&-1.0f*(BC_ASFWET+BC_AISFWET+BC_AXSFWET+BC_ACSFWET+BC_NSFWET+BC_NISFWET+BC_A_OCWSFWET+BC_AI_OCWSFWET+BC_AC_OCWSFWET+BC_N_OCWSFWET+BC_NI_OCWSFWET)&kg m-2 s-1&S" + "wetdust&-1.0f*(DST_A2SFWET+DST_A3SFWET+DST_A2_OCWSFWET+DST_A3_OCWSFWET)&kg m-2 s-1&S" + "wetss&-1.0*(SS_A1SFWET+SS_A2SFWET+SS_A3SFWET+SS_A1_OCWSFWET+SS_A2_OCWSFWET+SS_A3_OCWSFWET)&kg m-2 s-1&S" + "wetso4&-1.0f*$SF1*(SO4_ACSFWET+SO4_A1SFWET+${SF2}/${SF1}*SO4_A2SFWET+SO4_PRSFWET+SO4_NASFWET+SO4_AC_OCWSFWET+SO4_A1_OCWSFWET+${SF2}/${SF1}*SO4_A2_OCWSFWET+SO4_PR_OCWSFWET+SO4_NA_OCWSFWET)&kg m-2 s-1&S" + "dryoa&-1.0*(OM_ACDDF+OM_NIDDF+OM_AIDDF+SOA_NADDF+SOA_A1DDF+OM_AC_OCWDDF+OM_NI_OCWDDF+OM_AI_OCWDDF+SOA_NA_OCWDDF+SOA_A1_OCWDDF)&kg m-2 s-1&S" + "drybc&-1.0f*(BC_ADDF+BC_AIDDF+BC_ACDDF+BC_AXDDF+BC_NDDF+BC_NIDDF+BC_A_OCWDDF+BC_AI_OCWDDF+BC_AC_OCWDDF+BC_N_OCWDDF+BC_NI_OCWDDF)&kg m-2 s-1&S" + "dryss&-1.0f*(SS_A1DDF+SS_A2DDF+SS_A3DDF+SS_A1_OCWDDF+SS_A2_OCWDDF+SS_A3_OCWDDF)&kg m-2 s-1&S" + "drydust&-1.0f*(DST_A2DDF+DST_A3DDF+DST_A2_OCWDDF+DST_A3_OCWDDF)&kg m-2 s-1&S" + "dryso4&-1.0f*$SF1*(SO4_A1DDF+${SF2}/${SF1}*SO4_A2DDF+SO4_NADDF+SO4_PRDDF+SO4_ACDDF+SO4_A1_OCWDDF+${SF2}/${SF1}*SO4_A2_OCWDDF+SO4_NA_OCWDDF+SO4_PR_OCWDDF+SO4_AC_OCWDDF)&kg m-2 s-1&S" + "dryso2&DF_SO2&kg m-2 s-1&S" + "drydms&DF_SO2*0.0f&kg m-2 s-1&S" + "loadoa&cb_OM+cb_OM_NI_OCW+cb_OM_AI_OCW+cb_OM_AC_OCW+cb_SOA_NA_OCW+cb_SOA_A1_OCW&kg m-2&C" + "loadbc&cb_BC+cb_BC_NI_OCW+cb_BC_N_OCW+cb_BC_A_OCW+cb_BC_AI_OCW+cb_BC_AC_OCW&kg m-2&C" + "loadss&cb_SALT+cb_SS_A1_OCW+cb_SS_A2_OCW+cb_SS_A3_OCW&kg m-2&C" + "loaddust&cb_DUST+cb_DST_A2_OCW+cb_DST_A3_OCW&kg m-2&C" + "loadso2&cb_SO2&kg m-2&C" + "loadso4&$SF1*(cb_SO4_A1+${SF2}/${SF1}*cb_SO4_A2+cb_SO4_NA+cb_SO4_PR+cb_SO4_AC+cb_SO4_A1_OCW+${SF2}/${SF1}*cb_SO4_A2_OCW+cb_SO4_AC_OCW+cb_SO4_NA_OCW+cb_SO4_PR_OCW)&kg m-2&C" + "loaddms&cb_DMS&kg m-2&C" + "clt&CLDTOT&1&C" + "rsdt&SOLIN&W m-2&S" + "rsds&FSDS&W m-2&S" + "rsut&FSUTOA&W m-2&S" + "rsus&FSDS-FSNS&W m-2&S" + "rsdscs&FSDSC&W m-2&S" + "rlutcs&FLUTC&W m-2&C" + "rlut&FLUT&W m-2&C" + "rlds&FLDS&W m-2&C" + "rlus&FLDS-FLNS&W m-2&C" + "orog&PHIS/9.81f&m&S" + "precip&(PRECC+PRECL)*1.e3f&kg m-2 s-1&M" + "temp&T&K&M" + "hus&Q&K&M" + "airmass&AIRMASS&kg m-3&M" + "ec550aer&EC550AER&m-1&M" + "ec550dryaer&ECDRYAER&m-1&M" + "abs550dryaer&ABSDRYAE&m-1&M" + "absc550aer&ABS550_A&m-1&M" + "bc5503Daer&BS550AER&m-1 sr-1&M" + "cl3D&CLOUD&1&M" + "asy3Daer&ASYMMVIS&1&M" + "mmraerh2o&MMR_AH2O&kg kg-1&M" + "vmrso2&SO2&m3 m-3&M" + "vmrdms&DMS&m3 m-3&M" + "mmrso4&$SF1*(SO4_A1+${SF2}/${SF1}*SO4_A2+SO4_AC+SO4_NA+SO4_PR+SO4_A1_OCW+${SF2}/${SF1}*SO4_A2_OCW+SO4_AC_OCW+SO4_NA_OCW+SO4_PR_OCW)&kg kg-1&M" + "mmroa&OM_AC+OM_AI+OM_NI+SOA_NA+SOA_A1+OM_AC_OCW+OM_AI_OCW+OM_NI_OCW+SOA_NA_OCW+SOA_A1_OCW&kg kg-1&M" + "mmrbc&BC_A+BC_AC+BC_AX+BC_N+BC_NI+BC_AI+BC_A_OCW+BC_AC_OCW+BC_N_OCW+BC_NI_OCW+BC_AI_OCW&kg kg-1&M" + "mmrss&SS_A1+SS_A2+SS_A3+SS_A1_OCW+SS_A2_OCW+SS_A3_OCW&kg kg-1&M" + "mmrdu&DST_A2+DST_A3+DST_A2_OCW+DST_A3_OCW&kg kg-1&M" + "pressure[time,lev,lat,lon]&float(P0*hyam+PS*hybm)&Pa&M" + "sconcso4[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*$SF1*(SO4_A1(:,$LL,:,:)+${SF2}/${SF1}*SO4_A2(:,$LL,:,:)+SO4_PR(:,$LL,:,:)+SO4_NA(:,$LL,:,:)+SO4_A1_OCW(:,$LL,:,:)+${SF2}/${SF1}*SO4_A2_OCW(:,$LL,:,:)+SO4_PR_OCW(:,$LL,:,:)+SO4_NA_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcso2[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*SO2(:,$LL,:,:)*1.e9f*64.066f/28.97f&ug m-3&S" + "sconcdms[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*DMS(:,$LL,:,:)*1.e9f*62.13f/28.97f&ug m-3&S" + "sconcss[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(SS_A1(:,$LL,:,:)+SS_A2(:,$LL,:,:)+SS_A3(:,$LL,:,:)+SS_A1_OCW(:,$LL,:,:)+SS_A2_OCW(:,$LL,:,:)+SS_A3_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcdust[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(DST_A2(:,$LL,:,:)+DST_A3(:,$LL,:,:)+DST_A2_OCW(:,$LL,:,:)+DST_A3_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcbc[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(BC_A(:,$LL,:,:)+BC_AC(:,$LL,:,:)+BC_AX(:,$LL,:,:)+BC_N(:,$LL,:,:)+BC_NI(:,$LL,:,:)+BC_AI(:,$LL,:,:)+BC_A_OCW(:,$LL,:,:)+BC_AC_OCW(:,$LL,:,:)+BC_N_OCW(:,$LL,:,:)+BC_NI_OCW(:,$LL,:,:)+BC_AI_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + "sconcoa[time,lat,lon]&(PS(:,:,:)/287.0f/TS(:,:,:))*(OM_AC(:,$LL,:,:)+OM_AI(:,$LL,:,:) +OM_NI(:,$LL,:,:)+SOA_NA(:,$LL,:,:)+SOA_A1(:,$LL,:,:)+OM_AC_OCW(:,$LL,:,:)+OM_AI_OCW(:,$LL,:,:)+OM_NI_OCW(:,$LL,:,:)+SOA_NA_OCW(:,$LL,:,:)+SOA_A1_OCW(:,$LL,:,:))*1.e9f&ug m-3&S" + ) + + +#For each month ==> do an ensemble average of the variables in question +for aMonth in ${AVAILABLEMONTHS[@]};do + fileList="" + for aYear in ${AVAILABLEYEARS[@]}; do + echo $aYear $aMonth +# fileList+="$INPUTDIRECTORY/$EXPERIMENTNAME/atm/hist/$EXPERIMENTNAME.cam.h0.$aYear-$aMonth.nc" +# fileList+="$INPUTDIRECTORY/$EXPERIMENTNAME/atm_clim_yr3-30/nc3/$EXPERIMENTNAME.cam.h0.0003-0030_$aMonth.nc" + fileList+="$INPUTDIRECTORY/$EXPERIMENTNAME.cam.h0.$aYear-$aMonth.nc" + fileList+=" " + #echo $fileList + done + echo Will perform ncea for month $aMonth $fileList $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_$aMonth.nc + ncea -O $fileList $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_$aMonth.nc + echo $fileList +done + + +#Now that we have an enesmble for each month ==> merge them with ncrcat! +TMPOUTPUTFILE=$OUTPUTDIRECTORY/${EXPERIMENTNAME}_MONTHLY.nc +ncrcat -O $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_*.nc $TMPOUTPUTFILE + +#The rest of the script operates on the ensemble average file + +#Go through all entries and apply formulas as specified by table +for entry in "${ARRAY[@]}"; do + #VARIABLE TO CREATE + KEY=${entry%%&*} #This is Aerocom-name (including dimensions if needed by ncap2) + UNITKEY=${KEY%%[*} #This is Aerocom-name (skip anything following "[") + TMPVALUE=${entry#*&} #This is the formula to be used (AND UNITS AND COORDINATES) + #VALUE TO EXTRACT + VALUE=${TMPVALUE%%&*} #This is the formula to be used (REMOVED UNITS) + #UNIT OF OUTPUT VALUE + TMPUNIT=${TMPVALUE#*&} #These are the units AND MODEL COORDINATE + + UNIT=${TMPUNIT%%&*} + TMPCOORD=${TMPUNIT#*&} + + getVariableCoordinateString $TMPCOORD + + #BASED ON VARIABLE NAME, THIS IS OUTPUT FILE +# OUTFILE=$OUTPUTDIRECTORY/aerocom3_${MODELNAME}_${FULLEXPERIMENTNAME}_${UNITKEY}_${coordinateType}_${PERIOD}_${FREQUENCY}.nc + OUTFILE=$OUTPUTDIRECTORY/${MODELNAME}_${FULLEXPERIMENTNAME}_${UNITKEY}_${coordinateType}_${PERIOD}_${FREQUENCY}.nc + echo "...extracting ${KEY} using formula " $KEY "=" $VALUE " , unit= " $UNIT + ncap2 -O -v -s "$KEY=$VALUE" $TMPOUTPUTFILE $OUTFILE + #Add some more variables to final output file + ncks -A -v gw,time_bnds $TMPOUTPUTFILE $OUTFILE + #Make sure unit is correct + #echo "...changing unit for ${UNITKEY} " + ncatted -O -a units,${UNITKEY},o,c,"${UNIT}" ${OUTFILE} +done + +#Clean up and make sure anyone can read this.. +chmod -R a+r $OUTPUTDIRECTORY +rm $OUTPUTDIRECTORY/ENSEMBLE_AVG_${EXPERIMENTNAME}_??.nc +rm $OUTPUTDIRECTORY/${EXPERIMENTNAME}_MONTHLY.nc + +exit diff --git a/tools/aerocom3-PNSD_scripts-and-code/README b/tools/aerocom3-PNSD_scripts-and-code/README new file mode 100644 index 0000000000..914afb7e7e --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/README @@ -0,0 +1,34 @@ +For info about the "In-situ Particle Number Size +Distribution (PNSD) Measurement Comparison", see +https://wiki.met.no/aerocom/phase3-experiments + +The first scripts are used to convert monthly model +output to usable input to the PNSD fortran code, and +are to be run in the following order (e.g. on the +norstore cruncher): + +1. make-12mnth-climatotlogy.sh +2. take-out-surface-fields.sh + +Then some fortan code must be used to create the +global aerocom3-INSITU-PNSD output (this program, +pnsd, can be run from your home directory at hexagon): + +3. pnsd + +Finally use these ncl scripts (from Kai Zhang, see +https://github.com/kaizhangpnl/sample_insitu, slightly +modified) to create nc file with lat-lon station info +(latlon.nc), and produce size distribution data for +each station (these scripts can easily be run on local +machine, e.g. with symbolical links to the input files +from pnsd): + +4. create_latlon.ncl +5. sample.ncl + +Input to 4 is st.dat, lat.dat and lon.dat. The script +sample.ncl must be edited for choice of type of size +distribution field. Available so far: dndlogdaer, +dmdlogdss and dmdlogddust, where the latter two +are just approximations (see pnsd.f for more info). diff --git a/tools/aerocom3-PNSD_scripts-and-code/make-12mnth-climatotlogy.sh b/tools/aerocom3-PNSD_scripts-and-code/make-12mnth-climatotlogy.sh new file mode 100755 index 0000000000..f8c3f28629 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/make-12mnth-climatotlogy.sh @@ -0,0 +1,32 @@ +#!/bin/tcsh -f + + echo '' + echo 'Note: if not working, try "module load nco-cnl (or nco)" first' + echo '' + +set ARCDIR = /projects/NS2345K/noresm/cases/PD_MG15MegVadSOA/atm/hist/ +set ARCDIR2 = /scratch/kirkevag/pnsd/ +set AVAILABLEEXP = (PD_MG15MegVadSOA) +set AVAILABLEMONTHS = (01 02 03 04 05 06 07 08 09 10 11 12) +#set AVAILABLEYEARS = (0003 0004 0005 0006 0007 0008 0009 0010 0011 0012) + +foreach EXP ($AVAILABLEEXP) + + echo '' + echo '------------------------ climatological means ----------------------------' + echo '' + echo '' + + echo 'Calculating ensemble means for each month for all variables (i.e. only 12 months of data)' + echo '' + foreach MONTH ($AVAILABLEMONTHS) + echo 'MONTH' $MONTH + + ncea $ARCDIR/${EXP}.cam.h0.0003-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0004-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0005-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0006-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0007-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0008-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0009-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0010-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0011-${MONTH}.nc $ARCDIR/${EXP}.cam.h0.0012-${MONTH}.nc -O $ARCDIR2/${EXP}.cam.h0.climyr3-12_${MONTH}.nc + + end + +end + +exit + diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/Makefile b/tools/aerocom3-PNSD_scripts-and-code/pnsd/Makefile new file mode 100644 index 0000000000..10afc793d1 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/Makefile @@ -0,0 +1,248 @@ +################################################################## +# Makefile for multiple platforms and multiple resolutions +################################################################## +# +#Get machine info +UNAMES = $(shell uname -s) +MAKEFILE = Makefile +#MAIN = test +MAIN = pnsd +MAKDEP=/home/met/oyvinds/ipccemis/makdep +#NETCDF_PATH := /opt/cray/netcdf/default/pgi/121 +#NETCDF_PATH := /opt/cray/netcdf/default/pgi/141 +#NETCDF_PATH := /opt/cray/netcdf/default/pgi/153 +NETCDF_PATH := /opt/cray/netcdf/4.3.1/pgi/121 +NETCDF_INC := $(NETCDF_PATH)/include +NETCDF_LIB := $(NETCDF_PATH)/lib +################################################################## +#Set user choices. NO SPACES BEFORE OR AFTER Y/N SIGNS +#------------------------------------------------------ +#Make model compatible with netCDF files (Y/N) +NETCDF:=Y +#Compiler options O=Optimize, D = Debug +OPTS :=O +# Model horizontal resolution +HOR_RSN :=BXM +# Set model vertical resolution +VRT_RSN := 1 +#Set directory where you store object files +MY_OBJ_DIR:=./obj +#Integrate chemistry with/without NOZ (Yes (Y) means use NOZ) +#NOZ yields oscillations in photochem. and is normally not recommended +#Set NOZ to "Y" only if you really know what you are doing. +NOZ:=Y +####################END OF USER CHOICES################ +################################################################## +#Normally don't touch anything below this line +#(except to add or remove a source file) + +#Define some signs needed for the Makefile below +null= +comma=${null},${null} +space=${null} ${null} +kolon=${null}:${null} + +#Directory where you store dependency files (same as MY_OBJ_DIR) +MY_DPN_DIR:=${MY_OBJ_DIR} +#Set model resolution +MDL_RSN :=${HOR_RSN}L${VRT_RSN} + +#Initialize user token +#USR_TKN :=-DDUST +#USR_TKN :=-DSALT +#USR_TKN :=-DDMS +#Initialize LDFLAGS (Libraries needed when linking object files) +LDFLAGS := +#Initialize includes (Directories to include when looking for files to compile) +INCLUDES:= -I. -I${NETCDF_INC} -I${NETCDF_LIB} + + +# Set the right compiler and compiler options for the right architecture +# This part (and the directories above) should in theory be the only machine +# dependent things... +#----------------------------------------------------------------------------- + +#Set the value of DPN_GNR to makdep +DPN_GNR:=${MAKDEP} + +FC = pgf90 +CC = gcc +FIXEDFLAGS = -Mfixed +FREEFLAGS = -Mfree +STDOPT = +FCOPT = -O4 -r8 +DEBUG = + +OPTFLAGS=${FCOPT} +# Set user tokens +# 1) Check if NOZ or primitive equations +ifeq (${NOZ},Y) +USR_TKN += -DNOZCHEM +endif + + +#Set single precision +USR_TKN += -DPRC_FLT + +############################################################################# + +# Get Model source files +# +########GET SALT SOURCES AND SET OPTIONS############################### +#List of directories in which to search for source files +#MDL_PTH:= ./stig ./readnc +MDL_PTH:= . +#Set the Makefile VPATH variable (change space for colon in modelpath) +VPATH_TMP:=$(subst ${space},${kolon},${MDL_PTH}) +# Define function to find all Fortran files in a given directory +FIND_FNC= $(wildcard ${dir}/*.F ${dir}/*.f ${dir}/*.f90 ${dir}/*.F90) +# Assemble list of source files from all dust directories +SRC_LST_TMP = $(foreach dir, ${MDL_PTH},$(FIND_FNC)) +# Source file names with directories removed +SRC_LST := $(notdir $(SRC_LST_TMP)) +# Prepend -I to use for compiler argument +#include directories to search for #included files +MDL_INC := $(foreach dir,${MDL_PTH},-I${dir}) + +#Set model source to be SRC_LST +MDL_SRC:= ${SRC_LST} + +#Expand includes +INCLUDES += ${MDL_INC} + +#Set LDFLAGS +LDFLAGS += -L${NETCDF_LIB} -lnetcdf -lnetcdff + +#USR_TKN has to be changed for AIX where the preprocessing is of the form +#-WF,-DTKN1,-DTKN2.... All the other machines use the form -DTKN1 -DTKN2... +ifeq (${UNAMES},AIX) +USR_TKN := $(subst $(space)${space}$(space),$(null),${USR_TKN}) #Get rid of triple spaces +USR_TKN := $(subst $(space)${space},$(null),${USR_TKN}) #Get rid of double spaces +USR_TKN := $(subst $(space),$(null),${USR_TKN}) #Get rid of single spaces +USR_TKN := $(subst -D,$(comma)-D,$(USR_TKN)) #Change "-D" to ",-D" +USR_TKN2 := $(subst -WF${comma},${null},$(USR_TKN)) #Argument to c processor.. +USR_TKN2 := $(subst ${comma},${space},$(USR_TKN2)) #..is on the form -D1 -D2 +else #not AIX +USR_TKN2 := ${USR_TKN} #Needed for compiling .F90 files +endif + +#Includes for makdep (in should not look for netcdf.o) +#MAKDEPINC := $(subst -I${NETCDF_INC},$(null),${INCLUDES}) +MAKDEPINC := ${INCLUDES} + +#After VPATH_TMP has been expanded by all different modules, +#we now construct the variable VPATH by changing space with kolon +VPATH := $(subst $(space),$(kolon),${VPATH_TMP}) + +# List of object files is constructed directly from source files +# It is made made AFTER the source list is constructed +# In this statement we say that all object files are in MY_OBJ_DIR +# and that they are based on the files in MDL_SRC +MDL_OBJ := ${addprefix ${MY_OBJ_DIR}/,${addsuffix .o, ${basename ${MDL_SRC}}}} + +#List of dependency files. Make will read the dependency files and find out what files need +#To be recompiled in case of a change in any file. This is useful if you use modules and #include +MDL_DPN := $(addprefix ${MY_OBJ_DIR}/,$(addsuffix .d, $(basename ${MDL_SRC}))) + +# limit what files to check for updates +.SUFFIXES: +.SUFFIXES: .f .f90 .F .F90 .c .o + +#Pattern rules: Tell make how to construct a pattern from another pattern +#Note the pattern to construct *.f90 from *.F90: The HP-UX compiler does not recognize .F90 as fortran code +#Other compilers recognize *.F90 as fortran code, but it is better to to it general for all compilers. +#Normally, *.F90 is fortran code in free format with CPP statements (#ifdefs) +#http://devrsrc1.external.hp.com/STK/man/11.20/f90_1.html +${MY_OBJ_DIR}/%.o : %.f + ${FC} ${FIXEDFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +${MY_OBJ_DIR}/%.o : %.F + ${FC} ${FIXEDFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} ${USR_TKN} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +${MY_OBJ_DIR}/%.o : %.f90 + ${FC} ${FREEFLAGS} ${STDOPT} ${INCLUDES} ${OPTFLAGS} -o ${MY_OBJ_DIR}/${notdir $@} -c $< +%.f90 : %.F90 + ${CC} -C -E ${INCLUDES} ${USR_TKN2} $< > $@ + +#Dependency rules Generate dependency files which tells Make what files to +#recompile and not after a given change in the code. You need the makdep program +#to do this. The last line in the makefile -include ${MDL_DPN} tells make to use this. +#Makdep is publicly available, f.ex. http://dust.ps.uci.edu/dead/makdep.c +#Compile it with ${CC} -o makdep makdep.c and put the binary somewhere in your path. +${MY_DPN_DIR}/%.d : %.F + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.f + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.F90 + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ +${MY_DPN_DIR}/%.d : %.f90 + @echo "Building dependency file $@" + ${DPN_GNR} -f ${MAKDEPINC} -D ${MY_DPN_DIR} -O ${MY_OBJ_DIR} -s f -s f90 $< > $@ + +#Make will try to execute the first target of the Makefile +.PHONY: all +all: ${MAIN} ${MDL_OBJ} ${MDL_DPN} +# I think .PHONY tells make that "all" is a non file target +# I am not sure if it helps, but the manual recommends it. + +# Here I tell make only to update MAIN if +# MDL_OBJ is newer +${MAIN}: ${MDL_OBJ} + @echo COMPILING AND LINKING MAIN + ${FC} ${STDOPT} ${OPTFLAGS} -o $@ ${MDL_OBJ} ${LDFLAGS} + +#We need new object files if the Makefile is newer +${MDL_OBJ}: ${MAKEFILE} + +#We need new dependency files if the Makefile is newer +${MDL_DPN}: ${MAKEFILE} + +#Check if what you think is really set in this makefile +#The command "make check" will print all the stuff below +check: + @echo SOURCE FILES ${MDL_SRC} + @echo MDL_OBJ ${MDL_OBJ} + @echo INCLUDES ${INCLUDES} + @echo makdepinc ${MAKDEPINC} + @echo CORE ${CORE_SRC} + @echo USR_TKN ${USR_TKN} + @echo FIXEDFLAGS ${FIXEDFLAGS} + @echo MY_OBJ_DIR ${MY_OBJ_DIR} + @echo MAIN ${MAIN} + @echo MAKEFILE ${MAKEFILE} + @echo Dependency files ${MDL_DPN} + @echo VPATH_TMP ${VPATH_TMP} + @echo VPATH ${VPATH} + @echo comma a${comma}a + @echo space a${space}a + @echo kolon a${kolon}a + @echo USR_TKN2 ${USR_TKN2} + @echo MAKDEP ${MAKDEP} + @echo NETCDF_INC ${NETCDF_INC} +# Clean up +clean: + rm -f ${MY_OBJ_DIR}/*.o + rm -f ${MY_DPN_DIR}/*.d + rm -f ${MDL_DPN} + rm -f ${MDL_OBJ} + rm -f loader.info + rm -f ${MAIN} + rm -f core + rm -f *.mod + rm -f *~ + +#This last part includes the dependencies +#But we only want to do this for options which actually compile something +#That's why we want to check on "GOALS_WHICH...BLA BLA.." +INCLUDE_DPN := TRUE +GOALS_WHICH_IGNORE_DEPENDENCY_FILES := clean clean_all check +ifeq (${null},$(findstring $(MAKECMDGOALS),${GOALS_WHICH_IGNORE_DEPENDENCY_FILES})) + INCLUDE_DPN := TRUE +else + INCLUDE_DPN := FALSE +endif +ifeq (${INCLUDE_DPN},TRUE) +# Following incorporates dependency files into Makefile rules +-include ${MDL_DPN} +endif diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/chkerr.f90 b/tools/aerocom3-PNSD_scripts-and-code/pnsd/chkerr.f90 new file mode 100644 index 0000000000..f11997edd2 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/chkerr.f90 @@ -0,0 +1,10 @@ + subroutine chkerr(status) + use netcdf + implicit none + integer status + if (status.ne.nf90_noerr) then + write(*,*) trim(nf90_strerror(status)) + stop + end if + end subroutine chkerr + diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/handleerr.f90 b/tools/aerocom3-PNSD_scripts-and-code/pnsd/handleerr.f90 new file mode 100644 index 0000000000..d2b310827b --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/handleerr.f90 @@ -0,0 +1,9 @@ + + subroutine handle_err(status) + use netcdf + integer, intent(in) :: status !Error status + if(status/=nf90_noerr)then + print *, trim(nf90_strerror(status)) + stop "stopped" + endif + end subroutine handle_err diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/pnsd.f b/tools/aerocom3-PNSD_scripts-and-code/pnsd/pnsd.f new file mode 100644 index 0000000000..14023d6ca0 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/pnsd.f @@ -0,0 +1,340 @@ +!********************************************************************** +! This program reads model output data of aerosol mode number, +! median radius and width (for log-normal size distriobutions) +! from a netCDF file produced with the script pnsd.sh (giving 12 +! months of climatological data), and calculates and writes to a +! new file the number size distribution as function of month, +! latitude, longitude and particle diameter. +!********************************************************************** +! Main propgram (pnsd.f) is created by Alf Kirkevag and Dirk Olivie, +! April 2016. Subroutines (nc read, write, check) are based on code +! from Dirk Olivie, Oyvind Seland, Alf Grini, and Jostein Sundet... +!********************************************************************** + + program pnsd + + implicit none + + integer i,j,ibin + integer nt, inr, inrmin, ivtype + + real readfield(288,192) + real nmr(288,192,0:14) + real sig(288,192,0:14) + real num(288,192,0:14) + + real time(12) + real longitude(288) + real latitude(192) + real diameter(60) + + real rgm(60) + real dndlogr(288,192,60,0:14), dndlogrsum(288,192,60) + real dmdlogr_ss(288,192,60), dmdlogr_du(288,192,60) + real dndlogrsummode(288,192,0:14) + real writfield(288,192), writfield3d(288,192,60) + + character*128 filename + character*10 wname,wname1,wname2 + character*10 woutname,longname,unit + character*120 fwname,fp,wn + + real pi, fourpibythree, pibysix, const + + pi=4.*atan(1.) + fourpibythree=4.*pi/3. + pibysix=pi/6. + + fwname='/work/kirkevag/pnsd/PD_MG15MegVadSOA.cam.'// + & 'h0.climyr3-12surface_monthly-nolev.nc' + +! First read lat-lon info from the imput file + call readnclatlon(longitude,'lon',fwname,288) +! write(*,*) longitude + call readnclatlon(latitude,'lat',fwname,192) +! write(*,*) latitude + + +! Calculate geometric median radius for 60 bins along log(r) axis, +! where log is log_10 and r = 0.01 - 10 um + do ibin=1,60 + rgm(ibin)=1.e-6*10**(0.05*(ibin-0.5)-2) ! unit m +! write(100,*) ibin, rgm(ibin) + diameter(ibin) = 2.*rgm(ibin)*1.e6 ! unit um + end do + +! Calculate const in "dN/dlogD = const * NNAT/log(SIGMA)*exp(-0,5*(...)**2) + const=1./sqrt(2.*pi) +! write(*,*) 'const =', const + + +! Then start reading the data from postprocess model output netcdf file + + do nt=1,12 ! time loop moved outside to reduce # of dimensions + + + do ivtype=1,3 ! loop over variable type + + if(ivtype.eq.1) then + wname1='NMR' + inrmin=1 + elseif(ivtype.eq.2) then + wname1='SIGMA' + inrmin=1 + else + wname1='NNAT_' + inrmin=0 + endif + + do inr=inrmin,14 + + if(inr.ne.3.and.inr.ne.11.and.inr.ne.13) then + wname2=" " + write(wname2,"(I2)"),inr + if(inr.lt.10.and.ivtype.ne.3) then + wname2="0"//adjustl(wname2) + else + wname2=adjustl(wname2) + endif + wname = trim(wname1)//trim(wname2) + + if(nt.eq.1) write(*,*) 'wname=', wname + + call readnc( + & readfield !O Output field + & ,wname !I Name of field to pick + & ,fwname !I Name of file to pick from + & ,288 !I Number of longitudes + & ,192 !I Number of latitudes + & ,nt !I Timestep to pick + & ) + do j=1,192 + do i=1,288 + if(wname1.eq.'NMR') then + nmr(i,j,inr)=readfield(i,j) ! unit m + elseif(wname1.eq.'SIGMA') then + sig(i,j,inr)=readfield(i,j) ! no unit + elseif(wname1.eq.'NNAT_') then + num(i,j,inr)=readfield(i,j) ! unit cm-3 + else + write(*,*) 'Requested variabel non-existent' + stop + endif + end do + end do + + endif ! inr.ne.3,11,13 + + end do ! inr + + end do ! ivtype + + +! ------ reading for this nt is done: now use the read in fields ------- + +! Define fields which have not been read in (because they are constant), +! and initialize outfields + + do j=1,192 + do i=1,288 + sig(i,j,0)=1.6 + nmr(i,j,0)=0.1e-6 + do ibin=1,60 + dndlogrsum(i,j,ibin)=0.0 + dmdlogr_ss(i,j,ibin)=0.0 + dmdlogr_du(i,j,ibin)=0.0 + end do + do inr=0,14 + dndlogrsummode(i,j,inr)=0.0 + end do + end do + end do + +! Calculate dry number size distributions dN/dlogr (unit cm-3) for each mode inr + + do inr=0,14 + if(inr.ne.3.and.inr.ne.11.and.inr.ne.13) then + do ibin=1,60 + do j=1,192 + do i=1,288 + dndlogr(i,j,ibin,inr)=const*(num(i,j,inr) + & /log10(sig(i,j,inr))) + & *exp(-0.5*(log10(rgm(ibin)/nmr(i,j,inr)) + & /log10(sig(i,j,inr)))**2) +! write(*,*) 'inr, ibin, dndlogr =', inr, ibin, +! & dndlogr(i,j,ibin,inr) + end do + end do + end do + endif + end do + +! Then sum over all modes for the number size distribitions (dndlogrsum has unit cm-3) + + do inr=0,14 + do j=1,192 + do i=1,288 + do ibin=1,60 + dndlogrsum(i,j,ibin)=dndlogrsum(i,j,ibin) + & + dndlogr(i,j,ibin,inr) + end do + end do + end do + end do + +! And similarly, approximate dry mass size distributions dMdlogr for SS and DU +! (with mass densities of 2.6 and 2.2 g cm-3). Unit: 1.e12 g cm-3 = ug m-3 + + do inr=6,7 + do ibin=1,60 + do j=1,192 + do i=1,288 + dmdlogr_du(i,j,ibin)=dmdlogr_du(i,j,ibin) + & +2.6*pibysix*dndlogr(i,j,ibin,inr)*diameter(ibin)**3 + end do + end do + end do + end do + do inr=9,10 + do ibin=1,60 + do j=1,192 + do i=1,288 + dmdlogr_ss(i,j,ibin)=dmdlogr_ss(i,j,ibin) + & +2.2*pibysix*dndlogr(i,j,ibin,inr)*diameter(ibin)**3 + end do + end do + end do + end do + +! Some test output------------------------- + do ibin=1,60 +! Ca. Birkenes station in southern Norway + do j=157,157 + do i=7,7 + write(101,*) diameter(ibin), dndlogr(i,j,ibin,1), nt + write(102,*) diameter(ibin), dndlogrsum(i,j,ibin), nt + end do + end do + end do + write(103,*) nt, nmr(7,157,1) + write(104,*) nt, num(7,157,1) +! Checking that the sum of particles from each bin actually sums up to the total: + do inr=0,14 + if(inr.ne.3.and.inr.ne.11.and.inr.ne.13) then + do j=1,192 + do i=1,288 + do ibin=1,60 + dndlogrsummode(i,j,inr)=dndlogrsummode(i,j,inr) + & + 0.05*dndlogr(i,j,ibin,inr) + end do + end do + end do + endif + end do + do inr=0,14 + if(inr.ne.3.and.inr.ne.11.and.inr.ne.13) then + do j=157,157 + do i=7,7 + write(100,*) nt, inr, num(i,j,inr), + & dndlogrsummode(i,j,inr)/num(i,j,inr) + end do + end do + endif + end do +! for a dusty region (Arabic peninsula) +! do j=120,120 +! do i=38,38 +! write(200,*) diameter(ibin), dmdlogr_du(i,j,ibin) +! write(206,*) diameter(ibin), dndlogr(i,j,ibin,6) +! write(207,*) diameter(ibin), dndlogr(i,j,ibin,7) +! end do +! end do +! and for a marine region (Southern ocean) +! do j=40,40 +! do i=17,17 +! write(300,*) diameter(ibin), dmdlogr_ss(i,j,ibin) +! write(309,*) diameter(ibin), dndlogr(i,j,ibin,9) +! write(310,*) diameter(ibin), dndlogr(i,j,ibin,10) +! end do +! end do +! end do +! Some test output------------------------- + + +! Finally write the final data to a single netcdf file (for each PNSD variable) +! filename='/work/kirkevag/pnsd/dndlogd_global.nc' + fp='/work/kirkevag/pnsd/' + + wn='aerocom03_CAM5.3-Oslo_global-PNSD_dndlogdaer_2000_monthly.nc' + filename=trim(fp)//trim(wn) + woutname='dndlogdaer' ! note that dndlogdaer=dndlograer + longname='dndlogdaer' + unit='cm-3' + do ibin=1,60 + do j=1,192 + do i=1,288 + writfield3d(i,j,ibin)=dndlogrsum(i,j,ibin) + end do + end do + end do + call writenc4d_diameter(writfield3d, woutname, longname, unit, + & filename, 288, 192, 60, nt, + & longitude, latitude, diameter, + & 'lon','lat','particle_diameter','time', + & 'longitude EAST to WEST','latitude SOUTH to NORTH', + & 'particle diameter','time in months', + & 'deg','deg','um','month') + + wn='aerocom03_CAM5.3-Oslo_global-PNSD_dmdlogdss_2000_monthly.nc' + filename=trim(fp)//trim(wn) + woutname='dmdlogdss' + longname='dmdlogdss' + unit='ug m-3' + do ibin=1,60 + do j=1,192 + do i=1,288 + writfield3d(i,j,ibin)=dmdlogr_ss(i,j,ibin) + end do + end do + end do + call writenc4d_diameter(writfield3d, woutname, longname, unit, + & filename, 288, 192, 60, nt, + & longitude, latitude, diameter, + & 'lon','lat','particle_diameter','time', + & 'longitude EAST to WEST','latitude SOUTH to NORTH', + & 'particle diameter','time in months', + & 'deg','deg','um','month') + + wn='aerocom03_CAM5.3-Oslo_global-PNSD_dmdlogddust_2000_monthly.nc' + filename=trim(fp)//trim(wn) + woutname='dmdlogddust' + longname='dmdlogddust' + unit='ug m-3' + do ibin=1,60 + do j=1,192 + do i=1,288 + writfield3d(i,j,ibin)=dmdlogr_du(i,j,ibin) + end do + end do + end do + call writenc4d_diameter(writfield3d, woutname, longname, unit, + & filename, 288, 192, 60, nt, + & longitude, latitude, diameter, + & 'lon','lat','particle_diameter','time', + & 'longitude EAST to WEST','latitude SOUTH to NORTH', + & 'particle diameter','time in months', + & 'deg','deg','um','month') + + end do ! nt + + + return + end + + + + + + + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnc.f90 b/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnc.f90 new file mode 100644 index 0000000000..917c5bdd3e --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnc.f90 @@ -0,0 +1,142 @@ +subroutine readnc( & + twoDfield & !O A three dimensional field + ,fieldname & !I The name of the field + ,filename & !I The name of the file to read from + ,IM & !I Number of longitudes + ,JM & !I Number of latitudes + ,ntimestep & !I The timestep to read + ) + + !Purpose: Open a netCDF file and get 2D field from the file + !The field you want to get has the name "fieldname", and the file + !has the name "filename". + !The timestep you want to read is the input parameter ntimestep + + !Remember to include -I${NETCDF_INC} -I${NETCDF_LIB} for compiling + !And for linking -L${NETCDF_LIB} and -lnetcdf in your makefile + !The values of these two should be set in your .bashrc file like this: + !export NETCDF_INC = /mn/hox/u8/jsundet/include/ + !export NETCDF_LIB = /mn/hox/u8/jsundet/lib/ + !Or if you are using C-shell put the following in your .cshrc file + !setenv NETCDF_INC /mn/hox/u8/jsundet/include/ + !setenv NETCDF_LIB /mn/hox/u8/jsundet/lib/ + !If this doesn't work, the explicitly link $NETCDF_INC/netcdf.mod to your run-dir + + !Author: Alf Grini, alf.grini@geofysikk.uio.no + + use netcdf + + implicit none + include 'netcdf.inc' + !INPUT + character*(*), intent(in) :: fieldname !I Name of field + character*(*), intent(in) :: filename !I Name of netCDFfile + integer,intent(in) :: IM !I Number of longitudes + integer,intent(in) :: JM !I Number of latitudes + integer,intent(in) :: ntimestep !I The timestep to be read + + !OUTPUT + real, intent(out) :: twoDfield(IM,JM) !Three dimensional field + + !LOCAL + !LOCAL NETCDF DIMENSION IDs ETCETERA + integer :: lon_dim_id !Id for longitude dimension + integer :: lon_id !Id for variable longitude + real :: lon(IM) !variable lon (in file) + integer :: lat_dim_id !Id for latitude dimension + integer :: lat_id !Id for latitude + real :: lat(JM) !Variable for latitude + integer :: time_dim_id !Id for time dimension + integer :: time_id !Id for time + integer :: field_dim_id(3) !Dimension id for field + integer :: field_id !Variable id for field + integer :: srt_lon_lat_time(3) !Start point + integer :: cnt_lon_lat_time(3) !Count indexes + integer :: nlons !Longitudes in file + integer :: nlats !Latitudes in file + integer :: nsteps !Timesteps avaiable in file + integer :: status !status of process (0=OK) + integer :: ncid !file id + + !Array which tells you where to start picking your 3D field + srt_lon_lat_time= (/ 1 , 1 , ntimestep /) !Start array + !Array which tells you how far to count when picking it + cnt_lon_lat_time= (/ IM , JM , 1 /) !Count array + + !**********START CODE************************'' + + status=nf_noerr !Status is 0 and should be kept that way !! + +! write(6,*) filename,fieldname,IM,JM,ntimestep + + !Open the existing file + status=nf_open(filename, nf_nowrite, ncid) +! if(status/=nf_noerr)call handle_err(status) + + !Inquire dimension ids + status = nf_inq_dimid(ncid,"time",time_dim_id) + + status = nf_inq_dimid(ncid,"lat",lat_dim_id) +! if(status/=nf_noerr)call handle_err(status) + status = nf_inq_dimid(ncid,"lon",lon_dim_id) +! if(status/=nf_noerr)call handle_err(status) + +! if(status/=nf_noerr)call handle_err(status) + + !Dimension id for 3D field /lon/lat/lev/time + field_dim_id(3)=time_dim_id + field_dim_id(2)=lon_dim_id + field_dim_id(1)=lat_dim_id + + !Inquire dimensions + status = nf_inq_dimlen(ncid,lat_dim_id,nlats) +! if(status/=nf_noerr)call handle_err(status) + if(nlats/=JM)then + write(6,*)'file'//filename//' reports JM = ',nlats + write(6,*)'your array has dimension ',JM + stop + endif + + status = nf_inq_dimlen(ncid,lon_dim_id,nlons) +! if(status/=nf_noerr)call handle_err(status) + if(nlons/=IM)then + write(6,*)'file'//filename//'file reports IM = ',nlons + write(6,*)'your array has dimension',IM + stop + endif + status = nf_inq_dimlen(ncid,time_dim_id,nsteps) +! if(status/=nf_noerr)call handle_err(status) + if(ntimestep.gt.nsteps.or.nsteps.le.0)then + write(6,*)'file'//filename//'file reports nsteps = ',nsteps + write(6,*)'you try to read timestep',ntimestep + stop + endif + + !Get variable ID + status=nf_inq_varid(ncid,fieldname,field_id) +! if(status/=nf_noerr)call handle_err(status) +! write(6,*) 'Before reading' + !Finally after all this, you can get the variable you want !! + !and put it in the threeDfield array +! status=nf_get_vara_real(ncid,field_id,twoDfield & +! ,srt_lon_lat_time & +! ,cnt_lon_lat_time ) + + status=nf_get_vara_double(ncid,field_id & + ,srt_lon_lat_time & + ,cnt_lon_lat_time,twoDfield ) + + if(status/=nf_noerr) stop +call handle_err(status) + +! write(6,*)'got variable ',fieldname,srt_lon_lat_time,cnt_lon_lat_time + +!Closing file + status=nf_close(ncid) +! if(status/=nf_noerr)call handle_err(status) + + + return + end subroutine readnc + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnclatlon.f90 b/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnclatlon.f90 new file mode 100644 index 0000000000..b160ec3eac --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/readnclatlon.f90 @@ -0,0 +1,147 @@ +subroutine readnclatlon( & + oneDfield & !O A three dimensional field + ,fieldname & !I The name of the field + ,filename & !I The name of the file to read from + ,IM & !I Number of latutudes/longitudes + ) + + !Purpose: Open a netCDF file and get 2D field from the file + !The field you want to get has the name "fieldname", and the file + !has the name "filename". + !The timestep you want to read is the input parameter ntimestep + + !Remember to include -I${NETCDF_INC} -I${NETCDF_LIB} for compiling + !And for linking -L${NETCDF_LIB} and -lnetcdf in your makefile + !The values of these two should be set in your .bashrc file like this: + !export NETCDF_INC = /mn/hox/u8/jsundet/include/ + !export NETCDF_LIB = /mn/hox/u8/jsundet/lib/ + !Or if you are using C-shell put the following in your .cshrc file + !setenv NETCDF_INC /mn/hox/u8/jsundet/include/ + !setenv NETCDF_LIB /mn/hox/u8/jsundet/lib/ + !If this doesn't work, the explicitly link $NETCDF_INC/netcdf.mod to your run-dir + + !Author: Alf Grini, alf.grini@geofysikk.uio.no + + use netcdf + + implicit none + include 'netcdf.inc' + !INPUT + character*(*), intent(in) :: fieldname !I Name of field + character*(*), intent(in) :: filename !I Name of netCDFfile + integer,intent(in) :: IM !I Number of latitudes/longitudes + + !OUTPUT + real, intent(out) :: oneDfield(IM) !Three dimensional field + + !LOCAL + !LOCAL NETCDF DIMENSION IDs ETCETERA + integer :: lon_dim_id !Id for longitude dimension + integer :: lon_id !Id for variable longitude + real :: lon(IM) !variable lon (in file) + integer :: lat_dim_id !Id for latitude dimension + integer :: lat_id !Id for latitude + real :: lat(IM) !Variable for latitude +! integer :: time_dim_id !Id for time dimension +! integer :: time_id !Id for time + integer :: field_dim_id(1) !Dimension id for field + integer :: field_id !Variable id for field + integer :: srt_lat(1) !Start point + integer :: cnt_lat(1) !Count indexes + integer :: srt_lon(1) !Start point + integer :: cnt_lon(1) !Count indexes + integer :: nlons !Longitudes in file + integer :: nlats !Latitudes in file +! integer :: nsteps !Timesteps avaiable in file + integer :: status !status of process (0=OK) + integer :: ncid !file id + + !Array which tells you where to start picking your 3D field + srt_lon= (/ 1 /) !Start array + !Array which tells you how far to count when picking it + cnt_lon= (/ IM /) !Count array + + !**********START CODE************************'' + + status=nf_noerr !Status is 0 and should be kept that way !! + +! write(6,*) filename,fieldname,IM,JM,ntimestep + + !Open the existing file + status=nf_open(filename, nf_nowrite, ncid) +! if(status/=nf_noerr)call handle_err(status) + + !Inquire dimension ids +! status = nf_inq_dimid(ncid,"time",time_dim_id) + + if(fieldname.eq.'lat') then + status = nf_inq_dimid(ncid,"lat",lat_dim_id) +! if(status/=nf_noerr)call handle_err(status) + field_dim_id(1)=lat_dim_id + else + status = nf_inq_dimid(ncid,"lon",lon_dim_id) +! if(status/=nf_noerr)call handle_err(status) + field_dim_id(1)=lon_dim_id + endif + +! if(status/=nf_noerr)call handle_err(status) + + !Dimension id for 3D field /lon/lat/lev/time +! field_dim_id(3)=time_dim_id +! field_dim_id(1)=lat_dim_id + + !Inquire dimensions + + if(fieldname.eq.'lat') then + status = nf_inq_dimlen(ncid,lat_dim_id,nlats) +! if(status/=nf_noerr)call handle_err(status) + if(nlats/=IM)then + write(6,*)'file'//filename//' reports JM = ',nlats + write(6,*)'your array has dimension ',IM + stop + endif + else + status = nf_inq_dimlen(ncid,lon_dim_id,nlons) +! if(status/=nf_noerr)call handle_err(status) + if(nlons/=IM)then + write(6,*)'file'//filename//'file reports IM = ',nlons + write(6,*)'your array has dimension',IM + stop + endif + endif +! status = nf_inq_dimlen(ncid,time_dim_id,nsteps) +! if(status/=nf_noerr)call handle_err(status) +! if(ntimestep.gt.nsteps.or.nsteps.le.0)then +! write(6,*)'file'//filename//'file reports nsteps = ',nsteps +! write(6,*)'you try to read timestep',ntimestep +! stop +! endif + + !Get variable ID + status=nf_inq_varid(ncid,fieldname,field_id) +! if(status/=nf_noerr)call handle_err(status) +! write(6,*) 'Before reading' + !Finally after all this, you can get the variable you want !! + !and put it in the threeDfield array +! status=nf_get_vara_real(ncid,field_id,twoDfield & +! ,srt_lon_lat_time & +! ,cnt_lon_lat_time ) + + status=nf_get_vara_double(ncid,field_id & + ,srt_lon & + ,cnt_lon,oneDfield ) + + if(status/=nf_noerr) stop +call handle_err(status) + +! write(6,*)'got variable ',fieldname,srt_lon_lat_time,cnt_lon_lat_time + +!Closing file + status=nf_close(ncid) +! if(status/=nf_noerr)call handle_err(status) + + + return + end subroutine readnclatlon + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/pnsd/writenc4d-diameter.f90 b/tools/aerocom3-PNSD_scripts-and-code/pnsd/writenc4d-diameter.f90 new file mode 100644 index 0000000000..c245918457 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/pnsd/writenc4d-diameter.f90 @@ -0,0 +1,206 @@ + subroutine writenc4d_diameter( & + fourDfield & !I A four dimensional field + ,fieldname & !I The name of the field + ,fieldlong & !I Long name of the field + ,fieldunits & !I Units of the field + ,filename & !I The name of the file to write to + ,IM & !I Number of longitudes + ,JM & !I Number of latitudes +!x ,LM & !I Number of levels + ,LM & !I Number of size bins +!x ,MM & !I Length of fixed time dimensions (usually set to nmonths=12) + ,ntimestep & !I The timestep to read + ,longitude & + ,latitude & + ,diameter & + ,clongitude & + ,clatitude & + ,cdiameter & + ,ctime & + ,longname_longitude & + ,longname_latitude & + ,longname_diameter & + ,longname_time & + ,unit_longitude & + ,unit_latitude & + ,unit_diameter & + ,unit_time & + ) + +! --- Purpose: Open a netCDF file and write 4D field to the file +! --- The field written has the name "fieldname", and the file +! --- has the name "filename". +! --- The timestep in file is set to the input argument ntimestep + + use netcdf + + implicit none + +! --- INPUT + character*(*), intent(in) :: fieldname !I Name of field + character*(*), intent(in) :: fieldlong !I Long name of field + character*(*), intent(in) :: fieldunits !I Units of field + character*(*), intent(in) :: filename !I Name of netCDFfile + integer,intent(in) :: IM !I Number of longitudes + integer,intent(in) :: JM !I Number of latitudes + integer,intent(in) :: LM !I Number of size bins +!x integer,intent(in) :: MM !I Length of fixed time dimension + integer,intent(in) :: ntimestep !I The timestep to be read +!x real, intent(in) :: fourDfield(IM,JM,LM,MM) !I Four dimensional field + real, intent(in) :: fourDfield(IM,JM,LM) !I Four dimensional field + + real, intent(in) :: longitude(IM) + real, intent(in) :: latitude(JM) + real, intent(in) :: diameter(LM) + character*(*), intent(in) :: clongitude + character*(*), intent(in) :: clatitude + character*(*), intent(in) :: cdiameter + character*(*), intent(in) :: ctime + + character*(*), intent(in) :: longname_longitude + character*(*), intent(in) :: longname_latitude + character*(*), intent(in) :: longname_diameter + character*(*), intent(in) :: longname_time + character*(*), intent(in) :: unit_longitude + character*(*), intent(in) :: unit_latitude + character*(*), intent(in) :: unit_diameter + character*(*), intent(in) :: unit_time + +! --- LOCAL +! --- LOCAL NETCDF DIMENSION IDs ETCETERA + + integer :: lon_dim_id !Id for longitude dimension + integer :: lat_dim_id !Id for latitude dimension +!x integer :: lev_dim_id !Id for level dimension + integer :: bin_dim_id !Id for level dimension +!x integer :: month_dim_id !Id for calendar month dimension + integer :: time_dim_id !Id for time dimension + integer :: field_id !Variable id for field + integer :: file_id !NetCDF file identifier + integer :: status !Error return code + + integer :: lon_var_id + integer :: lat_var_id + integer :: bin_var_id + integer :: time_var_id + + integer :: time_array(12) + +! --- **********START CODE************************ + +!x write(6,*) 'startnc ',im,jm,lm,mm,ntimestep,filename + write(6,*) 'startnc ',im,jm,lm,ntimestep,filename + +! -------------------------------- +! --- Define NetCDF grid files --- +! -------------------------------- + +! --- Create file if ntimestep=1, append to file if ntimestep>1 + if (ntimestep.eq.1) then + call chkerr(nf90_create(trim(filename), nf90_clobber, file_id)) + else + call chkerr(nf90_open(trim(filename), nf90_write, file_id)) + end if + +! --- Create dimensions + if (ntimestep.eq.1) then + call chkerr(nf90_def_dim(file_id, 'lon', IM, lon_dim_id)) + call chkerr(nf90_def_dim(file_id, 'lat', JM, lat_dim_id)) +!x call chkerr(nf90_def_dim(file_id, 'lev', LM, lev_dim_id)) + call chkerr(nf90_def_dim(file_id, 'particle_diameter', & + & LM, bin_dim_id)) +!x call chkerr(nf90_def_dim(file_id, 'month', MM, month_dim_id)) +!x call chkerr(nf90_def_dim(file_id, 'year', NF90_UNLIMITED, & +! call chkerr(nf90_def_dim(file_id, 'time', NF90_UNLIMITED, & + call chkerr(nf90_def_dim(file_id, 'time', 12, & + & time_dim_id)) + else + call chkerr(nf90_inq_dimid(file_id, 'lon', lon_dim_id)) + call chkerr(nf90_inq_dimid(file_id, 'lat', lat_dim_id)) +!x call chkerr(nf90_inq_dimid(file_id, 'lev', lev_dim_id)) + call chkerr(nf90_inq_dimid(file_id, 'particle_diameter', & + & bin_dim_id)) +!x call chkerr(nf90_inq_dimid(file_id, 'month', month_dim_id)) +!x call chkerr(nf90_inq_dimid(file_id, 'year', time_dim_id)) + call chkerr(nf90_inq_dimid(file_id, 'time', time_dim_id)) + endif + +! --- Define variable and attributes + if (ntimestep.eq.1) then + call chkerr(nf90_def_var(file_id, trim(fieldname), NF90_FLOAT, & +!x & (/lon_dim_id, lat_dim_id, lev_dim_id, month_dim_id, & +!x & time_dim_id/), field_id)) +!x & (/lon_dim_id, lat_dim_id, lev_dim_id, & + & (/lon_dim_id, lat_dim_id, bin_dim_id, & + & time_dim_id/), field_id)) + call chkerr(nf90_put_att(file_id,field_id,'long_name', & + & trim(fieldlong))) + call chkerr(nf90_put_att(file_id,field_id,'units', & + & trim(fieldunits))) +! define longitude + call chkerr(nf90_def_var(file_id, trim(clongitude), NF90_FLOAT, & + (/lon_dim_id/), lon_var_id)) + call chkerr(nf90_put_att(file_id,lon_var_id,'long_name', & + & trim(longname_longitude))) + call chkerr(nf90_put_att(file_id,lon_var_id,'units', & + & trim(unit_longitude))) +! define latitude + call chkerr(nf90_def_var(file_id, trim(clatitude), NF90_FLOAT, & + (/lat_dim_id/), lat_var_id)) + call chkerr(nf90_put_att(file_id,lat_var_id,'long_name', & + & trim(longname_latitude))) + call chkerr(nf90_put_att(file_id,lat_var_id,'units', & + & trim(unit_latitude))) +! define diameter + call chkerr(nf90_def_var(file_id, trim(cdiameter), NF90_FLOAT, & + (/bin_dim_id/), bin_var_id)) + call chkerr(nf90_put_att(file_id,bin_var_id,'long_name', & + & trim(longname_diameter))) + call chkerr(nf90_put_att(file_id,bin_var_id,'units', & + & trim(unit_diameter))) +! define time + call chkerr(nf90_def_var(file_id, trim(ctime), NF90_INT, & + (/time_dim_id/), time_var_id)) + call chkerr(nf90_put_att(file_id,time_var_id,'long_name', & + & trim(longname_time))) + call chkerr(nf90_put_att(file_id,time_var_id,'units', & + & trim(unit_time))) + + call chkerr(nf90_enddef(file_id)) +! write longitude + call chkerr(nf90_put_var(file_id, lon_var_id, longitude, & + & (/1/),(/IM/))) +! write latitude + call chkerr(nf90_put_var(file_id, lat_var_id, latitude, & + & (/1/),(/JM/))) +! write diameter + call chkerr(nf90_put_var(file_id, bin_var_id, diameter, & + & (/1/),(/LM/))) +! write time + time_array(:)=(/1,2,3,4,5,6,7,8,9,10,11,12/) + call chkerr(nf90_put_var(file_id, time_var_id, time_array, & + & (/1/),(/12/))) + + else + call chkerr(nf90_inq_varid(file_id, trim(fieldname),field_id)) + end if + +! --- Write data +!x call chkerr(nf90_put_var(file_id, field_id, fourDfield, & +!x & (/1, 1, 1, 1, ntimestep/),(/IM, JM, LM, MM, 1/))) + call chkerr(nf90_put_var(file_id, field_id, fourDfield, & + & (/1, 1, 1, ntimestep/),(/IM, JM, LM, 1/))) + +! if ( ntimestep .eq. 1 ) then +! time_array(1) = ntimestep +! call chkerr(nf90_put_var(file_id, time_var_id, time_array, & +! & (/ntimestep/),(/0/))) +! endif + + +! --- Close file + call chkerr(nf90_close(file_id)) + + + return + end subroutine writenc4d_diameter diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/LICENSE b/tools/aerocom3-PNSD_scripts-and-code/stationdata/LICENSE new file mode 100644 index 0000000000..8cdb8451d9 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + {description} + Copyright (C) {year} {fullname} + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + {signature of Ty Coon}, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. + diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/create_latlon.ncl b/tools/aerocom3-PNSD_scripts-and-code/stationdata/create_latlon.ncl new file mode 100644 index 0000000000..a80377a19d --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/create_latlon.ncl @@ -0,0 +1,54 @@ + + xlat = asciiread("lat.dat",-1,"float") + xlon = asciiread("lon.dat",-1,"float") + stname = asciiread("st.dat",-1,"string") + + xlon = where(xlon.lt.0., xlon + 360., xlon) + + nlon = dimsizes(xlon) + nlat = dimsizes(xlat) + + lat = new((/nlat/),"float") + lon = new((/nlon/),"float") + + lat!0 = "st" + lat&st = ispan(1,nlat,1) + lat = (/ xlat /) + + lon!0 = "st" + lon&st = ispan(1,nlon,1) + lon = (/ xlon /) + + fno = "latlon.nc" + + system("rm "+fno) + + fla = addfile(fno,"c") + + fla->lat=lat + fla->lon=lon + + wallClock = systemfunc("date") + +;;........................................................................................ +;; file provenance +;;........................................................................................ + + fatt = True + fatt@experiment = "INSITU" + fatt@source = "https://wiki.met.no/_media/aerocom/INSITU_Station_Inventory.xlsx" + fatt@creat_time = wallClock + + fatt@station_name = "" + + do is = nlat-1,0,1 + it = is + 1 + myname = "station_name_" + it + fatt@$myname$ = stname(is) + end do + + fileattdef( fla, fatt ) + + + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/lat.dat b/tools/aerocom3-PNSD_scripts-and-code/stationdata/lat.dat new file mode 100644 index 0000000000..9af6e03713 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/lat.dat @@ -0,0 +1,71 @@ +82.49915 +36.54 +50.57 +36.213 +58.80578 +71.32301 +42.1792 +58.38833 +40.05 +-0.20194 +52.99806 +51.971 +42.07 +-40.68222 +-34.35348 +18.38107 +-16.2 +4.98139 +37.995 +54.3501 +44.23 +37.104 +-30.17254 +35.3378 +33.28 +39.08 +37.16389 +48.54 +47.8015 +61.84738 +45.803 +28.309 +46.54749 +46.96667 +51.352500 +51.31805556 +23.47 +53.32583 +-3.21 +-2.595 +19.53623 +51.53 +41.76667 +44.16667 +27.9578 +29.36 +-70.666 +13.47 +48.5622 +67.97361 +55.35 +38.091 +45.7719 +74.71667 +43.93333 +47.9 +47.4165 +32.558383 +48.70861 +-89.99695 +36.6 +40.455 +72.58 +71.586166 +41.0541 +-72.0117 +56.01667 +52.80222 +50.0593 +36.2879 +78.90669 diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/lon.dat b/tools/aerocom3-PNSD_scripts-and-code/stationdata/lon.dat new file mode 100644 index 0000000000..569f47da12 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/lon.dat @@ -0,0 +1,71 @@ +-62.34153 +126.33 +13 +-81.692 +17.38837 +-156.61147 +23.5856 +8.25194 +-88.36667 +100.31805 +7.9425 +4.927 +-70.2 +144.68834 +18.48968 +-65.61775 +-68.1 +117.84361 +23.816 +-104.9834 +-79.78333 +-6.7342 +-70.79923 +25.6694 +126.17 +-28.03 +-3.605 +8.4 +11.00962 +24.29478 +8.627 +-16.4994 +7.98509 +19.58333 +12.434600 +12.2975 +120.87 +-9.89944 +-60.59 +-60.209 +-155.57616 +12.93 +2.35 +10.68333 +86.8149 +79.46 +-8.266 +2.17 +5.5056 +24.11583 +21.06667 +-122.957167 +2.9658 +-94.98333 +-60.01667 +7.91667 +10.97964 +116.78195 +2.15889 +-24.8 +-97.5 +-106.744 +-38.48 +128.918823 +-124.151 +2.5351 +13.15 +10.75944 +-122.9576 +100.8964 +11.88934 diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/readme b/tools/aerocom3-PNSD_scripts-and-code/stationdata/readme new file mode 100644 index 0000000000..22827d54d3 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/readme @@ -0,0 +1,21 @@ + +Required software: NCL (http://www.ncl.ucar.edu/) + +create_latlon.ncl : create latlon information file latlon.nc + +sample.ncl : sample grid-box mean model data at given lat/lon + all variables in the history file will be sampled at given locations + + the output variables will have dimensions like [time, station_index] or [time, lev, station_index] + + the station index is put into the rightest dimension so that we can use CDO (https://code.zmaw.de/projects/cdo) to process the data (e.g. temporal averaging). + + +### 2015-10-23 ### + +added two new sites: + +1. WLG - Mt Waliguan, CHINA, lat=36.2879 long=100.8964 elev=3810 masl +2. OPE - Obs. Per. d'Envi., FRANCE, lat=48.5622 long= 5.5056 elev= 395 masl + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/sample.ncl b/tools/aerocom3-PNSD_scripts-and-code/stationdata/sample.ncl new file mode 100644 index 0000000000..8b573e1164 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/sample.ncl @@ -0,0 +1,201 @@ + +;; model history file + +;; fna = "example_monthly_2D.nc" +;; fna = "example_monthly_3D.nc" +;; fna = "aerocom03_CAM5.3-Oslo_global-PNSD_dndlogdaer_2000_monthly.nc" +;; fna = "aerocom03_CAM5.3-Oslo_global-PNSD_dmdlogdss_2000_monthly.nc" + fna = "aerocom03_CAM5.3-Oslo_global-PNSD_dmdlogddust_2000_monthly.nc" + +;; site location information + + fnb = "latlon.nc" + +;; output file + +;; fno = "OUT_" + fna +;; fno = "aerocom03_CAM5.3-Oslo_INSITU-PNSD_dndlogdaer_2000_monthly.nc" +;; fno = "aerocom03_CAM5.3-Oslo_INSITU-PNSD_dmdlogdss_2000_monthly.nc" + fno = "aerocom03_CAM5.3-Oslo_INSITU-PNSD_dmdlogddust_2000_monthly.nc" + + system("rm " + fno) + +;;........................................................... +;; load data +;;........................................................... + + fla = addfile(fna, "r") + flb = addfile(fnb, "r") + flo = addfile(fno, "c") + + lat = flb->lat + lon = flb->lon + + ns = dimsizes(lat) ; number of stations + + vn = getfilevarnames(fla) ; get names of all variables on file + + nv = dimsizes (vn) ; number of variables on the file + + time = fla->time + + print(vn) + +;;........................................................... +;; determine if we have levels +;;........................................................... + have_levels = isfilevar(fla,"lev") + + if(have_levels) then + hyam = fla->hyam + hybm = fla->hybm + hyai = fla->hyai + hybi = fla->hybi + end if + +;;........................................................... +;; loop over variables +;;........................................................... + + do n=0,nv-1 + + vv = fla->$vn(n)$ ; read the varible to memory + + ndim = dimsizes(vv) ; dimension size of the variable + nran = dimsizes(ndim) ; rank [ie: number of dimensions] + + bname = vn(n) + wn = bname + +;;........................................................... +;; 3-D +;;........................................................... + + if(nran.eq.3) then + va = vv + n1 = dimsizes(va(:,0,0)) + n2 = dimsizes(va(0,:,0)) + n3 = dimsizes(va(0,0,:)) + + wn = bname + + wa = new((/n1,ns/),"float") + + wa!1 = "st" + wa&st = ispan(1,ns,1) + wa&st@long_name = "station" + + wa!0 = "time" + wa&time = time + + wa@long_name = va@long_name + wa@units = va@units + + ;; get grid-box mean value + + do is = 0, ns-1 + wa(:,is) = (/ va(:,{lat(is)},{lon(is)}) /) + end do + + print(" varname : " + wn ) ; print all variable names on file + flo->$wn$=wa + + delete(va) + delete(wa) + + end if + +;;........................................................... +;; 4-D +;;........................................................... + + if(nran.eq.4) then + + va = vv + + print(dimsizes(vv)) + + n1 = dimsizes(va(:,0,0,0)) + n2 = dimsizes(va(0,:,0,0)) + n3 = dimsizes(va(0,0,:,0)) + n4 = dimsizes(va(0,0,0,:)) + + bname = vn(n) + + wn = bname + + wa = new((/n1,n2,ns/),"float") + + wa!2 = "st" + wa&st = ispan(1,ns,1) + wa&st@long_name = "station" + + wa!0 = "time" + wa&time = time + + wa!1 = "particle_diameter" + wa&particle_diameter = va&particle_diameter + + wa@long_name = va@long_name + wa@units = va@units + + ;; get grid-box mean value + + do is = 0, ns-1 + wa(:,:,is) = (/ va(:,:,{lat(is)},{lon(is)}) /) + end do + + print(" varname : " + wn ) ; print all variable names on file + flo->$wn$=wa + + delete(va) + delete(wa) + + end if + + ;;print(" varname : " + wn ) ; print all variable names on file + + delete(ndim) + delete(vv) + + end do + + +;;........................................................................................ +;; Coordinate info +;;........................................................................................ + if(have_levels) then + flo->hyam=hyam + flo->hybm=hybm + flo->hyai=hyai + flo->hybi=hybi + end if + + stname = asciiread("st.dat",-1,"string") + + wallClock = systemfunc("date") + +;;........................................................................................ +;; file provenance +;;........................................................................................ + + fatt = True + fatt@experiment = "INSITU" + fatt@source = "https://wiki.met.no/_media/aerocom/INSITU_Station_Inventory.xlsx" + fatt@creat_time = wallClock + + fatt@station_name = "" + + do is = ns-1,0,1 + it = is + 1 + myname = "station_name_" + it + fatt@$myname$ = stname(is) + end do + + fileattdef( flo, fatt ) + + + + + + diff --git a/tools/aerocom3-PNSD_scripts-and-code/stationdata/st.dat b/tools/aerocom3-PNSD_scripts-and-code/stationdata/st.dat new file mode 100644 index 0000000000..899a6f0d82 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/stationdata/st.dat @@ -0,0 +1,71 @@ +Alert +Anmyeon-do +Annaberg-Buchholz +Appalachian_State_U +Aspvreten +Barrow +BEO_Moussala +Birkenes +Bondville +Bukit_Kototabang +Bösel +Cabauw +Cape_Cod +Cape_Grim +Cape_Point +Cape_San_Juan +Chacaltaya +Danum_Valley +Demokritos +East_Trout_Lake +Egbert +El_Arenosillo +El_Tololo +Finokalia +Gosan +Graciosa +Granada +Hesselbach +Hohenpeissenberg +Hyytiala +Ispra +Izana +Jungfraujoch +K-puszta +Leipzig +Leipzig-West +Lulin +Mace_Head +Manacapuro +Manaus +Mauna_Loa +Melpitz +Montseny +Mt_Cimone +Nepal_Climate_Observatory +Nainital +Neumayer +Niamey +Obs_Per_dEnvi +Pallas +Preila +Pt_Reyes +Puy_de_Dôme +Resolute_Bay +Sable_Island +Schauinsland +Schneefernerhaus +Shouxian +SIRTA +South_Pole +Southern_Great_Plains +Storm_Peak +Summit +Tiksi +Trinidad_Head +Trollhaugen +Vavihill +Waldhof +Whistler_Mountain +Waliguan +Zeppelin diff --git a/tools/aerocom3-PNSD_scripts-and-code/take-out-surface-fields.sh b/tools/aerocom3-PNSD_scripts-and-code/take-out-surface-fields.sh new file mode 100755 index 0000000000..4bddca8ef8 --- /dev/null +++ b/tools/aerocom3-PNSD_scripts-and-code/take-out-surface-fields.sh @@ -0,0 +1,52 @@ +#!/bin/tcsh -f + +set ARCDIR = /scratch/kirkevag/pnsd/ +set OUTDIR = /scratch/kirkevag/pnsd/ + +set AVAILABLEEXP = (PD_MG15MegVadSOA) + +set AVAILABLEMONTHS = (01 02 03 04 05 06 07 08 09 10 11 12) + +set AVAILABLEVARS = (NNAT_0 NNAT_1 NNAT_2 NNAT_4 NNAT_5 NNAT_6 NNAT_7 NNAT_8 NNAT_9 NNAT_10 NNAT_12 NNAT_14 NMR01 NMR02 NMR04 NMR05 NMR06 NMR07 NMR08 NMR09 NMR10 NMR12 NMR14 SIGMA01 SIGMA02 SIGMA04 SIGMA05 SIGMA06 SIGMA07 SIGMA08 SIGMA09 SIGMA10 SIGMA12 SIGMA14) + +foreach EXP ($AVAILABLEEXP) + + foreach MNTH ($AVAILABLEMONTHS) + echo 'month' $MNTH + echo '' + + echo 'Take out surface values of all 3D fields for each monthly file:' + echo '' + ncks -d lev,29 $ARCDIR/${EXP}.cam.h0.climyr3-12_${MNTH}.nc -O $OUTDIR/${EXP}.cam.h0.climyr3-12surf_${MNTH}.nc + + echo 'Then take out only the required fields --> new and smaller output:' + echo '' + foreach VAR ($AVAILABLEVARS) + echo 'VAR' $VAR + echo '' + ncks -v $VAR,time_bnds $OUTDIR/${EXP}.cam.h0.climyr3-12surf_${MNTH}.nc -A $OUTDIR/${EXP}.cam.h0.climyr3-12surface_${MNTH}.nc + end + + end + + echo 'Join all the monthly data into one file' + echo '' + ncrcat $OUTDIR/${EXP}.cam.h0.climyr3-12surface_??.nc -O $OUTDIR/${EXP}.cam.h0.climyr3-12surface_monthly.nc + + echo 'Calculate new variables which are necessary for the PNSD fortran code' + echo '' + ncap -s 'NMR00=float(0.1)*NMR01/NMR01' \ + -s 'SIGMA00=float(1.60)*NMR01/NMR01' $OUTDIR/${EXP}.cam.h0.climyr3-12surface_monthly.nc -O $OUTDIR/${EXP}.cam.h0.climyr3-12surfNewVar_monthly.nc + + + echo 'And finally remove lev as dimension' + echo '' + ncwa -a lev $OUTDIR/${EXP}.cam.h0.climyr3-12surface_monthly.nc $OUTDIR/${EXP}.cam.h0.climyr3-12surface_monthly-nolev.nc + + +end + +exit + + + diff --git a/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.ncl b/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.ncl new file mode 100644 index 0000000000..7b7c1d38b5 --- /dev/null +++ b/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.ncl @@ -0,0 +1,530 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +MWH2SO4 = 98.0 +MWNH4HSO4 = 114.0 +MWScale = MWNH4HSO4/MWH2SO4 + + +if (.not. isvar("format")) then ; is format on command line? + format = "pdf" +; format = "png" +; format = "pdf" + end if + +if (.not. isvar("var"))then + var="undef" +end if + +;filename_PT="/disk1/alfg/noresmrun/PTAER/PTAERO1_1YR_LR/out_YA.nc" +;filename_MAM="/disk1/alfg/noresmrun/PTAER/MAM3_1YR_LR/out_MAM_YA.nc" +; ************************************************************************* +;filename_PT="/disk1/alfg/noresmrun/PTAER/PTAERO1_1YR_HR/PTAERO_10Mnth.nc" +;filename_MAM="/disk1/alfg/noresmrun/PTAER/MAM3_1YR_HR/MAM3_10Mnth.nc" +; No changes by the user should be necessary below... +filename_PT="/disk1/alfg/noresmrun/PTAER/PTAERO1_1YR_HR/BF1NudgePD2000.cam.h0.1979_AVG.nc" +filename_MAM="/disk1/alfg/noresmrun/PTAER/MAM3_1YR_HR/MAM3_HR_NUDGE2_1979_AVG.nc" +; ************************************************************************* +f_PT = addfile (filename_PT, "r") +f_MAM = addfile (filename_MAM, "r") +varname="" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;BURDENS +plotType=1 +if(var .eq. "BC")then + varname_PT = "BC burden (clean), PTAERO" + varname_MAM = "BC burden (clean), MAM3" + PT_AERO = f_PT->cb_BC_NI ; + PT_AERO = PT_AERO + f_PT->cb_BC_AI + PT_AERO = PT_AERO + f_PT->cb_BC_A + PT_AERO = PT_AERO + f_PT->cb_BC_AC + PT_AERO = PT_AERO + f_PT->cb_BC_N + PT_AERO = PT_AERO + f_PT->cb_BC_AX + + MAM_AERO = f_MAM->BURDENBC +else if (var .eq. "DUST") then + varname_PT = "Dust burden (clean), PTAERO" + varname_MAM = "Dust burden (clean), MAM3" + PT_AERO = f_PT->cb_DST_A2 ; + PT_AERO = PT_AERO + f_PT->cb_DST_A3 + + MAM_AERO = f_MAM->BURDENDUST +else if (var .eq. "OM")then + varname_PT = "Organics burden (clean), PTAERO" + varname_MAM = "Organics burden (clean), MAM3" + PT_AERO = f_PT->cb_OM_AC ; + PT_AERO = PT_AERO + f_PT->cb_OM_NI + PT_AERO = PT_AERO + f_PT->cb_OM_AI + + MAM_AERO = f_MAM->BURDENPOM + MAM_AERO = MAM_AERO + f_MAM->BURDENSOA +else if (var .eq. "SS")then + varname_PT = "Sea salt burden (clean), PTAERO" + varname_MAM = "Sea salt burden (clean), MAM3" + PT_AERO = f_PT->cb_SS_A1 + PT_AERO = PT_AERO + f_PT->cb_SS_A2 + PT_AERO = PT_AERO + f_PT->cb_SS_A3 + + MAM_AERO = f_MAM->BURDENSEASALT +else if (var .eq. "SO4")then + varname_PT = "Sulfate burden (clean), PTAERO" + varname_MAM = "Sulfate burden (clean), MAM3" + PT_AERO = f_PT->cb_SO4_A1*MWScale + PT_AERO = PT_AERO + f_PT->cb_SO4_A2*MWScale + PT_AERO = PT_AERO + f_PT->cb_SO4_PR*MWScale + PT_AERO = PT_AERO + f_PT->cb_SO4_N*MWScale + PT_AERO = PT_AERO + f_PT->cb_SO4_AC*MWScale + PT_AERO = PT_AERO + f_PT->cb_SO4_NA*MWScale + + copy_VarCoords(f_PT->cb_SO4_A1, PT_AERO) + + MAM_AERO = f_MAM->BURDENSO4 +end if +end if +end if +end if +end if + +;Surface concentrations +if(var .eq. "BC_SRF")then + varname_PT = "BC surface conc (clean), PTAERO" + varname_MAM = "BC surface conc (clean), MAM3" + PT_AERO = f_PT->BC_NI_SRF ; + PT_AERO = PT_AERO + f_PT->BC_AI_SRF + PT_AERO = PT_AERO + f_PT->BC_A_SRF + PT_AERO = PT_AERO + f_PT->BC_AC_SRF + PT_AERO = PT_AERO + f_PT->BC_N_SRF + PT_AERO = PT_AERO + f_PT->BC_AX_SRF + + MAM_AERO = f_MAM->bc_a1_SRF + +else if (var .eq. "DUST_SRF") then + + varname_PT = "Dust surface conc (clean), PTAERO" + varname_MAM = "Dust surface conc (clean), MAM3" + PT_AERO = f_PT->DST_A2_SRF ; + PT_AERO = PT_AERO + f_PT->DST_A3_SRF + + MAM_AERO = f_MAM->dst_a1_SRF + MAM_AERO = MAM_AERO + f_MAM->dst_a3_SRF +else if (var .eq. "OM_SRF")then + varname_PT = "Organics surface conc (clean), PTAERO" + varname_MAM = "Organics surface conc (clean), MAM3" + PT_AERO = f_PT->OM_AC_SRF ; + PT_AERO = PT_AERO + f_PT->OM_NI_SRF + PT_AERO = PT_AERO + f_PT->OM_AI_SRF + + MAM_AERO = f_MAM->pom_a1_SRF + MAM_AERO = MAM_AERO + f_MAM->soa_a1_SRF + MAM_AERO = MAM_AERO + f_MAM->soa_a2_SRF +else if (var .eq. "SS_SRF")then + varname_PT = "Sea salt surface conc (clean), PTAERO" + varname_MAM = "Sea salt surface conc (clean), MAM3" + PT_AERO = f_PT->SS_A1_SRF + PT_AERO = PT_AERO + f_PT->SS_A2_SRF + PT_AERO = PT_AERO + f_PT->SS_A3_SRF + + MAM_AERO = f_MAM->ncl_a1_SRF + MAM_AERO = MAM_AERO + f_MAM->ncl_a2_SRF + MAM_AERO = MAM_AERO + f_MAM->ncl_a3_SRF + +else if (var .eq. "SO4_SRF")then + varname_PT = "Sulfate surface concentration (clean), PTAERO" + varname_MAM = "Sulfate surface concentration (clean), MAM3" + PT_AERO = f_PT->SO4_A1_SRF*MWScale + PT_AERO = PT_AERO + f_PT->SO4_A2_SRF + PT_AERO = PT_AERO + f_PT->SO4_PR_SRF*MWScale + PT_AERO = PT_AERO + f_PT->SO4_N_SRF*MWScale + PT_AERO = PT_AERO + f_PT->SO4_AC_SRF*MWScale + PT_AERO = PT_AERO + f_PT->SO4_NA_SRF*MWScale + + ;Multiplying with scale factor messes up meta-info + copy_VarCoords(f_PT->SO4_A1_SRF, PT_AERO) + + MAM_AERO = f_MAM->so4_a1_SRF + MAM_AERO = MAM_AERO + f_MAM->so4_a2_SRF + MAM_AERO = MAM_AERO + f_MAM->so4_a3_SRF +else if (var .eq. "SO2_SRF")then + varname_PT = "SO2 surface concentration, PTAERO" + varname_MAM = "SO2 surface concentration, MAM3" + PT_AERO = f_PT->SO2_SRF + MAM_AERO = f_MAM->SO2_SRF +end if +end if +end if +end if +end if +end if + +if (var .eq. "SF_DUST")then + varname_PT = "Dust emissions, PTAERO" + varname_MAM = "Dust emissions, MAM3" + PT_AERO = f_PT->SFDST_A2 + PT_AERO = PT_AERO + f_PT->SFDST_A3 + + MAM_AERO = f_MAM->SFdst_a1 + MAM_AERO = MAM_AERO + f_MAM->SFdst_a3 +else if (var .eq. "SF_SALT")then + varname_PT = "Sea salt emissions, PTAERO" + varname_MAM = "Sea salt emissions, MAM3" + PT_AERO = f_PT->SFSS_A1 + PT_AERO = PT_AERO + f_PT->SFSS_A2 + PT_AERO = PT_AERO + f_PT->SFSS_A3 + + + MAM_AERO = f_MAM->SFncl_a1 + MAM_AERO = MAM_AERO + f_MAM->SFncl_a2 + MAM_AERO = MAM_AERO + f_MAM->SFncl_a3 +end if +end if + + +;ZONAL MEANS +if(var .eq. "BC_ZM")then + varname_PT = "BC ZM, PTAERO" + varname_MAM = "BC ZM, MAM3" + PT_AERO = f_PT->BC_NI ; + PT_AERO = PT_AERO + f_PT->BC_AI + PT_AERO = PT_AERO + f_PT->BC_A + PT_AERO = PT_AERO + f_PT->BC_AC + PT_AERO = PT_AERO + f_PT->BC_N + PT_AERO = PT_AERO + f_PT->BC_AX + + + MAM_AERO = f_MAM->bc_a1 + + plotType = 2 + +else if (var .eq. "DUST_ZM") then + + varname_PT = "Dust ZM, PTAERO" + varname_MAM = "Dust ZM, MAM3" + PT_AERO = f_PT->DST_A2 ; + PT_AERO = PT_AERO + f_PT->DST_A3 + + MAM_AERO = f_MAM->dst_a1 + MAM_AERO = MAM_AERO + f_MAM->dst_a3 + plotType = 2 +else if (var .eq. "OM_ZM")then + varname_PT = "Organics ZM, PTAERO" + varname_MAM = "Organics ZM, MAM3" + PT_AERO = f_PT->OM_AC ; + PT_AERO = PT_AERO + f_PT->OM_NI + PT_AERO = PT_AERO + f_PT->OM_AI + + MAM_AERO = f_MAM->pom_a1 + MAM_AERO = MAM_AERO + f_MAM->soa_a1 + MAM_AERO = MAM_AERO + f_MAM->soa_a2 + plotType = 2 +else if (var .eq. "SS_ZM")then + varname_PT = "Sea salt ZM, PTAERO" + varname_MAM = "Sea salt ZM, MAM3" + PT_AERO = f_PT->SS_A1 + PT_AERO = PT_AERO + f_PT->SS_A2 + PT_AERO = PT_AERO + f_PT->SS_A3 + + MAM_AERO = f_MAM->ncl_a1 + MAM_AERO = MAM_AERO + f_MAM->ncl_a2 + MAM_AERO = MAM_AERO + f_MAM->ncl_a3 + + plotType = 2 +else if (var .eq. "SO4_ZM")then + varname_PT = "Sulfate ZM, PTAERO" + varname_MAM = "Sulfate ZM, MAM3" + PT_AERO = f_PT->SO4_A1*MWScale + PT_AERO = PT_AERO + f_PT->SO4_A2 + PT_AERO = PT_AERO + f_PT->SO4_PR*MWScale + PT_AERO = PT_AERO + f_PT->SO4_N*MWScale + PT_AERO = PT_AERO + f_PT->SO4_AC*MWScale + PT_AERO = PT_AERO + f_PT->SO4_NA*MWScale + + copy_VarCoords(f_PT->SO4_A1, PT_AERO) + + MAM_AERO = f_MAM->so4_a1 + MAM_AERO = MAM_AERO + f_MAM->so4_a2 + MAM_AERO = MAM_AERO + f_MAM->so4_a3 + plotType = 2 +end if +end if +end if +end if +end if + +;Cloud concentrations +if(var .eq. "BC_CLOUD")then + varname_PT = "BC Cloud, PTAERO" + varname_MAM = "BC cloud, MAM3" + PT_AERO = f_PT->BC_NI_OCW ; + PT_AERO = PT_AERO + f_PT->BC_AI_OCW + PT_AERO = PT_AERO + f_PT->BC_A_OCW + PT_AERO = PT_AERO + f_PT->BC_AC_OCW + PT_AERO = PT_AERO + f_PT->BC_N_OCW + + + MAM_AERO = f_MAM->bc_c1 + + plotType = 2 + +else if (var .eq. "DUST_CLOUD") then + + varname_PT = "Dust cloud, PTAERO" + varname_MAM = "Dust cloud, MAM3" + PT_AERO = f_PT->DST_A2_OCW ; + PT_AERO = PT_AERO + f_PT->DST_A3_OCW + + MAM_AERO = f_MAM->dst_c1 + MAM_AERO = MAM_AERO + f_MAM->dst_c3 + plotType = 2 +else if (var .eq. "OM_CLOUD")then + varname_PT = "Organics cloud, PTAERO" + varname_MAM = "Organics cloud, MAM3" + PT_AERO = f_PT->OM_AC_OCW ; + PT_AERO = PT_AERO + f_PT->OM_NI_OCW + PT_AERO = PT_AERO + f_PT->OM_AI_OCW + + MAM_AERO = f_MAM->pom_c1 + MAM_AERO = MAM_AERO + f_MAM->soa_c1 + MAM_AERO = MAM_AERO + f_MAM->soa_c2 + plotType = 2 +else if (var .eq. "SS_CLOUD")then + varname_PT = "Sea salt cloud, PTAERO" + varname_MAM = "Sea salt cloud, MAM3" + PT_AERO = f_PT->SS_A1_OCW + PT_AERO = PT_AERO + f_PT->SS_A2_OCW + PT_AERO = PT_AERO + f_PT->SS_A3_OCW + + MAM_AERO = f_MAM->ncl_c1 + MAM_AERO = MAM_AERO + f_MAM->ncl_c2 + MAM_AERO = MAM_AERO + f_MAM->ncl_c3 + + plotType = 2 +else if (var .eq. "SO4_CLOUD")then + varname_PT = "Sulfate cloud, PTAERO" + varname_MAM = "Sulfate cloud, MAM3" + PT_AERO = f_PT->SO4_A1_OCW + PT_AERO = PT_AERO + f_PT->SO4_A2_OCW + PT_AERO = PT_AERO + f_PT->SO4_PR_OCW + PT_AERO = PT_AERO + f_PT->SO4_N_OCW + PT_AERO = PT_AERO + f_PT->SO4_AC_OCW + PT_AERO = PT_AERO + f_PT->SO4_NA_OCW + + MAM_AERO = f_MAM->so4_c1 + MAM_AERO = MAM_AERO + f_MAM->so4_c2 + MAM_AERO = MAM_AERO + f_MAM->so4_c3 + plotType = 2 +end if +end if +end if +end if +end if + +;Cloud concentration fractions +if(var .eq. "BC_CLFR")then + varname_PT = "BC CLFR, PTAERO" + varname_MAM = "BC CLFR, MAM3" + PT_AERO_1 = f_PT->BC_NI ; + PT_AERO_1 = PT_AERO_1 + f_PT->BC_AI + PT_AERO_1 = PT_AERO_1 + f_PT->BC_A + PT_AERO_1 = PT_AERO_1 + f_PT->BC_AC + PT_AERO_1 = PT_AERO_1 + f_PT->BC_N + + PT_AERO_2 = f_PT->BC_NI_OCW ; + PT_AERO_2 = PT_AERO_2 + f_PT->BC_AI_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->BC_A_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->BC_AC_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->BC_N_OCW + + + MAM_AERO_1 = f_MAM->bc_a1 + MAM_AERO_2 = f_MAM->bc_c1 + + ;Divide the zonal means to find the fraction inside clouds! + PT_AERO = (dim_avg_Wrap(PT_AERO_2)) /(dim_avg_Wrap(PT_AERO_1 + PT_AERO_2)) + MAM_AERO = (dim_avg_Wrap(MAM_AERO_2))/(dim_avg_Wrap(MAM_AERO_1 + MAM_AERO_2)) + + copy_VarCoords(dim_avg_Wrap(PT_AERO_2), PT_AERO) + copy_VarCoords(dim_avg_Wrap(MAM_AERO_2), MAM_AERO) + + plotType = 3 +;Cloud concentration fractions +else if(var .eq. "DUST_CLFR")then + varname_PT = "DUST CLFR, PTAERO" + varname_MAM = "DUST CLFR, MAM3" + PT_AERO_1 = f_PT->DST_A2 ; + PT_AERO_1 = PT_AERO_1 + f_PT->DST_A3 + + PT_AERO_2 = f_PT->DST_A2_OCW ; + PT_AERO_2 = PT_AERO_2 + f_PT->DST_A3_OCW + + MAM_AERO_1 = f_MAM->dst_a1 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->dst_a3 + + MAM_AERO_2 = f_MAM->dst_c1 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->dst_c3 + + ;Divide the zonal means to find the fraction inside clouds! + PT_AERO = (dim_avg_Wrap(PT_AERO_2)) /(dim_avg_Wrap(PT_AERO_1 + PT_AERO_2)) + MAM_AERO = (dim_avg_Wrap(MAM_AERO_2))/(dim_avg_Wrap(MAM_AERO_1 + MAM_AERO_2)) + + copy_VarCoords(dim_avg_Wrap(PT_AERO_2), PT_AERO) + copy_VarCoords(dim_avg_Wrap(MAM_AERO_2), MAM_AERO) + + plotType = 3 +;Cloud concentration fractions +else if(var .eq. "SS_CLFR")then + varname_PT = "SALT CLFR, PTAERO" + varname_MAM = "SALT CLFR, MAM3" + PT_AERO_1 = f_PT->SS_A1 ; + PT_AERO_1 = PT_AERO_1 + f_PT->SS_A2 + PT_AERO_1 = PT_AERO_1 + f_PT->SS_A3 + + PT_AERO_2 = f_PT->SS_A1_OCW ; + PT_AERO_2 = PT_AERO_2 + f_PT->SS_A2_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->SS_A3_OCW + + MAM_AERO_1 = f_MAM->ncl_a1 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->ncl_a2 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->ncl_a3 + + MAM_AERO_2 = f_MAM->ncl_c1 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->ncl_c2 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->ncl_c3 + + ;Divide the zonal means to find the fraction inside clouds! + PT_AERO = (dim_avg_Wrap(PT_AERO_2)) /(dim_avg_Wrap(PT_AERO_1 + PT_AERO_2)) + MAM_AERO = (dim_avg_Wrap(MAM_AERO_2))/(dim_avg_Wrap(MAM_AERO_1 + MAM_AERO_2)) + + copy_VarCoords(dim_avg_Wrap(PT_AERO_2), PT_AERO) + copy_VarCoords(dim_avg_Wrap(MAM_AERO_2), MAM_AERO) + + plotType = 3 +;Cloud concentration fractions +else if(var .eq. "SO4_CLFR")then + varname_PT = "SO4 CLFR, PTAERO" + varname_MAM = "SO4 CLFR, MAM3" + PT_AERO_1 = f_PT->SO4_A1 ; + PT_AERO_1 = PT_AERO_1 + f_PT->SO4_A2 + PT_AERO_1 = PT_AERO_1 + f_PT->SO4_NA + PT_AERO_1 = PT_AERO_1 + f_PT->SO4_N + PT_AERO_1 = PT_AERO_1 + f_PT->SO4_AC + PT_AERO_1 = PT_AERO_1 + f_PT->SO4_PR + + PT_AERO_2 = f_PT->SO4_A1_OCW ; + PT_AERO_2 = PT_AERO_2 + f_PT->SO4_A2_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->SO4_NA_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->SO4_N_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->SO4_AC_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->SO4_PR_OCW + + MAM_AERO_1 = f_MAM->so4_a1 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->so4_a2 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->so4_a3 + + MAM_AERO_2 = f_MAM->so4_c1 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->so4_c2 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->so4_c3 + + ;Divide the zonal means to find the fraction inside clouds! + PT_AERO = (dim_avg_Wrap(PT_AERO_2)) /(dim_avg_Wrap(PT_AERO_1 + PT_AERO_2)) + MAM_AERO = (dim_avg_Wrap(MAM_AERO_2))/(dim_avg_Wrap(MAM_AERO_1 + MAM_AERO_2)) + + copy_VarCoords(dim_avg_Wrap(PT_AERO_2), PT_AERO) + copy_VarCoords(dim_avg_Wrap(MAM_AERO_2), MAM_AERO) + + plotType = 3 +;Cloud concentration fractions +else if(var .eq. "OM_CLFR")then + varname_PT = "OM CLFR, PTAERO" + varname_MAM = "OM CLFR, MAM3" + PT_AERO_1 = f_PT->OM_NI ; + PT_AERO_1 = PT_AERO_1 + f_PT->OM_AC + PT_AERO_1 = PT_AERO_1 + f_PT->OM_AI + + PT_AERO_2 = f_PT->OM_NI_OCW ; + PT_AERO_2 = PT_AERO_2 + f_PT->OM_AC_OCW + PT_AERO_2 = PT_AERO_2 + f_PT->OM_AI_OCW + + MAM_AERO_1 = f_MAM->pom_a1 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->soa_a1 + MAM_AERO_1 = MAM_AERO_1 + f_MAM->soa_a2 + + MAM_AERO_2 = f_MAM->pom_c1 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->soa_c1 + MAM_AERO_2 = MAM_AERO_2 + f_MAM->soa_c2 + + ;Divide the zonal means to find the fraction inside clouds! + PT_AERO = (dim_avg_Wrap(PT_AERO_2)) /(dim_avg_Wrap(PT_AERO_1 + PT_AERO_2)) + MAM_AERO = (dim_avg_Wrap(MAM_AERO_2))/(dim_avg_Wrap(MAM_AERO_1 + MAM_AERO_2)) + + copy_VarCoords(dim_avg_Wrap(PT_AERO_2), PT_AERO) + copy_VarCoords(dim_avg_Wrap(MAM_AERO_2), MAM_AERO) + + plotType = 3 +end if +end if +end if +end if +end if + +if(plotType .eq. 1)then + plotArray_PT = PT_AERO + plotArray_MAM = MAM_AERO +else if(plotType .eq. 2)then + ;Create the zonal mean + plotArray_PT = dim_avg_Wrap(PT_AERO) + plotArray_MAM = dim_avg_Wrap(MAM_AERO) +else if(plotType .eq. 3)then + ;Zonal mean already created + plotArray_PT = PT_AERO + plotArray_MAM = MAM_AERO +end if +end if +end if + +;Set intervals for plotting +maxPT = max(plotArray_PT) +minPT = maxPT/20.0 +maxMAM = max(plotArray_MAM) +minMAM = min(plotArray_MAM) + +maxUsed = sqrt(maxMAM*maxPT) +minUsed = sqrt(minMAM*minPT) + + +maxint = 10 +intervals = fspan(minUsed, maxUsed, maxint) + +;Do the plotting +wks = gsn_open_wks(format,var) + +plot=new(2,graphic) + +res = True ; plot mods desired + +res@cnFillOn = True ; color fill +res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +res@cnLevels = sprintf("%3.1e",intervals) +res@gsnFrame = False ; Do not draw plot +res@gsnDraw = False ; Do not advance frame + +if(plotType .eq. 1)then + res@gsnLeftString = varname_PT + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(plotArray_PT,0),res) ; create the plot + res@gsnLeftString = varname_MAM + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(plotArray_MAM,0),res) ; create the plot +else if (plotType .eq. 2 .or. plotType .eq. 3 )then + res@trYReverse = True ; reverse Y axis + res@gsnLeftString = varname_PT + plot(0)=gsn_csm_contour(wks,dim_avg_n_Wrap(plotArray_PT,0),res) + res@gsnLeftString = varname_MAM + plot(1)=gsn_csm_contour(wks,dim_avg_n_Wrap(plotArray_MAM,0),res) +end if +end if + +pres = True +gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.sh b/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.sh new file mode 100755 index 0000000000..2fbc5e3dcf --- /dev/null +++ b/tools/diagnostics/ncl/MAM3_vs_PTAERO/MAM3_vs_PTAERO.sh @@ -0,0 +1,20 @@ +#!/bin/sh + +#Create the plots +varlist="BC SO4 SS DUST OM BC_SRF SO4_SRF SS_SRF DUST_SRF OM_SRF SO2_SRF BC_CLOUD SO4_CLOUD SS_CLOUD DUST_CLOUD OM_CLOUD SF_DUST SF_SALT BC_CLFR OM_CLFR DUST_CLFR SS_CLFR SO4_CLFR BC_ZM OM_ZM DUST_ZM SS_ZM SO4_ZM" +for var in $varlist +do + echo $var + expression=\'var=\"$var\"\' + cmd="ncl $expression ./MAM3_vs_PTAERO.ncl" + echo $cmd + eval $cmd + pdf2ps $var.pdf + ps2eps -f $var.ps + epstopdf $var.eps + #echo $alf +done + +pdflatex burdens.tex +pdflatex burdens.tex + diff --git a/tools/diagnostics/ncl/MAM3_vs_PTAERO/README.txt b/tools/diagnostics/ncl/MAM3_vs_PTAERO/README.txt new file mode 100644 index 0000000000..944af3c549 --- /dev/null +++ b/tools/diagnostics/ncl/MAM3_vs_PTAERO/README.txt @@ -0,0 +1,11 @@ +THIS SCRIPT NEEDS THAT TWO VALID FILES +(WITH ONE TIME STEP EACH) ARE PLACED SOMEWHERE +WHICH CAN BE ACCESSED BY THE SCRIPT + +FILENAME_PT NEEDS TO CONTAIN THE OUTPUT VARIABLES FROM +A PRODUCTION TAGGED AEROSOL RUN +filename_PT="/disk1/alfg/noresmrun/PTAER/PTAERO1_1YR_HR/PTAERO_10Mnth.nc" + +FILENAME_MAM NEEDS TO CONTAIN THE OUTPUT VARIABLES FROM +A MAM3 AEROSOL RUN +filename_MAM="/disk1/alfg/noresmrun/PTAER/MAM3_1YR_HR/MAM3_10Mnth.nc" diff --git a/tools/diagnostics/ncl/MAM3_vs_PTAERO/burdens.tex b/tools/diagnostics/ncl/MAM3_vs_PTAERO/burdens.tex new file mode 100644 index 0000000000..a6b357871f --- /dev/null +++ b/tools/diagnostics/ncl/MAM3_vs_PTAERO/burdens.tex @@ -0,0 +1,182 @@ +% fisheye screenshot is from +%https://confluence.atlassian.com/display/FISHEYE/Viewing+the+commit+graph+for+a+repository + +\documentclass{beamer} +\usetheme{Frankfurt} +\usepackage{color} +%\usepackage{beamerthemeshadow} +\begin{document} +\title{Burdens MAM vs PTAERO} +%\author{Alf Grini} + +\frame{\titlepage} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{BC - Column} +\begin{center} +\includegraphics[width=\textwidth,height=0.8\textheight]{BC.pdf} +\end{center} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{OM - Column} +\includegraphics[width=\textwidth,height=0.8\textheight]{OM.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{DUST - Column} +\includegraphics[width=\textwidth,height=0.8\textheight]{DUST.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SS - Column} +\includegraphics[width=\textwidth,height=0.8\textheight]{SS.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO4 - Column} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO4.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{BC - SRF} +\begin{center} +\includegraphics[width=\textwidth,height=0.8\textheight]{BC_SRF.pdf} +\end{center} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{OM - SRF} +\includegraphics[width=\textwidth,height=0.8\textheight]{OM_SRF.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{DUST - SRF} +\includegraphics[width=\textwidth,height=0.8\textheight]{DUST_SRF.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SS - SRF} +\includegraphics[width=\textwidth,height=0.8\textheight]{SS_SRF.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO4 - SRF} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO4_SRF.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO2 - SRF} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO2_SRF.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{BC - CLOUD} +\begin{center} +\includegraphics[width=\textwidth,height=0.8\textheight]{BC_CLOUD.pdf} +\end{center} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{OM - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{OM_CLOUD.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{DUST - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{DUST_CLOUD.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SS - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{SS_CLOUD.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO4 - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO4_CLOUD.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{BC - ZM} +\begin{center} +\includegraphics[width=\textwidth,height=0.8\textheight]{BC_ZM.pdf} +\end{center} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{OM - ZM} +\includegraphics[width=\textwidth,height=0.8\textheight]{OM_ZM.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{DUST - ZM} +\includegraphics[width=\textwidth,height=0.8\textheight]{DUST_ZM.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SS - ZM} +\includegraphics[width=\textwidth,height=0.8\textheight]{SS_ZM.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO4 - ZM} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO4_ZM.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{BC - CLOUDFRACTION} +\begin{center} +\includegraphics[width=\textwidth,height=0.8\textheight]{BC_CLFR.pdf} +\end{center} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{OM - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{OM_CLFR.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{DUST - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{DUST_CLFR.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SS - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{SS_CLFR.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{SO4 - CLOUD} +\includegraphics[width=\textwidth,height=0.8\textheight]{SO4_CLFR.pdf} +\end{frame} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{frame}{Emissions dust } +\includegraphics[width=\textwidth,height=0.8\textheight]{SF_DUST.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\begin{frame}{Emissions salt } +\includegraphics[width=\textwidth,height=0.8\textheight]{SF_SALT.pdf} +\end{frame} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\end{document} diff --git a/tools/diagnostics/ncl/ModIvsModII/AOD_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/AOD_ModIvsModII.ncl new file mode 100644 index 0000000000..942d52092f --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/AOD_ModIvsModII.ncl @@ -0,0 +1,228 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in clear-sky or all-sky aerosol optical depth (AOD) +; from two versions of NorESM/CAM-Oslo and makes global plots of the annually +; averaged AODs, including global average as a number in the title line for +; each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 0 ; 0 => clear-sky AOD + ; 1 => all-sky AOD + ; 2 => all-sky SO4 AOD + ; 3 => all-sky BC AOD + ; 4 => all-sky OM AOD + ; 5 => all-sky SS AOD + ; 6 => all-sky DU AOD + ; 7 => clear-sky ABS + ; 8 => all-sky ABS + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + AOD_I=tmp_I + AOD_II=tmp_II + + if (plot_type.eq.0) then + var="CDOD550" ; name of main input-variable and plot + varname="Clear-sky AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->CDOD550)/)/((/(f1_I[:]->CLDFREE)/)+small)/((/(f1_I[:]->DAYFOC)/)+small) + AOD_II=(/(f1_II[:]->CDOD550)/)/((/(f1_II[:]->CLDFREE)/)+small)/((/(f1_II[:]->DAYFOC)/)+small) + else if (plot_type.eq.1) then + var="DOD550" ; name of main input-variable and plot + varname="AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->DOD550)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->DOD550)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.2) then + var="D550_SO4" ; name of main input-variable and plot + varname="SO4 AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_SO4)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->D550_SO4)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.3) then + var="D550_BC" ; name of main input-variable and plot + varname="BC AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_BC)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->D550_BC)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.4) then + var="D550_POM" ; name of main input-variable and plot + varname="POM AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_POM)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->D550_POM)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.5) then + var="D550_SS" ; name of main input-variable and plot + varname="Sea-salt AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_SS)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->D550_SS)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.6) then + var="D550_DU" ; name of main input-variable and plot + varname="Dust AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_DU)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->D550_DU)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.7) then + var="ABS550AL" ; name of main input-variable and plot + varname="All-sky ABS" ; variable name used in text string: + AOD_I=(/(f1_I[:]->ABS550AL)/)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->ABS550AL)/)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + else if (plot_type.eq.8) then + var="CABS550A" ; name of main input-variable and plot + varname="Clear-sky ABS" ; variable name used in text string: + AOD_I=(/(f1_I[:]->CABS550A)/)/((/(f1_I[:]->CLDFREE)/)+small)/((/(f1_I[:]->DAYFOC)/)+small) ; variable to be plotted from I + AOD_II=(/(f1_II[:]->CABS550A)/)/((/(f1_II[:]->CLDFREE)/)+small)/((/(f1_II[:]->DAYFOC)/)+small) ; variable to be plotted from II + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted AODs + + AOD_Ia=AOD_I ; initialization of global average variable + AOD_IIa=AOD_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(AOD_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + AOD_Ia(:,i,:)=AOD_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(AOD_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + AOD_IIa(:,i,:)=AOD_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each AOD variable +if (var .eq. "DOD550" .or. var .eq. "CDOD550" .or. var .eq. "D550_DU") then +; digg=(/0.01,0.02,0.03,0.05,0.1,0.15,0.2,0.25,0.3,0.5/) ; Total, DU + digg=(/0.02,0.03,0.05,0.1,0.15,0.2,0.25,0.3,0.5,1.0/) ; Total, DU +;test digg=(/0.05,0.1,0.15,0.2,0.25,0.3,0.5,1.0, 1.4, 1.6/) ; Total, DU + else if (var .eq. "D550_SO4" .or. var .eq. "D550_POM" .or. var .eq. "D550_SS") then + digg=(/0.005,0.01,0.02,0.03,0.04,0.05,0.07,0.1,0.15,0.2/) ; SO4, POM, SS + else if (var .eq. "D550_BC") then + digg=(/0.0005,0.001,0.002,0.003,0.004,0.005,0.007,0.01,0.015,0.02/) ; BC + else if (var .eq. "ABS550AL" .or. var .eq. "CABS550A") then + digg=(/0.0005,0.001,0.002,0.003,0.005,0.01,0.015,0.02,0.03,0.05/) ; ABS + end if + end if + end if +end if + + + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%7.4f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(AOD_Ia,0))/area1)) + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(AOD_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(AOD_IIa,0))/area1)) + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(AOD_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/AODratio_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/AODratio_ModIvsModII.ncl new file mode 100644 index 0000000000..95f5d52f67 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/AODratio_ModIvsModII.ncl @@ -0,0 +1,266 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in clear-sky and all-sky aerosol optical depth (AOD) for +; ambient and zero hunidities from two versions of NorESM/CAM-Oslo and makes global +; plots of the annually averaged (clear-sky AOD)/AOD or (dry aerosol AOD)/AOD, +; including global average as a number in the title line for each figure. Also +; (fine aerosol AOD)/AOD, (fine aerosol AOD + larger aerosol AOD)/AOD, and +; (sum of AOD for all constituents)/AOD can be plotted in the same way. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 6 ; 0 => (dry aerosol AOD)/AOD + ; 1 => (clear-sky AOD)/AOD, + ; 2 => (small sizes (wet d<1um) AOD)/AOD + ; 3 => (small & lage sizes AOD)/AOD + ; 4 => (sum of AOD for all species)/AOD + ; 5 => all-sky ANG = -ln(DOD870/DOD440)/ln(870/440) + ; 6 => clear-sky ANG = -ln(CDOD870/CDOD440)/ln(870/440) +end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + AOD_I=tmp_I + AOD_II=tmp_II + AOD1_I=tmp_I + AOD1_II=tmp_II + AOD2_I=tmp_I + AOD2_II=tmp_II + + if (plot_type.eq.0) then + var="dryAODbyAOD" ; name of main input-variable and plot + varname="AOD~B~dry ~N~/AOD" ; variable name used in text string: + AOD_I=(/(f1_I[:]->OD550DRY)/)/((/(f1_I[:]->DOD550)/)+small) + AOD1_I=(/(f1_I[:]->OD550DRY)/) + AOD2_I=(/(f1_I[:]->DOD550)/) + AOD_II=(/(f1_II[:]->OD550DRY)/)/((/(f1_II[:]->DOD550)/)+small) + AOD1_II=(/(f1_II[:]->OD550DRY)/) + AOD2_II=(/(f1_II[:]->DOD550)/) + else if (plot_type.eq.1) then + var="CAODbyAOD" ; name of plot to be made + varname="AOD~B~clear-sky ~N~/AOD " ; variable name used in text string: + AOD_I=(/(f1_I[:]->CDOD550)/)/((/(f1_I[:]->CLDFREE)/)+small)/((/(f1_I[:]->DOD550)/)) + AOD1_I=(/(f1_I[:]->CDOD550)/)/((/(f1_I[:]->CLDFREE)/)+small) + AOD2_I=(/(f1_I[:]->DOD550)/) + AOD_II=(/(f1_II[:]->CDOD550)/)/((/(f1_II[:]->CLDFREE)/)+small)/((/(f1_II[:]->DOD550)/)) + AOD1_II=(/(f1_II[:]->CDOD550)/)/((/(f1_II[:]->CLDFREE)/)+small) + AOD2_II=(/(f1_II[:]->DOD550)/) + else if (plot_type.eq.2) then + var="DLTbyAOD" ; name of plot to be made + varname="AOD~B~r<0.5~F33~m~F21~m ~N~/AOD " ; variable name used in text string: + AOD_I=((/(f1_I[:]->DLT_BC+f1_I[:]->DLT_SO4+f1_I[:]->DLT_POM+f1_I[:]->DLT_SS+f1_I[:]->DLT_DUST)/))/((/(f1_I[:]->DOD550)/)) + AOD1_I=(/(f1_I[:]->DLT_BC+f1_I[:]->DLT_SO4+f1_I[:]->DLT_POM+f1_I[:]->DLT_SS+f1_I[:]->DLT_DUST)/) + AOD2_I=(/(f1_I[:]->DOD550)/) + AOD_II=((/(f1_II[:]->DLT_BC+f1_II[:]->DLT_SO4+f1_II[:]->DLT_POM+f1_II[:]->DLT_SS+f1_II[:]->DLT_DUST)/))/((/(f1_II[:]->DOD550)/)) + AOD1_II=(/(f1_II[:]->DLT_BC+f1_II[:]->DLT_SO4+f1_II[:]->DLT_POM+f1_II[:]->DLT_SS+f1_II[:]->DLT_DUST)/) + AOD2_II=(/(f1_II[:]->DOD550)/) + else if (plot_type.eq.3) then + var="DLGTbyAOD" ; name of plot to be made + varname="(AOD~B~r<0.5~F33~m~F21~m ~N~+AOD~B~r>0.5~F33~m~F21~m~N~)/AOD " ; variable name used in text string: + AOD_I=(/(f1_I[:]->DLT_BC+f1_I[:]->DLT_SO4+f1_I[:]->DLT_POM+f1_I[:]->DLT_SS+f1_I[:]->DLT_DUST)/) + AOD1_I=(AOD_I+(/(f1_I[:]->DGT_BC+f1_I[:]->DGT_SO4+f1_I[:]->DGT_POM+f1_I[:]->DGT_SS+f1_I[:]->DGT_DUST)/)) + AOD2_I=(/(f1_I[:]->DOD550)/) + AOD_I=AOD1_I/AOD2_I + AOD_II=(/(f1_II[:]->DLT_BC+f1_II[:]->DLT_SO4+f1_II[:]->DLT_POM+f1_II[:]->DLT_SS+f1_II[:]->DLT_DUST)/) + AOD1_II=(AOD_II+(/(f1_II[:]->DGT_BC+f1_II[:]->DGT_SO4+f1_II[:]->DGT_POM+f1_II[:]->DGT_SS+f1_II[:]->DGT_DUST)/)) + AOD2_II=(/(f1_II[:]->DOD550)/) + AOD_II=AOD1_II/AOD2_II + else if (plot_type.eq.4) then + var="SumODbyAOD" ; name of plot to be made + varname="(AOD~B~SO4~N~+AOD~B~POM~N~+AOD~B~BC~N~+AOD~B~SS~N~+AOD~B~DU~N~)/AOD " ; variable name used in text string: + AOD_I=(/(f1_I[:]->D550_BC+f1_I[:]->D550_SO4+f1_I[:]->D550_POM+f1_I[:]->D550_SS+f1_I[:]->D550_DU)/)/(/(f1_I[:]->DOD550)/) + AOD_II=(/(f1_II[:]->D550_BC+f1_II[:]->D550_SO4+f1_II[:]->D550_POM+f1_II[:]->D550_SS+f1_II[:]->D550_DU)/)/(/(f1_II[:]->DOD550)/) + else if (plot_type.eq.5) then + var="ANG4487" ; name of plot to be made + varname="ANG~B~4487~N~ " ; variable name used in text string: +; AOD_I=-log((/f1_I[:]->DOD870/)/(/(f1_I[:]->DOD440)/))/log(870.0/440.0) + AOD_I=-log((/(f1_I[:]->DOD870)/)/(/(f1_I[:]->DOD440)/))/log(870.0/440.0) + AOD_II=-log((/(f1_II[:]->DOD870)/)/(/(f1_II[:]->DOD440)/))/log(870.0/440.0) +; AOD_I=-log((/(f1_I[:]->DOD670)/)/(/(f1_I[:]->DOD500)/))/log(670.0/500.0) ; alternative definition (ANG5067) +; AOD_II=-log((/(f1_II[:]->DOD670)/)/(/(f1_II[:]->DOD500)/))/log(670.0/500.0) ; alternative definition (ANG5067) + else if (plot_type.eq.6) then + var="CANG4487" ; name of plot to be made + varname="Clear-sky ANG~B~4487~N~ " ; variable name used in text string: + AOD_I =-log(((/(f1_I[:]->CDOD870)/)+small/((/(f1_I[:]->CLDFREE)/)+small))/((/(f1_I[:]->CDOD440)/)+small/((/(f1_I[:]->CLDFREE)/)+small)))/log(870.0/440.0) + AOD_II=-log((((/(f1_II[:]->CDOD870)/)+small)/((/(f1_II[:]->CLDFREE)/)+small))/(((/(f1_II[:]->CDOD440)/)+small)/((/(f1_II[:]->CLDFREE)/)+small)))/log(870.0/440.0) + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted values + + AOD_Ia=AOD_I ; initialization of global average variable + AOD_IIa=AOD_II + AOD1_Ia=AOD_I + AOD2_Ia=AOD_I + AOD1_IIa=AOD_II + AOD2_IIa=AOD_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(AOD_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + AOD_Ia(:,i,:)=AOD_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + if (plot_type.le.3) then + do i=0,dimsizes(gw0_I)-1 + AOD1_Ia(:,i,:)=AOD1_I(:,i,:)*coffa*dlon_I*gw0_I(i) + AOD2_Ia(:,i,:)=AOD2_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + end if + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(AOD_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + AOD_IIa(:,i,:)=AOD_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + if (plot_type.le.3) then + do i=0,dimsizes(gw0_II)-1 + AOD1_IIa(:,i,:)=AOD1_II(:,i,:)*coffa*dlon_II*gw0_II(i) + AOD2_IIa(:,i,:)=AOD2_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + end if + +; Defining color scales for each AOD variable + if (plot_type.eq.1) then + digg=(/0.5,0.75,0.9,0.95,0.99,1.01,1.05,1.1,1.25,1.5/) + else if (plot_type.eq.3.or.plot_type.eq.4) then + digg=(/0.998,0.999,0.9995,0.9998,0.9999,1.0/) + else if (plot_type.eq.5.or.plot_type.eq.6) then + digg=(/0.1,0.2,0.3,0.5,0.75,1.0,1.25,1.5,1.75,2.0/) + else + digg=(/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,0.95/) + end if + end if + end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + if (plot_type.eq.3) then + res@cnLevels = sprintf("%7.4f",digg) ; min level + else + res@cnLevels = sprintf("%5.2f",digg) ; min level + end if + +; res@tiMainString = "CAM4-Oslo" +; res@gsnRightString = "avg = "+sprintf("%5.2f",extave_I)+" ("+sprintf("%5.2f",aodave_I/loadave_I)+")" + + if (plot_type.le.3) then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(AOD_Ia,0))/area1))+" ("+sprintf("%5.3f",(sum(dim_avg_n(AOD1_Ia,0)))/(sum(dim_avg_n(AOD2_Ia,0))))+")" + else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(AOD_Ia,0))/area1)) + end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(AOD_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + if (plot_type.le.3) then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(AOD_IIa,0))/area1))+" ("+sprintf("%5.3f",(sum(dim_avg_n(AOD1_IIa,0)))/(sum(dim_avg_n(AOD2_IIa,0))))+")" + else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(AOD_IIa,0))/area1)) + end if + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(AOD_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/Cld2d_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Cld2d_ModIvsModII.ncl new file mode 100644 index 0000000000..aad120d0e5 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Cld2d_ModIvsModII.ncl @@ -0,0 +1,295 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 2d cloud cover or liquid/ice water path from two +; versions of NorESM/CAM-Oslo and makes global plots of the annually averaged +; cloud cover or water path, including global average as a number in the title +; line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 5 ; 0 => CLDTOT + ; 1 => CLDLOW + ; 2 => CLDMED + ; 3 => CLDHGH + ; 4 => Liquid Water Path + ; 5 => Ice Water Path + ; 6 => Column integrated cloud droplet concentration, a + ; 7 => Column integrated cloud droplet concentration, b + ; 8 => Precipitation + ; 9 => U10 +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + met_I=tmp_I + met_II=tmp_II + + if (plot_type.eq.0) then + var="CLDTOT" ; name of input-variable and plot + varname="CLDTOT" ; variable name used in text string: + met_I=(/(f1_I[:]->CLDTOT)/) ; variable to be plotted from I + met_II=(/(f1_II[:]->CLDTOT)/) ; variable to be plotted from II + else if (plot_type.eq.1) then + var="CLDLOW" ; name of input-variable and plot + varname="CLDLOW" ; variable name used in text string: + met_I=(/(f1_I[:]->CLDLOW)/) ; variable to be plotted from I + met_II=(/(f1_II[:]->CLDLOW)/) ; variable to be plotted from II + else if (plot_type.eq.2) then + var="CLDMED" ; name of input-variable and plot + varname="CLDMED" ; variable name used in text string: + met_I=(/(f1_I[:]->CLDMED)/) ; variable to be plotted from I + met_II=(/(f1_II[:]->CLDMED)/) ; variable to be plotted from II + else if (plot_type.eq.3) then + var="CLDHGH" ; name of input-variable and plot + varname="CLDHGH" ; variable name used in text string: + met_I=(/(f1_I[:]->CLDHGH)/) ; variable to be plotted from I + met_II=(/(f1_II[:]->CLDHGH)/) ; variable to be plotted from II + else if (plot_type.eq.4) then + var="TGCLDLWP" ; name of input-variable and plot + varname="Liquid water path" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + met_I=(/(f1_I[:]->TGCLDLWP)/) ; variable to be plotted from I + else + met_I=(/(f1_I[:]->TGCLDLWP)/)*1.e3 ; variable to be plotted from I + end if + met_II=(/(f1_II[:]->TGCLDLWP)/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.5) then + var="TGCLDIWP" ; name of input-variable and plot + varname="Ice water path" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + met_I=(/(f1_I[:]->TGCLDIWP)/) ; variable to be plotted from I + else + met_I=(/(f1_I[:]->TGCLDIWP)/)*1.e3 ; variable to be plotted from I + end if + met_II=(/(f1_II[:]->TGCLDIWP)/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.6) then + var="CDNUMC1" ; name of plot + varname="CDNC col." ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + met_I=1.e-6*(/(f1_I[:]->CLDTOT)/)*(/(f1_I[:]->CDNCINT)/)/((/(f1_I[:]->FOCHANA)/)+small) ; variable to be plotted from I + else + met_I=1.e-10*(/(f1_I[:]->CDNUMC)/) ; variable to be plotted from I + end if + met_II=1.e-10*(/(f1_II[:]->CDNUMC)/) ; variable to be plotted from II + else if (plot_type.eq.7) then + var="CDNUMC2" ; name of plot + varname="CDNC col." ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + met_I=1.e-6*(/(f1_I[:]->CLDTOT)/)*(/(f1_I[:]->CDNCINT)/) ; variable to be plotted from I + else + met_I=1.e-10*(/(f1_I[:]->CDNUMC)/) ; variable to be plotted from I + end if + met_II=1.e-10*(/(f1_II[:]->CDNUMC)/) ; variable to be plotted from II + else if (plot_type.eq.8) then + var="PRECIP" ; name of plot + varname="Precipitation" ; variable name used in text string: + met_I=8.64e7*((/(f1_I[:]->PRECC)/)+(/(f1_I[:]->PRECL)/)) ; variable to be plotted from I + met_II=8.64e7*((/(f1_II[:]->PRECC)/)+(/(f1_II[:]->PRECL)/)) ; variable to be plotted from II + else if (plot_type.eq.9) then + var="U10" ; name of plot + varname="10m wind" ; variable name used in text string: + met_I=(/(f1_I[:]->U10)/) ; variable to be plotted from I + met_II=(/(f1_II[:]->U10)/) ; variable to be plotted from II +; met_I=(/(f1_I[:]->U10)/)*(/(f1_I[:]->U10)/)*(/(f1_I[:]->U10)/) ; variable to be plotted from I +; met_II=(/(f1_II[:]->U10)/)*(/(f1_II[:]->U10)/)*(/(f1_II[:]->U10)/) ; variable to be plotted from II + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted meteorology variables + + met_Ia=met_I ; initialization of global average variable + met_IIa=met_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(met_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + met_Ia(:,i,:)=met_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(met_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + met_IIa(:,i,:)=met_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each meteorology variable +if (var.eq."CLDTOT".or.var.eq."CLDLOW".or.var.eq."CLDMED".or.var.eq."CLDHGH") then + digg=(/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,0.95/) + else if (var .eq. "TGCLDLWP") then + digg=(/3,5,10,20,30,50,100,150,200,300/) + else if (var .eq. "TGCLDIWP") then + digg=(/0.5,1,2,3,5,10,20,30,50,100/) + else if (var .eq. "CDNUMC1" .or. var .eq. "CDNUMC2") then + digg=(/0.1,0.2,0.3,0.5,1,2,4,6,8,10/) + else if (var .eq. "PRECIP") then + digg=(/0.05,0.1,0.25,0.5,1,1.5,2,3,5,10/) + else if (var .eq. "U10") then + digg=(/0.5,1.,2.,3.,4.,5.0,7.5,10.0,12.5,15./) +; digg=(/0.1,1.,5.,10.,50.,100.,500.,1000.,5000.,10000./) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" +if (var .eq. "TGCLDLWP" .or. var .eq. "TGCLDIWP") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" g m~S~-2~N~" +else if (var .eq. "CDNUMC1") then + if(ModI.eq."CAM4-Oslo") then + res@gsnRightString = "(CDNCINT*CLDTOT/FOCHANA) avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + else + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + end if +else if (var .eq. "CDNUMC2") then + if(ModI.eq."CAM4-Oslo") then + res@gsnRightString = "(CDNCINT*CLDTOT) avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + else + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + end if +else if (var .eq. "PRECIP") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (mm day~S~-1~N~)" +else if (var .eq. "U10") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1))+" (m s~S~-1~N~)" + else + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_Ia,0))/area1)) +end if +end if +end if +end if +end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(met_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" +if (var .eq. "TGCLDLWP" .or. var .eq. "TGCLDIWP") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_IIa,0))/area1))+" g m~S~-2~N~" +else if (var .eq. "CDNUMC1" .or. var .eq. "CDNUMC2") then + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_IIa,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" +else if (var .eq. "PRECIP") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_IIa,0))/area1))+" (mm day~S~-1~N~)" +else if (var .eq. "U10") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_IIa,0))/area1))+" (m s~S~-1~N~)" + else + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(met_IIa,0))/area1)) +end if +end if +end if +end if + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(met_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/ERF_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ERF_ModIvsModII.ncl new file mode 100644 index 0000000000..7eedcc18ca --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ERF_ModIvsModII.ncl @@ -0,0 +1,256 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in effective aerosol forcings/fluxes from two versions +; of NorESM / CAM-Oslo and makes global plots of the annually averaged forcings +; (ERF) including global average as a number in the title line for each figure. +; Note: LW forcings/fluxes have been defined positive downwards, as for SW. +; Hence, total forcing = SW + LW (instead of SW-LW). + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 3 ; 0 => TOA SW direct radiative forcing as ERF + dn + ; 1 => TOA SW Cloud radiative forcing as ERF + dn + ; 2 => TOA SW Surface albedo forcing as ERF + dn + ; 3 => TOA LW direct radiative forcing as ERF + dn also + ; 4 => TOA LW Cloud radiative forcing as ERF + dn also + ; 5 => TOA LW Surface albedo forcing as ERF + dn also + ; 6 => total TOA LW ERF (sun of 0 to 5) + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.0) then + var="direct_ERF" ; name of plot + varname="SW Direct radiative forcing at TOA" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNT_DRF)/)-(/(f1PI_I[:]->FSNT_DRF)/) ; variable to be plotted from I + else + forc_I=(/(f1PD_I[:]->FSNT)/)-(/(f1PI_I[:]->FSNT)/)-((/(f1PD_I[:]->FSNT_DRF)/)-(/(f1PI_I[:]->FSNT_DRF)/)) + end if + forc_II=(/(f1PD_II[:]->FSNT)/)-(/(f1PI_II[:]->FSNT)/)-((/(f1PD_II[:]->FSNT_DRF)/)-(/(f1PI_II[:]->FSNT_DRF)/)) + else if (plot_type.eq.1) then + var="cloud_ERF" ; name of input-variable and plot + varname="SW cloud radiative forcing at TOA" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNT_AIE)/)-(/(f1PI_I[:]->FSNT_AIE)/) ; variable to be plotted from I + else + forc_I=(/(f1PD_I[:]->FSNT_DRF)/)-(/(f1PI_I[:]->FSNT_DRF)/)-((/(f1PD_I[:]->FSNTCDRF)/)-(/(f1PI_I[:]->FSNTCDRF)/)) + end if + forc_II=(/(f1PD_II[:]->FSNT_DRF)/)-(/(f1PI_II[:]->FSNT_DRF)/)-((/(f1PD_II[:]->FSNTCDRF)/)-(/(f1PI_II[:]->FSNTCDRF)/)) + else if (plot_type.eq.2) then + var="surfalb_ERF" ; name of input-variable and plot + varname="SW surface albedo forcing (TOA)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNTCDRF)/)*0.0 ; variable to be plotted from I (no output, set = 0) + else + forc_I=(/(f1PD_I[:]->FSNTCDRF)/)-(/(f1PI_I[:]->FSNTCDRF)/) ; variable to be plotted from I + end if + forc_II=(/(f1PD_II[:]->FSNTCDRF)/)-(/(f1PI_II[:]->FSNTCDRF)/) ; variable to be plotted from II + else if (plot_type.eq.3) then + var="direct_ERF_LW" ; name of input-variable and plot + varname="LW Direct radiative forcing at TOA" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNT_DRF)/)*0.0 + else + forc_I=((/(f1PD_I[:]->FLNT_DRF)/)-(/(f1PI_I[:]->FLNT_DRF)/))-((/(f1PD_I[:]->FLNT)/)-(/(f1PI_I[:]->FLNT)/)) + end if + forc_II=((/(f1PD_II[:]->FLNT_DRF)/)-(/(f1PI_II[:]->FLNT_DRF)/))-((/(f1PD_II[:]->FLNT)/)-(/(f1PI_II[:]->FLNT)/)) + else if (plot_type.eq.4) then + var="cloud_ERF_LW" ; name of input-variable and plot + varname="LW cloud radiative forcing at TOA" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=-((/(f1PD_I[:]->FLNT_AIE)/)-(/(f1PI_I[:]->FLNT_AIE)/)) + else + forc_I=-((/(f1PD_I[:]->FLNT_DRF)/)-(/(f1PI_I[:]->FLNT_DRF)/))+((/(f1PD_I[:]->FLNTCDRF)/)-(/(f1PI_I[:]->FLNTCDRF)/)) + end if + forc_II=-((/(f1PD_II[:]->FLNT_DRF)/)-(/(f1PI_II[:]->FLNT_DRF)/))+((/(f1PD_II[:]->FLNTCDRF)/)-(/(f1PI_II[:]->FLNTCDRF)/)) + else if (plot_type.eq.5) then + var="surfalb_ERF_LW" ; name of input-variable and plot + varname="LW surface albedo forcing (TOA)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNTCDRF)/)*0.0 ; variable to be plotted from I (no output, set = 0) + else + forc_I=-((/(f1PD_I[:]->FLNTCDRF)/)-(/(f1PI_I[:]->FLNTCDRF)/)) ; variable to be plotted from I + end if + forc_II=-((/(f1PD_II[:]->FLNTCDRF)/)-(/(f1PI_II[:]->FLNTCDRF)/)) ; variable to be plotted from II + else if (plot_type.eq.6) then + var="total_ERF" ; name of input-variable and plot + varname="Total SW + LW ERF (TOA)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then +; forc_I=(/(f1PD_I[:]->FSNT_DRF)/)-(/(f1PI_I[:]->FSNT_DRF)/)+(/(f1PD_I[:]->FSNT_AIE)/)-(/(f1PI_I[:]->FSNT_AIE)/)-((/(f1PD_I[:]->FLNT_AIE)/)-(/(f1PI_I[:]->FLNT_AIE)/)) + forc_I=(/(f1PD_I[:]->FSNT)/)-(/(f1PI_I[:]->FSNT)/)-((/(f1PD_I[:]->FLNT)/)-(/(f1PI_I[:]->FLNT)/)) + else + forc_I=(/(f1PD_I[:]->FSNT)/)-(/(f1PI_I[:]->FSNT)/)-((/(f1PD_I[:]->FLNT)/)-(/(f1PI_I[:]->FLNT)/)) + end if + forc_II=(/(f1PD_II[:]->FSNT)/)-(/(f1PI_II[:]->FSNT)/)-((/(f1PD_II[:]->FLNT)/)-(/(f1PI_II[:]->FLNT)/)) + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each forcing variable +if (var .eq. "direct_ERF") then + digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) +; digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) +; else if (var .eq. "cloud_ERF") then + else if (var .eq. "cloud_ERF" .or. var .eq. "total_ERF") then +; digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5/) + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) + else if (var .eq. "surfalb_ERF") then + digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) + else if (var .eq. "direct_ERF_LW") then + digg=(/0.005,0.01,0.02,0.03,0.05,0.07,0.1,0,0.15/) +; digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) + else if (var .eq. "cloud_ERF_LW") then +; digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) + else if (var .eq. "surfalb_ERF_LW") then +; digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/ERFsurf_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ERFsurf_ModIvsModII.ncl new file mode 100644 index 0000000000..62c4322d36 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ERFsurf_ModIvsModII.ncl @@ -0,0 +1,221 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in effective aerosol forcings/fluxes from two versions +; of NorESM / CAM-Oslo and makes global plots of the annually averaged forcings +; (ERF) including global average as a number in the title line for each figure. +; Note: LW forcings/fluxes have been defined positive downwards, as for SW. +; Hence, total forcing = SW + LW (instead of SW-LW). + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 3 ; 0 => surface TOA SW direct radiative forcing as ERF + ; 1 => TOA SW Cloud radiative forcing as ERF + ; 2 => TOA LW direct radiative forcing as ERF + ; 3 => TOA LW Cloud radiative forcing as ERF + ; 4 => total TOA LW ERF (sun of 0 to 5) + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.0) then + var="direct_ERFsurf" ; name of plot + varname="SW Direct radiative forcing at surface" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNS_DRF)/)-(/(f1PI_I[:]->FSNS_DRF)/) ; variable to be plotted from I + else + forc_I=(/(f1PD_I[:]->FSNS)/)-(/(f1PI_I[:]->FSNS)/)-((/(f1PD_I[:]->FSNS_DRF)/)-(/(f1PI_I[:]->FSNS_DRF)/)) + end if + forc_II=(/(f1PD_II[:]->FSNS)/)-(/(f1PI_II[:]->FSNS)/)-((/(f1PD_II[:]->FSNS_DRF)/)-(/(f1PI_II[:]->FSNS_DRF)/)) + else if (plot_type.eq.1) then + var="cloud_ERFsurf" ; name of input-variable and plot + varname="SW cloud radiative forcing at surface" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNS_AIE)/)-(/(f1PI_I[:]->FSNS_AIE)/) ; variable to be plotted from I + else + forc_I=(/(f1PD_I[:]->FSNS_DRF)/)-(/(f1PI_I[:]->FSNS_DRF)/)-((/(f1PD_I[:]->FSNSCDRF)/)-(/(f1PI_I[:]->FSNSCDRF)/)) + end if + forc_II=(/(f1PD_II[:]->FSNS_DRF)/)-(/(f1PI_II[:]->FSNS_DRF)/)-((/(f1PD_II[:]->FSNSCDRF)/)-(/(f1PI_II[:]->FSNSCDRF)/)) + else if (plot_type.eq.2) then + var="direct_ERFsurf_LW" ; name of input-variable and plot + varname="LW Direct radiative forcing at surface" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNS_DRF)/)*0.0 + else + forc_I=((/(f1PD_I[:]->FLNS_DRF)/)-(/(f1PI_I[:]->FLNS_DRF)/))-((/(f1PD_I[:]->FLNS)/)-(/(f1PI_I[:]->FLNS)/)) + end if + forc_II=((/(f1PD_II[:]->FLNS_DRF)/)-(/(f1PI_II[:]->FLNS_DRF)/))-((/(f1PD_II[:]->FLNS)/)-(/(f1PI_II[:]->FLNS)/)) + else if (plot_type.eq.3) then + var="cloud_ERFsurf_LW" ; name of input-variable and plot + varname="LW cloud radiative forcing at surface" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=-((/(f1PD_I[:]->FLNS_AIE)/)-(/(f1PI_I[:]->FLNS_AIE)/)) + else + forc_I=-((/(f1PD_I[:]->FLNS_DRF)/)-(/(f1PI_I[:]->FLNS_DRF)/))+((/(f1PD_I[:]->FLNSCDRF)/)-(/(f1PI_I[:]->FLNSCDRF)/)) + end if + forc_II=-((/(f1PD_II[:]->FLNS_DRF)/)-(/(f1PI_II[:]->FLNS_DRF)/))+((/(f1PD_II[:]->FLNSCDRF)/)-(/(f1PI_II[:]->FLNSCDRF)/)) + else if (plot_type.eq.4) then + var="total_ERFsurf" ; name of input-variable and plot + varname="Total SW + LW ERF at surface" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + forc_I=(/(f1PD_I[:]->FSNS)/)-(/(f1PI_I[:]->FSNS)/)-((/(f1PD_I[:]->FLNS)/)-(/(f1PI_I[:]->FLNS)/)) + else + forc_I=(/(f1PD_I[:]->FSNS)/)-(/(f1PI_I[:]->FSNS)/)-((/(f1PD_I[:]->FLNS)/)-(/(f1PI_I[:]->FLNS)/)) + end if + forc_II=(/(f1PD_II[:]->FSNS)/)-(/(f1PI_II[:]->FSNS)/)-((/(f1PD_II[:]->FLNS)/)-(/(f1PI_II[:]->FLNS)/)) + end if + end if + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each forcing variable +if (var .eq. "direct_ERFsurf") then + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) + else if (var .eq. "cloud_ERFsurf" .or. var .eq. "total_ERFsurf") then + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) + else if (var .eq. "direct_ERFsurf_LW") then + digg=(/-2,-1,-0.5,-0.25,-0.1,0,0.1,0.25,0.5,1,2/) + else if (var .eq. "cloud_ERFsurf_LW") then + digg=(/-10,-5,-3,-1,-0.5,0,0.5,1,3,5,10/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/EffDryRad_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/EffDryRad_ModIvsModII.ncl new file mode 100644 index 0000000000..a6c117e6aa --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/EffDryRad_ModIvsModII.ncl @@ -0,0 +1,181 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in vertically integrated effective dry aerosol radii +; (from total aerosol volume divided by area) for all sizes, and for dry r < 0.5um +; and r > 0.5um, from two versions of NorESM/CAM-Oslo. It makes global plots of +; the respective annually averaged effective dry radius, including global average +; as a number in the title line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => effective dry radius, all r + ; 1 => effective dry radius, r < 0.5 um + ; 2 => effective dry radius, r > 0.5 um + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + DER_I=tmp_I + DER_II=tmp_II + + if (plot_type.eq.0) then + var="DER" ; name of main input-variable and plot + varname="Effective dry radius, all r" ; variable name used in text string: + DER_I=(/(f1_I[:]->DER)/) + DER_II=(/(f1_II[:]->DER)/) + else if (plot_type.eq.1) then + var="DERLT05" ; name of plot to be made + varname="Effective dry radius, r<0.5~F33~m~F21~m" ; variable name used in text string: + DER_I=(/(f1_I[:]->DERLT05)/) + DER_II=(/(f1_II[:]->DERLT05)/) + else if (plot_type.eq.2) then + var="DERGT05" ; name of plot to be made + varname="Effective dry radius, r>0.5~F33~m~F21~m" ; variable name used in text string: + DER_I=(/(f1_I[:]->DERGT05)/) + DER_II=(/(f1_II[:]->DERGT05)/) + end if + end if + end if + +; Calculating area weighted values + + DER_Ia=DER_I ; initialization of global average variable + DER_IIa=DER_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(DER_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + DER_Ia(:,i,:)=DER_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(DER_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + DER_IIa(:,i,:)=DER_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each DER variable + if (plot_type.eq.0) then + digg=(/0.1,0.15,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9/) + else if (plot_type.eq.1) then + digg=(/0.06,0.07,0.08,0.1,0.12,0.15,0.2,0.25,0.3,0.4/) + else + digg=(/0.8,1.0,1.2,1.4,1.6,1.8,2.0,2.2,2.4,2.6/) + end if + end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + if (plot_type.eq.3) then + res@cnLevels = sprintf("%7.4f",digg) ; min level + else + res@cnLevels = sprintf("%5.2f",digg) ; min level + end if + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(DER_Ia,0))/area1))+" ~F33~m~F21~m" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(DER_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(DER_IIa,0))/area1))+" ~F33~m~F21~m" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(DER_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/Emis_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Emis_ModIvsModII.ncl new file mode 100644 index 0000000000..bb91ebe59c --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Emis_ModIvsModII.ncl @@ -0,0 +1,304 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol emissions from two versions of NorESM/CAM-Oslo +; and makes global plots of the annually averaged emissions, including global +; average as a number in the title line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 5 ;-1 => DMS emissions + ; 0 => SO2 emissions + ; 1 => SO4 emissions + ; 2 => BC emissions + ; 3 => POM emissions + ; 4 => SS emissions + ; 5 => DU emissions + ; 6 => Isoprene emissions + ; 7 => Monoterpene emissions + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + load_I=tmp_I + load_II=tmp_II + + if (plot_type.eq.-1) then + var="EMI_DMS" + varname="DMS emissions" + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_DMS)/)*1.e12 + else + load_I = (/f1_I[:]->SFDMS/)*32/62; as S + load_I = load_I*1.e12 + end if + load_II = (/f1_II[:]->SFDMS/)*32/62; as S + load_II = load_II*1.e12 + else if (plot_type.eq.0) then + var="EMI_SO2" ; name of input-variable and plot + varname="SO2 emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_SO2)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFSO2)/)/1.998 + (/(f1_I[:]->SO2_XFRC_COL)/)/1.998 ; variable to be plotted from I + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFSO2)/)/1.998 + (/(f1_II[:]->SO2_XFRC_COL)/)/1.998 ; variable to be plotted from II + load_II = load_II*1.e12 + else if (plot_type.eq.1) then + var="EMI_SO4" ; name of input-variable and plot + varname="SO4 emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_SO4)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFSO4_A1)/)/3.06 + (/(f1_I[:]->SFSO4_A2)/)/3.59 + (/(f1_I[:]->SFSO4_AC)/)/3.06 + (/(f1_I[:]->SFSO4_NA)/)/3.06 + (/(f1_I[:]->SFSO4_PR)/)/3.06 + (/(f1_I[:]->SO4_PR_XFRC_COL)/)/3.06 + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFSO4_A1)/)/3.06 + (/(f1_II[:]->SFSO4_A2)/)/3.59 + (/(f1_II[:]->SFSO4_AC)/)/3.06 + (/(f1_II[:]->SFSO4_NA)/)/3.06 + (/(f1_II[:]->SFSO4_PR)/)/3.06 + (/(f1_II[:]->SO4_PR_XFRC_COL)/)/3.06 + load_II = load_II*1.e12 + else if (plot_type.eq.2) then + var="EMI_BC" ; name of input-variable and plot + varname="BC emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_BC)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFBC_A)/) + (/(f1_I[:]->SFBC_AC)/) + (/(f1_I[:]->SFBC_AX)/) + (/(f1_I[:]->SFBC_AI)/) + (/(f1_I[:]->SFBC_NI)/) + (/(f1_I[:]->SFBC_N)/) + (/(f1_I[:]->BC_AX_XFRC_COL)/) + (/(f1_I[:]->BC_NI_XFRC_COL)/) + (/(f1_I[:]->BC_N_XFRC_COL)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFBC_A)/) + (/(f1_II[:]->SFBC_AC)/) + (/(f1_II[:]->SFBC_AX)/) + (/(f1_II[:]->SFBC_AI)/) + (/(f1_II[:]->SFBC_NI)/) + (/(f1_II[:]->SFBC_N)/) + (/(f1_II[:]->BC_AX_XFRC_COL)/) + (/(f1_II[:]->BC_NI_XFRC_COL)/) + (/(f1_II[:]->BC_N_XFRC_COL)/) + load_II = load_II*1.e12 + else if (plot_type.eq.3) then + var="EMI_POM" ; name of input-variable and plot + varname="POM emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_POM)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFOM_AI)/) + (/(f1_I[:]->SFOM_AC)/) + (/(f1_I[:]->SFOM_NI)/) + (/(f1_I[:]->OM_NI_XFRC_COL)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFOM_AI)/) + (/(f1_II[:]->SFOM_AC)/) + (/(f1_II[:]->SFOM_NI)/) + (/(f1_II[:]->OM_NI_XFRC_COL)/) + load_II = load_II*1.e12 + else if (plot_type.eq.4) then + var="EMI_SS" ; name of input-variable and plot + varname="Sea-salt emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_SS)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFSS_A1)/) + (/(f1_I[:]->SFSS_A2)/) + (/(f1_I[:]->SFSS_A3)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFSS_A1)/) + (/(f1_II[:]->SFSS_A2)/) + (/(f1_II[:]->SFSS_A3)/) + load_II = load_II*1.e12 + else if (plot_type.eq.5) then + var="EMI_DUST" ; name of input-variable and plot + varname="Dust emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_DUST)/)*1.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFDST_A2)/) + (/(f1_I[:]->SFDST_A3)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFDST_A2)/) + (/(f1_II[:]->SFDST_A3)/) + load_II = load_II*1.e12 + else if (plot_type.eq.6) then + var="SFisoprene" ; name of input-variable and plot + varname="Isoprene emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_DUST)/)*0.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFisoprene)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFisoprene)/) + load_II = load_II*1.e12 + else if (plot_type.eq.7) then + var="SFmonoterp" ; name of input-variable and plot + varname="Monoterpene emissions" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->EMI_DUST)/)*0.e12 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->SFmonoterp)/) + load_I = load_I*1.e12 + end if + load_II=(/(f1_II[:]->SFmonoterp)/) + load_II = load_II*1.e12 + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted loads + + load_Ia=load_I ; initialization of global average variable + load_IIa=load_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(load_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(load_IIa) +; print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each load variable +if (var .eq. "EMI_SO2" .or. var .eq. "EMI_BC" .or. var .eq. "EMI_DMS") then + digg=(/0.01,0.05,0.1,0.25,0.5,1,2.5,5,10,25/) ; EMI_DMS & SO2 & BC + else if (var .eq. "EMI_SO4") then + digg=(/0.001,0.005,0.01,0.025,0.05,0.1,0.25,0.5,1,2.5/) ; EMI_SO4 + else if (var .eq. "EMI_POM") then + digg=(/0.1,0.25,0.5,1,2.5,5,10,25,50,100/) ; EMI_POM + else if (var .eq. "EMI_SS") then + digg=(/5,10,25,50,100,250,500,1000,1500,2000/) ; EMI_SS + else if (var .eq. "SFisoprene" .or. var .eq. "SFmonoterp") then + digg=(/1,2,5,10,25,50,100,250,500,1000/) ; SFisoprene + else if (var .eq. "EMI_DUST") then +; digg=(/50,100,250,500,750,1000,1500,2500,5000,7500/) ; EMI_DU + digg=(/250,500,750,1000,1500,2500,5000,7500,15000,25000/) ; EMI_DU + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level +; res@mpShapeMode = "FreeAspect" +; res@vpWidthF = 0.8 +; res@vpHeightF = 0.6 + + +; res@tiMainString = "CAM4-Oslo" +if (var .eq. "EMI_SO2" .or. var .eq. "EMI_SO4") then +;err res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_Ia,0))/area1))+" ~F33~m~F21~g S m~S~-2~N~ s~S~-1~N~" + res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_Ia,0))/area1))+" ng S m~S~-2~N~ s~S~-1~N~" +else +;err res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_Ia,0))/area1))+" ~F33~m~F21~g m~S~-2~N~ s~S~-1~N~" + res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_Ia,0))/area1))+" ng m~S~-2~N~ s~S~-1~N~" +end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(load_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" +if (var .eq. "EMI_SO2" .or. var .eq. "EMI_SO4") then +;err res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_IIa,0))/area1))+" ~F33~m~F21~g S m~S~-2~N~ s~S~-1~N~" + res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_IIa,0))/area1))+" ng S m~S~-2~N~ s~S~-1~N~" +else +;err res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_IIa,0))/area1))+" ~F33~m~F21~g m~S~-2~N~ s~S~-1~N~" + res@gsnRightString = "avg = "+sprintf("%6.3f",(sum(dim_avg_n(load_IIa,0))/area1))+" ng m~S~-2~N~ s~S~-1~N~" +end if + res@gsnLeftString = varname + + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(load_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" +; pres@gsnPaperOrientation = "portrait + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/Ext_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Ext_ModIvsModII.ncl new file mode 100644 index 0000000000..97a4e790e2 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Ext_ModIvsModII.ncl @@ -0,0 +1,454 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol loads and AOD from two versions of +; NorESM/CAM-Oslo and makes global plots of the annually averaged +; aerosol extinction coefficient, defined as AOD/load, including global +; average as a number in the title line for each figure. In this updated +; version of the script the global average is be calculated both as area +; averaged EXT and as area averaged AOD / area averaged aerosol column +; burden (load), with its calculated value given in brackets. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 1 ; 1 => SO4 mass extinction coefficient + ; 2 => BC mass extinction coefficient + ; 3 => POM mass extinction coefficient + ; 4 => SS mass extinction coefficient + ; 5 => DU mass extinction coefficient + ; 6 => Mode 0 (dry) mass extinction coefficient + ; 7 => Mode 1 (dry) mass extinction coefficient + ; 8 => Mode 2 (dry) mass extinction coefficient + ; 9 => Mode 4 (dry) mass extinction coefficient + ; 10 => Mode 5 (dry) mass extinction coefficient + ; 11 => Mode 6 (dry) mass extinction coefficient + ; 12 => Mode 7 (dry) mass extinction coefficient + ; 12 => Mode 8 (dry) mass extinction coefficient + ; 14 => Mode 9 (dry) mass extinction coefficient + ; 15 => Mode 10 (dry) mass extinction coefficient + ; 16 => Mode 12 (dry) mass extinction coefficient + ; 17 => Mode 14 (dry) mass extinction coefficient + ; 18 => BC mass absorbtion coefficient + ; 19 => alternative BC mass absorbtion coefficient (min) + ; 20 => alternative BC mass absorbtion coefficient (max) + end if + if (.not. isvar("format")) then ; is format on command line? +; format = "ps" +; format = "eps" + format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + ext_I=tmp_I + ext_II=tmp_II + aod_I=tmp_I + aod_II=tmp_II + load_I=tmp_I + load_II=tmp_II + + if (plot_type.eq.1) then + var="EXT_SO4" ; name of input-variable and plot + varname="SO~B~4~N~ extinction coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->D550_SO4/) ; variable to be plotted from I + aod_II=(/f1_II[:]->D550_SO4/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_SO4/)*1.e3 ; variable to be plotted from I + ext_I=(/f1_I[:]->D550_SO4/)/(/(f1_I[:]->C_SO4)/)*1.e-3 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_SO4_A1)/)/3.06 + (/(f1_I[:]->cb_SO4_A2)/)/3.59 + (/(f1_I[:]->cb_SO4_AC)/)/3.06 + (/(f1_I[:]->cb_SO4_NA)/)/3.06 + (/(f1_I[:]->cb_SO4_PR)/)/3.06 + load_I=load_I*1.e3 + ext_I=aod_I/load_I + end if + load_II=(/(f1_II[:]->cb_SO4_A1)/)/3.06 + (/(f1_II[:]->cb_SO4_A2)/)/3.59 + (/(f1_II[:]->cb_SO4_AC)/)/3.06 + (/(f1_II[:]->cb_SO4_NA)/)/3.06 + (/(f1_II[:]->cb_SO4_PR)/)/3.06 + load_II=load_II*1.e3 + ext_II=aod_II/load_II + else if (plot_type.eq.2) then + var="EXT_BC" ; name of input-variable and plot + varname="BC extinction coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->D550_BC/) ; variable to be plotted from I + aod_II=(/f1_II[:]->D550_BC/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + ext_I=(/f1_I[:]->D550_BC/)/(/(f1_I[:]->C_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_BC/)*1.e3 ; variable to be plotted from I + else + ext_I=(/f1_I[:]->D550_BC/)/(/(f1_I[:]->cb_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_BC/)*1.e3 ; variable to be plotted from I + end if + ext_II=(/f1_II[:]->D550_BC/)/(/(f1_II[:]->cb_BC)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_BC/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.3) then + var="EXT_POM" ; name of input-variable and plot + varname="POM extinction coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->D550_POM/) ; variable to be plotted from I + aod_II=(/f1_II[:]->D550_POM/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + ext_I=(/f1_I[:]->D550_POM/)/(/(f1_I[:]->C_POM)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_POM/)*1.e3 ; variable to be plotted from I + else + ext_I=(/f1_I[:]->D550_POM/)/(/(f1_I[:]->cb_OM)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_OM/)*1.e3 ; variable to be plotted from I + end if + ext_II=(/f1_II[:]->D550_POM/)/(/(f1_II[:]->cb_OM)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_OM/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.4) then + var="EXT_SS" ; name of input-variable and plot + varname="Sea-salt extinction coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->D550_SS/) ; variable to be plotted from I + aod_II=(/f1_II[:]->D550_SS/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + ext_I=(/f1_I[:]->D550_SS/)/(/(f1_I[:]->C_SS)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_SS/)*1.e3 ; variable to be plotted from I + else + ext_I=(/f1_I[:]->D550_SS/)/(/(f1_I[:]->cb_SALT)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_SALT/)*1.e3 ; variable to be plotted from I + end if + ext_II=(/f1_II[:]->D550_SS/)/(/(f1_II[:]->cb_SALT)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_SALT/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.5) then + var="EXT_DUST" ; name of input-variable and plot + varname="Dust extinction coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->D550_DU/) ; variable to be plotted from I + aod_II=(/f1_II[:]->D550_DU/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + ext_I=(/f1_I[:]->D550_DU/)/(/(f1_I[:]->C_DUST)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_DUST/)*1.e3 ; variable to be plotted from I + else + ext_I=(/f1_I[:]->D550_DU/)/(/(f1_I[:]->cb_DUST)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_DUST/)*1.e3 ; variable to be plotted from I + end if + ext_II=(/f1_II[:]->D550_DU/)/(/(f1_II[:]->cb_DUST)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_DUST/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.6) then +; ex: mecdry0=1.e3*float(TAUKC0/CMDRY0) + var="MEC_mode0" ; name of input-variable and plot + varname="Mode 0 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC0/) + load_II=1.e-3*(/f1_II[:]->CMDRY0/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.7) then + var="MEC_mode1" ; name of input-variable and plot + varname="Mode 1 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC1/) + load_II=1.e-3*(/f1_II[:]->CMDRY1/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.8) then + var="MEC_mode2" ; name of input-variable and plot + varname="Mode 2 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC2/) + load_II=1.e-3*(/f1_II[:]->CMDRY2/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.9) then + var="MEC_mode4" ; name of input-variable and plot + varname="Mode 4 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC4/) + load_II=1.e-3*(/f1_II[:]->CMDRY4/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.10) then + var="MEC_mode5" ; name of input-variable and plot + varname="Mode 5 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC5/) + load_II=1.e-3*(/f1_II[:]->CMDRY5/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.11) then + var="MEC_mode6" ; name of input-variable and plot + varname="Mode 6 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC6/) + load_II=1.e-3*(/f1_II[:]->CMDRY6/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.12) then + var="MEC_mode7" ; name of input-variable and plot + varname="Mode 7 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC7/) + load_II=1.e-3*(/f1_II[:]->CMDRY7/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.13) then + var="MEC_mode8" ; name of input-variable and plot + varname="Mode 8 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC8/) + load_II=1.e-3*(/f1_II[:]->CMDRY8/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.14) then + var="MEC_mode9" ; name of input-variable and plot + varname="Mode 9 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC9/) + load_II=1.e-3*(/f1_II[:]->CMDRY9/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.15) then + var="MEC_mode10" ; name of input-variable and plot + varname="Mmode 10 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC10/) + load_II=1.e-3*(/f1_II[:]->CMDRY10/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.16) then + var="MEC_mode12" ; name of input-variable and plot + varname="Mode 12 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC12/) + load_II=1.e-3*(/f1_II[:]->CMDRY12/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.17) then + var="MEC_mode14" ; name of input-variable and plot + varname="Mode 14 extinction coefficient" ; variable name used in text string: +;temporary fix for ModI + aod_I=(/f1_I[:]->DOD550/)*1.e-9 + load_I=1.e-3*(/f1_I[:]->DOD550/) + ext_I=aod_I/(load_I+1.e-9) + aod_II=(/f1_II[:]->TAUKC14/) + load_II=1.e-3*(/f1_II[:]->CMDRY14/) + ext_II=aod_II/(load_II+1.e-9) + else if (plot_type.eq.18) then + var="ABS_BC" ; name of input-variable and plot + varname="BC absorption coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->A550_BC/) ; variable to be plotted from I + aod_II=(/f1_II[:]->A550_BC/) ; variable to be plotted from II + if(ModI.eq."CAM4-Oslo") then + ext_I=(/f1_I[:]->A550_BC/)/(/(f1_I[:]->C_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_BC/)*1.e3 ; variable to be plotted from I + else + ext_I=(/f1_I[:]->A550_BC/)/(/(f1_I[:]->cb_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_BC/)*1.e3 ; variable to be plotted from I + end if + ext_II=(/f1_II[:]->A550_BC/)/(/(f1_II[:]->cb_BC)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_BC/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.19) then + var="ABS_BCalt" ; name of input-variable and plot + varname="BC+SO4+SS absorption coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->A550_BC/) + (/f1_I[:]->A550_SO4/) + (/f1_I[:]->A550_SS/) + aod_II=(/f1_II[:]->A550_BC/) + (/f1_II[:]->A550_SO4/) + (/f1_II[:]->A550_SS/) + if(ModI.eq."CAM4-Oslo") then + ext_I=((/f1_I[:]->A550_BC/)+(/f1_I[:]->A550_SO4/)+(/f1_I[:]->A550_SS/))/(/(f1_I[:]->C_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->C_BC/)*1.e3 ; variable to be plotted from I + else + ext_I=((/f1_I[:]->A550_BC/)+(/f1_I[:]->A550_SO4/)+(/f1_I[:]->A550_SS/))/(/(f1_I[:]->cb_BC)/)*1.e-3 ; variable to be plotted from I + load_I=(/f1_I[:]->cb_BC/)*1.e3 ; variable to be plotted from I + end if + ext_II=((/f1_II[:]->A550_BC/)+(/f1_II[:]->A550_SO4/)+(/f1_II[:]->A550_SS/))/(/(f1_II[:]->cb_BC)/)*1.e-3 ; variable to be plotted from II + load_II=(/f1_II[:]->cb_BC/)*1.e3 ; variable to be plotted from II + else if (plot_type.eq.20) then + var="ABS_BCaltmax" ; name of input-variable and plot + varname="BC+all absorption coefficient" ; variable name used in text string: + aod_I=(/f1_I[:]->A550_BC/) + (/f1_I[:]->A550_SO4/) + (/f1_I[:]->A550_SS/) + (/f1_I[:]->A550_POM/)+ (/f1_I[:]->A550_DU/) + aod_II=(/f1_II[:]->A550_BC/) + (/f1_II[:]->A550_SO4/) + (/f1_II[:]->A550_SS/) + (/f1_II[:]->A550_POM/)+ (/f1_II[:]->A550_DU/) + if(ModI.eq."CAM4-Oslo") then + ext_I=((/f1_I[:]->A550_BC/)+(/f1_I[:]->A550_SO4/)+(/f1_I[:]->A550_SS/)+(/f1_I[:]->A550_POM/)+(/f1_I[:]->A550_DU/))/(/(f1_I[:]->C_BC)/)*1.e-3 + load_I=(/f1_I[:]->C_BC/)*1.e3 ; variable to be plotted from I + else + ext_I=((/f1_I[:]->A550_BC/)+(/f1_I[:]->A550_SO4/)+(/f1_I[:]->A550_SS/)+(/f1_I[:]->A550_POM/)+(/f1_I[:]->A550_DU/))/(/(f1_I[:]->cb_BC)/)*1.e-3 + load_I=(/f1_I[:]->cb_BC/)*1.e3 ; variable to be plotted from I + end if + ext_II=((/f1_II[:]->A550_BC/)+(/f1_II[:]->A550_SO4/)+(/f1_II[:]->A550_SS/)+(/f1_II[:]->A550_POM/)+(/f1_II[:]->A550_DU/))/(/(f1_II[:]->cb_BC)/)*1.e-3 + load_II=(/f1_II[:]->cb_BC/)*1.e3 ; variable to be plotted from II + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted extinctions + + ext_Ia=ext_I ; initialization of global average variables + ext_IIa=ext_II + aod_Ia=ext_I + aod_IIa=ext_II + load_Ia=ext_I + load_IIa=ext_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(ext_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + ext_Ia(:,i,:)=ext_I(:,i,:)*coffa*dlon_I*gw0_I(i) + aod_Ia(:,i,:)=aod_I(:,i,:)*coffa*dlon_I*gw0_I(i) + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + extave_I=sum(dim_avg_n(ext_Ia,0))/area1 + aodave_I=sum(dim_avg_n(aod_Ia,0))/area1 + loadave_I=sum(dim_avg_n(load_Ia,0))/area1 + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(ext_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + ext_IIa(:,i,:)=ext_II(:,i,:)*coffa*dlon_II*gw0_II(i) + aod_IIa(:,i,:)=aod_II(:,i,:)*coffa*dlon_II*gw0_II(i) + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + extave_II=sum(dim_avg_n(ext_IIa,0))/area1 + aodave_II=sum(dim_avg_n(aod_IIa,0))/area1 + loadave_II=sum(dim_avg_n(load_IIa,0))/area1 + +; Defining color scale + digg=(/1,2,3,4,5,7,10,15,20,30/) + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" +if (var .eq. "EXT_SO4") then + res@gsnRightString = "avg = "+sprintf("%5.2f",extave_I)+" ("+sprintf("%5.2f",aodave_I/loadave_I)+") m~S~2~N~ (g S)~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.2f",extave_I)+" ("+sprintf("%4.2f",aodave_I/loadave_I)+") m~S~2~N~ g~S~-1~N~" +end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(ext_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" +if (var .eq. "EXT_SO4") then +;old version: res@gsnRightString = "avg = "+sprintf("%5.2f",extave_II)+" ("+sprintf("%5.2f",aodave_II/loadave_II)+") m~S~2~N~ (g S)~S~-1~N~" +;err res@gsnRightString = "avg = "+sprintf("%5.2f",extave_II)+" ("+sprintf("%5.2f",aodave_II/loadave_II)+") m~S~2~N~ (g sulfate)~S~-1~N~" + res@gsnRightString = "avg = "+sprintf("%5.2f",extave_II)+" ("+sprintf("%5.2f",aodave_II/loadave_II)+") m~S~2~N~ (g S)~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.2f",extave_II)+" ("+sprintf("%4.2f",aodave_II/loadave_II)+") m~S~2~N~ g~S~-1~N~" +end if + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(ext_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/LevelCloudProp_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/LevelCloudProp_ModIvsModII.ncl new file mode 100644 index 0000000000..c30d913c6d --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/LevelCloudProp_ModIvsModII.ncl @@ -0,0 +1,486 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d cloud cover or ambient relative humidity or liquid +; or ice water content from two versions of NorESM/CAM-Oslo and makes global plots +; of annually averaged variables at a certain eta-level. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 1 ; 1 => CDNC Cloud droplet number concentration + ; 2 => REFFL Cloud droplet effective radius + ; 3 => ICNC Ice crystal number concentration + ; 4 => CCN1 CCN at 0.02% supersaturation + ; 5 => CCN2 CCN at 0.05% supersaturation + ; 6 => CCN3 CCN at 0.1% supersaturation + ; 7 => CCN4 CCN at 0.2% supersaturation + ; 8 => CCN5 CCN at 0.5% supersaturation + ; 9 => CCN6 CCN at 1.0% supersaturation + ;10 => N_AER Aerosol number concentration +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) +varlev_I=f1_I[:]->PS +varlev_II=f1_II[:]->PS + +;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +; Note: layers 19 and 20 are at 446 and 525 hPa in CAM5 L32 +; Note: layers 25 and 26 are at 860 and 887 hPa in CAM5 L32 +; Note: layers 17 and 18 are at 446 and 525 hPa in CAM5 L30 +; Note: layers 23 and 24 are at 860 and 887 hPa in CAM5 L30 +; Note: layers 21 and 22 are at 787 and 867 hPa in CAM4 +; (if 0 is the first model layer, as costomary in ncl) +;XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if(LevModI .eq. "L32") then + L446_I=19 + L860_I=25 + else + L446_I=17 + L860_I=23 + end if + if(LevModII .eq. "L32") then + L446_II=19 + L860_II=25 + else + L446_II=17 + L860_II=23 + end if + + if (plot_type.eq.1) then + var="CDNC" ; name of plot + varname="CDNC" ; variable name used in text string + plot_name="CDNC860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)/((/(f1_I[:]->CLDFOC)/)+small) + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)/((/(f1_I[:]->CLDFOC(:,22,:,:))/)+small) + else + var_I=1.e-6*(/(f1_I[:]->AWNC)/)/((/(f1_I[:]->FREQL)/)+small) + varlev_I=1.e-6*(/(f1_I[:]->AWNC(:,L860_I,:,:))/)/((/(f1_I[:]->FREQL(:,L860_I,:,:))/)+small) + end if + var_II=1.e-6*(/(f1_II[:]->AWNC)/)/((/(f1_II[:]->FREQL)/)+small) + varlev_II=1.e-6*(/(f1_II[:]->AWNC(:,L860_II,:,:))/)/((/(f1_II[:]->FREQL(:,L860_II,:,:))/)+small) + else if (plot_type.eq.2) then + var="REFFL" ; name of plot + varname="REFFL" ; variable name used in text string + plot_name="REFFL860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->REFFL)/)/((/(f1_I[:]->CLDFOC)/)+small) + varlev_I=(/(f1_I[:]->REFFL(:,22,:,:))/)/((/(f1_I[:]->CLDFOC(:,22,:,:))/)+small) + else + var_I=(/(f1_I[:]->AREL)/)/((/(f1_I[:]->FREQL)/)+small) + varlev_I=(/(f1_I[:]->AREL(:,L860_I,:,:))/)/((/(f1_I[:]->FREQL(:,L860_I,:,:))/)+small) + end if + var_II=(/(f1_II[:]->AREL)/)/((/(f1_II[:]->FREQL)/)+small) + varlev_II=(/(f1_II[:]->AREL(:,L860_II,:,:))/)/((/(f1_II[:]->FREQL(:,L860_II,:,:))/)+small) + else if (plot_type.eq.3) then + var="ICNC" ; name of plot + varname="ICNC" ; variable name used in text string + plot_name="ICNC446hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=1.e-6*(/(f1_I[:]->CDNC(:,17,:,:))/)*0.0 + else + var_I=1.e-6*(/(f1_I[:]->AWNI)/)/((/(f1_I[:]->FREQI)/)+small) + varlev_I=1.e-6*(/(f1_I[:]->AWNI(:,L446_I,:,:))/)/((/(f1_I[:]->FREQI(:,L446_I,:,:))/)+small) + end if + var_II=1.e-6*(/(f1_II[:]->AWNI)/)/((/(f1_II[:]->FREQI)/)+small) + varlev_II=1.e-6*(/(f1_II[:]->AWNI(:,L446_II,:,:))/)/((/(f1_II[:]->FREQI(:,L446_II,:,:))/)+small) + else if (plot_type.eq.4) then + var="CCN1" ; name of plot + varname="CCN1" ; variable name used in text string + plot_name="CCN_S0.02_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN1)/) + varlev_I=(/(f1_I[:]->CCN1(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN1)/) + varlev_II=(/(f1_II[:]->CCN1(:,L860_II,:,:))/) + else if (plot_type.eq.5) then + var="CCN2" ; name of plot + varname="CCN2" ; variable name used in text string + plot_name="CCN_S0.05_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN2)/) + varlev_I=(/(f1_I[:]->CCN2(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN2)/) + varlev_II=(/(f1_II[:]->CCN2(:,L860_II,:,:))/) + else if (plot_type.eq.6) then + var="CCN3" ; name of plot + varname="CCN3" ; variable name used in text string + plot_name="CCN_S0.1_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN3)/) + varlev_I=(/(f1_I[:]->CCN3(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN3)/) + varlev_II=(/(f1_II[:]->CCN3(:,L860_II,:,:))/) + else if (plot_type.eq.7) then + var="CCN4" ; name of plot + varname="CCN4" ; variable name used in text string + plot_name="CCN_S0.2_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN4)/) + varlev_I=(/(f1_I[:]->CCN4(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN4)/) + varlev_II=(/(f1_II[:]->CCN4(:,L860_II,:,:))/) + else if (plot_type.eq.8) then + var="CCN5" ; name of plot + varname="CCN5" ; variable name used in text string + plot_name="CCN_S0.5_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN5)/) + varlev_I=(/(f1_I[:]->CCN5(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN5)/) + varlev_II=(/(f1_II[:]->CCN5(:,L860_II,:,:))/) + else if (plot_type.eq.9) then + var="CCN6" ; name of plot + varname="CCN6" ; variable name used in text string + plot_name="CCN_S1.0_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 + varlev_I=(/(f1_I[:]->CDNC(:,22,:,:))/)*0.0 + else + var_I=(/(f1_I[:]->CCN6)/) + varlev_I=(/(f1_I[:]->CCN6(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->CCN6)/) + varlev_II=(/(f1_II[:]->CCN6(:,L860_II,:,:))/) + else if (plot_type.eq.10) then + var="N_AER" ; name of plot + varname="N_AER" ; variable name used in text string + plot_name="N_AER_860hPa" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->N_AER)/) + varlev_I=(/(f1_I[:]->N_AER(:,22,:,:))/) + else + var_I=(/(f1_I[:]->N_AER)/) + varlev_I=(/(f1_I[:]->N_AER(:,L860_I,:,:))/) + end if + var_II=(/(f1_II[:]->N_AER)/) + varlev_II=(/(f1_II[:]->N_AER(:,L860_II,:,:))/) + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) +; printVarSummary(varlev_I) +; printVarSummary(varlev_I) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + +; zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave +; zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) +;************************************************ + + varlev_Ia=varlev_I ; initialization of global average variable + varlev_IIa=varlev_II + + xdims_I = dimsizes(gw0_I) + ydims_I = dimsizes(varlev_I) + do i=0,dimsizes(gw0_I)-1 + varlev_Ia(:,i,:)=varlev_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + xdims_II = dimsizes(gw0_II) + ydims_II = dimsizes(varlev_II) + do i=0,dimsizes(gw0_II)-1 + varlev_IIa(:,i,:)=varlev_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each meteorology variable +if (var .eq. "CDNC") then +; digg=(/10,15,20,30,40,50,75,100,150,200/) + digg=(/1,5,10,25,50,75,100,150,200,500/) + else if (var .eq. "REFFL") then + digg=(/0,2,4,5,6,8,10,12,14,16/) + else if (plot_type .eq. 10) then + digg=(/25,50,100,500,1000,2500,5000,7500,10000,15000/) + else if (plot_type .ge. 4 .and. plot_type .le. 9) then +; digg=(/1,2.5,5,10,25,50,75,100,150,200/) + digg=(/1,5,10,25,50,75,100,150,200,500/) + else ; for ICNC + digg= (/.0005,.001,.003,.005,.01,.03,.05,.1,.3,.5/) + end if + end if + end if +end if + + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + +; res@sfYArray = eta_I ; use eta for y axis +; res@sfXArray = lat_I ; use lat for x axis +; res@sfYArray = lat_I +; res@sfXArray = lon_I +; res@tiXAxisString = "latitude" ; x-axis label +; res@tiYAxisString = "eta x 1000" ; y-axis label +; res@trXReverse = False ; reverse x-axis +; res@trYReverse = True ; reverse y-axis +; res@trYReverse = False ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + +if (var .eq. "CDNC") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CDNC/CLDFOC (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "AWNC/FREQL (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "REFFL") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "REFFL/CLDFOC (~F33~m~F21~m) at 867 hPa" + else + res@gsnLeftString = "AREL/FREQL (~F33~m~F21~m) at 860 hPa" + end if +else if (var .eq. "ICNC") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "(Not available)" + else + res@gsnLeftString = varname+" (cm~S~-3~N~) at 447 hPa" + end if +else if (var .eq. "CCN1") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=0.02%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=0.02%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "CCN2") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=0.05%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=0.05%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "CCN3") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=0.1%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=0.1%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "CCN4") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=0.2%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=0.2%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "CCN5") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=0.5%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=0.5%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "CCN6") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "CCN(S=1.0%) (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "CCN(S=1.0%) (cm~S~-3~N~) at 860 hPa" + end if +else if (var .eq. "N_AER") then +res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_Ia,0))/area1)) + if(ModI.eq."CAM4-Oslo") then + res@gsnLeftString = "N_AER (cm~S~-3~N~) at 867 hPa" + else + res@gsnLeftString = "N_AER (cm~S~-3~N~) at 860 hPa" + end if +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if + +; plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(varlev_I,0),res) ; create the plot + +if (var .eq. "CDNC") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "AWNC/FREQL (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "REFFL") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "AREL/FREQL (~F33~m~F21~m) at 860 hPa" +else if (var .eq. "ICNC") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = varname+" (cm~S~-3~N~) at 447 hPa" +else if (var .eq. "CCN1") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=0.02%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "CCN2") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=0.05%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "CCN3") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=0.1%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "CCN4") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=0.2%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "CCN5") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=0.5%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "CCN6") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "CCN(S=1.0%) (cm~S~-3~N~) at 860 hPa" +else if (var .eq. "N_AER") then + res@gsnRightString = "avg = "+sprintf("%5.2f",(sum(dim_avg_n(varlev_IIa,0))/area1)) + res@gsnLeftString = "N_AER (cm~S~-3~N~) at 860 hPa" +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if + +; plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res) ; create the plot + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(varlev_II,0),res) ; create the plot + + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/Lifetimes_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Lifetimes_ModIvsModII.ncl new file mode 100644 index 0000000000..3639008c6b --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Lifetimes_ModIvsModII.ncl @@ -0,0 +1,336 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol and gas burdens and loss and production terms +; from two versions of NorESM/CAM-Oslo and makes global plots of the respective +; annually averaged lifetimes, including global average as a number in the title +; line for each figure. The global average is be calculated both as area load/loss +; and as area averaged load / area averaged loss, with the latter value shown in +; brackets. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-30 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 0 ;-1 => DMS lifetime + ; 0 => SO2 lifetime + ; 1 => SO4 lifetime + ; 2 => BC lifetime + ; 3 => POM lifetime + ; 4 => SS lifetime + ; 5 => DU lifetime + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + lifetime_I=tmp_I + lifetime_II=tmp_II + load_I=tmp_I + load_II=tmp_II + netloss_I=tmp_I + netloss_II=tmp_II + + if (plot_type.eq.-1) then ; is skipped due to missing msga variables in CAM5-Oslo + var="Lifetime_DMS" ; name of plot + varname="DMS lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_DMS/) ; variable to be plotted from I + netloss_I=-((/f1_I[:]->S2GA/)+(/f1_I[:]->MSAGA/)) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_DMS/) ; variable to be plotted from I + netloss_I=-((/f1_I[:]->S2GA/)+(/f1_I[:]->MSAGA/)) ; mangler ennÃ¥ variable her... + end if + load_II=(/f1_II[:]->cb_DMS/) ; variable to be plotted from II + netloss_II=-((/f1_II[:]->S2GA/)+(/f1_II[:]->MSAGA/)) ; mangler ennÃ¥ variable her... + else if (plot_type.eq.0) then + var="Lifetime_SO2" ; name of plot + varname="SO~B~2~N~ lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_SO2/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_SO2/)+(/f1_I[:]->DRY_SO2/)-((/f1_I[:]->S4GA/)+(/f1_I[:]->S4AQ/)) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_SO2/)/1.998 ; variable to be plotted from I + +if(GdepI .eq. "Neu") then + netloss_I= -(/f1_I[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_I[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_I[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_XFRC_COL/)/1.998 + (/f1_I[:]->GS_DMS/)/1.938 ; net chemical loss (gas phase) +else + netloss_I= -(/f1_I[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_I[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_I[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_CLXF/)/1.998 + (/f1_I[:]->GS_DMS/)/1.938 + (/f1_I[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) +end if + end if + load_II=(/f1_II[:]->cb_SO2/)/1.998 ; variable to be plotted from II + ;In new model, GS_SO2 is budget of all that goes on in the chemistry-routine which is + ;1) Gas phase chemistry, 2) Wet deposition and 3) 3D-emissions + ;Gas phase chemistry is both production from DMS (GS_DMS) and loss through OH (GL_OH) + ;We are only interested in the loss through OH from the chemistry-term (GL_OH) + ;GS_SO2 = GL_OH + SO2_CLXF - WD_A_SO2 - GS_DMS*64/62 -> GS_SO2 = GL_OH + SO2_XFRC_COL - WD_A_SO2 - GS_DMS*64/62 in new version + ;GL_OH = GS_SO2 -SO2_CLXF + WD_A_SO2 + GS_DMS*64/62 -> GL_OH = GS_SO2 -SO2_XFRC_COL + WD_A_SO2 + GS_DMS*64/62 in new version +if(GdepII .eq. "Neu") then + netloss_II= -(/f1_II[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_II[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_II[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_XFRC_COL/)/1.998 + (/f1_II[:]->GS_DMS/)/1.938 ; net chemical loss (gas phase) +else + netloss_II= -(/f1_II[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_II[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_II[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_CLXF/)/1.998 + (/f1_II[:]->GS_DMS/)/1.938 + (/f1_II[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) +end if + else if (plot_type.eq.1) then + var="Lifetime_SO4" ; name of input-variable and plot + varname="SO~B~4~N~ lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_SO4/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_SO4/)+(/f1_I[:]->DRY_SO4/) ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_SO4_A1)/)/3.06 + (/(f1_I[:]->cb_SO4_A2)/)/3.59 + (/(f1_I[:]->cb_SO4_AC)/)/3.06 + (/(f1_I[:]->cb_SO4_NA)/)/3.06 + (/(f1_I[:]->cb_SO4_PR)/)/3.06 + (/(f1_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_PR_OCW)/)/3.06 + wet_I=(/f1_I[:]->SO4_A1SFWET/)/3.06 + (/f1_I[:]->SO4_A2SFWET/)/3.59 + (/f1_I[:]->SO4_ACSFWET/)/3.06 + (/f1_I[:]->SO4_NASFWET/)/3.06 + (/f1_I[:]->SO4_PRSFWET/)/3.06 + (/f1_I[:]->SO4_A1_OCWSFWET/)/3.06 + (/f1_I[:]->SO4_A2_OCWSFWET/)/3.59 + (/f1_I[:]->SO4_AC_OCWSFWET/)/3.06 + (/f1_I[:]->SO4_NA_OCWSFWET/)/3.06 + (/f1_I[:]->SO4_PR_OCWSFWET/)/3.06 + wet_I=-wet_I + dry_I=(/f1_I[:]->SO4_A1DDF/)/3.06 + (/f1_I[:]->SO4_A2DDF/)/3.59 + (/f1_I[:]->SO4_ACDDF/)/3.06 + (/f1_I[:]->SO4_NADDF/) + (/f1_I[:]->SO4_PRDDF/)/3.06 + (/f1_I[:]->SO4_A1_OCWDDF/)/3.06 + (/f1_I[:]->SO4_A2_OCWDDF/)/3.59 + (/f1_I[:]->SO4_AC_OCWDDF/) /3.06+ (/f1_I[:]->SO4_NA_OCWDDF/)/3.06 + (/f1_I[:]->SO4_PR_OCWDDF/)/3.06 + netloss_I=-(wet_I+dry_I) + end if + load_II=(/(f1_II[:]->cb_SO4_A1)/)/3.06 + (/(f1_II[:]->cb_SO4_A2)/)/3.59 + (/(f1_II[:]->cb_SO4_AC)/)/3.06 + (/(f1_II[:]->cb_SO4_NA)/)/3.06 + (/(f1_II[:]->cb_SO4_PR)/)/3.06 + (/(f1_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_PR_OCW)/)/3.06 + wet_II=(/f1_II[:]->SO4_A1SFWET/)/3.06 + (/f1_II[:]->SO4_A2SFWET/)/3.59 + (/f1_II[:]->SO4_ACSFWET/)/3.06 + (/f1_II[:]->SO4_NASFWET/)/3.06 + (/f1_II[:]->SO4_PRSFWET/)/3.06 + (/f1_II[:]->SO4_A1_OCWSFWET/)/3.06 + (/f1_II[:]->SO4_A2_OCWSFWET/)/3.59 + (/f1_II[:]->SO4_AC_OCWSFWET/)/3.06 + (/f1_II[:]->SO4_NA_OCWSFWET/)/3.06 + (/f1_II[:]->SO4_PR_OCWSFWET/)/3.06 + wet_II=-wet_II + dry_II=(/f1_II[:]->SO4_A1DDF/)/3.06 + (/f1_II[:]->SO4_A2DDF/)/3.59 + (/f1_II[:]->SO4_ACDDF/)/3.06 + (/f1_II[:]->SO4_NADDF/) + (/f1_II[:]->SO4_PRDDF/)/3.06 + (/f1_II[:]->SO4_A1_OCWDDF/)/3.06 + (/f1_II[:]->SO4_A2_OCWDDF/)/3.59 + (/f1_II[:]->SO4_AC_OCWDDF/) /3.06 + (/f1_II[:]->SO4_NA_OCWDDF/)/3.06 + (/f1_II[:]->SO4_PR_OCWDDF/)/3.06 + netloss_II=-(wet_II+dry_II) + else if (plot_type.eq.2) then + var="Lifetime_BC" ; name of input-variable and plot + varname="BC lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_BC/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_BC/)+(/f1_I[:]->DRY_BC/) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_BC/) + (/(f1_I[:]->cb_BC_A_OCW)/) + (/(f1_I[:]->cb_BC_AC_OCW)/) + (/(f1_I[:]->cb_BC_AI_OCW)/) + (/(f1_I[:]->cb_BC_NI_OCW)/) + (/(f1_I[:]->cb_BC_N_OCW)/) + wet_I=(/f1_I[:]->BC_ASFWET/) + (/f1_I[:]->BC_ACSFWET/) + (/f1_I[:]->BC_AXSFWET/) + (/f1_I[:]->BC_AISFWET/) + (/f1_I[:]->BC_NISFWET/) + (/f1_I[:]->BC_NSFWET/) + (/f1_I[:]->BC_A_OCWSFWET/) + (/f1_I[:]->BC_AC_OCWSFWET/) + (/f1_I[:]->BC_AI_OCWSFWET/) + (/f1_I[:]->BC_NI_OCWSFWET/) + (/f1_I[:]->BC_N_OCWSFWET/) + wet_I=-wet_I + dry_I=(/f1_I[:]->BC_ACDDF/) + (/f1_I[:]->BC_AXDDF/) + (/f1_I[:]->BC_AIDDF/) + (/f1_I[:]->BC_NIDDF/) + (/f1_I[:]->BC_NDDF/) + (/f1_I[:]->BC_A_OCWDDF/) + (/f1_I[:]->BC_AC_OCWDDF/) + (/f1_I[:]->BC_AI_OCWDDF/) + (/f1_I[:]->BC_NI_OCWDDF/) + (/f1_I[:]->BC_N_OCWDDF/) + netloss_I=-(wet_I+dry_I) + end if + load_II=(/f1_II[:]->cb_BC/) + (/(f1_II[:]->cb_BC_A_OCW)/) + (/(f1_II[:]->cb_BC_AC_OCW)/) + (/(f1_II[:]->cb_BC_AI_OCW)/) + (/(f1_II[:]->cb_BC_NI_OCW)/) + (/(f1_II[:]->cb_BC_N_OCW)/) + wet_II=(/f1_II[:]->BC_ASFWET/) + (/f1_II[:]->BC_ACSFWET/) + (/f1_II[:]->BC_AXSFWET/) + (/f1_II[:]->BC_AISFWET/) + (/f1_II[:]->BC_NISFWET/) + (/f1_II[:]->BC_NSFWET/) + (/f1_II[:]->BC_A_OCWSFWET/) + (/f1_II[:]->BC_AC_OCWSFWET/) + (/f1_II[:]->BC_AI_OCWSFWET/) + (/f1_II[:]->BC_NI_OCWSFWET/) + (/f1_II[:]->BC_N_OCWSFWET/) + wet_II=-wet_II + dry_II=(/f1_II[:]->BC_ACDDF/) + (/f1_II[:]->BC_AXDDF/) + (/f1_II[:]->BC_AIDDF/) + (/f1_II[:]->BC_NIDDF/) + (/f1_II[:]->BC_NDDF/) + (/f1_II[:]->BC_A_OCWDDF/) + (/f1_II[:]->BC_AC_OCWDDF/) + (/f1_II[:]->BC_AI_OCWDDF/) + (/f1_II[:]->BC_NI_OCWDDF/) + (/f1_II[:]->BC_N_OCWDDF/) + netloss_II=-(wet_II+dry_II) + else if (plot_type.eq.3) then + var="Lifetime_POM" ; name of input-variable and plot + varname="POM lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_POM/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_POM/)+(/f1_I[:]->DRY_POM/) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_OM/) + (/(f1_I[:]->cb_OM_AI_OCW)/) + (/(f1_I[:]->cb_OM_AC_OCW)/) + (/(f1_I[:]->cb_OM_NI_OCW)/) + wet_I=(/f1_I[:]->OM_AISFWET/) + (/f1_I[:]->OM_ACSFWET/) + (/f1_I[:]->OM_NISFWET/) + (/f1_I[:]->OM_AI_OCWSFWET/) + (/f1_I[:]->OM_AC_OCWSFWET/) + (/f1_I[:]->OM_NI_OCWSFWET/) \ + + (/f1_I[:]->SOA_A1SFWET/) + (/f1_I[:]->SOA_NASFWET/) + (/f1_I[:]->SOA_A1_OCWSFWET/) + (/f1_I[:]->SOA_NA_OCWSFWET/) + wet_I=-wet_I + dry_I=(/f1_I[:]->OM_AIDDF/) + (/f1_I[:]->OM_ACDDF/) + (/f1_I[:]->OM_NIDDF/) + (/f1_I[:]->OM_AI_OCWDDF/) + (/f1_I[:]->OM_AC_OCWDDF/) + (/f1_I[:]->OM_NI_OCWDDF/) \ + + (/f1_I[:]->SOA_A1DDF/) + (/f1_I[:]->SOA_NADDF/) + (/f1_I[:]->SOA_A1_OCWDDF/) + (/f1_I[:]->SOA_NA_OCWDDF/) + netloss_I=-(wet_I+dry_I) + end if + load_II=(/f1_II[:]->cb_OM/) + (/(f1_II[:]->cb_OM_AI_OCW)/) + (/(f1_II[:]->cb_OM_AC_OCW)/) + (/(f1_II[:]->cb_OM_NI_OCW)/) + wet_II=(/f1_II[:]->OM_AISFWET/) + (/f1_II[:]->OM_ACSFWET/) + (/f1_II[:]->OM_NISFWET/) + (/f1_II[:]->OM_AI_OCWSFWET/) + (/f1_II[:]->OM_AC_OCWSFWET/) + (/f1_II[:]->OM_NI_OCWSFWET/) \ + + (/f1_II[:]->SOA_A1SFWET/) + (/f1_II[:]->SOA_NASFWET/) + (/f1_II[:]->SOA_A1_OCWSFWET/) + (/f1_II[:]->SOA_NA_OCWSFWET/) + wet_II=-wet_II + dry_II=(/f1_II[:]->OM_AIDDF/) + (/f1_II[:]->OM_ACDDF/) + (/f1_II[:]->OM_NIDDF/) + (/f1_II[:]->OM_AI_OCWDDF/) + (/f1_II[:]->OM_AC_OCWDDF/) + (/f1_II[:]->OM_NI_OCWDDF/) \ + + (/f1_II[:]->SOA_A1DDF/) + (/f1_II[:]->SOA_NADDF/) + (/f1_II[:]->SOA_A1_OCWDDF/) + (/f1_II[:]->SOA_NA_OCWDDF/) + netloss_II=-(wet_II+dry_II) + else if (plot_type.eq.4) then + var="Lifetime_SS" ; name of input-variable and plot + varname="Sea-salt lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_SS/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_SS/)+(/f1_I[:]->DRY_SS/) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_SALT/) + (/(f1_I[:]->cb_SS_A1_OCW)/) + (/(f1_I[:]->cb_SS_A2_OCW)/) + (/(f1_I[:]->cb_SS_A3_OCW)/) + wet_I=(/f1_I[:]->SS_A1SFWET/) + (/f1_I[:]->SS_A2SFWET/) + (/f1_I[:]->SS_A3SFWET/) + (/f1_I[:]->SS_A1_OCWSFWET/) + (/f1_I[:]->SS_A2_OCWSFWET/) + (/f1_I[:]->SS_A3_OCWSFWET/) + wet_I=-wet_I + dry_I=(/f1_I[:]->SS_A1DDF/) + (/f1_I[:]->SS_A2DDF/) + (/f1_I[:]->SS_A3DDF/) + (/f1_I[:]->SS_A1_OCWDDF/) + (/f1_I[:]->SS_A2_OCWDDF/) + (/f1_I[:]->SS_A3_OCWDDF/) + netloss_I=-(wet_I+dry_I) + end if + load_II=(/f1_II[:]->cb_SALT/) + (/(f1_II[:]->cb_SS_A1_OCW)/) + (/(f1_II[:]->cb_SS_A2_OCW)/) + (/(f1_II[:]->cb_SS_A3_OCW)/) + wet_II=(/f1_II[:]->SS_A1SFWET/) + (/f1_II[:]->SS_A2SFWET/) + (/f1_II[:]->SS_A3SFWET/) + (/f1_II[:]->SS_A1_OCWSFWET/) + (/f1_II[:]->SS_A2_OCWSFWET/) + (/f1_II[:]->SS_A3_OCWSFWET/) + wet_II=-wet_II + dry_II=(/f1_II[:]->SS_A1DDF/) + (/f1_II[:]->SS_A2DDF/) + (/f1_II[:]->SS_A3DDF/) + (/f1_II[:]->SS_A1_OCWDDF/) + (/f1_II[:]->SS_A2_OCWDDF/) + (/f1_II[:]->SS_A3_OCWDDF/) + netloss_II=-(wet_II+dry_II) + else if (plot_type.eq.5) then + var="Lifetime_DUST" ; name of input-variable and plot + varname="Dust lifetime (d)" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/f1_I[:]->C_DUST/) ; variable to be plotted from I + netloss_I=(/f1_I[:]->WET_DUST/)+(/f1_I[:]->DRY_DUST/) ; variable to be plotted from I + else + load_I=(/f1_I[:]->cb_DUST/) + (/(f1_I[:]->cb_DST_A2_OCW)/) + (/(f1_I[:]->cb_DST_A3_OCW)/) + wet_I=(/f1_I[:]->DST_A2SFWET/) + (/f1_I[:]->DST_A3SFWET/) + (/f1_I[:]->DST_A2_OCWSFWET/) + (/f1_I[:]->DST_A3_OCWSFWET/) + wet_I=-wet_I + dry_I=(/f1_I[:]->DST_A2DDF/) + (/f1_I[:]->DST_A3DDF/) + (/f1_I[:]->DST_A2_OCWDDF/) + (/f1_I[:]->DST_A3_OCWDDF/) + netloss_I=-(wet_I+dry_I) + end if + load_II=(/f1_II[:]->cb_DUST/) + (/(f1_II[:]->cb_DST_A2_OCW)/) + (/(f1_II[:]->cb_DST_A3_OCW)/) + wet_II=(/f1_II[:]->DST_A2SFWET/) + (/f1_II[:]->DST_A3SFWET/) + (/f1_II[:]->DST_A2_OCWSFWET/) + (/f1_II[:]->DST_A3_OCWSFWET/) + wet_II=-wet_II + dry_II=(/f1_II[:]->DST_A2DDF/) + (/f1_II[:]->DST_A3DDF/) + (/f1_II[:]->DST_A2_OCWDDF/) + (/f1_II[:]->DST_A3_OCWDDF/) + netloss_II=-(wet_II+dry_II) + end if + end if + end if + end if + end if + end if + end if +;for model 2, net loss is negative, so need to multiply by -1 before adding "small" + lifetime_I=-load_I/(netloss_I+small)/3600.0/24.0 ; variable to be plotted from I + lifetime_II=load_II/(-1.0*netloss_II+small)/3600.0/24.0 ; variable to be plotted from II + +; Calculating area weighted lifetimes + + lifetime_Ia=lifetime_I ; initialization of global average variables + lifetime_IIa=lifetime_II + load_Ia=lifetime_I + load_IIa=lifetime_II + netloss_Ia=lifetime_I + netloss_IIa=lifetime_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(lifetime_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + lifetime_Ia(:,i,:)=lifetime_I(:,i,:)*coffa*dlon_I*gw0_I(i) + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + netloss_Ia(:,i,:)=netloss_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + lifetimeave_I=sum(dim_avg_n(lifetime_Ia,0))/area1 + loadave_I=sum(dim_avg_n(load_Ia,0))/area1 + netlossave_I=sum(dim_avg_n(netloss_Ia,0))/area1 + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(lifetime_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + lifetime_IIa(:,i,:)=lifetime_II(:,i,:)*coffa*dlon_II*gw0_II(i) + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + netloss_IIa(:,i,:)=netloss_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + lifetimeave_II=sum(dim_avg_n(lifetime_IIa,0))/area1 + loadave_II=sum(dim_avg_n(load_IIa,0))/area1 + netlossave_II=sum(dim_avg_n(netloss_IIa,0))/area1 + +; Defining color scale +; digg=(/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,0.95/) +; digg=(/0.1,0.25,0.5,0.6,0.7,0.8,0.9,0.95,0.99/) +if (plot_type.eq.-1.or.plot_type.eq.4) then + digg=(/0.2,0.3,0.5,1.0,1.5,2.0,3.0,5.0,7.0,10.0/) +else + digg=(/1.0,1.5,2.0,3.0,5.0,7.0,10.0,20.0,30.0,50.0/) +end if +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.2f",lifetimeave_I)+" ("+sprintf("%4.2f",-loadave_I/(netlossave_I+small)/3600.0/24.0)+")" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(lifetime_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.2f",lifetimeave_II)+" ("+sprintf("%4.2f",-loadave_II/(netlossave_II+small)/3600.0/24.0)+")" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(lifetime_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/Load_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Load_ModIvsModII.ncl new file mode 100644 index 0000000000..6808583385 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Load_ModIvsModII.ncl @@ -0,0 +1,407 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol column burdens (loads) from two versions +; of NorESM/CAM-Oslo and makes global plots of the annually averaged loads, +; including global average as a number in the title line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 6 ; 0 => SO2 load + ; 1 => SO4 load + ; 2 => BC load + ; 3 => POM load + ; 4 => SS load + ; 5 => DU load + ; 6 => H2O load + ; 7 => Excess look-up table load + ; 8 => COLRBC0 BC0 column budren ratio + ; 9 => COLRBC2 BC2 column budren ratio + ; 10 => COLRBC4 BC4 column budren ratio + ; 11 => COLRBC12 BC12 column budren ratio + ; 12 => COLRBC14 BC14 column budren ratio + ; 13 => COLRBCAC BCAC column budren ratio + ; 14 => COLROC4 OC4 column budren ratio + ; 15 => COLRBC14 BC14 column budren ratio + ; 16 => COLROCAC OCAC column budren ratio + ; 17 => COLRSUL1 SUL1 column budren ratio + ; 18 => COLRSUL5 SUL5 column budren ratio + ; 19 => COLRSULA SULA column budren ratio +; Note: column burden ratio for tracer X = (look-up table burden X)/(life-cycle burden X) + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + load_I=tmp_I + load_II=tmp_II + + if (plot_type.eq.0) then + var="C_SO2" ; name of input-variable and plot + varname="SO2" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_SO2)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_SO2)/)*1.e6/1.998 ; variable to be plotted from I + end if + load_II=(/(f1_II[:]->cb_SO2)/)*1.e6/1.998 ; variable to be plotted from II + else if (plot_type.eq.1) then + var="C_SO4" ; name of input-variable and plot + varname="SO4" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_SO4)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_SO4_A1)/)/3.06 + (/(f1_I[:]->cb_SO4_A2)/)/3.59 + (/(f1_I[:]->cb_SO4_AC)/)/3.06 + (/(f1_I[:]->cb_SO4_NA)/)/3.06 + (/(f1_I[:]->cb_SO4_PR)/)/3.06 + (/(f1_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_PR_OCW)/)/3.06 + load_I = load_I*1.e6 + end if + load_II=(/(f1_II[:]->cb_SO4_A1)/)/3.06 + (/(f1_II[:]->cb_SO4_A2)/)/3.59 + (/(f1_II[:]->cb_SO4_AC)/)/3.06 + (/(f1_II[:]->cb_SO4_NA)/)/3.06 + (/(f1_II[:]->cb_SO4_PR)/)/3.06 + (/(f1_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_PR_OCW)/)/3.06 + load_II = load_II*1.e6 + else if (plot_type.eq.2) then + var="C_BC" ; name of input-variable and plot + varname="BC" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_BC)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_BC)/) + (/(f1_I[:]->cb_BC_A_OCW)/) + (/(f1_I[:]->cb_BC_AC_OCW)/) + (/(f1_I[:]->cb_BC_AI_OCW)/) + (/(f1_I[:]->cb_BC_NI_OCW)/) + (/(f1_I[:]->cb_BC_N_OCW)/) + load_I = load_I*1.e6 + end if + load_II=(/(f1_II[:]->cb_BC)/) + (/(f1_II[:]->cb_BC_A_OCW)/) + (/(f1_II[:]->cb_BC_AC_OCW)/) + (/(f1_II[:]->cb_BC_AI_OCW)/) + (/(f1_II[:]->cb_BC_NI_OCW)/) + (/(f1_II[:]->cb_BC_N_OCW)/) + load_II = load_II*1.e6 + else if (plot_type.eq.3) then + var="C_POM" ; name of input-variable and plot + varname="POM" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_POM)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_OM)/) + (/(f1_I[:]->cb_OM_AI_OCW)/) + (/(f1_I[:]->cb_OM_AC_OCW)/) + (/(f1_I[:]->cb_OM_NI_OCW)/) \ + + (/f1_I[:]->cb_SOA_A1_OCW/) + (/f1_I[:]->cb_SOA_NA_OCW/) + load_I = load_I*1.e6 + end if + load_II=(/(f1_II[:]->cb_OM)/) + (/(f1_II[:]->cb_OM_AI_OCW)/) + (/(f1_II[:]->cb_OM_AC_OCW)/) + (/(f1_II[:]->cb_OM_NI_OCW)/) \ + + (/f1_II[:]->cb_SOA_A1_OCW/) + (/f1_II[:]->cb_SOA_NA_OCW/) + load_II = load_II*1.e6 + else if (plot_type.eq.4) then + var="C_SS" ; name of input-variable and plot + varname="Sea-salt" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_SS)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_SALT)/) + (/(f1_I[:]->cb_SS_A1_OCW)/) + (/(f1_I[:]->cb_SS_A2_OCW)/) + (/(f1_I[:]->cb_SS_A3_OCW)/) + load_I = load_I*1.e6 + end if + load_II=(/(f1_II[:]->cb_SALT)/) + (/(f1_II[:]->cb_SS_A1_OCW)/) + (/(f1_II[:]->cb_SS_A2_OCW)/) + (/(f1_II[:]->cb_SS_A3_OCW)/) + load_II = load_II*1.e6 + else if (plot_type.eq.5) then + var="C_DUST" ; name of input-variable and plot + varname="Dust" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + load_I=(/(f1_I[:]->C_DUST)/)*1.e6 ; variable to be plotted from I + else + load_I=(/(f1_I[:]->cb_DUST)/) + (/(f1_I[:]->cb_DST_A2_OCW)/) + (/(f1_I[:]->cb_DST_A3_OCW)/) + load_I = load_I*1.e6 + end if + load_II=(/(f1_II[:]->cb_DUST)/) + (/(f1_II[:]->cb_DST_A2_OCW)/) + (/(f1_II[:]->cb_DST_A3_OCW)/) + load_II = load_II*1.e6 + else if (plot_type.eq.6) then + var="DAERH2O" ; name of input-variable and plot + varname="Condensed H2O" ; variable name used in text string: + load_I=(/(f1_I[:]->DAERH2O)/) ; variable to be plotted from I + load_II=(/(f1_II[:]->DAERH2O)/) ; variable to be plotted from II + else if (plot_type.eq.7) then + var="AKCXS" ; name of input-variable and plot + varname="AKCXS" ; variable name used in text string: + load_I=(/(f1_I[:]->AKCXS)/) ; variable to be plotted from I + load_II=(/(f1_II[:]->AKCXS)/) ; variable to be plotted from II + else if (plot_type.eq.8) then + var="COLRBC0" ; name of input-variable and plot + varname="COLRBC0" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC0)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC0)/) ; variable to be plotted from II + else if (plot_type.eq.9) then + var="COLRBC2" ; name of input-variable and plot + varname="COLRBC2" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC2)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC2)/) ; variable to be plotted from II + else if (plot_type.eq.10) then + var="COLRBC4" ; name of input-variable and plot + varname="COLRBC4" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC4)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC4)/) ; variable to be plotted from II + else if (plot_type.eq.11) then + var="COLRBC12" ; name of input-variable and plot + varname="COLRBC12" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC12)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC12)/) ; variable to be plotted from II + else if (plot_type.eq.10) then + var="COLRBC4" ; name of input-variable and plot + varname="COLRBC4" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC4)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC4)/) ; variable to be plotted from II + else if (plot_type.eq.12) then + var="COLRBC14" ; name of input-variable and plot + varname="COLRBC14" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBC14)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBC14)/) ; variable to be plotted from II + else if (plot_type.eq.13) then + var="COLRBCAC" ; name of input-variable and plot + varname="COLRBCAC" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRBCAC)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRBCAC)/) ; variable to be plotted from II + else if (plot_type.eq.14) then + var="COLROC4" ; name of input-variable and plot + varname="COLROC4" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLROC4)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLROC4)/) ; variable to be plotted from II + else if (plot_type.eq.15) then + var="COLROC14" ; name of input-variable and plot + varname="COLROC14" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLROC14)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLROC14)/) ; variable to be plotted from II + else if (plot_type.eq.16) then + var="COLROCAC" ; name of input-variable and plot + varname="COLROCAC" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLROCAC)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLROCAC)/) ; variable to be plotted from II + else if (plot_type.eq.17) then + var="COLRSUL1" ; name of input-variable and plot + varname="COLRSUL1" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRSUL1)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRSUL1)/) ; variable to be plotted from II + else if (plot_type.eq.18) then + var="COLRSUL5" ; name of input-variable and plot + varname="COLRSUL5" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRSUL5)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRSUL5)/) ; variable to be plotted from II + else if (plot_type.eq.19) then + var="COLRSULA" ; name of input-variable and plot + varname="COLRSULA" ; variable name used in text string: +; load_I=(/(f1_I[:]->COLRSULA)/) ; variable to be plotted from I +;temporary fix + load_I=(/(f1_I[:]->AKCXS)/)*0.0 ; variable to be plotted from I + load_II=(/(f1_II[:]->COLRSULA)/) ; variable to be plotted from II + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted loads + + load_Ia=load_I ; initialization of global average variable + load_IIa=load_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(load_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(load_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each load variable +if (var .eq. "C_SO2" .or. var .eq. "C_SO4") then + digg=(/0.1,0.2,0.3,0.5,1,2,3,5,10,20/) ; C_SO2 & C_SO4 +; else if (var .eq. "C_BC") then + else if (var .eq. "C_BC") then + digg=(/0.03,0.05,0.1,0.2,0.3,0.5,1,2,3,5/) ; C_BC + else if (var .eq. "C_POM" .or. var .eq. "C_SS") then + digg=(/0.3,0.5,1,2,3,5,10,20,30,50/) ; C_POM & C_SS + else if (var .eq. "C_DUST") then + digg=(/0.5,1,2.5,5,10,25,50,100,250,500/) ; C_DUST + else if (var .eq. "DAERH2O") then + digg=(/0.5,1,2.5,5,10,25,50,100,250,500/) ; C_H2O + else if (var .eq. "AKCXS") then + digg=(/0.01,0.02,0.03,0.05,.1,.2,.3,.5/) ; AKCXS + else + digg=(/0.8,0.85,0.95,0.99,0.995,1.0,1.005,1.01,1.025,1.05/) ; COLR* + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level +if(plot_type.le.7) then + res@cnLevels = sprintf("%5.2f",digg) ; min level +else + res@cnLevels = sprintf("%5.3f",digg) ; min level +end if + +; res@tiMainString = "ModI" +if (var .eq. "C_SO2" .or. var .eq. "C_SO4") then + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(load_Ia,0))/area1))+" mg S m~S~-2~N~" +else if (var .eq. "AKCXS") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(load_Ia,0))/area1))+" mg m~S~-2~N~" +else if (plot_type .ge. 8) then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(load_Ia,0))/area1)) +else + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(load_Ia,0))/area1))+" mg m~S~-2~N~" +end if +end if +end if +if (plot_type.le.7) then + res@gsnLeftString = varname + " column burden" +else + res@gsnLeftString = varname + " column burden ratio" +end if + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(load_I,0),res) ; create the plot + +; res@tiMainString = "ModII" +if (var .eq. "C_SO2" .or. var .eq. "C_SO4") then + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(load_IIa,0))/area1))+" mg S m~S~-2~N~" +else if (var .eq. "AKCXS") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(load_IIa,0))/area1))+" mg m~S~-2~N~" +else if (plot_type .ge. 8) then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(load_IIa,0))/area1)) +else + res@gsnRightString = "avg = "+sprintf("%4.2f",(sum(dim_avg_n(load_IIa,0))/area1))+" mg m~S~-2~N~" +end if +end if +end if +if (plot_type.le.7) then + res@gsnLeftString = varname + " column burden" +else + res@gsnLeftString = varname + " column burden ratio" +end if + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(load_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/Mass-budget_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/Mass-budget_ModIvsModII.ncl new file mode 100644 index 0000000000..373d856c51 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/Mass-budget_ModIvsModII.ncl @@ -0,0 +1,618 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol and gas burdens and loss and production terms +; from two versions of NorESM/CAM-Oslo and calculates global annual mass budget +; numbers, as e.g. found in Table 3 of KirkevÃ¥g et al. (2013). + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-30 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 5 ;-1 => DMS mass budget + ; 0 => SO2 mass budget + ; 1 => SO4 mass budget + ; 2 => BC mass budget + ; 3 => POM mass budget + ; 4 => SS mass budget + ; 5 => DU mass budget + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + + lifetime_I=tmp_I + lifetime_II=tmp_II + load_I=tmp_I + load_II=tmp_II + +; wetdepp_I=tmp_I +; wetdepp_II=tmp_II + wet_I=tmp_I + wet_II=tmp_II + sink_I=tmp_I + sink_II=tmp_II + + ;budget on dms/DMS/SO2 used by several plots + if(ModI .eq. "CAM5-Oslo")then + ;small dms_soa_msa budget + tot_dms_lost_as_s_I = -((/f1_I[:]->GS_DMS/))/1.938 ; (as s) + terpenes_lost_as_soa_I = -1.0* ( 0.05*168/68*(/(f1_I[:]->GS_isoprene)/) + 0.15*168/136*(/(f1_I[:]->GS_monoterp)/)) ; (as SOA (> 0)) + soa_g_prod_as_soa_I = ((/f1_I[:]->GS_SOA_LV + f1_I[:]->GS_SOA_SV /)) ; (as SOA) + soa_g_prod_from_msa_I = soa_g_prod_as_soa_I - terpenes_lost_as_soa_I ; as soa + msa_prod_from_dms_as_s_I = soa_g_prod_from_msa_I*32/96 ; 32 ==> 96 is msa ==> s + so2_formed_from_dms_as_s_I = tot_dms_lost_as_s_I - msa_prod_from_dms_as_s_I + ;; + end if + ;small dms_soa_msa budget + tot_dms_lost_as_s_II = -((/f1_II[:]->GS_DMS/))/1.938 ; (as s) + terpenes_lost_as_soa_II = -1.0* ( 0.05*168/68*(/(f1_II[:]->GS_isoprene)/) + 0.15*168/136*(/(f1_II[:]->GS_monoterp)/)) ; (as SOA (> 0)) + soa_g_prod_as_soa_II = ((/f1_II[:]->GS_SOA_LV + f1_II[:]->GS_SOA_SV /)) ; (as SOA) + soa_g_prod_from_msa_II = soa_g_prod_as_soa_II - terpenes_lost_as_soa_II ; as soa + msa_prod_from_dms_as_s_II = soa_g_prod_from_msa_II*32/96 ; 32 ==> 96 is msa ==> s + so2_formed_from_dms_as_s_II = tot_dms_lost_as_s_II - msa_prod_from_dms_as_s_II + ;; + + + if (plot_type.eq.-1) then + var="DMS" + varname="DMS" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_DMS)/) + sour_I=(/(f1_I[:]->EMI_DMS)/) + load_I=(/f1_I[:]->C_DMS/) + sink_I=-((/f1_I[:]->S2GA/)+(/f1_I[:]->MSAGA/)) + chloss_I=-((/f1_I[:]->S2GA/)+(/f1_I[:]->MSAGA/)) + chlossg_I=-(/f1_I[:]->MSAGA/) + else + emis_I = (/f1_I[:]->SFDMS/)*32/62; as S + sour_I = emis_I + sink_I = (/f1_I[:]->GS_DMS/)*32/62; as S + load_I = (/f1_I[:]->cb_DMS/)*32/62; as S + chloss_I = -1.0* (msa_prod_from_dms_as_s_I + so2_formed_from_dms_as_s_I) + chlossg_I = -1.0* msa_prod_from_dms_as_s_I + end if + emis_II = (/f1_II[:]->SFDMS/)*32/62; as S + sour_II = emis_II + sink_II = (/f1_II[:]->GS_DMS/)*32/62; as S + load_II = (/f1_II[:]->cb_DMS/)*32/62; as S + chloss_II = -1.0*(msa_prod_from_dms_as_s_II + so2_formed_from_dms_as_s_II) + chlossg_II = -1.0*msa_prod_from_dms_as_s_II + + else if (plot_type.eq.0) then + var="SO2" + varname="SO~B~2~N" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_SO2)/) + sour_I=(/(f1_I[:]->EMI_SO2)/)+(/f1_I[:]->S2GA/) + load_I=(/f1_I[:]->C_SO2/) + wet_I=(/f1_I[:]->WET_SO2/) + sink_I=(/f1_I[:]->WET_SO2/)+(/f1_I[:]->DRY_SO2/)-((/f1_I[:]->S4GA/)+(/f1_I[:]->S4AQ/)) + chloss_I=-((/f1_I[:]->S4GA/)+(/f1_I[:]->S4AQ/)) + chlossg_I=-((/f1_I[:]->S4GA/)) + else + ; In CAM5 -- using mozart chemistry and buget-terms: + ; GS_SO2 = Prod_from_DMS + 3d_emis - wet-dep - oh-loss ==> rewrite this eqn to get the terms we need + ; Note the SOA formed is supposed to be MSA which is factor 3 larger mole-weight than S + + if(GdepI .eq. "Neu") then + emis_I=(/(f1_I[:]->SFSO2)/)/1.998 + (/(f1_I[:]->SO2_XFRC_COL)/)/1.998 + else + emis_I=(/(f1_I[:]->SFSO2)/)/1.998 + (/(f1_I[:]->SO2_CLXF)/)/1.998 + end if + + sour_I = emis_I + so2_formed_from_dms_as_s_I + + load_I=(/f1_I[:]->cb_SO2/)/1.998 + wet_I=-(/f1_I[:]->WD_A_SO2/)/1.998 + + if(GdepI .eq. "Neu") then + sink_I= -(/f1_I[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_I[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_I[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_XFRC_COL/)/1.998 - so2_formed_from_dms_as_s_I ; net chemical loss (gas phase) + chlossg_I = (/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_XFRC_COL/)/1.998 \ + - so2_formed_from_dms_as_s_I ; net chemical loss (gas phase) + else + sink_I=-(/f1_I[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_I[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_I[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_CLXF/)/1.998 - so2_formed_from_dms_as_s_I + (/f1_I[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) + chlossg_I = (/f1_I[:]->GS_SO2/)/1.998 - (/f1_I[:]->SO2_CLXF/)/1.998 \ + - so2_formed_from_dms_as_s_I + (/f1_I[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) + end if + + chloss_I = chlossg_I + (/f1_I[:]->AQ_SO2/)/1.998 ; net chemical loss (gas and wet-phase) + + end if + + if(GdepI .eq. "Neu") then + emis_II=(/(f1_II[:]->SFSO2)/)/1.998 + (/(f1_II[:]->SO2_XFRC_COL)/)/1.998 + else + emis_II=(/(f1_II[:]->SFSO2)/)/1.998 + (/(f1_II[:]->SO2_CLXF)/)/1.998 + end if + +sour_II=emis_II + so2_formed_from_dms_as_s_II + + load_II=(/f1_II[:]->cb_SO2/)/1.998 + wet_II=-(/f1_II[:]->WD_A_SO2/)/1.998 + if(GdepII .eq. "Neu") then + sink_II= -(/f1_II[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_II[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_II[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_XFRC_COL/)/1.998 - so2_formed_from_dms_as_s_II ; net chemical loss (gas phase) + chlossg_II = (/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_XFRC_COL/)/1.998 \ + - so2_formed_from_dms_as_s_II ; net chemical loss (gas phase) + else + sink_II= -(/f1_II[:]->WD_A_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + -(/f1_II[:]->DF_SO2/)/1.998 \ ;kg/m2/sec (positive in output file) + +(/f1_II[:]->AQ_SO2/)/1.998 \ ;kg/m2/ses (negative in output file) + +(/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_CLXF/)/1.998 - so2_formed_from_dms_as_s_II + (/f1_II[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) + chlossg_II = (/f1_II[:]->GS_SO2/)/1.998 - (/f1_II[:]->SO2_CLXF/)/1.998 \ + - so2_formed_from_dms_as_s_II + (/f1_II[:]->WD_A_SO2/)/1.998 ; net chemical loss (gas phase) + end if + + chloss_II = chlossg_II + (/f1_II[:]->AQ_SO2/)/1.998 ; net chemical loss (gas and wet-phase) + else if (plot_type.eq.1) then + var="SO4" + varname="SO~B~4~N~" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_SO4)/) + sour_I=(/(f1_I[:]->EMI_SO4)/)+(/(f1_I[:]->S4GA)/)+(/(f1_I[:]->S4AQ)/) + load_I=(/f1_I[:]->C_SO4/) + wet_I=(/f1_I[:]->WET_SO4/) + sink_I=(/f1_I[:]->WET_SO4/)+(/f1_I[:]->DRY_SO4/) + else + + if(GdepI .eq. "Neu") then + emis_I= (/(f1_I[:]->SFSO4_PR)/)/3.06 + (/(f1_I[:]->SO4_PR_XFRC_COL)/)/3.06 + else + emis_I= (/(f1_I[:]->SFSO4_PR)/)/3.06 + (/(f1_I[:]->SO4_PR_CLXF)/)/3.06 + end if + + if(GdepI .eq. "Neu") then + sour_I=emis_I + (/(f1_I[:]->GS_H2SO4)/)/3.06 \ ; gas phase H2SO4 production + + (/f1_I[:]->AQ_SO4_A2_OCW/)/3.59 \ ; aq phase H2SO4 production + + (/f1_I[:]->AQ_H2SO4/)/3.06 ; some of the aq phase prod is just cond of gas phase + + else + sour_I=emis_I + (/(f1_I[:]->GS_H2SO4)/)/3.06 + (/(f1_I[:]->WD_A_H2SO4)/)/3.06 \ ; gas phase H2SO4 production + + (/f1_I[:]->AQ_SO4_A2_OCW/)/3.59\ ; aq phase H2SO4 production + + (/f1_I[:]->AQ_H2SO4/)/3.06 ; some of the aq phase prod is just cond of gas phase + end if + + + load_I=(/(f1_I[:]->cb_SO4_A1)/)/3.06 + (/(f1_I[:]->cb_SO4_A2)/)/3.59 + (/(f1_I[:]->cb_SO4_AC)/)/3.06 \ + + (/(f1_I[:]->cb_SO4_NA)/)/3.06 + (/(f1_I[:]->cb_SO4_PR)/)/3.06 \ + + (/(f1_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_I[:]->cb_SO4_AC_OCW)/)/3.06 \ + + (/(f1_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_I[:]->cb_SO4_PR_OCW)/)/3.06 + + wet_I=(/f1_I[:]->SO4_A1SFWET/)/3.06 + (/f1_I[:]->SO4_A2SFWET/)/3.59 + (/f1_I[:]->SO4_ACSFWET/)/3.06 \ + + (/f1_I[:]->SO4_NASFWET/)/3.06 + (/f1_I[:]->SO4_PRSFWET/)/3.06 \ + + (/f1_I[:]->SO4_A1_OCWSFWET/)/3.06 + (/f1_I[:]->SO4_A2_OCWSFWET/)/3.59 + (/f1_I[:]->SO4_AC_OCWSFWET/)/3.06 \ + + (/f1_I[:]->SO4_NA_OCWSFWET/)/3.06 + (/f1_I[:]->SO4_PR_OCWSFWET/)/3.06 \ + + (/f1_I[:]->WD_A_H2SO4/)/3.06 + + dry_I=(/f1_I[:]->SO4_A1DDF/)/3.06 + (/f1_I[:]->SO4_A2DDF/)/3.59 + (/f1_I[:]->SO4_ACDDF/)/3.06 \ + + (/f1_I[:]->SO4_NADDF/)/3.06 + (/f1_I[:]->SO4_PRDDF/)/3.06 \ + + (/f1_I[:]->SO4_A1_OCWDDF/)/3.06 + (/f1_I[:]->SO4_A2_OCWDDF/)/3.59 + (/f1_I[:]->SO4_AC_OCWDDF/) /3.06 \ + + (/f1_I[:]->SO4_NA_OCWDDF/)/3.06 + (/f1_I[:]->SO4_PR_OCWDDF/)/3.06 + + sink_I=wet_I-dry_I + + end if + + if(GdepII .eq. "Neu") then + emis_II= (/(f1_II[:]->SFSO4_PR)/)/3.06 + (/(f1_II[:]->SO4_PR_XFRC_COL)/)/3.06 + else + emis_II= (/(f1_II[:]->SFSO4_PR)/)/3.06 + (/(f1_II[:]->SO4_PR_CLXF)/)/3.06 + end if + + if(GdepII .eq. "Neu") then + sour_II=emis_II + (/(f1_II[:]->GS_H2SO4)/)/3.06 \ ; gas phase H2SO4 production + + (/f1_II[:]->AQ_SO4_A2_OCW/)/3.59 \ ; aq phase H2SO4 production + + (/f1_II[:]->AQ_H2SO4/)/3.06 ; some of the aq phase prod is just cond of gas phase + else + sour_II=emis_II + (/(f1_II[:]->GS_H2SO4)/)/3.06 + (/(f1_II[:]->WD_A_H2SO4)/)/3.06 \ ; gas phase H2SO4 production + + (/f1_II[:]->AQ_SO4_A2_OCW/)/3.59 \ ; aq phase H2SO4 production + + (/f1_II[:]->AQ_H2SO4/)/3.06 ; some of the aq phase prod is just cond of gas phase + end if + + load_II=(/(f1_II[:]->cb_SO4_A1)/)/3.06 + (/(f1_II[:]->cb_SO4_A2)/)/3.59 + (/(f1_II[:]->cb_SO4_AC)/)/3.06 \ + + (/(f1_II[:]->cb_SO4_NA)/)/3.06 + (/(f1_II[:]->cb_SO4_PR)/)/3.06 \ + + (/(f1_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1_II[:]->cb_SO4_AC_OCW)/)/3.06 \ + + (/(f1_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1_II[:]->cb_SO4_PR_OCW)/)/3.06 + + wet_II=(/f1_II[:]->SO4_A1SFWET/)/3.06 + (/f1_II[:]->SO4_A2SFWET/)/3.59 + (/f1_II[:]->SO4_ACSFWET/)/3.06 \ + + (/f1_II[:]->SO4_NASFWET/)/3.06 + (/f1_II[:]->SO4_PRSFWET/)/3.06 \ + + (/f1_II[:]->SO4_A1_OCWSFWET/)/3.06 + (/f1_II[:]->SO4_A2_OCWSFWET/)/3.59 + (/f1_II[:]->SO4_AC_OCWSFWET/)/3.06 \ + + (/f1_II[:]->SO4_NA_OCWSFWET/)/3.06 + (/f1_II[:]->SO4_PR_OCWSFWET/)/3.06 \ + + (/f1_II[:]->WD_A_H2SO4/)/3.06 + + dry_II=(/f1_II[:]->SO4_A1DDF/)/3.06 + (/f1_II[:]->SO4_A2DDF/)/3.59 + (/f1_II[:]->SO4_ACDDF/)/3.06 \ + + (/f1_II[:]->SO4_NADDF/)/3.06 + (/f1_II[:]->SO4_PRDDF/)/3.06 \ + + (/f1_II[:]->SO4_A1_OCWDDF/)/3.06 + (/f1_II[:]->SO4_A2_OCWDDF/)/3.59 + (/f1_II[:]->SO4_AC_OCWDDF/) /3.06 \ + + (/f1_II[:]->SO4_NA_OCWDDF/)/3.06 + (/f1_II[:]->SO4_PR_OCWDDF/)/3.06 + + sink_II=wet_II-dry_II + + else if (plot_type.eq.2) then + var="BC" + varname="BC" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_BC)/) + sour_I=(/(f1_I[:]->EMI_BC)/) + load_I=(/f1_I[:]->C_BC/) + wet_I=(/f1_I[:]->WET_BC/) + sink_I=(/f1_I[:]->WET_BC/)+(/f1_I[:]->DRY_BC/) + else + if(GdepII .eq. "Neu") then + emis_I=(/(f1_I[:]->SFBC_A)/) + (/(f1_I[:]->SFBC_AC)/) + (/(f1_I[:]->SFBC_AX)/) + (/(f1_I[:]->SFBC_AI)/) + (/(f1_I[:]->SFBC_NI)/) + (/(f1_I[:]->SFBC_N)/) + (/(f1_I[:]->BC_AX_XFRC_COL)/) + (/(f1_I[:]->BC_NI_XFRC_COL)/) + (/(f1_I[:]->BC_N_XFRC_COL)/) + else + emis_I=(/(f1_I[:]->SFBC_A)/) + (/(f1_I[:]->SFBC_AC)/) + (/(f1_I[:]->SFBC_AX)/) + (/(f1_I[:]->SFBC_AI)/) + (/(f1_I[:]->SFBC_NI)/) + (/(f1_I[:]->SFBC_N)/) + (/(f1_I[:]->BC_AX_CLXF)/) + (/(f1_I[:]->BC_NI_CLXF)/) + (/(f1_I[:]->BC_N_CLXF)/) + end if + sour_I=emis_I + + load_I=(/(f1_I[:]->cb_BC)/) + (/(f1_I[:]->cb_BC_A_OCW)/) + (/(f1_I[:]->cb_BC_AC_OCW)/) + (/(f1_I[:]->cb_BC_AI_OCW)/) + (/(f1_I[:]->cb_BC_NI_OCW)/) + (/(f1_I[:]->cb_BC_N_OCW)/) + + wet_I=(/f1_I[:]->BC_ASFWET/) + (/f1_I[:]->BC_ACSFWET/) + (/f1_I[:]->BC_AXSFWET/) + (/f1_I[:]->BC_AISFWET/) + (/f1_I[:]->BC_NISFWET/) + (/f1_I[:]->BC_NSFWET/) \ + + (/f1_I[:]->BC_A_OCWSFWET/) + (/f1_I[:]->BC_AC_OCWSFWET/) + (/f1_I[:]->BC_AI_OCWSFWET/) + (/f1_I[:]->BC_NI_OCWSFWET/) + (/f1_I[:]->BC_N_OCWSFWET/) + + dry_I=(/f1_I[:]->BC_ADDF/) + (/f1_I[:]->BC_ACDDF/) + (/f1_I[:]->BC_AXDDF/) + (/f1_I[:]->BC_AIDDF/) + (/f1_I[:]->BC_NIDDF/) + (/f1_I[:]->BC_NDDF/) \ + + (/f1_I[:]->BC_A_OCWDDF/) + (/f1_I[:]->BC_AC_OCWDDF/) + (/f1_I[:]->BC_AI_OCWDDF/) + (/f1_I[:]->BC_NI_OCWDDF/) + (/f1_I[:]->BC_N_OCWDDF/) + + sink_I=wet_I-dry_I + end if + if(GdepII .eq. "Neu") then + emis_II=(/(f1_II[:]->SFBC_A)/) + (/(f1_II[:]->SFBC_AC)/) + (/(f1_II[:]->SFBC_AX)/) + (/(f1_II[:]->SFBC_AI)/) + (/(f1_II[:]->SFBC_NI)/) + (/(f1_II[:]->SFBC_N)/) + (/(f1_II[:]->BC_AX_XFRC_COL)/) + (/(f1_II[:]->BC_NI_XFRC_COL)/) + (/(f1_II[:]->BC_N_XFRC_COL)/) + else + emis_II=(/(f1_II[:]->SFBC_A)/) + (/(f1_II[:]->SFBC_AC)/) + (/(f1_II[:]->SFBC_AX)/) + (/(f1_II[:]->SFBC_AI)/) + (/(f1_II[:]->SFBC_NI)/) + (/(f1_II[:]->SFBC_N)/) + (/(f1_II[:]->BC_AX_CLXF)/) + (/(f1_II[:]->BC_NI_CLXF)/) + (/(f1_II[:]->BC_N_CLXF)/) + end if + +sour_II=emis_II + + load_II=(/(f1_II[:]->cb_BC)/) + (/(f1_II[:]->cb_BC_A_OCW)/) + (/(f1_II[:]->cb_BC_AC_OCW)/) + (/(f1_II[:]->cb_BC_AI_OCW)/) + (/(f1_II[:]->cb_BC_NI_OCW)/) + (/(f1_II[:]->cb_BC_N_OCW)/) + + wet_II=(/f1_II[:]->BC_ASFWET/) + (/f1_II[:]->BC_ACSFWET/) + (/f1_II[:]->BC_AXSFWET/) + (/f1_II[:]->BC_AISFWET/) + (/f1_II[:]->BC_NISFWET/) + (/f1_II[:]->BC_NSFWET/) + (/f1_II[:]->BC_A_OCWSFWET/) + (/f1_II[:]->BC_AC_OCWSFWET/) + (/f1_II[:]->BC_AI_OCWSFWET/) + (/f1_II[:]->BC_NI_OCWSFWET/) + (/f1_II[:]->BC_N_OCWSFWET/) + + dry_II=(/f1_II[:]->BC_ADDF/) + (/f1_II[:]->BC_ACDDF/) + (/f1_II[:]->BC_AXDDF/) + (/f1_II[:]->BC_AIDDF/) + (/f1_II[:]->BC_NIDDF/) + (/f1_II[:]->BC_NDDF/) \ + + (/f1_II[:]->BC_A_OCWDDF/) + (/f1_II[:]->BC_AC_OCWDDF/) + (/f1_II[:]->BC_AI_OCWDDF/) + (/f1_II[:]->BC_NI_OCWDDF/) + (/f1_II[:]->BC_N_OCWDDF/) + + sink_II=wet_II-dry_II + else if (plot_type.eq.3) then + var="POM" + varname="POM" + if(ModI.eq."CAM4-Oslo") then + MSAProd_I = 1.0*(/f1_I[:]->MSAGA /)*96/32 ; MSAProd is written out as "S", but MSA has Mw of 96 + ; hardcoded as factor "3" in gaschem.F90: dqdt(i,k,l_om_ni)= 3._r8*pmsa + SOAProd_I = 0.0*MSAProd_I ; Don't have this term from NorESM1 + terpeneLoss_I = 0.0*SOAProd_I ; Don't have any terpene loss in noresm1 + + emis_I=(/(f1_I[:]->EMI_POM)/) + sour_I=(/(f1_I[:]->EMI_POM)/) + MSAProd_I + load_I=(/f1_I[:]->C_POM/) + wet_I=(/f1_I[:]->WET_POM/) + sink_I=(/f1_I[:]->WET_POM/)+(/f1_I[:]->DRY_POM/) + + else + + SOAProd_I = (/(f1_I[:]->GS_SOA_LV)/) + (/(f1_I[:]->GS_SOA_SV)/) + + terpeneLoss_I = -1.0*terpenes_lost_as_soa_I + + MSAProd_I = 0.0*terpeneLoss_I + + if(GdepII .eq. "Neu") then + emis_I=(/(f1_I[:]->SFOM_AI)/) + (/(f1_I[:]->SFOM_AC)/) + (/(f1_I[:]->SFOM_NI)/) + (/f1_I[:]->OM_NI_XFRC_COL/) + else + emis_I=(/(f1_I[:]->SFOM_AI)/) + (/(f1_I[:]->SFOM_AC)/) + (/(f1_I[:]->SFOM_NI)/) + (/f1_I[:]->OM_NI_CLXF/) + end if + + sour_I=emis_I + SOAProd_I + + load_I=(/(f1_I[:]->cb_OM)/) \ + + (/(f1_I[:]->cb_OM_AI_OCW)/) + (/(f1_I[:]->cb_OM_AC_OCW)/) + (/(f1_I[:]->cb_OM_NI_OCW)/) \ + + (/(f1_I[:]->cb_SOA_NA_OCW)/) + (/(f1_I[:]->cb_SOA_A1_OCW)/) + + wet_I=(/f1_I[:]->OM_AISFWET/) + (/f1_I[:]->OM_ACSFWET/) + (/f1_I[:]->OM_NISFWET/) \ + + (/f1_I[:]->OM_AI_OCWSFWET/) + (/f1_I[:]->OM_AC_OCWSFWET/) + (/f1_I[:]->OM_NI_OCWSFWET/) \ + + (/f1_I[:]->SOA_NASFWET/) + (/f1_I[:]->SOA_A1SFWET/) \ + + (/f1_I[:]->SOA_NA_OCWSFWET/) + (/f1_I[:]->SOA_A1_OCWSFWET/) + + dry_I=(/f1_I[:]->OM_AIDDF/) + (/f1_I[:]->OM_ACDDF/) + (/f1_I[:]->OM_NIDDF/) \ + + (/f1_I[:]->OM_AI_OCWDDF/) + (/f1_I[:]->OM_AC_OCWDDF/) + (/f1_I[:]->OM_NI_OCWDDF/) \ + + (/f1_I[:]->SOA_NADDF/) + (/f1_I[:]->SOA_A1DDF/) \ + + (/f1_I[:]->SOA_NA_OCWDDF/) + (/f1_I[:]->SOA_A1_OCWDDF/) + + sink_I=wet_I-dry_I + end if + + SOAProd_II = (/(f1_II[:]->GS_SOA_LV)/) + (/(f1_II[:]->GS_SOA_SV)/) + + terpeneLoss_II = -1.0*terpenes_lost_as_soa_II + + MSAProd_II = 0.0*terpeneLoss_II + + if(GdepII .eq. "Neu") then + emis_II=(/(f1_II[:]->SFOM_AI)/) + (/(f1_II[:]->SFOM_AC)/) + (/(f1_II[:]->SFOM_NI)/) + (/f1_II[:]->OM_NI_XFRC_COL/) + else + emis_I=(/(f1_I[:]->SFOM_AI)/) + (/(f1_I[:]->SFOM_AC)/) + (/(f1_I[:]->SFOM_NI)/) + (/f1_I[:]->OM_NI_CLXF/) + end if + + sour_II=emis_II + SOAProd_II + + load_II=(/(f1_II[:]->cb_OM)/) \ + + (/(f1_II[:]->cb_OM_AI_OCW)/) + (/(f1_II[:]->cb_OM_AC_OCW)/) + (/(f1_II[:]->cb_OM_NI_OCW)/) \ + + (/(f1_II[:]->cb_SOA_NA_OCW)/) + (/(f1_II[:]->cb_SOA_A1_OCW)/) + + wet_II=(/f1_II[:]->OM_AISFWET/) + (/f1_II[:]->OM_ACSFWET/) + (/f1_II[:]->OM_NISFWET/) \ + + (/f1_II[:]->OM_AI_OCWSFWET/) + (/f1_II[:]->OM_AC_OCWSFWET/) + (/f1_II[:]->OM_NI_OCWSFWET/) \ + + (/f1_II[:]->SOA_NASFWET/) + (/f1_II[:]->SOA_A1SFWET/) \ + + (/f1_II[:]->SOA_NA_OCWSFWET/) + (/f1_II[:]->SOA_A1_OCWSFWET/) + + dry_II=(/f1_II[:]->OM_AIDDF/) + (/f1_II[:]->OM_ACDDF/) + (/f1_II[:]->OM_NIDDF/) \ + + (/f1_II[:]->OM_AI_OCWDDF/) + (/f1_II[:]->OM_AC_OCWDDF/) + (/f1_II[:]->OM_NI_OCWDDF/) \ + + (/f1_II[:]->SOA_NADDF/) + (/f1_II[:]->SOA_A1DDF/) \ + + (/f1_II[:]->SOA_NA_OCWDDF/) + (/f1_II[:]->SOA_A1_OCWDDF/) + + sink_II=wet_II-dry_II + else if (plot_type.eq.4) then + var="SS" + varname="Sea-salt" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_SS)/) + sour_I=(/(f1_I[:]->EMI_SS)/) + + load_I=(/f1_I[:]->C_SS/) + wet_I=(/f1_I[:]->WET_SS/) + sink_I=(/f1_I[:]->WET_SS/)+(/f1_I[:]->DRY_SS/) + else + emis_I=(/(f1_I[:]->SFSS_A1)/) + (/(f1_I[:]->SFSS_A2)/) + (/(f1_I[:]->SFSS_A3)/) + sour_I=emis_I + load_I=(/(f1_I[:]->cb_SALT)/) + (/(f1_I[:]->cb_SS_A1_OCW)/) + (/(f1_I[:]->cb_SS_A2_OCW)/) + (/(f1_I[:]->cb_SS_A3_OCW)/) + wet_I=(/f1_I[:]->SS_A1SFWET/) + (/f1_I[:]->SS_A2SFWET/) + (/f1_I[:]->SS_A3SFWET/) + (/f1_I[:]->SS_A1_OCWSFWET/) + (/f1_I[:]->SS_A2_OCWSFWET/) + (/f1_I[:]->SS_A3_OCWSFWET/) + dry_I=(/f1_I[:]->SS_A1DDF/) + (/f1_I[:]->SS_A2DDF/) + (/f1_I[:]->SS_A3DDF/) + (/f1_I[:]->SS_A1_OCWDDF/) + (/f1_I[:]->SS_A2_OCWDDF/) + (/f1_I[:]->SS_A3_OCWDDF/) + sink_I=wet_I-dry_I + end if + emis_II=(/(f1_II[:]->SFSS_A1)/) + (/(f1_II[:]->SFSS_A2)/) + (/(f1_II[:]->SFSS_A3)/) + sour_II=emis_II + load_II=(/(f1_II[:]->cb_SALT)/) + (/(f1_II[:]->cb_SS_A1_OCW)/) + (/(f1_II[:]->cb_SS_A2_OCW)/) + (/(f1_II[:]->cb_SS_A3_OCW)/) + wet_II=(/f1_II[:]->SS_A1SFWET/) + (/f1_II[:]->SS_A2SFWET/) + (/f1_II[:]->SS_A3SFWET/) + (/f1_II[:]->SS_A1_OCWSFWET/) + (/f1_II[:]->SS_A2_OCWSFWET/) + (/f1_II[:]->SS_A3_OCWSFWET/) + dry_II=(/f1_II[:]->SS_A1DDF/) + (/f1_II[:]->SS_A2DDF/) + (/f1_II[:]->SS_A3DDF/) + (/f1_II[:]->SS_A1_OCWDDF/) + (/f1_II[:]->SS_A2_OCWDDF/) + (/f1_II[:]->SS_A3_OCWDDF/) + sink_II=wet_II-dry_II + else if (plot_type.eq.5) then + var="DU" + varname="Dust" + if(ModI.eq."CAM4-Oslo") then + emis_I=(/(f1_I[:]->EMI_DUST)/) + sour_I=(/(f1_I[:]->EMI_DUST)/) + load_I=(/f1_I[:]->C_DUST/) + wet_I=(/f1_I[:]->WET_DUST/) + sink_I=(/f1_I[:]->WET_DUST/)+(/f1_I[:]->DRY_DUST/) + else + emis_I=(/(f1_I[:]->SFDST_A2)/) + (/(f1_I[:]->SFDST_A3)/) + sour_I=emis_I + load_I=(/(f1_I[:]->cb_DUST)/) + (/(f1_I[:]->cb_DST_A2_OCW)/) + (/(f1_I[:]->cb_DST_A3_OCW)/) + wet_I=(/f1_I[:]->DST_A2SFWET/) + (/f1_I[:]->DST_A3SFWET/) + (/f1_I[:]->DST_A2_OCWSFWET/) + (/f1_I[:]->DST_A3_OCWSFWET/) + dry_I=(/f1_I[:]->DST_A2DDF/) + (/f1_I[:]->DST_A3DDF/) + (/f1_I[:]->DST_A2_OCWDDF/) + (/f1_I[:]->DST_A3_OCWDDF/) + sink_I=wet_I-dry_I + end if + emis_II=(/(f1_II[:]->SFDST_A2)/) + (/(f1_II[:]->SFDST_A3)/) + sour_II=emis_II + load_II=(/(f1_II[:]->cb_DUST)/) + (/(f1_II[:]->cb_DST_A2_OCW)/) + (/(f1_II[:]->cb_DST_A3_OCW)/) + wet_II=(/f1_II[:]->DST_A2SFWET/) + (/f1_II[:]->DST_A3SFWET/) + (/f1_II[:]->DST_A2_OCWSFWET/) + (/f1_II[:]->DST_A3_OCWSFWET/) + dry_II=(/f1_II[:]->DST_A2DDF/) + (/f1_II[:]->DST_A3DDF/) + (/f1_II[:]->DST_A2_OCWDDF/) + (/f1_II[:]->DST_A3_OCWDDF/) + sink_II=wet_II-dry_II + end if + end if + end if + end if + end if + end if + end if + + lifetime_I=-load_I/(sink_I+small) + lifetime_II=-load_II/(sink_II+small) + +; Initializing and calculating area weighted values + + emis_Ia=emis_I + emis_IIa=emis_II + sour_Ia=sour_I + sour_IIa=sour_II + lifetime_Ia=lifetime_I + lifetime_IIa=lifetime_II + load_Ia=load_I + load_IIa=load_II + wet_Ia=wet_I + wet_IIa=wet_II + sink_Ia=sink_I + sink_IIa=sink_II +if (plot_type.eq.-1.or.plot_type.eq.0) then + chloss_Ia=chloss_I + chloss_IIa=chloss_II + chlossg_Ia=chlossg_I + chlossg_IIa=chlossg_II +end if +if(plot_type .eq. 3)then + MSAProd_Ia = MSAProd_I + MSAProd_IIa = MSAProd_II + SOAProd_Ia = SOAProd_I + SOAProd_IIa = SOAProd_II + terpeneLoss_Ia = terpeneLoss_I + terpeneLoss_IIa = terpeneLoss_II +end if + + xdims_I = dimsizes(gw0_I) + ydims_I = dimsizes(lifetime_Ia) + do i=0,dimsizes(gw0_I)-1 + sour_Ia(:,i,:)=sour_I(:,i,:)*coffa*dlon_I*gw0_I(i) + emis_Ia(:,i,:)=emis_I(:,i,:)*coffa*dlon_I*gw0_I(i) + lifetime_Ia(:,i,:)=lifetime_I(:,i,:)*coffa*dlon_I*gw0_I(i) + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + wet_Ia(:,i,:)=wet_I(:,i,:)*coffa*dlon_I*gw0_I(i) + sink_Ia(:,i,:)=sink_I(:,i,:)*coffa*dlon_I*gw0_I(i) +if (plot_type.eq.-1.or.plot_type.eq.0) then + chloss_Ia(:,i,:)=chloss_I(:,i,:)*coffa*dlon_I*gw0_I(i) + chlossg_Ia(:,i,:)=chlossg_I(:,i,:)*coffa*dlon_I*gw0_I(i) +end if +if (plot_type .eq. 3)then + MSAProd_Ia(:,i,:)=MSAProd_I(:,i,:)*coffa*dlon_I*gw0_I(i) + terpeneLoss_Ia(:,i,:)=terpeneLoss_I(:,i,:)*coffa*dlon_I*gw0_I(i) + SOAProd_Ia(:,i,:)=SOAProd_I(:,i,:)*coffa*dlon_I*gw0_I(i) +end if + end do + emisave_I=sum(dim_avg_n(emis_Ia,0))/area1 + sourave_I=sum(dim_avg_n(sour_Ia,0))/area1 + loadave_I=sum(dim_avg_n(load_Ia,0))/area1 + wetave_I=sum(dim_avg_n(wet_Ia,0))/area1 + sinkave_I=sum(dim_avg_n(sink_Ia,0))/area1 +if (plot_type.eq.-1.or.plot_type.eq.0) then + chlossave_I=sum(dim_avg_n(chloss_Ia,0))/area1 + chlossgave_I=sum(dim_avg_n(chlossg_Ia,0))/area1 +end if + + xdims_II = dimsizes(gw0_II) + ydims_II = dimsizes(lifetime_IIa) + do i=0,dimsizes(gw0_II)-1 + sour_IIa(:,i,:)=sour_II(:,i,:)*coffa*dlon_II*gw0_II(i) + emis_IIa(:,i,:)=emis_II(:,i,:)*coffa*dlon_II*gw0_II(i) + lifetime_IIa(:,i,:)=lifetime_II(:,i,:)*coffa*dlon_II*gw0_II(i) + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + wet_IIa(:,i,:)=wet_II(:,i,:)*coffa*dlon_II*gw0_II(i) + sink_IIa(:,i,:)=sink_II(:,i,:)*coffa*dlon_II*gw0_II(i) +if (plot_type.eq.-1.or.plot_type.eq.0) then + chloss_IIa(:,i,:)=chloss_II(:,i,:)*coffa*dlon_II*gw0_II(i) + chlossg_IIa(:,i,:)=chlossg_II(:,i,:)*coffa*dlon_II*gw0_II(i) +end if +if (plot_type .eq. 3)then + MSAProd_IIa(:,i,:)=MSAProd_II(:,i,:)*coffa*dlon_II*gw0_II(i) + terpeneLoss_IIa(:,i,:)=terpeneLoss_II(:,i,:)*coffa*dlon_II*gw0_II(i) + SOAProd_IIa(:,i,:)=SOAProd_II(:,i,:)*coffa*dlon_II*gw0_II(i) +end if + end do + emisave_II=sum(dim_avg_n(emis_IIa,0))/area1 + sourave_II=sum(dim_avg_n(sour_IIa,0))/area1 + loadave_II=sum(dim_avg_n(load_IIa,0))/area1 + wetave_II=sum(dim_avg_n(wet_IIa,0))/area1 + sinkave_II=sum(dim_avg_n(sink_IIa,0))/area1 +if (plot_type.eq.-1.or.plot_type.eq.0) then + chlossave_II=sum(dim_avg_n(chloss_IIa,0))/area1 + chlossgave_II=sum(dim_avg_n(chlossg_IIa,0))/area1 +end if +if (plot_type .eq. 3)then + MSAProdave_I = sum(dim_avg_n(MSAProd_Ia,0))/area1 + MSAProdave_II = sum(dim_avg_n(MSAProd_IIa,0))/area1 + SOAProdave_I = sum(dim_avg_n(SOAProd_Ia,0))/area1 + SOAProdave_II = sum(dim_avg_n(SOAProd_IIa,0))/area1 + terpeneLossave_I = sum(dim_avg_n(terpeneLoss_Ia,0))/area1 + terpeneLossave_II = sum(dim_avg_n(terpeneLoss_IIa,0))/area1 +end if +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Print the table entries +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; Note: Values for SO2 and SO4 are given as Sulfur (S) values +lifetimeave_I=-loadave_I/(sinkave_I+small)/3600.0/24.0 ; s -> days +lifetimeave_II=-loadave_II/(sinkave_II+small)/3600.0/24.0 ; s -> days +emisave_I=emisave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +emisave_II=emisave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +sourave_I=sourave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +sourave_II=sourave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +sinkave_I=-1.0*sinkave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +sinkave_II=-1.0*sinkave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +wetave_I = -1.0*wetave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +wetave_II = -1.0*wetave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +if(plot_type.eq.-1 .or. plot_type.eq.0)then + chlossave_I = chlossave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + chlossave_II = chlossave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + chlossgave_I = chlossgave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + chlossgave_II = chlossgave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr +end if +loadave_I=loadave_I*1.e-9*area1 ; kg/m2 -> Tg +loadave_II=loadave_II*1.e-9*area1 ; kg/m2 -> Tg +wetdeppave_I=1.e2*wetave_I/(sinkave_I+small) ; fraction -> % +wetdeppave_II=1.e2*wetave_II/(sinkave_II+small) ; fraction -> % +if (plot_type.eq.-1.or.plot_type.eq.0) then + chlosspave_I=1.e2*chlossave_I/(-1.0*sinkave_I+small) ; fraction -> % + chlosspave_II=1.e2*chlossave_II/(-1.0*sinkave_II+small) ; fraction -> % + chlossgpave_I=1.e2*chlossgave_I/(chlossave_I+small) ; fraction -> % + chlossgpave_II=1.e2*chlossgave_II/(chlossave_II+small) ; fraction -> % +end if +if(plot_type .eq. 3)then + MSAProdave_I = (MSAProdave_I \ + + terpeneLossave_I \ + + SOAProdave_I ) *1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + MSAProdave_II = ( MSAProdave_II \ + + terpeneLossave_II \ + + SOAProdave_II )*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + SOAProdave_I = SOAProdave_I*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + SOAProdave_II = SOAProdave_II*1.e-9*area1*3600*24*365 ; kg/m2/s -> Tg/yr + terpeneLossave_I = terpeneLossave_I*1.e-9*area1*3600*24*365 + terpeneLossave_II = terpeneLossave_II*1.e-9*area1*3600*24*365 +end if + +print("Mass budget numbers for model version I (old), II (new)") +print("Note: Values for DMS; SO2 and SO4 are given as Sulfur (S) values") +print("-------------------------------------------------------------") +print(var+" total emissions (Tg/yr) = "+sprintf("%4.3f",emisave_I)+", "+sprintf("%4.3f",emisave_II)) +print(var+" total sources (Tg/yr) = "+sprintf("%4.3f",sourave_I)+", "+sprintf("%4.3f",sourave_II)) +print(var+" total sink (Tg/yr) = "+sprintf("%4.3f",sinkave_I)+", "+sprintf("%4.3f",sinkave_II)) +print(var+" burden (Tg) = "+sprintf("%4.3f",loadave_I)+", "+sprintf("%4.3f",loadave_II)) +if (plot_type.ne.-1) then +print(var+" wet depostion (% of sinks) = "+sprintf("%4.3f",wetdeppave_I)+", "+sprintf("%4.3f",wetdeppave_II)) +end if +print(var+" lifetime (d) = "+sprintf("%4.3f",lifetimeave_I)+", "+sprintf("%4.3f",lifetimeave_II)) +if (plot_type.eq.-1.or.plot_type.eq.0) then +print(var+" chemical loss (%) = "+sprintf("%4.3f",chlosspave_I)+", "+sprintf("%4.3f",chlosspave_II)) +end if +if (plot_type.eq.-1) then +print(var+" pct of chem. loss to MSA (%) = "+sprintf("%4.3f",chlossgpave_I)+", "+sprintf("%4.3f",chlossgpave_II)) +end if +if (plot_type.eq.0) then +print(var+" pct of chem loss in clear air (%) = "+sprintf("%4.3f",chlossgpave_I)+", "+sprintf("%4.3f",chlossgpave_II)) +end if +if (plot_type.eq.3)then + print(var+ " chem prod from MSA (Tg/yr) = "+sprintf("%4.3f",MSAProdave_I)+", "+sprintf("%4.3f",MSAProdave_II)) + print(var+ " chem prod (total) (Tg/yr) = " +sprintf("%4.3f",SOAProdave_I)+", "+sprintf("%4.3f",SOAProdave_II)) + print(var+ " chem prod terpenes (Tg /yr) = " +sprintf("%4.3f",-1.0*terpeneLossave_I)+", "+sprintf("%4.3f",-1.0*terpeneLossave_II)) +end if + +print("-------------------------------------------------------------") + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.csh b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.csh new file mode 100755 index 0000000000..8084b7b00b --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.csh @@ -0,0 +1,383 @@ +echo ' Note: on norstore cruncher, run "module load ncl" first!' +echo '' +echo 'This script calls all the *ModIvsModII.ncl scripts' +echo 'and produces plots for all available/listed plot_types' +echo 'Note: All ncl scripts assumes that the input data on' +echo 'the listed directories are on a integer number times' +echo '12 nc-files for monthly model data for model I and II,' +echo 'and that no other files on the same name form are present.' +echo '' +echo 'If the number of years is so large that some of the' +echo 'ncl scripts run out of memory, with the error message' +echo 'systemfunc: cannot create child process:[errno=12],' +echo 'then make climatological input for each mponth in,' +echo 'advance, e.g. by use of the ncea command...' +echo '' +echo ' (Created by Alf KirkevÃ¥g, April 2014)' +echo '' + +# ncl 'dataFile=addfile("./modelData.nc", "r")' plot_type=0 Emis_ModIvsModII.ncl +#************************* To be edited by the user ******************************************** +# Plot type and plot output format: +plotf=png # chosen output format for figures (ps, eps, pdf, png) +# +# Paths and names of input files from model version I and II (PD case): +# +#pthI=/projects/NS2345K/noresm/cases/aerocomA2noresm_r128/tests_feb06-feb08/CTRL2000/yr7/ +#fnmI=aerocomA2r128_2006.cam2.h0.0007-01.nc +#fnmpI=aerocomA2r128_2006.cam2.h0.0007 +# +#pthI=/projects/NS2345K/noresm/cases/CCNCOMP06V_yr2011/ +#fnmI=CCNCOMP06V.cam.h0.2011-01.nc +#fnmpI=CCNCOMP06V.cam.h0.2011- +# +#pthI=/projects/NS2345K/noresm/cases/53OSLO_PD_UNTUNED_yr2006-2010/ +#fnmI=53OSLO_PD_UNTUNED.cam.h0.2006-2010_01.nc +#fnmpI=53OSLO_PD_UNTUNED.cam.h0.2006-2010_ +# +#pthI=/projects/NS2345K/noresm/cases/53OSLO_PDcorrlifeNMR12/ +#fnmI=53OSLO_PDcorrlifeNMR12.cam.h0.2006-2010_01.nc +#fnmpI=53OSLO_PDcorrlifeNMR12.cam.h0.2006-2010_ +# +pthI=/projects/NS2345K/noresm/cases/F2000ERF/mnthclim_yr3-30/ +fnmI=F2000ERF.cam.h0.0003-0030_01.nc +fnmpI=F2000ERF.cam.h0.0003-0030_ +# +#pthI=/projects/NS2345K/noresm/cases/NF1998HygCfree/orig/ +#fnmI=NF1998HygCfree.cam.h0.0001-05.nc +#fnmpI=NF1998HygCfree.cam.h0.000 +# +#pthI=/projects/NS2345K/noresm/cases/F2000ERF/2-07to3-06/ +#fnmI=F2000ERF.cam.h0.0002-07.nc +#fnmpI=F2000ERF.cam.h0.000 +# +#pthI=/projects/NS2345K/noresm/cases/7310AMIP20002_mnthclim_yr3-30/ +#fnmI=7310AMIP20002.cam.h0.0003-0030_01.nc +#fnmpI=7310AMIP20002.cam.h0.0003-0030_ +# +#pthII=/projects/NS2345K/noresm/cases/F2000ERF/mnthclim_yr3-30/ +#fnmII=F2000ERF.cam.h0.0003-0030_01.nc +#fnmpII=F2000ERF.cam.h0.0003-0030_ +# +#pthII=/projects/NS2345K/noresm/cases/53OSLO_PDnewDust/ +#fnmII=53OSLO_PDnewDust.cam.h0.2006-2010_01.nc +#fnmpII=53OSLO_PDnewDust.cam.h0.2006-2010_ +# +#pthII=/projects/NS2345K/noresm/cases/53OSLO_PDnoDust/ +#fnmII=53OSLO_PDnoDust.cam.h0.2006-2010_01.nc +#fnmpII=53OSLO_PDnoDust.cam.h0.2006-2010_ +# +#pthII=/projects/NS2345K/noresm/cases/AlfKtests/53OsloTstNuc/tst3_7yrs/yr6-10/ +#fnmII=53OsloTstNuc.cam.h0.2006-2010_01.nc +#fnmpII=53OsloTstNuc.cam.h0.2006-2010_ +# +#pthII=/projects/NS2345K/noresm/cases/NF1998ERF/mnthclim_yr3-30/ +#fnmII=NF1998ERF.cam.h0.0003-0030_01.nc +#fnmpII=NF1998ERF.cam.h0.0003-0030_ +# +#pthII=/projects/NS2345K/noresm/cases/NF1998HygCfree/ +#fnmII=NF1998HygCfree.cam.h0.0001-05.nc +#fnmpII=NF1998HygCfree.cam.h0.000 +# +#pthII=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNucl-all/mnth5-17b4corrsconc/ +#fnmII=NF2kNucl.cam.h0.0001-05.nc +#fnmpII=NF2kNucl.cam.h0.000 +# +pthII=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNucl-all/ +fnmII=NF2kNucl.cam.h0.0003-01.nc +fnmpII=NF2kNucl.cam.h0.000 +# +#pthII=/projects/NS2345K/noresm/cases/53OSLO_PDcorrlifeNMR12/ +#fnmII=53OSLO_PDcorrlifeNMR12.cam.h0.2006-2010_01.nc +#fnmpII=53OSLO_PDcorrlifeNMR12.cam.h0.2006-2010_ +# +# Paths and names of input files necessary for forcing plots (PI case)): +# +#pthI_PI=/projects/NS2345K/noresm/cases/aerocomA2noresm_r128/tests_feb06-feb08/CTRL2000/PRE1850_yr7/ +#fnmI_PI=aerocomA2r128_1850.cam2.h0.0007-01.nc +#fnmpI_PI=aerocomA2r128_1850.cam2.h0.0007 +# +#pthI_PI=/projects/NS2345K/noresm/cases/CCNCOMP06V_yr2011/ +#fnmI_PI=CCNCOMP06V.cam.h0.2011-01.nc +#fnmpI_PI=CCNCOMP06V.cam.h0.2011- +# +#pthI_PI=/projects/NS2345K/noresm/cases/53OSLO_PI_wPDoxi/ +#fnmI_PI=53OSLO_PI_wPDoxi.cam.h0.2006-2010_01.nc +#fnmpI_PI=53OSLO_PI_wPDoxi.cam.h0.2006-2010_ +# +#pthI_PI=/projects/NS2345K/noresm/cases/53OSLO_PIcorrlifeNMR12/ +#fnmI_PI=53OSLO_PIcorrlifeNMR12.cam.h0.2006-2010_01.nc +#fnmpI_PI=53OSLO_PIcorrlifeNMR12.cam.h0.2006-2010_ +# +#pthI_PI=/projects/NS2345K/noresm/cases/NF2000PIERF/mnthclim_yr3-30/ +#fnmI_PI=NF2000PIERF.cam.h0.0003-0030_01.nc +#fnmpI_PI=NF2000PIERF.cam.h0.0003-0030_ +# +#pthI_PI=/projects/NS2345K/noresm/cases/NF2000PIERF/2-07to3-06/ +#fnmI_PI=NF2000PIERF.cam.h0.0002-07.nc +#fnmpI_PI=NF2000PIERF.cam.h0.000 +# +pthI_PI=/projects/NS2345K/noresm/cases/NF2000PIERF/mnthclim_yr3-30/ +fnmI_PI=NF2000PIERF.cam.h0.0003-0030_01.nc +fnmpI_PI=NF2000PIERF.cam.h0.0003-0030_ +# +#pthI_PI=/projects/NS2345K/noresm/cases/NF1998HygCfree/orig/ +#fnmI_PI=NF1998HygCfree.cam.h0.0001-05.nc +#fnmpI_PI=NF1998HygCfree.cam.h0.000 +# +#pthII_PI=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNuclPI-all/2-07to3-06/ +#fnmII_PI=NF2kNuclPI.cam.h0.0002-07.nc +#fnmpII_PI=NF2kNuclPI.cam.h0.000 +# +#pthII_PI=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNucl-all/ +#fnmII_PI=NF2kNucl.cam.h0.0001-05.nc +#fnmpII_PI=NF2kNucl.cam.h0.000 +# +pthII_PI=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNuclPI-all/ +fnmII_PI=NF2kNuclPI.cam.h0.0003-01.nc +fnmpII_PI=NF2kNuclPI.cam.h0.000 +# +#pthI_PI=/projects/NS2345K/noresm/cases/F2000ERF/ +#fnmI_PI=F2000ERF.cam.h0.0001-05.nc +#fnmpI_PI=F2000ERF.cam.h0.000 +# +#pthI_PI=/projects/NS2345K/noresm/cases/53OSLO_PInewDust/ +#fnmI_PI=53OSLO_PInewDust.cam.h0.2006-2010_01.nc +#fnmpI_PI=53OSLO_PInewDust.cam.h0.2006-2010_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/53OSLO_PIcorrlifeNMR12/ +#fnmII_PI=53OSLO_PIcorrlifeNMR12.cam.h0.2006-2010_01.nc +#fnmpII_PI=53OSLO_PIcorrlifeNMR12.cam.h0.2006-2010_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/53OSLO_PDnoDust/ +#fnmII_PI=53OSLO_PDnoDust.cam.h0.2006-2010_01.nc +#fnmpII_PI=53OSLO_PDnoDust.cam.h0.2006-2010_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/53OSLO_PI_wPDoxi/ +#fnmII_PI=53OSLO_PI_wPDoxi.cam.h0.2006-2010_01.nc +#fnmpII_PI=53OSLO_PI_wPDoxi.cam.h0.2006-2010_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/AMIP_PI_wPDoxi/atm/hist/mnthclim_yr3-30/ +#fnmII_PI=AMIP_PI_wPDoxi.cam.h0.0003-0030_01.nc +#fnmpII_PI=AMIP_PI_wPDoxi.cam.h0.0003-0030_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/AlfKtests/PI53OsloTstNuc/tst3_7yrs/yr6-10/ +#fnmII_PI=PI53OsloTstNuc.cam.h0.2006-2010_01.nc +#fnmpII_PI=PI53OsloTstNuc.cam.h0.2006-2010_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/F2000PIERFfram/ +#fnmII_PI=F2000PIERF.cam.h0.0001-05.nc +#fnmpII_PI=F2000PIERF.cam.h0.000 +#pthII_PI=/projects/NS2345K/noresm/cases/NF2000PIERF/mnthclim_yr3-30/ +#fnmII_PI=NF2000PIERF.cam.h0.0003-0030_01.nc +#fnmpII_PI=NF2000PIERF.cam.h0.0003-0030_ +# +#pthII_PI=/projects/NS2345K/noresm/cases/NF1998HygCfree/ +#fnmII_PI=NF1998HygCfree.cam.h0.0001-05.nc +#fnmpII_PI=NF1998HygCfree.cam.h0.000 +# +#pthII_PI=/projects/NS2345K/noresm/cases/AlfKtests/CAM6-Oslo/NF2kNucl-all/mnth5-17b4corrsconc/ +#fnmII_PI=NF2kNucl.cam.h0.0001-05.nc +#fnmpII_PI=NF2kNucl.cam.h0.000 +# +#pthII_PI=/projects/NS2345K/noresm/cases/53OSLO_PIinclLndUse/ +#fnmII_PI=53OSLO_PIinclLndUse.cam.h0.2006-2010_01.nc +#fnmpII_PI=53OSLO_PIinclLndUse.cam.h0.2006-2010_ +#pthII_PI=/projects/NS2345K/noresm/cases/B05NudgePI4_2013-2015/ +#fnmII_PI=B05NudgePI4.cam.h0.2010-01.nc +#fnmpII_PI=B05NudgePI4.cam.h0.2010 +# +#ModelI=CAM4-Oslo # gives CAM4-Oslo vs. new CAM5-Oslo comparison plots +ModelI=CAM5-Oslo # gives CAM5/6-Oslo Revision N vs. CAM5/6-Oslo Revision M comparison plots +# +# Note: when using CAM5.5 or higher for ModI, include also GasdepI options, as for ModII below +GasdepI=Neu # use diagnostics as in the Moz or in the Neu (>CAM5.3) gas deposition scheme for ModI +GasdepII=Neu # use diagnostics as in the Moz or in the Neu (>CAM5.3) gas deposition scheme for ModII +# Note: when using 32 level version for ModI or ModII, include also the LevModI & LevModII options L32 +# (this does not work if ModI is CAM4-Oslo), for use (only) in LevelCloudProp_ModIvsModII.ncl +LevModI=L32 +LevModII=L32 +#********************************************************************************************** + + +# Run TMP version x instead of the above for ModII data before correction w.r.t. mmr vs. vmr in model output of individual tracers +# or the y version if the ModI data have this shortcoming, or z if both ModI and ModII do: + echo '' + echo 'Running ZonalAero_ModIvsModII_TMP.ncl' + echo '' + for I in {1..7};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep#_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalAero_ModIvsModII.ncl +# ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep#_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalAero_ModIvsModII_TMPx.ncl +# ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalAero_ModIvsModII_TMPy.ncl +# ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalAero_ModIvsModII_TMPz.ncl + done + +#No changes by the user should be necessary below... + +echo '' +echo 'Running Emis_ModIvsModII.ncl' +echo '' +for I in {-1..7};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" Emis_ModIvsModII.ncl +done + +echo '' +echo 'Running diffTOAbalance.ncl' +echo '' +for I in {0..9};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" diffTOAbalance.ncl +done + +echo '' +echo 'Running LevelCloudProp_ModIvsModII.ncl' +echo '' +for I in {1..10};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" LevModI=\"$LevModI\" LevModII=\"$LevModII\" LevelCloudProp_ModIvsModII.ncl +done + +echo '' +echo 'Running Cld2d_ModIvsModII.ncl' +echo '' +for I in {0..9};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" Cld2d_ModIvsModII.ncl +done + +echo '' +echo 'Running Load_ModIvsModII.ncl' +echo '' +for I in {0..19};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" Load_ModIvsModII.ncl +done + +echo '' +echo 'Running Ext_ModIvsModII.ncl' +echo '' +for I in {1..20};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" Ext_ModIvsModII.ncl +done + +echo '' +echo 'Running AODratio_ModIvsModII.ncl' +echo '' +for I in {0..6};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" AODratio_ModIvsModII.ncl +done + +echo '' +echo 'Running AOD_ModIvsModII.ncl' +echo '' +for I in {0..8};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" AOD_ModIvsModII.ncl +done + +echo '' +echo 'Running ZonalRHCl_ModIvsModII.ncl' +echo '' +for I in {0..7};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalRHCl_ModIvsModII.ncl +done + +echo '' +echo 'Running Lifetimes_ModIvsModII.ncl' +echo '' +for I in {0..5};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" GdepI=\"$GasdepI\" GdepII=\"$GasdepII\" Lifetimes_ModIvsModII.ncl +done + +echo '' +echo 'Running WetDepRat_ModIvsModII.ncl' +echo '' +for I in {0..5};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" WetDepRat_ModIvsModII.ncl +done + +echo '' +echo 'Running EffDryRad_ModIvsModII.ncl' +echo '' +for I in {0..2};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" EffDryRad_ModIvsModII.ncl +done + +echo '' +echo 'Running ZonalModepar_ModIvsModII.ncl' +echo '' +for I in {1..9};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalModepar_ModIvsModII.ncl +done + +echo '' +echo 'Running ZonalN_ModIvsModII.ncl' +echo '' +for I in {1..13};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" ZonalN_ModIvsModII.ncl +done + +echo '' +echo 'Running PM_ModIvsModII.ncl' +echo '' +for I in {1..5};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" PM_ModIvsModII.ncl +done + +echo '' +echo 'Running RadBudg_ModIvsModII.ncl' +echo '' +for I in {1..3};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" RadBudg_ModIvsModII.ncl +done + +echo '' +echo 'Running divPD-PI_ModIvsModII.ncl' +echo '' +for I in {0..9};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" divPD-PI_ModIvsModII.ncl +done + +echo '' +echo 'Running divPD-PI_Zonal_ModIvsModII.ncl' +echo '' +for I in {0..6};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" divPD-PI_Zonal_ModIvsModII.ncl +done + +echo '' +echo 'Running ERFsurf_ModIvsModII.ncl' +echo '' +for I in {0..4};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" ERFsurf_ModIvsModII.ncl +done + +echo '' +echo 'Running ERF_ModIvsModII.ncl' +echo '' +for I in {0..6};do +ncl plot_type=$I format=\"$plotf\" filepathPD_I=\"$pthI\" filenamePD_I=\"$fnmI\" filepathPD_II=\"$pthII\" filenamePD_II=\"$fnmII\" filenamepPD_I=\"$fnmpI\" filenamepPD_II=\"$fnmpII\" filepathPI_I=\"$pthI_PI\" filenamePI_I=\"$fnmI_PI\" filepathPI_II=\"$pthII_PI\" filenamePI_II=\"$fnmII_PI\" filenamepPI_I=\"$fnmpI_PI\" filenamepPI_II=\"$fnmpII_PI\" ModI=\"$ModelI\" ERF_ModIvsModII.ncl +done + +echo '' +echo 'Running Mass-budget_ModIvsModII.ncl' +echo '' +for I in {-1..5};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI\" filename_I=\"$fnmI\" filepath_II=\"$pthII\" filename_II=\"$fnmII\" filenamep_I=\"$fnmpI\" filenamep_II=\"$fnmpII\" ModI=\"$ModelI\" GdepI=\"$GasdepI\" GdepII=\"$GasdepII\" Mass-budget_ModIvsModII.ncl +done + +echo '' +echo 'Running Mass-budget_ModIvsModII.ncl for PI emissions' +echo '' +for I in {-1..5};do + ncl plot_type=$I format=\"$plotf\" filepath_I=\"$pthI_PI\" filename_I=\"$fnmI_PI\" filepath_II=\"$pthII_PI\" filename_II=\"$fnmII_PI\" filenamep_I=\"$fnmpI_PI\" filenamep_II=\"$fnmpII_PI\" ModI=\"$ModelI\" GdepI=\"$GasdepI\" GdepII=\"$GasdepII\" Mass-budget_ModIvsModII.ncl +done + +echo '' +echo 'All ncl script runs completed' +echo '' + +echo "trim whitespace in images" +for i in `ls *.png` +do + convert -trim $i $i +done + +exit + + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.htm new file mode 100644 index 0000000000..6fddac422a --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII.htm @@ -0,0 +1,280 @@ + + +Aerosol Diagnostic Plots + + +

+ +Model version I (left) vs. Model version II (right) CHANGE ALL TEXT and TABEL INPUT BELOW TO FIT YOUR SPECIFIC COMPARISON! + +

+ +Presenting annual means (from monthly climatological means) from simulations with the following casenames: +

+ModI = F2000ERF and NF2000PIERF +
+ModII = NF2kNucl and NF2kNuclPI with changes in nucleation treatment
+

+


+Both ModI and ModII are from the noresm-dev master version (slightly different vversions...) +
+MG2, CLM5, online DMS/POM, with Eul gas deposition scheme, and both using PD oxidants for PI.
+
+ +
+ModI & II both use CMIP6 emissions, but PD reference is different: +
+ ModI assumes that all bakckground tracers contribute to the coagulation sink for the nucleation rate equation
+

+ +


+

+ModI PD: CAM6-Oslo, 2000 emissions (PD oxidants), 2 years spin-up, showing years 3-30 +

+ModI PI: CAM6-Oslo, 1850 emissions (PD oxidants), 2 years spin-up, showing years 3-30 +

+ModII PD: CAM6-Oslo, 2000 emissions (PD oxidants), 2 years spin-up, showing years 3-10 +

+ModII PI: CAM6-Oslo, 1850 emissions (PD oxidants), 2 years spin-up, showing years 3-10 +

+ +


+ + +


+ + +
Emissions and 2m wind speed +
+

+ + +
Zonally averaged mass mixing ratios +
+

+ + +
Zonally averaged mode parameters +
+

+ + + +
Burdens +
+

+ + +
Effective dry aerosol radii +
+

+ + +
Particular Matter (PM) concentrations (CAM5-Oslo vs. CAM5-Oslo only) +
+

+ + +
Wet to total deposition ratios +
+

+ + +
Lifetimes +
+

+ + +
RH, cloud properties and precipitation +
+

+ + +
Cloud droplet properties +
+

+ + +
Cloud properties at specific model levels +
+

+ + + +
Gross aerosol optical properties +
+

+ + +
Aerosol optical depth for each species +
+

+ + +
Mass extinction coefficients for each species +
+

+ + +
Anthropogenic (PD - PI) aerosol and cloud/RH fields +
+

+ + +
Radiative forcings at top of the atmosphere +
+

+ + +
Radiative fluxes at top of the atmosphere +
+

+ +


+

+


+

+

Present-day Mass budget numbers for ModI and ModII

+

+ +

+ +
+(0)	Mass budget numbers for model version      I (old), II (new)
+(0)	Note: Values for DMS; SO2 and SO4 are given as Sulfur (S) values
+(0)	-------------------------------------------------------------
+(0)	DMS total emissions   (Tg/yr)             = 31.519, 31.567
+(0)	DMS total sources     (Tg/yr)             = 31.519, 31.567
+(0)	DMS total sink        (Tg/yr)             = 31.781, 31.832
+(0)	DMS burden            (Tg)                = 0.086, 0.086
+(0)	DMS lifetime          (d)                 = 0.988, 0.984
+(0)	DMS chemical loss     (%)                 = 99.974, 99.974
+(0)	DMS pct of chem. loss to MSA (%)          = 7.969, 7.955
+(0)	-------------------------------------------------------------
+(0)	SO2 total emissions   (Tg/yr)             = 66.749, 66.749
+(0)	SO2 total sources     (Tg/yr)             = 95.989, 96.041
+(0)	SO2 total sink        (Tg/yr)             = 95.864, 95.914
+(0)	SO2 burden            (Tg)                = 0.375, 0.374
+(0)	SO2 wet depostion     (% of sinks)        = 23.036, 22.974
+(0)	SO2 lifetime          (d)                 = 1.429, 1.422
+(0)	SO2 chemical loss     (%)                 = 44.494, 44.555
+(0)	SO2 pct of chem loss in clear air (%)     = 34.464, 34.260
+(0)	-------------------------------------------------------------
+(0)	SO4 total emissions   (Tg/yr)             = 1.708, 1.708
+(0)	SO4 total sources     (Tg/yr)             = 44.100, 44.180
+(0)	SO4 total sink        (Tg/yr)             = 43.855, 43.806
+(0)	SO4 burden            (Tg)                = 0.501, 0.442
+(0)	SO4 wet depostion     (% of sinks)        = 87.080, 87.823
+(0)	SO4 lifetime          (d)                 = 4.172, 3.679
+(0)	-------------------------------------------------------------
+(0)	BC total emissions   (Tg/yr)              = 7.496, 7.496
+(0)	BC total sources     (Tg/yr)              = 7.496, 7.496
+(0)	BC total sink        (Tg/yr)              = 7.496, 7.497
+(0)	BC burden            (Tg)                 = 0.138, 0.105
+(0)	BC wet depostion     (% of sinks)         = 70.707, 73.381
+(0)	BC lifetime          (d)                  = 6.726, 5.112
+(0)	-------------------------------------------------------------
+(0)	POM total emissions   (Tg/yr)             = 62.400, 62.387
+(0)	POM total sources     (Tg/yr)             = 158.497, 157.788
+(0)	POM total sink        (Tg/yr)             = 158.286, 157.596
+(0)	POM burden            (Tg)                = 2.373, 2.138
+(0)	POM wet depostion     (% of sinks)        = 87.778, 88.014
+(0)	POM lifetime          (d)                 = 5.473, 4.951
+(0)	POM chem prod from MSA (Tg/yr)            = 7.594, 7.592
+(0)	POM chem prod (total) (Tg/yr)             = 96.100, 95.403
+(0)	POM chem prod terpenes (Tg /yr)           = 88.505, 87.811
+(0)	-------------------------------------------------------------
+(0)	SS total emissions   (Tg/yr)              = 1624.380, 1628.928
+(0)	SS total sources     (Tg/yr)              = 1624.380, 1628.928
+(0)	SS total sink        (Tg/yr)              = 1625.355, 1629.907
+(0)	SS burden            (Tg)                 = 4.041, 4.067
+(0)	SS wet depostion     (% of sinks)         = 61.800, 61.842
+(0)	SS lifetime          (d)                  = 0.908, 0.911
+(0)	-------------------------------------------------------------
+(0)	DU total emissions   (Tg/yr)              = 2026.465, 2068.258
+(0)	DU total sources     (Tg/yr)              = 2026.465, 2068.258
+(0)	DU total sink        (Tg/yr)              = 2027.271, 2068.867
+(0)	DU burden            (Tg)                 = 9.380, 9.555
+(0)	DU wet depostion     (% of sinks)         = 18.129, 18.079
+(0)	DU lifetime          (d)                  = 1.689, 1.686
+(0)	-------------------------------------------------------------
+

+ +
+

+


+

+

Preindustrial Mass budget numbers for ModI and ModII

+

+ +

+ +
+(0)	Mass budget numbers for model version      I (old), II (new)
+(0)	Note: Values for DMS; SO2 and SO4 are given as Sulfur (S) values
+(0)	-------------------------------------------------------------
+(0)	DMS total emissions   (Tg/yr)             = 31.545, 31.575
+(0)	DMS total sources     (Tg/yr)             = 31.545, 31.575
+(0)	DMS total sink        (Tg/yr)             = 31.806, 31.839
+(0)	DMS burden            (Tg)                = 0.086, 0.086
+(0)	DMS lifetime          (d)                 = 0.987, 0.982
+(0)	DMS chemical loss     (%)                 = 99.974, 99.974
+(0)	DMS pct of chem. loss to MSA (%)          = 7.963, 7.951
+(0)	-------------------------------------------------------------
+(0)	SO2 total emissions   (Tg/yr)             = 14.500, 14.500
+(0)	SO2 total sources     (Tg/yr)             = 43.766, 43.800
+(0)	SO2 total sink        (Tg/yr)             = 43.686, 43.721
+(0)	SO2 burden            (Tg)                = 0.135, 0.135
+(0)	SO2 wet depostion     (% of sinks)        = 23.066, 23.081
+(0)	SO2 lifetime          (d)                 = 1.128, 1.126
+(0)	SO2 chemical loss     (%)                 = 45.093, 45.058
+(0)	SO2 pct of chem loss in clear air (%)     = 25.483, 25.409
+(0)	-------------------------------------------------------------
+(0)	SO4 total emissions   (Tg/yr)             = 0.372, 0.372
+(0)	SO4 total sources     (Tg/yr)             = 20.002, 20.003
+(0)	SO4 total sink        (Tg/yr)             = 19.765, 19.700
+(0)	SO4 burden            (Tg)                = 0.177, 0.170
+(0)	SO4 wet depostion     (% of sinks)        = 88.521, 88.761
+(0)	SO4 lifetime          (d)                 = 3.271, 3.153
+(0)	-------------------------------------------------------------
+(0)	BC total emissions   (Tg/yr)              = 2.595, 2.595
+(0)	BC total sources     (Tg/yr)              = 2.595, 2.595
+(0)	BC total sink        (Tg/yr)              = 2.592, 2.592
+(0)	BC burden            (Tg)                 = 0.040, 0.038
+(0)	BC wet depostion     (% of sinks)         = 75.907, 76.415
+(0)	BC lifetime          (d)                  = 5.617, 5.368
+(0)	-------------------------------------------------------------
+(0)	POM total emissions   (Tg/yr)             = 49.557, 49.531
+(0)	POM total sources     (Tg/yr)             = 145.849, 145.743
+(0)	POM total sink        (Tg/yr)             = 145.660, 145.550
+(0)	POM burden            (Tg)                = 2.070, 1.944
+(0)	POM wet depostion     (% of sinks)        = 88.331, 88.387
+(0)	POM lifetime          (d)                 = 5.188, 4.875
+(0)	POM chem prod from MSA (Tg/yr)            = 7.595, 7.591
+(0)	POM chem prod (total) (Tg/yr)             = 96.294, 96.215
+(0)	POM chem prod terpenes (Tg /yr)           = 88.699, 88.624
+(0)	-------------------------------------------------------------
+(0)	SS total emissions   (Tg/yr)              = 1627.006, 1626.318
+(0)	SS total sources     (Tg/yr)              = 1627.006, 1626.318
+(0)	SS total sink        (Tg/yr)              = 1627.962, 1627.337
+(0)	SS burden            (Tg)                 = 4.033, 4.056
+(0)	SS wet depostion     (% of sinks)         = 61.818, 61.872
+(0)	SS lifetime          (d)                  = 0.904, 0.910
+(0)	-------------------------------------------------------------
+(0)	DU total emissions   (Tg/yr)              = 2032.477, 2071.750
+(0)	DU total sources     (Tg/yr)              = 2032.477, 2071.750
+(0)	DU total sink        (Tg/yr)              = 2033.121, 2072.041
+(0)	DU burden            (Tg)                 = 9.513, 9.571
+(0)	DU wet depostion     (% of sinks)         = 18.432, 18.524
+(0)	DU lifetime          (d)                  = 1.708, 1.686
+(0)	-------------------------------------------------------------
+

+ + +
+
+ + + + + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_B.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_B.htm new file mode 100644 index 0000000000..7f1fd83d7d --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_B.htm @@ -0,0 +1,58 @@ + + +Aerosol Diagnostic Plots, Burdens + + +

+ +


+ +
+ Burdens
+ (AKCXS is total discarded internally mixed mass in the look-up tables) + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_DER.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_DER.htm new file mode 100644 index 0000000000..1bf254f6a4 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_DER.htm @@ -0,0 +1,23 @@ + + +Aerosol Diagnostic Plots, Effective Dry Radii + + +

+ +


+ +
+ Effective dry aerosol radii + +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_ERF.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_ERF.htm new file mode 100644 index 0000000000..dac0691940 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_ERF.htm @@ -0,0 +1,42 @@ + + +Aerosol Diagnostic Plots, Radiative Forcing + + +

+ +


+ +
+ Radiative forcings at top of the atmosphere (TOA) (def. positive down) + +

+ +
+ Note: Forcing definitions based on Ghan (2013) for SW have been extended to apply also for LW fluxes. + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Emi.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Emi.htm new file mode 100644 index 0000000000..830d8297c0 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Emi.htm @@ -0,0 +1,37 @@ + + +Aerosol Diagnostic Plots, Emissions + + +

+ +


+ +
+ Emissions + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+

+ + + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Life.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Life.htm new file mode 100644 index 0000000000..cd1f4e15c6 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Life.htm @@ -0,0 +1,31 @@ + + +Aerosol Diagnostic Plots, Lifetimes + + +

+ +


+ +
+ Lifetimes +

+ (Numbers in parantheses are global burden / global loss) + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MEC.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MEC.htm new file mode 100644 index 0000000000..15d1a3bc9e --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MEC.htm @@ -0,0 +1,85 @@ + + +Aerosol Diagnostic Plots. Mass Extinction (and Absorption) Coefficients + + +

+ +


+ +
+ Column intergrated mass extincion coefficients for each species +

+ (Numbers in parantheses are global AODs / global burdens) +

+ Note that these specific extinction (MEC) and absorption coefficicents (MABS) are based on the AeroCom assumption that +

+internally mixed components contribute to the total numbers linearly with their respective volume fractions of the total, +

+so that e.g. MABS for BC is smaller than expected much due to the fact that other components in this way has "borrowed" +

+its MABS. The first alternative MABS for BC below (BC+SO4+SS absorption coefficient) takes into account the absorption "borrowed" +

+from sulfate and sea-salt, taking out (A550_BC+A550_SO4+A550_SS)/cb_BC, and is closer to the true MABS for BC, although the +

+BC contribution from internal mixtures with POM and DUST are still not taken fully into account. The second alternative +

+(BC+all absorption coefficient) assumes that all absorption comes from BC, which is an overestimate since POM and Dust also +

+contributes. The real MABS for BC lies somewhere between these two alternatives (the last two figures). +

+The additional plots for MEC and MAC for antrhopogenic BC use the same definition as the standard MEC and MABS, +

+except that the AOD or ABS and BC burdens are anthropogenic contributions olny (PD-PI). + + + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MMR.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MMR.htm new file mode 100644 index 0000000000..d55e90fbf1 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_MMR.htm @@ -0,0 +1,29 @@ + + +Aerosol Diagnostic Plots, Mass Mixing Ratios + + +

+ +


+ +
+ Zonally averaged mass mixing ratios + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_OD.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_OD.htm new file mode 100644 index 0000000000..3d67b016c0 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_OD.htm @@ -0,0 +1,27 @@ + + +Aerosol Diagnostic Plots. species aerosol optical depth + + +

+ +


+ +
+ Aerosol optical depth for each species + +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Opt.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Opt.htm new file mode 100644 index 0000000000..4db1991213 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_Opt.htm @@ -0,0 +1,44 @@ + + +Aerosol Diagnostic Plots, Optical Properties + + +

+ +


+ +
+ Angstrom coefficient, Optical depth, SSA and G +

+ (Numbers in parantheses are global averages / global averages) + + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_PM.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_PM.htm new file mode 100644 index 0000000000..e60e96f0ee --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_PM.htm @@ -0,0 +1,28 @@ + + +Aerosol Diagnostic Plots, PM + + +

+ +


+ +
+ Dry PM concentrations (CAM5-Oslo only) + +

+

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RF.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RF.htm new file mode 100644 index 0000000000..b88c68063e --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RF.htm @@ -0,0 +1,25 @@ + + +Aerosol Diagnostic Plots, Radiative Forcing + + +

+ +


+ +
+ Radiative forcings + +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RHCl.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RHCl.htm new file mode 100644 index 0000000000..7c5eef521e --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_RHCl.htm @@ -0,0 +1,45 @@ + + +Aerosol Diagnostic Plots, RH and Cloud Properties + + +

+ +


+ +
+ RH and cloud properties + +

+ +
+ Note: RH from CAM4-Oslo and CAM5-Oslo +are not directly comparable due to different definitions + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_WetR.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_WetR.htm new file mode 100644 index 0000000000..ac3a14923e --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_WetR.htm @@ -0,0 +1,32 @@ + + +Aerosol Diagnostic Plots, Wet Deposition Ratios + + +

+ +


+ +
+ Wet deposition / total deposition +

+ (Numbers in parantheses are global wet-dep / global dep.) + +

+ +

+ +

+ +

+ +

+ +

+ +

+ + +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_divPD-PI.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_divPD-PI.htm new file mode 100644 index 0000000000..7d8c5f21c3 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_divPD-PI.htm @@ -0,0 +1,45 @@ + + +Aerosol Diagnostic Plots, PD - PI fields + + +

+ +


+ +
+ Anthropogenic (PD - PI) aerosol and cloud/RH fields + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_drops.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_drops.htm new file mode 100644 index 0000000000..38c23f840a --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_drops.htm @@ -0,0 +1,34 @@ + + +Aerosol Diagnostic Plots, Cloud Droplet Properties + + +

+ +


+ +
+ RH and some cloud properties + +

+ +
+ Note: Due to different definitions neither effective cloud dropet radii, + cloud droplet concentrations nor vertically integrated cloud droplet concentrations are directly comparable + between CAM4-Oslo and CAM5-Oslo + +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_levelvals.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_levelvals.htm new file mode 100644 index 0000000000..1a1e12392f --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_levelvals.htm @@ -0,0 +1,38 @@ + + +Aerosol Diagnostic Plots, Properties at specific model levels + + +

+ +


+ +
+ Cloud properties at specific model levels + +

+

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_modepar.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_modepar.htm new file mode 100644 index 0000000000..76e9fd960c --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_modepar.htm @@ -0,0 +1,63 @@ + + +Aerosol Diagnostic Plots, Zonally averaged modal parameters + + +

+ +


+ +
+ Zonally averaged modal parameters + +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+


+

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_rad-fluxes.htm b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_rad-fluxes.htm new file mode 100644 index 0000000000..4376919d65 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ModIvsModII_rad-fluxes.htm @@ -0,0 +1,24 @@ + + +Aerosol Diagnostic Plots, Radiative Fluxes + + +

+ +


+ +
+ Radiative fluxes at top of the atmosphere (TOA) + +

+

+ +

+ +

+ +

+ +


+ + diff --git a/tools/diagnostics/ncl/ModIvsModII/PM_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/PM_ModIvsModII.ncl new file mode 100644 index 0000000000..0414f744bb --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/PM_ModIvsModII.ncl @@ -0,0 +1,222 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in radiative fluxes from two versions of NorESM / +; CAM-Oslo and makes global plots of the annually averaged aerosol PM fields, +; including global average as a number in the title line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 1 ; 1 => PM2.5 (PD) + ; 2 => PM2.5 (PD-PI) + ; 3 => PMTOT (PD) + ; 4 => PM2.5/PMTOT (PD) + ; 5 => PMTOT (PD-PI) + ; 6 => PMTOT/PMTOT_lifecycle (PD) MANGLER BAKKEKONSENTRASJONER FOR DETTE! + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.1) then + var="PM2.5_PD" ; name of input-variable and plot + varname="PM2.5 (PD)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->PM25)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->PM25)/) ; variable to be plotted from II + else if (plot_type.eq.2) then + var="PM2.5_PD-PI" ; name of input-variable and plot + varname="PM2.5 (PD-PI)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->PM25)/)-(/(f1PI_I[:]->PM25)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->PM25)/)-(/(f1PI_II[:]->PM25)/) ; variable to be plotted from II + else if (plot_type.eq.3) then + var="PMTOT_PD" ; name of input-variable and plot + varname="PMTOT (PD)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->PMTOT)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->PMTOT)/) ; variable to be plotted from II + else if (plot_type.eq.4) then + var="PM2.5byPMTOT_PD" ; name of input-variable and plot + varname="PM2.5/PMTOT (PD)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->PM25)/)/(/(f1PD_I[:]->PMTOT)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->PM25)/)/(/(f1PD_II[:]->PMTOT)/) ; variable to be plotted from II +; forc_I=((/(f1PD_I[:]->PMTOT)/)-(/(f1PD_I[:]->PM25)/))/(/(f1PD_I[:]->PMTOT)/) ; variable to be plotted from I +; forc_II=((/(f1PD_I[:]->PMTOT)/)-(/(f1PD_II[:]->PM25)/))/(/(f1PD_I[:]->PMTOT)/) ; variable to be plotted from II + else if (plot_type.eq.5) then + var="PMTOT_PD-PI" ; name of input-variable and plot + varname="PMTOT (PD-PI)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->PMTOT)/)-(/(f1PI_I[:]->PMTOT)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->PMTOT)/)-(/(f1PI_II[:]->PMTOT)/) ; variable to be plotted from II +; else if (plot_type.eq.6) then +; var="PMTOTbyPMOTlifecycle_PD" ; name of input-variable and plot +; varname="PMTOT/PMTOT_lifecycle (PD)" ; variable name used in text string: +; forc_I=(/(f1PD_I[:]->SS_A1_SRF)/) ; uferdig... /(/(f1PD_I[:]->PMTOT)/) ; variable to be plotted from I +; forc_II=(/(f1PD_II[:]->SS_A1_SRF)/) ; uferdig... /(/(f1PD_II[:]->PMTOT)/) ; variable to be plotted from II +; endif + end if + end if + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each forcing variable + if (var .eq. "PM2.5_PD") then + digg=(/1,2.5,5,10,25,50,100,250,500/) + else if (var .eq. "PM2.5_PD-PI" .or. var .eq. "PMTOT_PD-PI") then + digg=(/-10,-5,-2.5,-1,0,1,2.5,5,10/) + else if (var .eq. "PMTOT_PD") then + digg=(/1,2.5,5,10,25,50,100,250,500/) + else if (var .eq. "PM2.5byPMTOT_PD") then + digg=(/0.01,0.05,0.1,0.2,0.3,0.5,0.7,0.9,0.99/) + else if (var .eq. "PMTOTbyPMOTlifecycle_PD") then + digg=(/0.1,0.25,0.5,0.75,0.8,0.9,0.99,1.01,1.1/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if + + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + + if (var .ne. "PM2.5byPMTOT_PD" .and. var .ne. "PMTOTbyPMOTlifecycle_PD") then +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+ " ~F33~m~F~g m~S~-3~N~" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+ " ~F33~m~F~g m~S~-3~N~" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + else +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1)) + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1)) + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + end if + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/RadBudg_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/RadBudg_ModIvsModII.ncl new file mode 100644 index 0000000000..3cb284a636 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/RadBudg_ModIvsModII.ncl @@ -0,0 +1,183 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in radiative fluxes from two versions of NorESM / +; CAM-Oslo and makes global plots of the annually averaged flux differences +; (PD-PI), including global average as a number in the title line for each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 3 ; 1 => TOA SW + LW net flux imbalance + ; 2 => PD SW cloud forcing at TOA + ; 3 => PD LW cloud forcing at TOA + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.1) then + var="netfluximbalance" ; name of input-variable and plot + varname="PD net TOA flux imbalance" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->FSNT)/)-(/(f1PD_I[:]->FLNT)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->FSNT)/)-(/(f1PD_II[:]->FLNT)/) ; variable to be plotted from II + else if (plot_type.eq.2) then + var="SWCF" ; name of input-variable and plot + varname="PD SW cloud forcing at TOA (SWCF)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->SWCF)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->SWCF)/) ; variable to be plotted from II + else if (plot_type.eq.3) then + var="LWCF" ; name of input-variable and plot + varname="PD LW cloud forcing at TOA (LWCF)" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->LWCF)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->LWCF)/) ; variable to be plotted from II + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + +; Defining color scales for each forcing variable + if (var .eq. "netfluximbalance") then + digg=(/-100,-50,-25,-10,-5,5,10,25,50,100/) + else if (var .eq. "SWCF") then + digg=(/-150,-100,-75,-50,-30,-20,-15,-10,-5,0/) + else if (var .eq. "LWCF") then + digg=(/-5,0,5,10,15,20,30,50,75,100/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" W m~S~-2~N~" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/WetDepRat_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/WetDepRat_ModIvsModII.ncl new file mode 100644 index 0000000000..597a4902a3 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/WetDepRat_ModIvsModII.ncl @@ -0,0 +1,273 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol wet and dry deposition from two versions +; of NorESM/CAM-Oslo and makes global plots of the annually averaged ratio +; wet/(wet+dry), including global average as a number in the title line for +; each figure. The global average is be calculated both as area wet/(wet+dry) +; and as area averaged wet / area averaged (wet+dry), with the latter value +; shown in brackets. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 5 ; 0 => SO2 wet/(wet+dry) deposition + ; 1 => SO4 wet/(wet+dry) deposition + ; 2 => BC wet/(wet+dry) deposition + ; 3 => POM wet/(wet+dry) deposition + ; 4 => SS wet/(wet+dry) deposition + ; 5 => DU wet/(wet+dry) deposition + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0_I->gw) + gw0_II=doubletofloat(f0_II->gw) + + lon_I=f0_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1_I[:]->PS + tmp_II=f1_II[:]->PS + wratio_I=tmp_I + wratio_II=tmp_II + wet_I=tmp_I + wet_II=tmp_II + wetndry_I=tmp_I + wetndry_II=tmp_II + + if (plot_type.eq.0) then + var="WET_SO2" ; name of input-variable and plot + varname="SO~B~2~N~ wet dep. ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_SO2/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_SO2/)+(/f1_I[:]->DRY_SO2/) ; variable to be plotted from I + else + wet_I=(/f1_I[:]->WD_A_SO2/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WD_A_SO2/)+(/f1_I[:]->DF_SO2/) ; variable to be plotted from I + end if + wet_II=(/f1_II[:]->WD_A_SO2/) ; variable to be plotted from II + wetndry_II=(/f1_II[:]->WD_A_SO2/)+(/f1_II[:]->DF_SO2/) ; variable to be plotted from II + else if (plot_type.eq.1) then + var="WET_SO4" ; name of input-variable and plot + varname="SO~B~4~N~ wet dep. ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_SO4/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_SO4/)+(/f1_I[:]->DRY_SO4/) ; variable to be plotted from I + else + wet_I=(/f1_I[:]->SO4_A1SFWET/) + (/f1_I[:]->SO4_A2SFWET/) + (/f1_I[:]->SO4_ACSFWET/) + (/f1_I[:]->SO4_NASFWET/) + (/f1_I[:]->SO4_PRSFWET/) + (/f1_I[:]->SO4_A1_OCWSFWET/) + (/f1_I[:]->SO4_A2_OCWSFWET/) + (/f1_I[:]->SO4_AC_OCWSFWET/) + (/f1_I[:]->SO4_NA_OCWSFWET/) + (/f1_I[:]->SO4_PR_OCWSFWET/) + wet_I=-wet_I + wetndry_I=wet_I + (/f1_I[:]->SO4_A1DDF/) + (/f1_I[:]->SO4_A2DDF/) + (/f1_I[:]->SO4_ACDDF/) + (/f1_I[:]->SO4_NADDF/) + (/f1_I[:]->SO4_PRDDF/) + (/f1_I[:]->SO4_A1_OCWDDF/) + (/f1_I[:]->SO4_A2_OCWDDF/) + (/f1_I[:]->SO4_AC_OCWDDF/) + (/f1_I[:]->SO4_NA_OCWDDF/) + (/f1_I[:]->SO4_PR_OCWDDF/) + end if + wet_II=(/f1_II[:]->SO4_A1SFWET/) + (/f1_II[:]->SO4_A2SFWET/) + (/f1_II[:]->SO4_ACSFWET/) + (/f1_II[:]->SO4_NASFWET/) + (/f1_II[:]->SO4_PRSFWET/) + (/f1_II[:]->SO4_A1_OCWSFWET/) + (/f1_II[:]->SO4_A2_OCWSFWET/) + (/f1_II[:]->SO4_AC_OCWSFWET/) + (/f1_II[:]->SO4_NA_OCWSFWET/) + (/f1_II[:]->SO4_PR_OCWSFWET/) + wet_II=-wet_II + wetndry_II=wet_II + (/f1_II[:]->SO4_A1DDF/) + (/f1_II[:]->SO4_A2DDF/) + (/f1_II[:]->SO4_ACDDF/) + (/f1_II[:]->SO4_NADDF/) + (/f1_II[:]->SO4_PRDDF/) + (/f1_II[:]->SO4_A1_OCWDDF/) + (/f1_II[:]->SO4_A2_OCWDDF/) + (/f1_II[:]->SO4_AC_OCWDDF/) + (/f1_II[:]->SO4_NA_OCWDDF/) + (/f1_II[:]->SO4_PR_OCWDDF/) + else if (plot_type.eq.2) then + var="WET_BC" ; name of input-variable and plot + varname="BC wet dep. ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_BC/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_BC/)+(/f1_I[:]->DRY_BC/) ; variable to be plotted from I + else + wet_I=(/f1_I[:]->BC_ASFWET/) + (/f1_I[:]->BC_ACSFWET/) + (/f1_I[:]->BC_AXSFWET/) + (/f1_I[:]->BC_AISFWET/) + (/f1_I[:]->BC_NISFWET/) + (/f1_I[:]->BC_NSFWET/) + (/f1_I[:]->BC_A_OCWSFWET/) + (/f1_I[:]->BC_AC_OCWSFWET/) + (/f1_I[:]->BC_AI_OCWSFWET/) + (/f1_I[:]->BC_NI_OCWSFWET/) + (/f1_I[:]->BC_N_OCWSFWET/) + wet_I=-wet_I + wetndry_I=wet_I + (/f1_I[:]->BC_ADDF/) + (/f1_I[:]->BC_ACDDF/) + (/f1_I[:]->BC_AXDDF/) + (/f1_I[:]->BC_AIDDF/) + (/f1_I[:]->BC_NIDDF/) + (/f1_I[:]->BC_NDDF/) + (/f1_I[:]->BC_A_OCWDDF/) + (/f1_I[:]->BC_AC_OCWDDF/) + (/f1_I[:]->BC_AI_OCWDDF/) + (/f1_I[:]->BC_NI_OCWDDF/) + (/f1_I[:]->BC_N_OCWDDF/) + end if + wet_II=(/f1_II[:]->BC_ASFWET/) + (/f1_II[:]->BC_ACSFWET/) + (/f1_II[:]->BC_AXSFWET/) + (/f1_II[:]->BC_AISFWET/) + (/f1_II[:]->BC_NISFWET/) + (/f1_II[:]->BC_NSFWET/) + (/f1_II[:]->BC_A_OCWSFWET/) + (/f1_II[:]->BC_AC_OCWSFWET/) + (/f1_II[:]->BC_AI_OCWSFWET/) + (/f1_II[:]->BC_NI_OCWSFWET/) + (/f1_II[:]->BC_N_OCWSFWET/) + wet_II=-wet_II + wetndry_II=wet_II + (/f1_II[:]->BC_ADDF/) + (/f1_II[:]->BC_ACDDF/) + (/f1_II[:]->BC_AXDDF/) + (/f1_II[:]->BC_AIDDF/) + (/f1_II[:]->BC_NIDDF/) + (/f1_II[:]->BC_NDDF/) + (/f1_II[:]->BC_A_OCWDDF/) + (/f1_II[:]->BC_AC_OCWDDF/) + (/f1_II[:]->BC_AI_OCWDDF/) + (/f1_II[:]->BC_NI_OCWDDF/) + (/f1_II[:]->BC_N_OCWDDF/) + else if (plot_type.eq.3) then + var="WET_POM" ; name of input-variable and plot + varname="POM wet dep. ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_POM/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_POM/)+(/f1_I[:]->DRY_POM/) ; variable to be plotted from I + else + wet_I=(/f1_I[:]->OM_AISFWET/) + (/f1_I[:]->OM_ACSFWET/) + (/f1_I[:]->OM_NISFWET/)+ (/f1_I[:]->SOA_A1SFWET/) + (/f1_I[:]->SOA_NASFWET/) + \ + (/f1_I[:]->OM_AI_OCWSFWET/) + (/f1_I[:]->OM_AC_OCWSFWET/) + (/f1_I[:]->OM_NI_OCWSFWET/) + \ + (/f1_I[:]->SOA_A1_OCWSFWET/) + (/f1_I[:]->SOA_NA_OCWSFWET/) + wet_I=-wet_I + wetndry_I= wet_I + (/f1_I[:]->OM_AIDDF/) + (/f1_I[:]->OM_ACDDF/) + (/f1_I[:]->OM_NIDDF/) + (/f1_I[:]->SOA_A1DDF/) + (/f1_I[:]->SOA_NADDF/) +\ + (/f1_I[:]->OM_AI_OCWDDF/) + (/f1_I[:]->OM_AC_OCWDDF/) + (/f1_I[:]->OM_NI_OCWDDF/) + \ + (/f1_I[:]->SOA_A1_OCWDDF/) + (/f1_I[:]->SOA_NA_OCWDDF/) + end if + wet_II=(/f1_II[:]->OM_AISFWET/) + (/f1_II[:]->OM_ACSFWET/) + (/f1_II[:]->OM_NISFWET/) + (/f1_II[:]->SOA_A1SFWET/) + (/f1_II[:]->SOA_NASFWET/) + \ + (/f1_II[:]->OM_AI_OCWSFWET/) + (/f1_II[:]->OM_AC_OCWSFWET/) + (/f1_II[:]->OM_NI_OCWSFWET/) + \ + (/f1_II[:]->SOA_A1_OCWSFWET/) + (/f1_II[:]->SOA_NA_OCWSFWET/) + wet_II=-wet_II + wetndry_II= wet_II + (/f1_II[:]->OM_AIDDF/) + (/f1_II[:]->OM_ACDDF/) + (/f1_II[:]->OM_NIDDF/) + (/f1_II[:]->SOA_A1DDF/) + (/f1_II[:]->SOA_NADDF/) +\ + (/f1_II[:]->OM_AI_OCWDDF/) + (/f1_II[:]->OM_AC_OCWDDF/) + (/f1_II[:]->OM_NI_OCWDDF/) + \ + (/f1_II[:]->SOA_A1_OCWDDF/) + (/f1_II[:]->SOA_NA_OCWDDF/) + else if (plot_type.eq.4) then + var="WET_SS" ; name of input-variable and plot + varname="Sea-salt wet dep. ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_SS/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_SS/)+(/f1_I[:]->DRY_SS/) ; variable to be plotted from I + else + wet_I=(/f1_I[:]->SS_A1SFWET/) + (/f1_I[:]->SS_A2SFWET/) + (/f1_I[:]->SS_A3SFWET/) + (/f1_I[:]->SS_A1_OCWSFWET/) + (/f1_I[:]->SS_A2_OCWSFWET/) + (/f1_I[:]->SS_A3_OCWSFWET/) + wet_I=-wet_I + wetndry_I=wet_I + (/f1_I[:]->SS_A1DDF/) + (/f1_I[:]->SS_A2DDF/) + (/f1_I[:]->SS_A3DDF/) + (/f1_I[:]->SS_A1_OCWDDF/) + (/f1_I[:]->SS_A2_OCWDDF/) + (/f1_I[:]->SS_A3_OCWDDF/) + end if + wet_II=(/f1_II[:]->SS_A1SFWET/) + (/f1_II[:]->SS_A2SFWET/) + (/f1_II[:]->SS_A3SFWET/) + (/f1_II[:]->SS_A1_OCWSFWET/) + (/f1_II[:]->SS_A2_OCWSFWET/) + (/f1_II[:]->SS_A3_OCWSFWET/) + wet_II=-wet_II + wetndry_II=wet_II + (/f1_II[:]->SS_A1DDF/) + (/f1_II[:]->SS_A2DDF/) + (/f1_II[:]->SS_A3DDF/) + (/f1_II[:]->SS_A1_OCWDDF/) + (/f1_II[:]->SS_A2_OCWDDF/) + (/f1_II[:]->SS_A3_OCWDDF/) + else if (plot_type.eq.5) then + var="WET_DUST" ; name of input-variable and plot + varname="Dust wet dep.ratio" ; variable name used in text string: + if(ModI.eq."CAM4-Oslo") then + wet_I=(/f1_I[:]->WET_DUST/) ; variable to be plotted from I + wetndry_I=(/f1_I[:]->WET_DUST/)+(/f1_I[:]->DRY_DUST/) ; variable to be plotted from I + else + wet_I= (/f1_I[:]->DST_A2SFWET/) + (/f1_I[:]->DST_A3SFWET/) + (/f1_I[:]->DST_A2_OCWSFWET/) + (/f1_I[:]->DST_A3_OCWSFWET/) + wet_I=-wet_I + wetndry_I=wet_I + (/f1_I[:]->DST_A2DDF/) + (/f1_I[:]->DST_A3DDF/) + (/f1_I[:]->DST_A2_OCWDDF/) + (/f1_I[:]->DST_A3_OCWDDF/) + end if + wet_II= (/f1_II[:]->DST_A2SFWET/) + (/f1_II[:]->DST_A3SFWET/) + (/f1_II[:]->DST_A2_OCWSFWET/) + (/f1_II[:]->DST_A3_OCWSFWET/) + wet_II=-wet_II + wetndry_II=wet_II + (/f1_II[:]->DST_A2DDF/) + (/f1_II[:]->DST_A3DDF/) + (/f1_II[:]->DST_A2_OCWDDF/) + (/f1_II[:]->DST_A3_OCWDDF/) + end if + end if + end if + end if + end if + end if + wratio_I=wet_I/wetndry_I ; variable to be plotted from I + wratio_II=wet_II/wetndry_II ; variable to be plotted from II + +; Calculating area weighted extinctions + + wratio_Ia=wratio_I ; initialization of global average variables + wratio_IIa=wratio_II + wet_Ia=wratio_I + wet_IIa=wratio_II + wetndry_Ia=wratio_I + wetndry_IIa=wratio_II + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(wratio_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + wratio_Ia(:,i,:)=wratio_I(:,i,:)*coffa*dlon_I*gw0_I(i) + wet_Ia(:,i,:)=wet_I(:,i,:)*coffa*dlon_I*gw0_I(i) + wetndry_Ia(:,i,:)=wetndry_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + wratioave_I=sum(dim_avg_n(wratio_Ia,0))/area1 + wetave_I=sum(dim_avg_n(wet_Ia,0))/area1 + wetndryave_I=sum(dim_avg_n(wetndry_Ia,0))/area1 + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(wratio_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + wratio_IIa(:,i,:)=wratio_II(:,i,:)*coffa*dlon_II*gw0_II(i) + wet_IIa(:,i,:)=wet_II(:,i,:)*coffa*dlon_II*gw0_II(i) + wetndry_IIa(:,i,:)=wetndry_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + wratioave_II=sum(dim_avg_n(wratio_IIa,0))/area1 + wetave_II=sum(dim_avg_n(wet_IIa,0))/area1 + wetndryave_II=sum(dim_avg_n(wetndry_IIa,0))/area1 + +; Defining color scale +; digg=(/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,0.95/) + digg=(/0.1,0.25,0.5,0.6,0.7,0.8,0.9,0.95,0.99/) + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.2f",wratioave_I)+" ("+sprintf("%4.2f",wetave_I/wetndryave_I)+")" + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(wratio_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" + res@gsnRightString = "avg = "+sprintf("%5.2f",wratioave_II)+" ("+sprintf("%4.2f",wetave_II/wetndryave_II)+")" + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(wratio_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII.ncl new file mode 100644 index 0000000000..7cd1cfcff2 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII.ncl @@ -0,0 +1,371 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d aerosol properties from two versions of +; NorESM/CAM-Oslo and makes global plots of the zonally and annually +; averaged variables. Note: This script is only correct when the model +; has been run in AEROCOM mode. Otherwise EAK (SSAVIS) and GAK (AYMMVIS) +; has to be divided by DAYFOC (which is a bit cumbersome due to the +; different number of dimensions, 3d divided by 2d). + +; !!!!! Try changing to p-coordinates by use of vinth2p function in ncl !!!!! + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => WAK Single scattering albedo + ; 1 => GAK Assymtery factor + ; 2 => DUST Dust mass mixing ratio + ; 3 => SS Sea-salt mass mixing ratio + ; 4 => BC BC mass mixing ratio + ; 5 => OM OM mass mixing ratio + ; 6 => SO4 SO4 mass mixing ratio + ; 7 => SO2 SO2 mass mixing ratio +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="WAK" ; name of main input-variable + varname="Single Scattering Albedo" ; variable name used in text string + plot_name="SSA_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="SSAVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="SSAVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.1) then + var="GAK" ; name of main input-variable + varname="Asymmetry Factor" ; variable name used in text string + plot_name="G_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="ASYMMVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="ASYMMVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.2) then + var="DST" ; name of main input-variable + varname="Dust" ; variable name used in text string + plot_name="DUST_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + addfiles_GetVar(f1_I,all_files_I,"DST_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"DST_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"DST_A2") + addfiles_GetVar(f1_II,all_files_II,"DST_A3") + addfiles_GetVar(f1_II,all_files_II,"DST_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"DST_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.3) then + var="SS" ; name of main input-variable + varname="Sea-salt" ; variable name used in text string + plot_name="SS_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + addfiles_GetVar(f1_I,all_files_I,"SS_A1_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SS_A1") + addfiles_GetVar(f1_II,all_files_II,"SS_A2") + addfiles_GetVar(f1_II,all_files_II,"SS_A3") + addfiles_GetVar(f1_II,all_files_II,"SS_A1_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.4) then + var="BC" ; name of main input-variable + varname="BC" ; variable name used in text string + plot_name="BC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + addfiles_GetVar(f1_I,all_files_I,"BC_A_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_NI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_N_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"BC_A") + addfiles_GetVar(f1_II,all_files_II,"BC_AC") + addfiles_GetVar(f1_II,all_files_II,"BC_AX") + addfiles_GetVar(f1_II,all_files_II,"BC_AI") + addfiles_GetVar(f1_II,all_files_II,"BC_NI") + addfiles_GetVar(f1_II,all_files_II,"BC_N") + addfiles_GetVar(f1_II,all_files_II,"BC_A_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_N_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.5) then + var="OM" ; name of main input-variable + varname="OM" ; variable name used in text string + plot_name="OM_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") \ + + addfiles_GetVar(f1_I,all_files_I,"OM_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_NI_OCW") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA_OCW") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"OM_AI") + addfiles_GetVar(f1_II,all_files_II,"OM_AC") + addfiles_GetVar(f1_II,all_files_II,"OM_NI") \ + + addfiles_GetVar(f1_II,all_files_II,"OM_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_NI_OCW") \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1") \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1_OCW") + var_II = var_II*1.e12 +else if (plot_type.eq.6) then + var="SO4" ; name of main input-variable + varname="SO4" ; variable name used in text string + plot_name="SO4_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1") + addfiles_GetVar(f1_I,all_files_I,"SO4_A2") + addfiles_GetVar(f1_I,all_files_I,"SO4_AC") + addfiles_GetVar(f1_I,all_files_I,"SO4_N") + addfiles_GetVar(f1_I,all_files_I,"SO4_NA") + addfiles_GetVar(f1_I,all_files_I,"SO4_PR") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR_OCW")/3.06 + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO4_A1")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR_OCW")/3.06 + var_II = var_II*1.e12 +else if (plot_type.eq.7) then + var="SO2" ; name of main input-variable + varname="SO2" ; variable name used in text string + plot_name="SO2_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12/1.998 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO2") + var_II = var_II*1.e12/1.998 + +; conversion from mol(SO2)/mol to kg(SO2)/kg with the new code + if(ModI.eq."CAM5-Oslo") then + var_I = var_I*66.066/28.9647 + end if + var_II = var_II*66.066/28.9647 + + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var .eq. "WAK") then + digg=(/0.5,0.6,0.7,0.8,0.85,0.9,0.95,0.98,0.99,0.995/) + else if (var .eq. "GAK") then + digg=(/0.6,0.62,0.64,0.68,0.7,0.72,0.74,0.76,0.78/) + else if (var .eq. "DST" .or. var .eq. "SS") then + digg=(/25,50,100,250,500,1000,2500,5000,10000,25000/) + else if (var .eq. "BC" .or. var .eq. "OM" .or. var .eq. "SO4" .or. var .eq. "SO2") then + digg=(/2.5,5,10,25,50,100,250,500,1000,2500/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "WAK") then + res@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "WAK") then + res2@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res2@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res2@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res2@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res2@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res2@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res2@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res2@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMP.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMP.ncl new file mode 100644 index 0000000000..fa3c95a52b --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMP.ncl @@ -0,0 +1,371 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d aerosol properties from two versions of +; NorESM/CAM-Oslo and makes global plots of the zonally and annually +; averaged variables. Note: This script is only correct when the model +; has been run in AEROCOM mode. Otherwise EAK (SSAVIS) and GAK (AYMMVIS) +; has to be divided by DAYFOC (which is a bit cumbersome due to the +; different number of dimensions, 3d divided by 2d). + +; !!!!! Try changing to p-coordinates by use of vinth2p function in ncl !!!!! + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => WAK Single scattering albedo + ; 1 => GAK Assymtery factor + ; 2 => DUST Dust mass mixing ratio skalert pga CAM6-Oslo bug + ; 3 => SS Sea-salt mass mixing ratio skalert pga CAM6-Oslo bug + ; 4 => BC BC mass mixing ratio skalert pga CAM6-Oslo bug + ; 5 => OM OM mass mixing ratio skalert pga CAM6-Oslo bug + ; 6 => SO4 SO4 mass mixing ratio skalert pga CAM6-Oslo bug + ; 7 => SO2 SO2 mass mixing ratio +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="WAK" ; name of main input-variable + varname="Single Scattering Albedo" ; variable name used in text string + plot_name="SSA_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="SSAVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="SSAVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.1) then + var="GAK" ; name of main input-variable + varname="Asymmetry Factor" ; variable name used in text string + plot_name="G_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="ASYMMVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="ASYMMVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.2) then + var="DST" ; name of main input-variable + varname="Dust" ; variable name used in text string + plot_name="DUST_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"DST_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"DST_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.3) then + var="SS" ; name of main input-variable + varname="Sea-salt" ; variable name used in text string + plot_name="SS_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A1_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A1_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.4) then + var="BC" ; name of main input-variable + varname="BC" ; variable name used in text string + plot_name="BC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_A_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_NI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_N_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_A_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_N_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.5) then + var="OM" ; name of main input-variable + varname="OM" ; variable name used in text string + plot_name="OM_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_NI")*12.01/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"OM_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_NI_OCW") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"SOA_A1")*12.01/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA_OCW") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"OM_AI") *12.01/28.97+ addfiles_GetVar(f1_II,all_files_II,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_NI")*12.01/28.97 \ + + addfiles_GetVar(f1_II,all_files_II,"OM_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_NI_OCW") \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"SOA_A1")*12.01/28.97 \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1_OCW") + var_II = var_II*1.e12 +else if (plot_type.eq.6) then + var="SO4" ; name of main input-variable + varname="SO4" ; variable name used in text string + plot_name="SO4_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1") + addfiles_GetVar(f1_I,all_files_I,"SO4_A2") + addfiles_GetVar(f1_I,all_files_I,"SO4_AC") + addfiles_GetVar(f1_I,all_files_I,"SO4_N") + addfiles_GetVar(f1_I,all_files_I,"SO4_NA") + addfiles_GetVar(f1_I,all_files_I,"SO4_PR") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2")/3.59*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR_OCW")/3.06 + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2")/3.59 *96.06/28.97+ addfiles_GetVar(f1_II,all_files_II,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR_OCW")/3.06 + var_II = var_II*1.e12 +else if (plot_type.eq.7) then + var="SO2" ; name of main input-variable + varname="SO2" ; variable name used in text string + plot_name="SO2_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12/1.998 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO2") + var_II = var_II*1.e12/1.998 + +; conversion from mol(SO2)/mol to kg(SO2)/kg with the new code + if(ModI.eq."CAM5-Oslo") then + var_I = var_I*66.066/28.9647 + end if + var_II = var_II*66.066/28.9647 + + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var .eq. "WAK") then + digg=(/0.5,0.6,0.7,0.8,0.85,0.9,0.95,0.98,0.99,0.995/) + else if (var .eq. "GAK") then + digg=(/0.6,0.62,0.64,0.68,0.7,0.72,0.74,0.76,0.78/) + else if (var .eq. "DST" .or. var .eq. "SS") then + digg=(/25,50,100,250,500,1000,2500,5000,10000,25000/) + else if (var .eq. "BC" .or. var .eq. "OM" .or. var .eq. "SO4" .or. var .eq. "SO2") then + digg=(/2.5,5,10,25,50,100,250,500,1000,2500/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "WAK") then + res@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "WAK") then + res2@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res2@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res2@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res2@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res2@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res2@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res2@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res2@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPx.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPx.ncl new file mode 100644 index 0000000000..84ca80a074 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPx.ncl @@ -0,0 +1,371 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d aerosol properties from two versions of +; NorESM/CAM-Oslo and makes global plots of the zonally and annually +; averaged variables. Note: This script is only correct when the model +; has been run in AEROCOM mode. Otherwise EAK (SSAVIS) and GAK (AYMMVIS) +; has to be divided by DAYFOC (which is a bit cumbersome due to the +; different number of dimensions, 3d divided by 2d). + +; !!!!! Try changing to p-coordinates by use of vinth2p function in ncl !!!!! + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => WAK Single scattering albedo + ; 1 => GAK Assymtery factor + ; 2 => DUST Dust mass mixing ratio skalert pga CAM6-Oslo bug + ; 3 => SS Sea-salt mass mixing ratio skalert pga CAM6-Oslo bug + ; 4 => BC BC mass mixing ratio skalert pga CAM6-Oslo bug + ; 5 => OM OM mass mixing ratio skalert pga CAM6-Oslo bug + ; 6 => SO4 SO4 mass mixing ratio skalert pga CAM6-Oslo bug + ; 7 => SO2 SO2 mass mixing ratio +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="WAK" ; name of main input-variable + varname="Single Scattering Albedo" ; variable name used in text string + plot_name="SSA_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="SSAVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="SSAVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.1) then + var="GAK" ; name of main input-variable + varname="Asymmetry Factor" ; variable name used in text string + plot_name="G_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="ASYMMVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="ASYMMVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.2) then + var="DST" ; name of main input-variable + varname="Dust" ; variable name used in text string + plot_name="DUST_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + addfiles_GetVar(f1_I,all_files_I,"DST_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"DST_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"DST_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.3) then + var="SS" ; name of main input-variable + varname="Sea-salt" ; variable name used in text string + plot_name="SS_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + addfiles_GetVar(f1_I,all_files_I,"SS_A1_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A1_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.4) then + var="BC" ; name of main input-variable + varname="BC" ; variable name used in text string + plot_name="BC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + addfiles_GetVar(f1_I,all_files_I,"BC_A_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_NI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_N_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_A_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_N_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.5) then + var="OM" ; name of main input-variable + varname="OM" ; variable name used in text string + plot_name="OM_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") \ + + addfiles_GetVar(f1_I,all_files_I,"OM_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_NI_OCW") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA_OCW") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"OM_AI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_NI")*12.01/28.97 \ + + addfiles_GetVar(f1_II,all_files_II,"OM_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_NI_OCW") \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA")*168.23/28.97 + addfiles_GetVar(f1_II,all_files_II,"SOA_A1")*168.23/28.97 \ + + addfiles_GetVar(f1_II,all_files_II,"SOA_NA_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1_OCW") + var_II = var_II*1.e12 +else if (plot_type.eq.6) then + var="SO4" ; name of main input-variable + varname="SO4" ; variable name used in text string + plot_name="SO4_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1") + addfiles_GetVar(f1_I,all_files_I,"SO4_A2") + addfiles_GetVar(f1_I,all_files_I,"SO4_AC") + addfiles_GetVar(f1_I,all_files_I,"SO4_N") + addfiles_GetVar(f1_I,all_files_I,"SO4_NA") + addfiles_GetVar(f1_I,all_files_I,"SO4_PR") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR_OCW")/3.06 + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2")/3.59 *96.06/28.97+ addfiles_GetVar(f1_II,all_files_II,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR_OCW")/3.06 + var_II = var_II*1.e12 +else if (plot_type.eq.7) then + var="SO2" ; name of main input-variable + varname="SO2" ; variable name used in text string + plot_name="SO2_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12/1.998 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO2") + var_II = var_II*1.e12/1.998 + +; conversion from mol(SO2)/mol to kg(SO2)/kg with the new code + if(ModI.eq."CAM5-Oslo") then + var_I = var_I*66.066/28.9647 + end if + var_II = var_II*66.066/28.9647 + + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var .eq. "WAK") then + digg=(/0.5,0.6,0.7,0.8,0.85,0.9,0.95,0.98,0.99,0.995/) + else if (var .eq. "GAK") then + digg=(/0.6,0.62,0.64,0.68,0.7,0.72,0.74,0.76,0.78/) + else if (var .eq. "DST" .or. var .eq. "SS") then + digg=(/25,50,100,250,500,1000,2500,5000,10000,25000/) + else if (var .eq. "BC" .or. var .eq. "OM" .or. var .eq. "SO4" .or. var .eq. "SO2") then + digg=(/2.5,5,10,25,50,100,250,500,1000,2500/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "WAK") then + res@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "WAK") then + res2@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res2@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res2@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res2@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res2@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res2@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res2@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res2@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPy.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPy.ncl new file mode 100644 index 0000000000..730943773f --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPy.ncl @@ -0,0 +1,369 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d aerosol properties from two versions of +; NorESM/CAM-Oslo and makes global plots of the zonally and annually +; averaged variables. Note: This script is only correct when the model +; has been run in AEROCOM mode. Otherwise EAK (SSAVIS) and GAK (AYMMVIS) +; has to be divided by DAYFOC (which is a bit cumbersome due to the +; different number of dimensions, 3d divided by 2d). + +; !!!!! Try changing to p-coordinates by use of vinth2p function in ncl !!!!! + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => WAK Single scattering albedo + ; 1 => GAK Assymtery factor + ; 2 => DUST Dust mass mixing ratio skalert pga CAM6-Oslo bug + ; 3 => SS Sea-salt mass mixing ratio skalert pga CAM6-Oslo bug + ; 4 => BC BC mass mixing ratio skalert pga CAM6-Oslo bug + ; 5 => OM OM mass mixing ratio skalert pga CAM6-Oslo bug + ; 6 => SO4 SO4 mass mixing ratio skalert pga CAM6-Oslo bug + ; 7 => SO2 SO2 mass mixing ratio +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="WAK" ; name of main input-variable + varname="Single Scattering Albedo" ; variable name used in text string + plot_name="SSA_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="SSAVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="SSAVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.1) then + var="GAK" ; name of main input-variable + varname="Asymmetry Factor" ; variable name used in text string + plot_name="G_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="ASYMMVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="ASYMMVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.2) then + var="DST" ; name of main input-variable + varname="Dust" ; variable name used in text string + plot_name="DUST_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"DST_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"DST_A2") + addfiles_GetVar(f1_II,all_files_II,"DST_A3") + addfiles_GetVar(f1_II,all_files_II,"DST_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"DST_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.3) then + var="SS" ; name of main input-variable + varname="Sea-salt" ; variable name used in text string + plot_name="SS_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A1_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SS_A1") + addfiles_GetVar(f1_II,all_files_II,"SS_A2") + addfiles_GetVar(f1_II,all_files_II,"SS_A3") + addfiles_GetVar(f1_II,all_files_II,"SS_A1_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.4) then + var="BC" ; name of main input-variable + varname="BC" ; variable name used in text string + plot_name="BC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_A_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_NI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_N_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"BC_A") + addfiles_GetVar(f1_II,all_files_II,"BC_AC") + addfiles_GetVar(f1_II,all_files_II,"BC_AX") + addfiles_GetVar(f1_II,all_files_II,"BC_AI") + addfiles_GetVar(f1_II,all_files_II,"BC_NI") + addfiles_GetVar(f1_II,all_files_II,"BC_N") + addfiles_GetVar(f1_II,all_files_II,"BC_A_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_N_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.5) then + var="OM" ; name of main input-variable + varname="OM" ; variable name used in text string + plot_name="OM_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") + var_I = var_I*1.e12 + else +;var_I = addfiles_GetVar(f1_I,all_files_I,"mmr_OM") ; without OCW contributions... + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_NI")*12.01/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"OM_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_NI_OCW") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA")*168.23/28.97 + addfiles_GetVar(f1_I,all_files_I,"SOA_A1")*168.23/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA_OCW") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"OM_AI") + addfiles_GetVar(f1_II,all_files_II,"OM_AC") + addfiles_GetVar(f1_II,all_files_II,"OM_NI") + addfiles_GetVar(f1_II,all_files_II,"OM_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_NA") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1") + addfiles_GetVar(f1_II,all_files_II,"SOA_NA_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1_OCW") +var_II = var_II*1.e12 +else if (plot_type.eq.6) then + var="SO4" ; name of main input-variable + varname="SO4" ; variable name used in text string + plot_name="SO4_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1") + addfiles_GetVar(f1_I,all_files_I,"SO4_A2") + addfiles_GetVar(f1_I,all_files_I,"SO4_AC") + addfiles_GetVar(f1_I,all_files_I,"SO4_N") + addfiles_GetVar(f1_I,all_files_I,"SO4_NA") + addfiles_GetVar(f1_I,all_files_I,"SO4_PR") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2")/3.59*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR_OCW")/3.06 + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO4_A1")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR_OCW")/3.06 + var_II = var_II*1.e12 +else if (plot_type.eq.7) then + var="SO2" ; name of main input-variable + varname="SO2" ; variable name used in text string + plot_name="SO2_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12/1.998 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO2") + var_II = var_II*1.e12/1.998 + +; conversion from mol(SO2)/mol to kg(SO2)/kg with the new code + if(ModI.eq."CAM5-Oslo") then + var_I = var_I*66.066/28.9647 + end if + var_II = var_II*66.066/28.9647 + + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var .eq. "WAK") then + digg=(/0.5,0.6,0.7,0.8,0.85,0.9,0.95,0.98,0.99,0.995/) + else if (var .eq. "GAK") then + digg=(/0.6,0.62,0.64,0.68,0.7,0.72,0.74,0.76,0.78/) + else if (var .eq. "DST" .or. var .eq. "SS") then + digg=(/25,50,100,250,500,1000,2500,5000,10000,25000/) + else if (var .eq. "BC" .or. var .eq. "OM" .or. var .eq. "SO4" .or. var .eq. "SO2") then + digg=(/2.5,5,10,25,50,100,250,500,1000,2500/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "WAK") then + res@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "WAK") then + res2@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res2@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res2@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res2@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res2@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res2@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res2@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res2@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPz.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPz.ncl new file mode 100644 index 0000000000..d89470669d --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalAero_ModIvsModII_TMPz.ncl @@ -0,0 +1,369 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d aerosol properties from two versions of +; NorESM/CAM-Oslo and makes global plots of the zonally and annually +; averaged variables. Note: This script is only correct when the model +; has been run in AEROCOM mode. Otherwise EAK (SSAVIS) and GAK (AYMMVIS) +; has to be divided by DAYFOC (which is a bit cumbersome due to the +; different number of dimensions, 3d divided by 2d). + +; !!!!! Try changing to p-coordinates by use of vinth2p function in ncl !!!!! + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 2 ; 0 => WAK Single scattering albedo + ; 1 => GAK Assymtery factor + ; 2 => DUST Dust mass mixing ratio skalert pga CAM6-Oslo bug + ; 3 => SS Sea-salt mass mixing ratio skalert pga CAM6-Oslo bug + ; 4 => BC BC mass mixing ratio skalert pga CAM6-Oslo bug + ; 5 => OM OM mass mixing ratio skalert pga CAM6-Oslo bug + ; 6 => SO4 SO4 mass mixing ratio skalert pga CAM6-Oslo bug + ; 7 => SO2 SO2 mass mixing ratio +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="WAK" ; name of main input-variable + varname="Single Scattering Albedo" ; variable name used in text string + plot_name="SSA_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="SSAVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="SSAVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.1) then + var="GAK" ; name of main input-variable + varname="Asymmetry Factor" ; variable name used in text string + plot_name="G_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + varCAM5Oslo="ASYMMVIS" + var_I = addfiles_GetVar(f1_I,all_files_I,varCAM5Oslo) + end if + varCAM5Oslo="ASYMMVIS" + var_II = addfiles_GetVar(f1_II,all_files_II,varCAM5Oslo) + else if (plot_type.eq.2) then + var="DST" ; name of main input-variable + varname="Dust" ; variable name used in text string + plot_name="DUST_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2") + addfiles_GetVar(f1_I,all_files_I,"DST_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"DST_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"DST_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"DST_A2")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A3")*135.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"DST_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"DST_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.3) then + var="SS" ; name of main input-variable + varname="Sea-salt" ; variable name used in text string + plot_name="SS_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1") + addfiles_GetVar(f1_I,all_files_I,"SS_A2") + addfiles_GetVar(f1_I,all_files_I,"SS_A3") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_I,all_files_I,"SS_A1_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A2_OCW") + addfiles_GetVar(f1_I,all_files_I,"SS_A3_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SS_A1")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A2")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A3")*58.44/28.97 + addfiles_GetVar(f1_II,all_files_II,"SS_A1_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A2_OCW") + addfiles_GetVar(f1_II,all_files_II,"SS_A3_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.4) then + var="BC" ; name of main input-variable + varname="BC" ; variable name used in text string + plot_name="BC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A") + addfiles_GetVar(f1_I,all_files_I,"BC_AC") + addfiles_GetVar(f1_I,all_files_I,"BC_AX") + addfiles_GetVar(f1_I,all_files_I,"BC_AI") + addfiles_GetVar(f1_I,all_files_I,"BC_NI") + addfiles_GetVar(f1_I,all_files_I,"BC_N") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"BC_A_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_NI_OCW") + addfiles_GetVar(f1_I,all_files_I,"BC_N_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"BC_A")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AX")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_AI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_NI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_N")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"BC_A_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"BC_N_OCW") + var_II = var_II*1.e12 + else if (plot_type.eq.5) then + var="OM" ; name of main input-variable + varname="OM" ; variable name used in text string + plot_name="OM_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI") + addfiles_GetVar(f1_I,all_files_I,"OM_AC") + addfiles_GetVar(f1_I,all_files_I,"OM_NI") + var_I = var_I*1.e12 + else +;var_I = addfiles_GetVar(f1_I,all_files_I,"mmr_OM") ; without OCW contributions... + var_I = addfiles_GetVar(f1_I,all_files_I,"OM_AI")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_I,all_files_I,"OM_NI")*12.01/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"OM_AI_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_AC_OCW") + addfiles_GetVar(f1_I,all_files_I,"OM_NI_OCW") \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA")*168.23/28.97 + addfiles_GetVar(f1_I,all_files_I,"SOA_A1")*168.23/28.97 \ + + addfiles_GetVar(f1_I,all_files_I,"SOA_NA_OCW") + addfiles_GetVar(f1_I,all_files_I,"SOA_A1_OCW") + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"OM_AI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_AC")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_NI")*12.01/28.97 + addfiles_GetVar(f1_II,all_files_II,"OM_AI_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_AC_OCW") + addfiles_GetVar(f1_II,all_files_II,"OM_NI_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_NA")*168.23/28.97 + addfiles_GetVar(f1_II,all_files_II,"SOA_A1")*168.23/28.97 + addfiles_GetVar(f1_II,all_files_II,"SOA_NA_OCW") + addfiles_GetVar(f1_II,all_files_II,"SOA_A1_OCW") +var_II = var_II*1.e12 +else if (plot_type.eq.6) then + var="SO4" ; name of main input-variable + varname="SO4" ; variable name used in text string + plot_name="SO4_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1") + addfiles_GetVar(f1_I,all_files_I,"SO4_A2") + addfiles_GetVar(f1_I,all_files_I,"SO4_AC") + addfiles_GetVar(f1_I,all_files_I,"SO4_N") + addfiles_GetVar(f1_I,all_files_I,"SO4_NA") + addfiles_GetVar(f1_I,all_files_I,"SO4_PR") + var_I = var_I*1.e12 + else +var_I = addfiles_GetVar(f1_I,all_files_I,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2")/3.59*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_I,all_files_I,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_I,all_files_I,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_I,all_files_I,"SO4_PR_OCW")/3.06 + var_I = var_I*1.e12 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO4_A1")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2")/3.59*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR")/3.06*96.06/28.97 + addfiles_GetVar(f1_II,all_files_II,"SO4_A1_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_A2_OCW")/3.59 + addfiles_GetVar(f1_II,all_files_II,"SO4_AC_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_NA_OCW")/3.06 + addfiles_GetVar(f1_II,all_files_II,"SO4_PR_OCW")/3.06 + var_II = var_II*1.e12 +else if (plot_type.eq.7) then + var="SO2" ; name of main input-variable + varname="SO2" ; variable name used in text string + plot_name="SO2_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12 + else + var_I = addfiles_GetVar(f1_I,all_files_I,"SO2") + var_I = var_I*1.e12/1.998 + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"SO2") + var_II = var_II*1.e12/1.998 + +; conversion from mol(SO2)/mol to kg(SO2)/kg with the new code + if(ModI.eq."CAM5-Oslo") then + var_I = var_I*66.066/28.9647 + end if + var_II = var_II*66.066/28.9647 + + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var .eq. "WAK") then + digg=(/0.5,0.6,0.7,0.8,0.85,0.9,0.95,0.98,0.99,0.995/) + else if (var .eq. "GAK") then + digg=(/0.6,0.62,0.64,0.68,0.7,0.72,0.74,0.76,0.78/) + else if (var .eq. "DST" .or. var .eq. "SS") then + digg=(/25,50,100,250,500,1000,2500,5000,10000,25000/) + else if (var .eq. "BC" .or. var .eq. "OM" .or. var .eq. "SO4" .or. var .eq. "SO2") then + digg=(/2.5,5,10,25,50,100,250,500,1000,2500/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "WAK") then + res@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "WAK") then + res2@tiMainString = "Single Scattering Albedo" +else if (var .eq. "GAK") then + res2@tiMainString = "Asymmetry Factor" +else if (var .eq. "DST") then + res2@tiMainString = "Dust (ng kg~S~-1~N~)" +else if (var .eq. "SS") then + res2@tiMainString = "Sea-salt (ng kg~S~-1~N~)" +else if (var .eq. "BC") then + res2@tiMainString = "BC (ng kg~S~-1~N~)" +else if (var .eq. "OM") then + res2@tiMainString = "OM (ng kg~S~-1~N~)" +else if (var .eq. "SO4") then + res2@tiMainString = "SO4 (ng S kg~S~-1~N~)" +else if (var .eq. "SO2") then + res2@tiMainString = "SO2 (ng S kg~S~-1~N~)" +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalModepar_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalModepar_ModIvsModII.ncl new file mode 100644 index 0000000000..13ab9ff03a --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalModepar_ModIvsModII.ncl @@ -0,0 +1,340 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d modal (size or number or hygroscopic) parameters +; from two versions of NorESM/CAM-Oslo and makes global plots of the respective +; zonally and annually averaged variables. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 1 ; 1 => NMR01 Number median radius mode 1 + ; 2 => NMR02 Number median radius mode 2 + ; 3 => NMR04 Number median radius mode 4 + ; 4 => NMR05 Number median radius mode 5 + ; 5 => NMR06 Number median radius mode 6 + ; 6 => NMR07 Number median radius mode 7 + ; 7 => NMR08 Number median radius mode 8 + ; 8 => NMR09 Number median radius mode 9 + ; 9 => NMR10 Number median radius mode 10 +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + + if (plot_type.eq.1) then + var="NMR01" ; name of input-variable and plot + varname="NMR01" ; variable name used in text string + plot_name="NMR01" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.2) then + var="NMR02" ; name of input-variable and plot + varname="NMR02" ; variable name used in text string + plot_name="NMR02" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.3) then + var="NMR04" ; name of input-variable and plot + varname="NMR04" ; variable name used in text string + plot_name="NMR04" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.4) then + var="NMR05" ; name of input-variable and plot + varname="NMR05" ; variable name used in text string + plot_name="NMR05" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.5) then + var="NMR06" ; name of input-variable and plot + varname="NMR06" ; variable name used in text string + plot_name="NMR06" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.6) then + var="NMR07" ; name of input-variable and plot + varname="NMR07" ; variable name used in text string + plot_name="NMR07" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.7) then + var="NMR08" ; name of input-variable and plot + varname="NMR08" ; variable name used in text string + plot_name="NMR08" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.8) then + var="NMR09" ; name of input-variable and plot + varname="NMR09" ; variable name used in text string + plot_name="NMR09" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.9) then + var="NMR10" ; name of input-variable and plot + varname="NMR10" ; variable name used in text string + plot_name="NMR10" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + end if + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var.eq."NMR01") then + digg=(/0.012,0.014,0.016,0.018,0.02,0.022,0.025,0.03,0.035,0.04,0.05/) + else if (var .eq. "NMR02") then +; digg=(/0.012,0.013,0.014,0.015,0.016,0.017,0.018,0.019,0.020,0.021,0.022/) +; digg=(/0.012,0.014,0.016,0.018,0.020,0.022,0.024,0.025,0.027,0.029,0.03/) + digg=(/0.024,0.025,0.026,0.027,0.028,0.029,0.030,0.032,0.035,0.04,0.05/) + else if (var .eq. "NMR04") then + digg=(/0.04,0.05,0.06,0.07,0.08,0.09,0.1,0.15,0.2,0.3,0.4/) + else if (var .eq. "NMR05") then + digg=(/0.075,0.08,0.09,0.1,0.12,0.14,0.16,0.18,0.2,0.25,0.3/) + else if (var .eq. "NMR06") then + digg=(/0.22,0.24,0.28,0.3,0.35,0.4,0.45,0.5,0.55,0.6,0.65/) + else if (var .eq. "NMR07") then + digg=(/0.63,0.65,0.67,0.7,0.75,0.8,0.9,1.0,1.1,1.2,1.5/) + else if (var .eq. "NMR08") then + digg=(/0.0475,0.05,0.06,0.07,0.08,0.09,0.1,0.15,0.2,0.3,0.4/) + else if (var .eq. "NMR09") then + digg=(/0.3,0.31,0.32,0.34,0.36,0.38,0.4,0.45,0.5,0.55,0.6/) + else if (var .eq. "NMR10") then + digg=(/0.74,0.75,0.76,0.77,0.78,0.79,0.8,0.82,0.84,0.86,0.88/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;if (plot_type.eq.4) then +; wks = gsn_open_wks(format,"RHW") +;else +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) +;end if + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "NMR01") then + res@tiMainString = "NMR for mode 1 (~F33~m~F21~m)" +else if (var .eq. "NMR02") then + res@tiMainString = "NMR for mode 2 (~F33~m~F21~m)" +else if (var .eq. "NMR04") then + res@tiMainString = "NMR for mode 4 (~F33~m~F21~m)" +else if (var .eq. "NMR05") then + res@tiMainString = "NMR for mode 5 (~F33~m~F21~m)" +else if (var .eq. "NMR06") then + res@tiMainString = "NMR for mode 6 (~F33~m~F21~m)" +else if (var .eq. "NMR07") then + res@tiMainString = "NMR for mode 7 (~F33~m~F21~m)" +else if (var .eq. "NMR08") then + res@tiMainString = "NMR for mode 8 (~F33~m~F21~m)" +else if (var .eq. "NMR09") then + res@tiMainString = "NMR for mode 9 (~F33~m~F21~m)" +else if (var .eq. "NMR10") then + res@tiMainString = "NMR for mode 10 (~F33~m~F21~m)" +else + res@tiMainString = "NMR for mode ... (~F33~m~F21~m)" +end if +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "NMR01") then + res2@tiMainString = "NMR for mode 1 (~F33~m~F21~m)" +else if (var .eq. "NMR02") then + res2@tiMainString = "NMR for mode 2 (~F33~m~F21~m)" +else if (var .eq. "NMR04") then + res2@tiMainString = "NMR for mode 4 (~F33~m~F21~m)" +else if (var .eq. "NMR05") then + res2@tiMainString = "NMR for mode 5 (~F33~m~F21~m)" +else if (var .eq. "NMR06") then + res2@tiMainString = "NMR for mode 6 (~F33~m~F21~m)" +else if (var .eq. "NMR07") then + res2@tiMainString = "NMR for mode 7 (~F33~m~F21~m)" +else if (var .eq. "NMR08") then + res2@tiMainString = "NMR for mode 8 (~F33~m~F21~m)" +else if (var .eq. "NMR09") then + res2@tiMainString = "NMR for mode 9 (~F33~m~F21~m)" +else if (var .eq. "NMR10") then + res2@tiMainString = "NMR for mode 10 (~F33~m~F21~m)" +else + res2@tiMainString = "REFFL (AREL/FREQL) (~F33~m~F21~m)" +end if +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalN_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalN_ModIvsModII.ncl new file mode 100644 index 0000000000..56c16780bd --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalN_ModIvsModII.ncl @@ -0,0 +1,387 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d modal Number concentrations from two +; versions of NorESM/CAM-Oslo and makes global plots of the respective +; zonally and annually averaged variables. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 1 ; 1 => NNAT_1 Number concentration mode 1 + ; 2 => NNAT_2 Number concentration mode 2 + ; 3 => NNAT_4 Number concentration mode 4 + ; 4 => NNAT_5 Number concentration mode 5 + ; 5 => NNAT_6 Number concentration mode 6 + ; 6 => NNAT_7 Number concentration mode 7 + ; 7 => NNAT_8 Number concentration mode 8 + ; 8 => NNAT_9 Number concentration mode 9 + ; 9 => NNAT_10 Number concentration mode 10 + ;10 => NNAT_0 Number concentration mode 0 + ;11 => NNAT_12 Number concentration mode 12 + ;12 => NNAT_14 Number concentration mode 14 + ;13 => SURVNUC Survival rate for/to mode 1 +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + + if (plot_type.eq.1) then + var="NNAT_1" ; name of input-variable and plot + varname="NNAT_1" ; variable name used in text string + plot_name="NNAT_1" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.2) then + var="NNAT_2" ; name of input-variable and plot + varname="NNAT_2" ; variable name used in text string + plot_name="NNAT_2" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.3) then + var="NNAT_4" ; name of input-variable and plot + varname="NNAT_4" ; variable name used in text string + plot_name="NNAT_4" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.4) then + var="NNAT_5" ; name of input-variable and plot + varname="NNAT_5" ; variable name used in text string + plot_name="NNAT_5" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.5) then + var="NNAT_6" ; name of input-variable and plot + varname="NNAT_6" ; variable name used in text string + plot_name="NNAT_6" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.6) then + var="NNAT_7" ; name of input-variable and plot + varname="NNAT_7" ; variable name used in text string + plot_name="NNAT_7" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.7) then + var="NNAT_8" ; name of input-variable and plot + varname="NNAT_8" ; variable name used in text string + plot_name="NNAT_8" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.8) then + var="NNAT_9" ; name of input-variable and plot + varname="NNAT_9" ; variable name used in text string + plot_name="NNAT_9" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.9) then + var="NNAT_10" ; name of input-variable and plot + varname="NNAT_10" ; variable name used in text string + plot_name="NNAT_10" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.10) then + var="NNAT_0" ; name of input-variable and plot + varname="NNAT_0" ; variable name used in text string + plot_name="NNAT_0" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.11) then + var="NNAT_12" ; name of input-variable and plot + varname="NNAT_12" ; variable name used in text string + plot_name="NNAT_12" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + else if (plot_type.eq.12) then + var="NNAT_14" ; name of input-variable and plot + varname="NNAT_14" ; variable name used in text string + plot_name="NNAT_14" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.0e0 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.0e0 + +else if (plot_type.eq.13) then + var="SURVNUC" ; name of input-variable and plot + varname="SURVNUC" ; variable name used in text string + plot_name="SURVNUC" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,"FORMRATE") / (addfiles_GetVar(f1_I,all_files_I,"NUCLRATE") + 1.e-10) + var_II = addfiles_GetVar(f1_II,all_files_II,"FORMRATE") / (addfiles_GetVar(f1_II,all_files_II,"NUCLRATE") + 1.e-10) + end if + +end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var.eq."NNAT_1") then + digg=(/5,10,20,50,100,200,500,1000,2000,5000/) + else if (var .eq. "NNAT_2" .or. var .eq. "NNAT_12") then + digg=(/1,2,5,10,20,50,100,200,500,1000/) + else if (var .eq. "NNAT_4" .or. var .eq. "NNAT_14") then + digg=(/1,2,5,10,20,50,100,200,500,1000/) + else if (var .eq. "NNAT_5") then + digg=(/0.2,0.5,1,2,5,10,20,50,100,200/) + else if (var .eq. "NNAT_6") then + digg=(/0.2,0.5,1,5,10,20,50,100,200/) + else if (var .eq. "NNAT_7") then + digg=(/0.01,0.02,0.05,0.1,0.2,0.5,1,2,5,10/) + else if (var .eq. "NNAT_8") then + digg=(/0.2,0.5,1,5,10,20,50,100,200/) + else if (var .eq. "NNAT_9" .or. var .eq. "NNAT_10" .or. var .eq. "NNAT_0") then + digg=(/0.01,0.02,0.05,0.1,0.2,0.5,1,2,5,10/) + else + digg=(/0.01,0.02,0.03,0.05,0.1,0.2,0.3,0.5,0.75,1.0/) + end if + end if + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;if (plot_type.eq.4) then +; wks = gsn_open_wks(format,"RHW") +;else +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) +;end if + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "NNAT_1") then + res@tiMainString = "NNAT for mode 1 (cm~S~-3~N~)" +else if (var .eq. "NNAT_2") then + res@tiMainString = "NNAT for mode 2 (cm~S~-3~N~)" +else if (var .eq. "NNAT_4") then + res@tiMainString = "NNAT for mode 4 (cm~S~-3~N~)" +else if (var .eq. "NNAT_5") then + res@tiMainString = "NNAT for mode 5 (cm~S~-3~N~)" +else if (var .eq. "NNAT_6") then + res@tiMainString = "NNAT for mode 6 (cm~S~-3~N~)" +else if (var .eq. "NNAT_7") then + res@tiMainString = "NNAT for mode 7 (cm~S~-3~N~)" +else if (var .eq. "NNAT_8") then + res@tiMainString = "NNAT for mode 8 (cm~S~-3~N~)" +else if (var .eq. "NNAT_9") then + res@tiMainString = "NNAT for mode 9 (cm~S~-3~N~)" +else if (var .eq. "NNAT_10") then + res@tiMainString = "NNAT for mode 10 (cm~S~-3~N~)" +else if (var .eq. "NNAT_0") then + res@tiMainString = "NNAT for mode 0 (cm~S~-3~N~)" +else if (var .eq. "NNAT_12") then + res@tiMainString = "NNAT for mode 12 (cm~S~-3~N~)" +else if (var .eq. "NNAT_14") then + res@tiMainString = "NNAT for mode 14 (cm~S~-3~N~)" +else + res@tiMainString = "Survival rate to mode 1" +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if + + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "NNAT_1") then + res2@tiMainString = "NNAT for mode 1 (cm~S~-3~N~)" +else if (var .eq. "NNAT_2") then + res2@tiMainString = "NNAT for mode 2 (cm~S~-3~N~)" +else if (var .eq. "NNAT_4") then + res2@tiMainString = "NNAT for mode 4 (cm~S~-3~N~)" +else if (var .eq. "NNAT_5") then + res2@tiMainString = "NNAT for mode 5 (cm~S~-3~N~)" +else if (var .eq. "NNAT_6") then + res2@tiMainString = "NNAT for mode 6 (cm~S~-3~N~)" +else if (var .eq. "NNAT_7") then + res2@tiMainString = "NNAT for mode 7 (cm~S~-3~N~)" +else if (var .eq. "NNAT_8") then + res2@tiMainString = "NNAT for mode 8 (cm~S~-3~N~)" +else if (var .eq. "NNAT_9") then + res2@tiMainString = "NNAT for mode 9 (cm~S~-3~N~)" +else if (var .eq. "NNAT_10") then + res2@tiMainString = "NNAT for mode 10 (cm~S~-3~N~)" +else if (var .eq. "NNAT_0") then + res2@tiMainString = "NNAT for mode 0 (cm~S~-3~N~)" +else if (var .eq. "NNAT_12") then + res2@tiMainString = "NNAT for mode 12 (cm~S~-3~N~)" +else if (var .eq. "NNAT_14") then + res2@tiMainString = "NNAT for mode 14 (cm~S~-3~N~)" +else + res2@tiMainString = "Survival rate to mode 1" +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if +end if + + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/ZonalRHCl_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/ZonalRHCl_ModIvsModII.ncl new file mode 100644 index 0000000000..f782bfb088 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/ZonalRHCl_ModIvsModII.ncl @@ -0,0 +1,355 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in 3d cloud cover or ambient relative humidity or liquid +; or ice water content from two versions of NorESM/CAM-Oslo and makes global plots +; of the zonally and annually averaged variables. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 4 ; 0 => CLOUD Cloud fraction + ; 1 => RH Relative humidity RELHUM + ; 2 => CLDLIQ Cloud liquid amount + ; 3 => CLDICE Cloud ice amount + ; 4 => RHW Relative humidity RHW + ; 5 => CDNC Cloud droplet number concentration + ; 6 => REFFL Cloud droplet effective radius + ; 7 => ICNC Ice crystal number concentration +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_files_I = systemfunc ("ls " + filepath_I + filenamep_I + "*") + all_files_II = systemfunc ("ls " + filepath_II + filenamep_II + "*") + f0_I = addfile (filepath_I+filename_I, "r") + f0_II = addfile (filepath_II+filename_II, "r") + f1_I = addfiles (all_files_I, "r") ; note the "s" of addfile + f1_II = addfiles (all_files_II, "r") ; note the "s" of addfile + + + if (plot_type.eq.0) then + var="CLOUD" ; name of input-variable + varname="CLOUD" ; variable name used in text string + plot_name="CLOUD_Zonal" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var) + var_II = addfiles_GetVar(f1_II,all_files_II,var) + else if (plot_type.eq.1) then + var="RELHUM" ; name of input-variable and plot + varname="RH" ; variable name used in text string + plot_name="RELHUM_Zonal" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var) + var_II = addfiles_GetVar(f1_II,all_files_II,var) + else if (plot_type.eq.2) then + var="CLDLIQ" ; name of input-variable and plot + varname="Cloud liquid amount" ; variable name used in text string + plot_name="CLDLIQ_Zonal" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.3) then + var="CLDICE" ; name of input-variable and plot + varname="Cloud ice amount" ; variable name used in text string + plot_name="CLDICE_Zonal" ; name of the plot/figure + var_I = addfiles_GetVar(f1_I,all_files_I,var)*1.e6 + var_II = addfiles_GetVar(f1_II,all_files_II,var)*1.e6 + else if (plot_type.eq.4) then + var="RELHUM" ; name of input-variable and plot + varname="RH" ; variable name used in text string + plot_name="RHW_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = addfiles_GetVar(f1_I,all_files_I,var) + else + var_I = addfiles_GetVar(f1_I,all_files_I,"RHW") + end if + var_II = addfiles_GetVar(f1_II,all_files_II,"RHW") + else if (plot_type.eq.5) then + var="CDNC" ; name of plot + varname="CDNC" ; variable name used in text string + plot_name="CDNC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)/((/(f1_I[:]->CLDFOC)/)+small) ; variable to be plotted from I + else + var_I=1.e-6*(/(f1_I[:]->AWNC)/)/((/(f1_I[:]->FREQL)/)+small) ; variable to be plotted from II + end if + var_II=1.e-6*(/(f1_II[:]->AWNC)/)/((/(f1_II[:]->FREQL)/)+small) ; variable to be plotted from II + else if (plot_type.eq.6) then + var="REFFL" ; name of plot + varname="REFFL" ; variable name used in text string + plot_name="REFFL_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->REFFL)/)/((/(f1_I[:]->CLDFOC)/)+small) ; variable to be plotted from I + else + var_I=(/(f1_I[:]->AREL)/)/((/(f1_I[:]->FREQL)/)+small) ; variable to be plotted from II + end if + var_II=(/(f1_II[:]->AREL)/)/((/(f1_II[:]->FREQL)/)+small) ; variable to be plotted from II + else if (plot_type.eq.7) then + var="ICNC" ; name of plot + varname="ICNC" ; variable name used in text string + plot_name="ICNC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1_I[:]->CDNC)/)*0.0 ; variable to be plotted from I + else + var_I=1.e-6*(/(f1_I[:]->AWNI)/)/((/(f1_I[:]->FREQI)/)+small) ; variable to be plotted from II + end if + var_II=1.e-6*(/(f1_II[:]->AWNI)/)/((/(f1_II[:]->FREQI)/)+small) ; variable to be plotted from II + end if + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +lat_I = f0_I->lat ; pull lat off file +lat_II = f0_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0_I->hyam ; select hyam + b=f0_I->hybm ; select hybm + p=f0_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0_II->hyam ; select hyam + b_II=f0_II->hybm ; select hybm + p_II=f0_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + + zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave + zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var.eq."CLOUD") then + digg=(/0.05,0.1,0.15,0.2,0.25,0.3,0.35,0.4,0.45,0.5,0.55/) + else if (var .eq. "RELHUM") then + digg=(/10,25,40,50,60,70,80,90,95,100/) + else if (var .eq. "CLDLIQ") then + digg=(/0.1,1,2,3,5,10,20,30,50,100/) + else if (var .eq. "CLDICE") then + digg=(/0.01,0.1,0.2,0.3,0.5,1,2,3,5,10/) + else if (var .eq. "CDNC") then + digg=(/0.1,1,2,3,5,10,20,30,50,100/) + else if (var .eq. "REFFL") then + digg=(/0.1,0.5,1,1.5,2,3,5,10,15,20/) + else + digg=(/0.0005,0.001,0.01,0.02,0.03,0.05,.1,.2,.3,.5/) + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;if (plot_type.eq.4) then +; wks = gsn_open_wks(format,"RHW") +;else +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) +;end if + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "CLOUD") then + res@tiMainString = "Cloud Fraction" +else if (var .eq. "RELHUM") then + if (plot_type.eq.4) then + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "Relative Humidity RELHUM (%)" + else + res@tiMainString = "Relative Humidity RHW (%)" + end if + else + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "Relative Humidity RELHUM (%)" + else + res@tiMainString = "Relative Humidity RELHUM (%)" + end if + end if +else if (var .eq. "CLDLIQ") then + res@tiMainString = "Cloud Liquid Water (mg kg~S~-1~N~)" +else if (var .eq. "CLDICE") then + res@tiMainString = "Cloud Ice Water (mg kg~S~-1~N~)" +else if (var .eq. "CDNC") then + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "CDNC (CDNC/CLDFOC) (cm~S~-3~N~)" + else + res@tiMainString = "CDNC (AWNC/FREQL) (cm~S~-3~N~)" + end if +else if (var .eq. "REFFL") then + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "REFFL (REFFL/CLDFOC) (~F33~m~F21~m)" + else + res@tiMainString = "REFFL (AREL/FREQL) (~F33~m~F21~m)" + end if +else if (var .eq. "ICNC") then + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "ICNC (N/A)" + else + res@tiMainString = "ICNC (AWNI/FREQI) (cm~S~-3~N~)" + end if +end if +end if +end if +end if +end if +end if +end if + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "CLOUD") then + res2@tiMainString = "Cloud Fraction" +else if (var .eq. "RELHUM") then + if (plot_type.eq.4) then + if(ModI.eq."CAM4-Oslo") then + res2@tiMainString = "Relative Humidity RHW (%)" + else + res2@tiMainString = "Relative Humidity RHW (%)" + end if + else + if(ModI.eq."CAM4-Oslo") then + res2@tiMainString = "Relative Humidity RELHUM (%)" + else + res2@tiMainString = "Relative Humidity RELHUM (%)" + end if + end if +else if (var .eq. "CLDLIQ") then + res2@tiMainString = "Cloud Liquid Water (mg kg~S~-1~N~)" +else if (var .eq. "CLDICE") then + res2@tiMainString = "Cloud Ice Water (mg kg~S~-1~N~)" +else if (var .eq. "CDNC") then + res2@tiMainString = "CDNC (AWNC/FREQL) (cm~S~-3~N~)" +else if (var .eq. "REFFL") then + res2@tiMainString = "REFFL (AREL/FREQL) (~F33~m~F21~m)" +else if (var .eq. "ICNC") then + res2@tiMainString = "ICNC (AWNI/FREQI) (cm~S~-3~N~)" +end if +end if +end if +end if +end if +end if +end if + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/ModIvsModII/diffTOAbalance.ncl b/tools/diagnostics/ncl/ModIvsModII/diffTOAbalance.ncl new file mode 100644 index 0000000000..0607df8334 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/diffTOAbalance.ncl @@ -0,0 +1,361 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol and droplet properties from two versions of +; NorESM / CAM-Oslo and makes global plots of the annually averaged differences +; between PD and PI, including global average as a number in the title line for +; each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 3 ; 0 => AOD at 550 nm, PD - PI + ; 1 => ABS at 550 nm, PD - PI + ; 2 => CDNCINT, PD - PI + ; 3 => SO4 column burden, PD - PI + ; 4 => POM column burden, PD - PI + ; 5 => BC column burden, PD - PI + ; 6 => Dust column burden, PD - PI + ; 7 => Sea-salt column burden, PD - PI + ; 8 => BC MEC based on PD - PI AOD and Burdens + ; 9 => BC MABS based on PD - PI ABS and Burdens + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.0) then + var="dDOD550" ; name of plot + + varname="Anthropogenic AOD at 550nm" ; variable name used in text string: +; forc_I=(/(f1PD_I[:]->DOD550)/)-(/(f1PI_I[:]->DOD550)/) ; variable to be plotted from I +; forc_II=(/(f1PD_II[:]->DOD550)/)-(/(f1PI_II[:]->DOD550)/) + + forc_I=(/(f1PD_II[:]->FSNT)/)-(/(f1PD_II[:]->FLNT)/)-((/(f1PD_I[:]->FSNT)/)-(/(f1PD_I[:]->FLNT)/)) + forc_II=(/(f1PD_II[:]->FSNT)/)-(/(f1PD_II[:]->FLNT)/)-((/(f1PD_I[:]->FSNT)/)-(/(f1PD_I[:]->FLNT)/)) + + else if (plot_type.eq.1) then + var="dABS550" + varname="Anthropogenic ABS at 550nm" + forc_I=(/(f1PD_I[:]->ABS550)/)-(/(f1PI_I[:]->ABS550)/) + forc_II=(/(f1PD_II[:]->ABS550)/)-(/(f1PI_II[:]->ABS550)/) + else if (plot_type.eq.2) then + var="dCDNUMC2" + varname="Anthrop. CDNC col." + if(ModI.eq."CAM4-Oslo") then + forc_I=1.e-6*((/(f1PD_I[:]->CLDTOT)/)*(/(f1PD_I[:]->CDNCINT)/)-(/(f1PI_I[:]->CLDTOT)/)*(/(f1PI_I[:]->CDNCINT)/)) + else + forc_I=1.e-10*((/(f1PD_I[:]->CDNUMC)/)-(/(f1PI_I[:]->CDNUMC)/)) + end if + forc_II=1.e-10*((/(f1PD_II[:]->CDNUMC)/)-(/(f1PI_II[:]->CDNUMC)/)) + else if (plot_type.eq.3) then + var="dC_SO4" + varname="Anthropogenic SO4 column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_SO4)/)-(/(f1PI_I[:]->C_SO4)/))*1.e6 + else + forc_I=(/(f1PD_I[:]->cb_SO4_A1)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A2)/)/3.59 + (/(f1PD_I[:]->cb_SO4_AC)/)/3.06 + (/(f1PD_I[:]->cb_SO4_NA)/)/3.06 + (/(f1PD_I[:]->cb_SO4_PR)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PD_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_PR_OCW)/)/3.06 + forc_I=forc_I-((/(f1PI_I[:]->cb_SO4_A1)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A2)/)/3.59 + (/(f1PI_I[:]->cb_SO4_AC)/)/3.06 + (/(f1PI_I[:]->cb_SO4_NA)/)/3.06 + (/(f1PI_I[:]->cb_SO4_PR)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PI_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_PR_OCW)/)/3.06) + forc_I=forc_I*1.e6 + end if + forc_II=(/(f1PD_II[:]->cb_SO4_A1)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A2)/)/3.59 + (/(f1PD_II[:]->cb_SO4_AC)/)/3.06 + (/(f1PD_II[:]->cb_SO4_NA)/)/3.06 + (/(f1PD_II[:]->cb_SO4_PR)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PD_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_PR_OCW)/)/3.06 + forc_II=forc_II-((/(f1PI_II[:]->cb_SO4_A1)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A2)/)/3.59 + (/(f1PI_II[:]->cb_SO4_AC)/)/3.06 + (/(f1PI_II[:]->cb_SO4_NA)/)/3.06 + (/(f1PI_II[:]->cb_SO4_PR)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PI_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_PR_OCW)/)/3.06) + forc_II=forc_II*1.e6 + else if (plot_type.eq.4) then + var="dC_POM" + varname="Anthropogenic POM column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_POM)/)-(/(f1PI_I[:]->C_POM)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_OM)/)-(/(f1PI_I[:]->cb_OM)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_OM)/)-(/(f1PI_II[:]->cb_OM)/))*1.e6 + else if (plot_type.eq.5) then + var="dC_BC" + varname="Anthropogenic BC column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/))*1.e6 + else if (plot_type.eq.6) then + var="dC_DUST" + varname="Anthropogenic dust column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_DUST)/)-(/(f1PI_I[:]->C_DUST)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_DUST)/)-(/(f1PI_I[:]->cb_DUST)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_DUST)/)-(/(f1PI_II[:]->cb_DUST)/))*1.e6 + else if (plot_type.eq.7) then + var="dC_SS" + varname="Anthropogenic sea-salt column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_SS)/)-(/(f1PI_I[:]->C_SS)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_SALT)/)-(/(f1PI_I[:]->cb_SALT)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_SALT)/)-(/(f1PI_II[:]->cb_SALT)/))*1.e6 + else if (plot_type.eq.8) then + var="MECbcant" + varname="MEC for Anthropogenic BC" + aod_I=(/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/) + aod_II=(/f1PD_II[:]->D550_BC/)-(/f1PI_II[:]->D550_BC/) + if(ModI.eq."CAM4-Oslo") then + forc_I=(((/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/))/((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e3 + else + forc_I=(((/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/))/((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e3 + end if + forc_II=(((/f1PD_II[:]->D550_BC/)-(/f1PI_II[:]->D550_BC/))/((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e-3 + load_II=(((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e3 + else if (plot_type.eq.9) then + var="MACbcant" + varname="MAC for Anthropogenic BC" + aod_I=(/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/) + aod_II=(/f1PD_II[:]->A550_BC/)-(/f1PI_II[:]->A550_BC/) + if(ModI.eq."CAM4-Oslo") then + forc_I=(((/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/))/((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e3 + else + forc_I=(((/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/))/((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e3 + end if + forc_II=(((/f1PD_II[:]->A550_BC/)-(/f1PI_II[:]->A550_BC/))/((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e-3 + load_II=(((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e3 + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II +if (plot_type.ge.8) then + aod_Ia=forc_I + aod_IIa=forc_II + load_Ia=forc_I + load_IIa=forc_II +end if + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + forcave_I=sum(dim_avg_n(forc_Ia,0))/area1 + +if (plot_type.ge.8) then + do i=0,dimsizes(gw0_I)-1 + aod_Ia(:,i,:)=aod_I(:,i,:)*coffa*dlon_I*gw0_I(i) + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + aodave_I=sum(dim_avg_n(aod_Ia,0))/area1 + loadave_I=sum(dim_avg_n(load_Ia,0))/area1 +end if + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + forcave_II=sum(dim_avg_n(forc_IIa,0))/area1 + +if (plot_type.ge.8) then + do i=0,dimsizes(gw0_II)-1 + aod_IIa(:,i,:)=aod_II(:,i,:)*coffa*dlon_II*gw0_II(i) + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + aodave_II=sum(dim_avg_n(aod_IIa,0))/area1 + loadave_II=sum(dim_avg_n(load_IIa,0))/area1 +end if + +; Defining color scales for each forcing variable +if (var .eq. "dDOD550") then +; digg=(/-0.2,-.05,0,0.01,0.02,0.03,0.05,0.1,0.2,0.3/) + digg=(/-10,-5,-2.5,-1,-0.5,0,0.5,1,2.5,5,10/) + + else if (var .eq. "dABS550") then + digg=(/-.01,0,0.001,0.002,0.003,0.005,0.01,0.02,0.03/) + else if (var .eq. "dCDNUMC2") then + digg=(/-0.1,0,0.1,0.2,0.3,0.5,1,2,5,10/) + else if (var .eq. "dC_SO4") then +; digg=(/0.05,0.1,0.2,0.3,0.5,1,1.5,2,3,5/) + digg=(/0,0.05,0.1,0.2,0.3,0.5,1,2,3,5/) + else if (var .eq. "dC_POM") then + digg=(/-5,-2.5,-1,-0.5,0,0.5,1,2.5,5,10,15/) + else if (var .eq. "dC_BC") then + digg=(/-0.2,-0.1,0,0.1,0.2,0.3,0.5,1,1.5,2/) + else if (var .eq. "dC_DUST".or.var .eq. "dC_SS") then + digg=(/-0.5,-0.3,-0.2,-0.1,0,0.1,0.2,0.3,0.5/) + else ; MECbcant + digg=(/1,2,3,4,5,7,10,15,20,30/) + end if + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" +if (var.eq."dDOD550".or.var.eq."dABS550") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(forc_Ia,0))/area1)) +else if (var.eq."dCDNUMC2") then + if(ModI.eq."CAM4-Oslo") then + res@gsnRightString = "(CDNCINT*CLDTOT) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + else + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + end if +else if (var.eq."dC_SO4") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" mg S m~S~-2~N~" +else if (var.eq."dC_POM".or.var.eq."dC_BC".or.var.eq."dC_DUST".or.var.eq."dC_SS") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" mg m~S~-2~N~" +else if (var.eq."MECbcant".or.var.eq."MACbcant") then + res@gsnRightString = "avg = "+sprintf("%5.2f",forcave_I)+" ("+sprintf("%4.2f",aodave_I/loadave_I)+") m~S~2~N~ g~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1)) +end if +end if +end if +end if +end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" +if (var.eq."dDOD550".or.var.eq."dABS550") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(forc_IIa,0))/area1)) +else if (var.eq."dCDNUMC2") then + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" +else if (var.eq."dC_SO4") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" mg S m~S~-2~N~" +else if (var.eq."dC_POM".or.var.eq."dC_BC".or.var.eq."dC_DUST".or.var.eq."dC_SS") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" mg m~S~-2~N~" +else if (var.eq."MECbcant".or.var.eq."MACbcant") then + res@gsnRightString = "avg = "+sprintf("%5.2f",forcave_II)+" ("+sprintf("%4.2f",aodave_II/loadave_II)+") m~S~2~N~ g~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+"endre! W m~S~-2~N~" +end if +end if +end if +end if +end if + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/divPD-PI_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/divPD-PI_ModIvsModII.ncl new file mode 100644 index 0000000000..793c5e1c48 --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/divPD-PI_ModIvsModII.ncl @@ -0,0 +1,354 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in aerosol and droplet properties from two versions of +; NorESM / CAM-Oslo and makes global plots of the annually averaged differences +; between PD and PI, including global average as a number in the title line for +; each figure. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 3 ; 0 => AOD at 550 nm, PD - PI + ; 1 => ABS at 550 nm, PD - PI + ; 2 => CDNCINT, PD - PI + ; 3 => SO4 column burden, PD - PI + ; 4 => POM column burden, PD - PI + ; 5 => BC column burden, PD - PI + ; 6 => Dust column burden, PD - PI + ; 7 => Sea-salt column burden, PD - PI + ; 8 => BC MEC based on PD - PI AOD and Burdens + ; 9 => BC MABS based on PD - PI ABS and Burdens + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + +; Reading Gaussian weights and other required model variables + gw0_I=doubletofloat(f0PD_I->gw) + gw0_II=doubletofloat(f0PD_II->gw) + + lon_I=f0PD_I->lon + dlon_I=360./dimsizes(lon_I) + lon_II=f0PD_II->lon + dlon_II=360./dimsizes(lon_II) + +; Initialization (and obtain correct variable dimensions) + tmp_I=f1PD_I[:]->PS + tmp_II=f1PD_II[:]->PS + forc_I=tmp_I + forc_II=tmp_II + + if (plot_type.eq.0) then + var="dDOD550" ; name of plot + varname="Anthropogenic AOD at 550nm" ; variable name used in text string: + forc_I=(/(f1PD_I[:]->DOD550)/)-(/(f1PI_I[:]->DOD550)/) ; variable to be plotted from I + forc_II=(/(f1PD_II[:]->DOD550)/)-(/(f1PI_II[:]->DOD550)/) + else if (plot_type.eq.1) then + var="dABS550" + varname="Anthropogenic ABS at 550nm" + forc_I=(/(f1PD_I[:]->ABS550)/)-(/(f1PI_I[:]->ABS550)/) + forc_II=(/(f1PD_II[:]->ABS550)/)-(/(f1PI_II[:]->ABS550)/) + else if (plot_type.eq.2) then + var="dCDNUMC2" + varname="Anthrop. CDNC col." + if(ModI.eq."CAM4-Oslo") then + forc_I=1.e-6*((/(f1PD_I[:]->CLDTOT)/)*(/(f1PD_I[:]->CDNCINT)/)-(/(f1PI_I[:]->CLDTOT)/)*(/(f1PI_I[:]->CDNCINT)/)) + else + forc_I=1.e-10*((/(f1PD_I[:]->CDNUMC)/)-(/(f1PI_I[:]->CDNUMC)/)) + end if + forc_II=1.e-10*((/(f1PD_II[:]->CDNUMC)/)-(/(f1PI_II[:]->CDNUMC)/)) + else if (plot_type.eq.3) then + var="dC_SO4" + varname="Anthropogenic SO4 column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_SO4)/)-(/(f1PI_I[:]->C_SO4)/))*1.e6 + else + forc_I=(/(f1PD_I[:]->cb_SO4_A1)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A2)/)/3.59 + (/(f1PD_I[:]->cb_SO4_AC)/)/3.06 + (/(f1PD_I[:]->cb_SO4_NA)/)/3.06 + (/(f1PD_I[:]->cb_SO4_PR)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PD_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PD_I[:]->cb_SO4_PR_OCW)/)/3.06 + forc_I=forc_I-((/(f1PI_I[:]->cb_SO4_A1)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A2)/)/3.59 + (/(f1PI_I[:]->cb_SO4_AC)/)/3.06 + (/(f1PI_I[:]->cb_SO4_NA)/)/3.06 + (/(f1PI_I[:]->cb_SO4_PR)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PI_I[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PI_I[:]->cb_SO4_PR_OCW)/)/3.06) + forc_I=forc_I*1.e6 + end if + forc_II=(/(f1PD_II[:]->cb_SO4_A1)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A2)/)/3.59 + (/(f1PD_II[:]->cb_SO4_AC)/)/3.06 + (/(f1PD_II[:]->cb_SO4_NA)/)/3.06 + (/(f1PD_II[:]->cb_SO4_PR)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PD_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PD_II[:]->cb_SO4_PR_OCW)/)/3.06 + forc_II=forc_II-((/(f1PI_II[:]->cb_SO4_A1)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A2)/)/3.59 + (/(f1PI_II[:]->cb_SO4_AC)/)/3.06 + (/(f1PI_II[:]->cb_SO4_NA)/)/3.06 + (/(f1PI_II[:]->cb_SO4_PR)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A1_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_A2_OCW)/)/3.59 + (/(f1PI_II[:]->cb_SO4_AC_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_NA_OCW)/)/3.06 + (/(f1PI_II[:]->cb_SO4_PR_OCW)/)/3.06) + forc_II=forc_II*1.e6 + else if (plot_type.eq.4) then + var="dC_POM" + varname="Anthropogenic POM column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_POM)/)-(/(f1PI_I[:]->C_POM)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_OM)/)-(/(f1PI_I[:]->cb_OM)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_OM)/)-(/(f1PI_II[:]->cb_OM)/))*1.e6 + else if (plot_type.eq.5) then + var="dC_BC" + varname="Anthropogenic BC column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/))*1.e6 + else if (plot_type.eq.6) then + var="dC_DUST" + varname="Anthropogenic dust column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_DUST)/)-(/(f1PI_I[:]->C_DUST)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_DUST)/)-(/(f1PI_I[:]->cb_DUST)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_DUST)/)-(/(f1PI_II[:]->cb_DUST)/))*1.e6 + else if (plot_type.eq.7) then + var="dC_SS" + varname="Anthropogenic sea-salt column burden" + if(ModI.eq."CAM4-Oslo") then + forc_I=((/(f1PD_I[:]->C_SS)/)-(/(f1PI_I[:]->C_SS)/))*1.e6 + else + forc_I=((/(f1PD_I[:]->cb_SALT)/)-(/(f1PI_I[:]->cb_SALT)/))*1.e6 + end if + forc_II=((/(f1PD_II[:]->cb_SALT)/)-(/(f1PI_II[:]->cb_SALT)/))*1.e6 + else if (plot_type.eq.8) then + var="MECbcant" + varname="MEC for Anthropogenic BC" + aod_I=(/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/) + aod_II=(/f1PD_II[:]->D550_BC/)-(/f1PI_II[:]->D550_BC/) + if(ModI.eq."CAM4-Oslo") then + forc_I=(((/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/))/((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e3 + else + forc_I=(((/f1PD_I[:]->D550_BC/)-(/f1PI_I[:]->D550_BC/))/((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e3 + end if + forc_II=(((/f1PD_II[:]->D550_BC/)-(/f1PI_II[:]->D550_BC/))/((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e-3 + load_II=(((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e3 + else if (plot_type.eq.9) then + var="MACbcant" + varname="MAC for Anthropogenic BC" + aod_I=(/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/) + aod_II=(/f1PD_II[:]->A550_BC/)-(/f1PI_II[:]->A550_BC/) + if(ModI.eq."CAM4-Oslo") then + forc_I=(((/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/))/((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->C_BC)/)-(/(f1PI_I[:]->C_BC)/)))*1.e3 + else + forc_I=(((/f1PD_I[:]->A550_BC/)-(/f1PI_I[:]->A550_BC/))/((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e-3 + load_I=(((/(f1PD_I[:]->cb_BC)/)-(/(f1PI_I[:]->cb_BC)/)))*1.e3 + end if + forc_II=(((/f1PD_II[:]->A550_BC/)-(/f1PI_II[:]->A550_BC/))/((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e-3 + load_II=(((/(f1PD_II[:]->cb_BC)/)-(/(f1PI_II[:]->cb_BC)/)))*1.e3 + end if + end if + end if + end if + end if + end if + end if + end if + end if + end if + +; Calculating area weighted forcings + + forc_Ia=forc_I ; initialization of global average variable + forc_IIa=forc_II +if (plot_type.ge.8) then + aod_Ia=forc_I + aod_IIa=forc_II + load_Ia=forc_I + load_IIa=forc_II +end if + + xdims_I = dimsizes(gw0_I) + ;print(xdims_I) + ydims_I = dimsizes(forc_Ia) + ;print(ydims_I) + do i=0,dimsizes(gw0_I)-1 + forc_Ia(:,i,:)=forc_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + forcave_I=sum(dim_avg_n(forc_Ia,0))/area1 + +if (plot_type.ge.8) then + do i=0,dimsizes(gw0_I)-1 + aod_Ia(:,i,:)=aod_I(:,i,:)*coffa*dlon_I*gw0_I(i) + load_Ia(:,i,:)=load_I(:,i,:)*coffa*dlon_I*gw0_I(i) + end do + aodave_I=sum(dim_avg_n(aod_Ia,0))/area1 + loadave_I=sum(dim_avg_n(load_Ia,0))/area1 +end if + + xdims_II = dimsizes(gw0_II) + ;print(xdims_I) + ydims_II = dimsizes(forc_IIa) + ;print(ydims_II) + do i=0,dimsizes(gw0_II)-1 + forc_IIa(:,i,:)=forc_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + forcave_II=sum(dim_avg_n(forc_IIa,0))/area1 + +if (plot_type.ge.8) then + do i=0,dimsizes(gw0_II)-1 + aod_IIa(:,i,:)=aod_II(:,i,:)*coffa*dlon_II*gw0_II(i) + load_IIa(:,i,:)=load_II(:,i,:)*coffa*dlon_II*gw0_II(i) + end do + aodave_II=sum(dim_avg_n(aod_IIa,0))/area1 + loadave_II=sum(dim_avg_n(load_IIa,0))/area1 +end if + +; Defining color scales for each forcing variable +if (var .eq. "dDOD550") then + digg=(/-0.2,-.05,0,0.01,0.02,0.03,0.05,0.1,0.2,0.3/) + else if (var .eq. "dABS550") then + digg=(/-.01,0,0.001,0.002,0.003,0.005,0.01,0.02,0.03/) + else if (var .eq. "dCDNUMC2") then + digg=(/-0.1,0,0.1,0.2,0.3,0.5,1,2,5,10/) + else if (var .eq. "dC_SO4") then +; digg=(/0.05,0.1,0.2,0.3,0.5,1,1.5,2,3,5/) + digg=(/0,0.05,0.1,0.2,0.3,0.5,1,2,3,5/) + else if (var .eq. "dC_POM") then + digg=(/-5,-2.5,-1,-0.5,0,0.5,1,2.5,5,10,15/) + else if (var .eq. "dC_BC") then + digg=(/-0.2,-0.1,0,0.1,0.2,0.3,0.5,1,1.5,2/) + else if (var .eq. "dC_DUST".or.var .eq. "dC_SS") then + digg=(/-0.5,-0.3,-0.2,-0.1,0,0.1,0.2,0.3,0.5/) + else ; MECbcant + digg=(/1,2,3,4,5,7,10,15,20,30/) + end if + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + + wks = gsn_open_wks(format,var) + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap + res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + res@lbLabelBarOn = False + res@tmXBOn =False + res@tmXTOn =False + res@tmYLOn =False + res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 + res@txFontHeightF = 0.02 + res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels +; res@cnFillColors = (/3,4,5,6,7,8,9,0,10,11,12,13,14,15,16/) ; gir hvitt midt i ? +; res@cnFillColors = (/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/) + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) +; res@cnLevels = sprintf("%4.1f",digg) ; min level + res@cnLevels = sprintf("%5.3f",digg) ; min level + +; res@tiMainString = "CAM4-Oslo" +if (var.eq."dDOD550".or.var.eq."dABS550") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(forc_Ia,0))/area1)) +else if (var.eq."dCDNUMC2") then + if(ModI.eq."CAM4-Oslo") then + res@gsnRightString = "(CDNCINT*CLDTOT) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + else + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" + end if +else if (var.eq."dC_SO4") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" mg S m~S~-2~N~" +else if (var.eq."dC_POM".or.var.eq."dC_BC".or.var.eq."dC_DUST".or.var.eq."dC_SS") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1))+" mg m~S~-2~N~" +else if (var.eq."MECbcant".or.var.eq."MACbcant") then + res@gsnRightString = "avg = "+sprintf("%5.2f",forcave_I)+" ("+sprintf("%4.2f",aodave_I/loadave_I)+") m~S~2~N~ g~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_Ia,0))/area1)) +end if +end if +end if +end if +end if + res@gsnLeftString = varname + plot(0) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_I,0),res) ; create the plot + +; res@tiMainString = "CAM5-Oslo" +if (var.eq."dDOD550".or.var.eq."dABS550") then + res@gsnRightString = "avg = "+sprintf("%6.4f",(sum(dim_avg_n(forc_IIa,0))/area1)) +else if (var.eq."dCDNUMC2") then + res@gsnRightString = "(CDNUMC) avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" (10~S~6~N~ cm~S~-2~N~)" +else if (var.eq."dC_SO4") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" mg S m~S~-2~N~" +else if (var.eq."dC_POM".or.var.eq."dC_BC".or.var.eq."dC_DUST".or.var.eq."dC_SS") then + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+" mg m~S~-2~N~" +else if (var.eq."MECbcant".or.var.eq."MACbcant") then + res@gsnRightString = "avg = "+sprintf("%5.2f",forcave_II)+" ("+sprintf("%4.2f",aodave_II/loadave_II)+") m~S~2~N~ g~S~-1~N~" +else + res@gsnRightString = "avg = "+sprintf("%5.3f",(sum(dim_avg_n(forc_IIa,0))/area1))+"endre! W m~S~-2~N~" +end if +end if +end if +end if +end if + res@gsnLeftString = varname + plot(1) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(forc_II,0),res) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 +; pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/ModIvsModII/divPD-PI_Zonal_ModIvsModII.ncl b/tools/diagnostics/ncl/ModIvsModII/divPD-PI_Zonal_ModIvsModII.ncl new file mode 100644 index 0000000000..ed8bf5aa3b --- /dev/null +++ b/tools/diagnostics/ncl/ModIvsModII/divPD-PI_Zonal_ModIvsModII.ncl @@ -0,0 +1,350 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +; This ncl script reads in various 3d fields from two versions of NorESM/CAM-Oslo +; (PD and PI) and makes global plots of the anthropogenic (PD-PI) zonally and +; annually averaged variables. + +; Model independent constants + g=9.80665 + pi=3.1415926 + re=6378.39e3 ; earth radius in m + coffa=pi*re^2./180. + area1=4.*pi*re^2 + small=1.0e-15 ; small number + +; ************************************************************************* +; **** To be edited by the user if the ncl script is run interactively **** +; +; Define plot type and plot output format + if (.not. isvar("plot_type")) then ; is plot_type on command line? + plot_type = 4 ; 0 => CLOUD Cloud fraction + ; 1 => RH Relative humidity RELHUM + ; 2 => CLDLIQ Cloud liquid amount + ; 3 => CLDICE Cloud ice amount + ; 4 => RHW Relative humidity RHW + ; 5 => CDNC Cloud droplet number concentration + ; 6 => REFFL Cloud droplet effective radius +; ************************************************************************* + end if + if (.not. isvar("format")) then ; is format on command line? + format = "ps" +; format = "eps" +; format = "png" +; format = "pdf" + end if +; +; ************************************************************************* +; No changes by the user should be necessary below... +; ************************************************************************* +;old all_files_I = systemfunc ("ls /media/BackupAK/aerocomA2r128-tester/CTRL2000/aerocomA2r128_2006.cam2.h0.0007-*.nc") + all_filesPD_I = systemfunc ("ls " + filepathPD_I + filenamepPD_I + "*") + all_filesPD_II = systemfunc ("ls " + filepathPD_II + filenamepPD_II + "*") + f0PD_I = addfile (filepathPD_I+filenamePD_I, "r") + f0PD_II = addfile (filepathPD_II+filenamePD_II, "r") + f1PD_I = addfiles (all_filesPD_I, "r") ; note the "s" of addfile + f1PD_II = addfiles (all_filesPD_II, "r") ; note the "s" of addfile + all_filesPI_I = systemfunc ("ls " + filepathPI_I + filenamepPI_I + "*") + all_filesPI_II = systemfunc ("ls " + filepathPI_II + filenamepPI_II + "*") + f1PI_I = addfiles (all_filesPI_I, "r") ; note the "s" of addfile + f1PI_II = addfiles (all_filesPI_II, "r") ; note the "s" of addfile + + if (plot_type.eq.0) then + var="CLOUD" ; name of input-variable + varname="CLOUD" ; variable name used in text string + plot_name="dCLOUD_Zonal" ; name of the plot/figure + var_I = 1.e2*(/(f1PD_I[:]->CLOUD)/) - 1.e2*(/(f1PI_I[:]->CLOUD)/) + var_II = 1.e2*(/(f1PD_II[:]->CLOUD)/) - 1.e2*(/(f1PI_II[:]->CLOUD)/) + else if (plot_type.eq.1) then + var="RELHUM" ; name of input-variable and plot + varname="RH" ; variable name used in text string + plot_name="dRELHUM_Zonal" ; name of the plot/figure + var_I = (/(f1PD_I[:]->RELHUM)/) - (/(f1PI_I[:]->RELHUM)/) + var_II = (/(f1PD_II[:]->RHW)/) - (/(f1PI_II[:]->RHW)/) + else if (plot_type.eq.2) then + var="CLDLIQ" ; name of input-variable and plot + varname="Cloud liquid amount" ; variable name used in text string + plot_name="dCLDLIQ_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=1.e6*(/(f1PD_I[:]->CLDLIX)/) - 1.e6*(/(f1PI_I[:]->CLDLIX)/) ; if CAM4-Oslo only + else + var_I=1.e6*(/(f1PD_I[:]->CLDLIQ)/) - 1.e6*(/(f1PI_I[:]->CLDLIQ)/) + end if + var_II=1.e6*(/(f1PD_II[:]->CLDLIQ)/) - 1.e6*(/(f1PI_II[:]->CLDLIQ)/) + else if (plot_type.eq.3) then + var="CLDICE" ; name of input-variable and plot + varname="Cloud ice amount" ; variable name used in text string + plot_name="dCLDICE_Zonal" ; name of the plot/figure + var_I=1.e6*(/(f1PD_I[:]->CLDICE)/) - 1.e6*(/(f1PI_I[:]->CLDICE)/) + var_II=1.e6*(/(f1PD_II[:]->CLDICE)/) - 1.e6*(/(f1PI_II[:]->CLDICE)/) + else if (plot_type.eq.4) then + var="RELHUM" ; name of input-variable and plot + varname="RH" ; variable name used in text string + plot_name="dRHW_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = (/(f1PD_I[:]->RELHUM)/) - (/(f1PI_I[:]->RELHUM)/) + else + var_I = (/(f1PD_I[:]->RHW)/) - (/(f1PI_I[:]->RHW)/) + end if + var_II = (/(f1PD_II[:]->RHW)/) - (/(f1PI_II[:]->RHW)/) + else if (plot_type.eq.5) then + var="CDNC" ; name of plot + varname="CDNC" ; variable name used in text string + plot_name="dCDNC_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I = (/(f1PD_I[:]->CLOUD)/)*(/(f1PD_I[:]->CDNC)/)/((/(f1PD_I[:]->CLDFOC)/)+small) - (/(f1PI_I[:]->CLOUD)/)*(/(f1PI_I[:]->CDNC)/)/((/(f1PI_I[:]->CLDFOC)/)+small) + else + var_I = 1.e-6*(/(f1PD_I[:]->AWNC)/)/((/(f1PD_I[:]->FREQL)/)+small) - 1.e-6*(/(f1PI_I[:]->AWNC)/)/((/(f1PI_I[:]->FREQL)/)+small) + end if + var_II = 1.e-6*(/(f1PD_II[:]->AWNC)/)/((/(f1PD_II[:]->FREQL)/)+small) - 1.e-6*(/(f1PI_II[:]->AWNC)/)/((/(f1PI_II[:]->FREQL)/)+small) + else if (plot_type.eq.6) then + var="REFFL" ; name of plot + varname="REFFL" ; variable name used in text string + plot_name="dREFFL_Zonal" ; name of the plot/figure + if(ModI.eq."CAM4-Oslo") then + var_I=(/(f1PD_I[:]->REFFL)/)/((/(f1PD_I[:]->CLDFOC)/)+small) - (/(f1PI_I[:]->REFFL)/)/((/(f1PI_I[:]->CLDFOC)/)+small) + else + var_I=(/(f1PD_I[:]->AREL)/)/((/(f1PD_I[:]->FREQL)/)+small) - (/(f1PI_I[:]->AREL)/)/((/(f1PI_I[:]->FREQL)/)+small) + end if + var_II=(/(f1PD_II[:]->AREL)/)/((/(f1PD_II[:]->FREQL)/)+small) - (/(f1PI_II[:]->AREL)/)/((/(f1PI_II[:]->FREQL)/)+small) + end if + end if + end if + end if + end if + end if + end if +; printVarSummary(var_I) +; printVarSummary(var_II) + +;lat_I = f0_I->lat ; pull lat off file +;lat_II = f0_II->lat ; pull lat off file +lat_I = f0PD_I->lat ; pull lat off file +lat_II = f0PD_II->lat ; pull lat off file +;************************************************ +; calculate eta +;************************************************ + a=f0PD_I->hyam ; select hyam + b=f0PD_I->hybm ; select hybm + p=f0PD_I->P0 ; select P0 + eta = (a+b)*p ; calc eta + eta_I = eta/100 ; scale eta by 100 + a_II=f0PD_II->hyam ; select hyam + b_II=f0PD_II->hybm ; select hybm + p_II=f0PD_II->P0 ; select P0 + eta_II = (a_II+b_II)*p ; calc eta + eta_II = eta_II/100 ; scale eta by 100 + +; zave_I = dim_avg_Wrap(var_I) ; calculate zonal ave +; zave_II = dim_avg_Wrap(var_II) ; calculate zonal ave + zave_I = dim_avg_Wrap(var_I) + zave_II = dim_avg_Wrap(var_II) +; printVarSummary(zave_I) +; printVarSummary(zave_II) + +; Defining color scales for each meteorology variable +if (var.eq."CLOUD") then + digg=(/-1,-.5,-.1,0,0.1,0.5,1/) + else if (var .eq. "RELHUM") then + digg=(/-1,-.5,-.1,0,0.1,0.5,1/) + else if (var .eq. "CLDLIQ") then + digg=(/-.1,0,0.1,0.5,1,2,3/) + else if (var .eq. "CLDICE") then + digg=(/-0.2,-0.1,-0.05,0,0.05,0.1,0.2/) + else if (var .eq. "CDNC") then + digg=(/-.5,-0.1,0,0.1,0.5,1,2.5,5,10,15/) + else if (var .eq. "REFFL") then + digg=(/-1,-.5,-.1,0,0.1,0.5,1/) + else + digg=(/0.0,1.0/) ; Replace with error message + end if + end if + end if + end if + end if +end if + +;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Make the Plot +; +;;;;;;;;;;;;;;;;;;;;;;;;; + +;if (plot_type.eq.4) then +; wks = gsn_open_wks(format,"RHW") +;else +; wks = gsn_open_wks(format,var) + wks = gsn_open_wks(format,plot_name) +;end if + + gsn_define_colormap(wks,"amwg_blueyellowred") +; gsn_define_colormap(wks,"BlueDarkRed18") +; gsn_define_colormap(wks,"precip2_15lev") +; gsn_define_colormap(wks,"gui_default") +; gsn_define_colormap(wks,"hotres") + plot=new(2,graphic) + + res = True ; plot mods desired + res@gsnSpreadColors = False ; use full colormap +; res@mpFillOn = False + res@cnFillOn = True ; color fill + res@cnLinesOn = False ; no contour lines + res@cnLineLabelsOn = False + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame +; res@lbLabelBarOn = False +; res@tmXBOn =False +; res@tmXTOn =False +; res@tmYLOn =False +; res@tmYROn =False + res@cnMissingValFillPattern = 0 + res@cnMissingValFillColor = 16 + res@tiMainFontHeightF = 0.03 + res@tiMainFontThicknessF = 2 +; res@txFontHeightF = 0.02 +; res@cnFillMode = "RasterFill" ; Turn on raster fill + res@tiMainFont = "helvetica" + res@tmYRMode = "Automatic" + res@cnInfoLabelOn = False + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res@sfYArray = eta_I ; use eta for y axis + res@sfXArray = lat_I ; use lat for x axis + res@tiXAxisString = "latitude" ; x-axis label + res@tiYAxisString = "eta x 1000" ; y-axis label + res@trXReverse = False ; reverse x-axis + res@trYReverse = True ; reverse y-axis +; res@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res@cnLevels = sprintf("%7.5f",digg) ; min level + + res2 = True ; plot mods desired + res2@gsnSpreadColors = False ; use full colormap +; res2@mpFillOn = False + res2@cnFillOn = True ; color fill + res2@cnLinesOn = False ; no contour lines + res2@cnLineLabelsOn = False + res2@gsnFrame = False ; Do not draw plot + res2@gsnDraw = False ; Do not advance frame +; res2@lbLabelBarOn = False +; res2@tmXBOn =False +; res2@tmXTOn =False +; res2@tmYLOn =False +; res2@tmYROn =False + res2@cnMissingValFillPattern = 0 + res2@cnMissingValFillColor = 16 + res2@tiMainFontHeightF = 0.03 + res2@tiMainFontThicknessF = 2 +; res2@txFontHeightF = 0.02 +; res2@cnFillMode = "RasterFill" ; Turn on raster fill + res2@tiMainFont = "helvetica" + res2@tmYRMode = "Automatic" + res2@cnInfoLabelOn = False + res2@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + + res2@sfYArray = eta_II ; use eta for y axis + res2@sfXArray = lat_II ; use lat for x axis + res2@tiXAxisString = "latitude" ; x-axis label + res2@tiYAxisString = "eta x 1000" ; y-axis label + res2@trXReverse = False ; reverse x-axis + res2@trYReverse = True ; reverse y-axis +; res2@gsnYAxisIrregular2Log = True ; set y-axis to log scale + + res2@cnFillColors = (/3,5,6,8,9,10,11,12,13,14,15,16/) + res2@cnLevels = sprintf("%7.5f",digg) ; min level + +if (var .eq. "CLOUD") then + res@tiMainString = "Cloud Fraction (%)" +else if (var .eq. "RELHUM") then + if (plot_type.eq.4) then + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "Relative Humidity RELHUM (%)" + else + res@tiMainString = "Relative Humidity RHW (%)" + end if + else + if(ModI.eq."CAM4-Oslo") then + res@tiMainString = "Relative Humidity RELHUM (%)" + else + res@tiMainString = "Relative Humidity RELHUM (%)" + end if + end if +else if (var .eq. "CLDLIQ") then + res@tiMainString = "Cloud Liquid Water (mg kg~S~-1~N~)" +else if (var .eq. "CLDICE") then + res@tiMainString = "Cloud Ice (mg kg~S~-1~N~)" +else if (var .eq. "CDNC") then + if(ModI.eq."CAM4-Oslo") then +; res@tiMainString = "CDNC (CLDTOT*CDNC/CLDFOC) (cm~S~-3~N~)" + res@tiMainString = "CDNC (CDNC/CLDFOC) (cm~S~-3~N~)" + else +; res@tiMainString = "CDNC (AWNC) (cm~S~-3~N~)" + res@tiMainString = "CDNC (AWNC/FREQL) (cm~S~-3~N~)" + end if +else if (var .eq. "REFFL") then + if(ModI.eq."CAM4-Oslo") then +; res@tiMainString = "REFFL (CLDTOT*REFFL/CLDFOC) (~F33~m~F21~m)" + res@tiMainString = "REFFL (REFFL/CLDFOC) (~F33~m~F21~m)" + else +; res@tiMainString = "REFFL (AREL) (~F33~m~F21~m)" + res@tiMainString = "REFFL (AREL/FREQL) (~F33~m~F21~m)" + end if +end if +end if +end if +end if +end if +end if + plot(0) = gsn_contour(wks,dim_avg_n_Wrap(zave_I,0),res) ; create the plot + +if (var .eq. "CLOUD") then + res2@tiMainString = "Cloud Fraction (%)" +else if (var .eq. "RELHUM") then + if (plot_type.eq.4) then + if(ModI.eq."CAM4-Oslo") then + res2@tiMainString = "Relative Humidity RHW (%)" + else + res2@tiMainString = "Relative Humidity RHW (%)" + end if + else + if(ModI.eq."CAM4-Oslo") then + res2@tiMainString = "Relative Humidity RELHUM (%)" + else + res2@tiMainString = "Relative Humidity RELHUM (%)" + end if + end if +else if (var .eq. "CLDLIQ") then + res2@tiMainString = "Cloud Liquid Water (mg kg~S~-1~N~)" +else if (var .eq. "CLDICE") then + res2@tiMainString = "Cloud Ice (mg kg~S~-1~N~)" +else if (var .eq. "CDNC") then +; res2@tiMainString = "CDNC (AWNC) (cm~S~-3~N~)" + res2@tiMainString = "CDNC (AWNC/FREQL) (cm~S~-3~N~)" +else if (var .eq. "REFFL") then +; res2@tiMainString = "REFFL (AREL) (~F33~m~F21~m)" + res2@tiMainString = "REFFL (AREL/FREQL) (~F33~m~F21~m)" +end if +end if +end if +end if +end if +end if + plot(1) = gsn_contour(wks,dim_avg_n_Wrap(zave_II,0),res2) ; create the plot + + pres = True ; panel plot mods desired +; pres@gsnMaximize = True ; fill the page +; pres@txString = var + pres@txFontHeightF =0.015 + pres@txFontThicknessF =2 + pres@gsnPanelLabelBar = True + pres@lbLabelFontHeightF = 0.01 + pres@lbOrientation ="Vertical" + + gsn_panel(wks,plot,(/1,2/),pres) ; create panel plot + +end + diff --git a/tools/diagnostics/ncl/budgets/budgets.ncl b/tools/diagnostics/ncl/budgets/budgets.ncl new file mode 100644 index 0000000000..d9d6fb9c0b --- /dev/null +++ b/tools/diagnostics/ncl/budgets/budgets.ncl @@ -0,0 +1,175 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +if (.not. isvar("variableName")) then + variableName="BC_N" +end if + +model = "Oslo" + +if (model .eq. "Oslo") then + ;SOME PROCESSSES HAVE THE PROCESS-ID IN FRONT OF THE VAR-NAME + PRE_process=(/"SF","GS_","AQ_","DF_", "WD_A_"/) + PRE_reverse=(/False, False, False,False,False/) + ;SOME PROCESSES HAVE THE PROCESS-ID AFTER THE VAR-NAME + POST_process=(/"_mixnuc1","DDF","SFWET","condTend","coagTend","clcoagTend"/) + POST_reverse=(/False,True,False,False,False,False /) ;Dry dep is a loss, but plotted as positive! +else + ;MAM-MODEL + ;SOME PROCESSSES HAVE THE PROCESS-ID IN FRONT OF THE VAR-NAME + PRE_process=(/"SF","GS_","AQ_"/) + PRE_reverse=(/False, False, False/) + ;SOME PROCESSES HAVE THE PROCESS-ID AFTER THE VAR-NAME + POST_process=(/"_mixnuc1","DDF","SFWET","_sfcoag1","_sfcsiz3","_sfcsiz4","_sfgaex1","_sfgaex2","_sfnnuc1","AQH2SO4","AQSO4"/) + POST_reverse=(/False,True,False,False,False,False,False,False,False,False,False /) ;Dry dep is a loss, but plotted as positive! +end if + +;THE FILE NAME TO USE +;myFileName="/disk1/alfg/noresmrun/PTAER/MAM3_1YR_HR/MAM3_HR_NUDGE2_1979_AVG.nc" +myFileName="//disk1/oyvindse/NorESM2/aerbudgets/budgetfiles/NFAMIPNUDGEPTAERO_f09_f09_v519_so4n.cam.h0.1980.nc" + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; No changes by the user should be necessary below... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +myFile=addfile(myFileName,"r") + +; Get the gaussian weights +wgty = myFile->gw + +dim_PRE = dimsizes(PRE_process) +dim_POST = dimsizes(POST_process) +numberOfVariables = dim_PRE + dim_POST + +;Name of all the processes to print +process=new(numberOfVariables,string) +reverse=new(numberOfVariables,logical) +budget=new(numberOfVariables, float) + +;Do initial processing and construct variable names to take out +var_idx=0 +do while(var_idx .lt. dim_PRE) + str_array = (/PRE_process(var_idx), variableName/) + lookupVariable=str_concat(str_array) + process(var_idx) = lookupVariable + reverse(var_idx) = PRE_reverse(var_idx) + print("lookupVariable " + lookupVariable + " " + var_idx) + var_idx = var_idx + 1 +end do + +var_idx = 0 +do while(var_idx .lt. dim_POST) + str_array = (/ variableName, POST_process(var_idx)/) + lookupVariable=str_concat(str_array) + process(dim_PRE+var_idx) = lookupVariable + reverse(dim_PRE+var_idx)=POST_reverse(var_idx) + print("lookupVariable " + lookupVariable + " " + (dim_PRE + var_idx)) + var_idx = var_idx + 1 +end do + +print("NV " + numberOfVariables) + +;Do the plotting +format="pdf" +wks = gsn_open_wks(format,variableName) + +;Go through the variables and check if they are in the file +var_idx = 0 +numberOfVariablesUsed = 0 +fieldOK = new(numberOfVariables, logical) +do while(var_idx .lt. numberOfVariables) + budget(var_idx) = 0.0 + ;Check if field exists in file + lookupVariable = process(var_idx) + ;print("searching for variable " + lookupVariable) + fieldOK(var_idx) = isfilevarcoord(myFile, lookupVariable, "lon") + if(fieldOK(var_idx))then + numberOfVariablesUsed = numberOfVariablesUsed + 1 + else + ; print("Could not find field " + lookupVariable + " in file " + myFileName) + end if + var_idx = var_idx + 1 +end do + +print("Number of variables_USED " + numberOfVariablesUsed) + +plot=new(numberOfVariablesUsed,graphic) + +var_idx_used = 0 +var_idx=0 +nv_found = 0 +do while(var_idx .lt. numberOfVariables) + + lookupVariable = process(var_idx) + print("WILL TRY TO PLOT " + lookupVariable) + + if(fieldOK(var_idx))then + print ("field " + lookupVariable + " is ok") + myField= myFile->$lookupVariable$ + + ;Reverse field if field is plotted the wrong way.. + if(reverse(var_idx))then + myField = myField * (-1.0) + end if + + print("WILL PLOT " + lookupVariable + " in " + var_idx_used) + + ;Set intervals for plotting + maxPT = max(myField) + minPT = min(myField) + + maxint = 10 + intervals = fspan(minPT, maxPT, maxint) + + res = True ; plot mods desired + + res@cnFillOn = True ; color fill + ;res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + res@cnLevels = sprintf("%3.1e",intervals) + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + + glAve = wgt_areaave_Wrap(myField, wgty, 1.0, 1) + budget(var_idx)=glAve + + res@gsnLeftString = lookupVariable + avgString = " AVG = " + sprintf("%5.2e",glAve) + " [ "+ myField@units + " ]" + res@gsnRightString = avgString + + plot(var_idx_used) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(myField,0),res) ; create the plot + + var_idx_used = var_idx_used + 1 + end if + + var_idx=var_idx+1 + +;end do number of variables +end do + +var_idx=0 +totprod = 0.0 +totloss = 0.0 +do while(var_idx .lt. numberOfVariables) + print("BUDGET " + var_idx + " " + process(var_idx) + budget(var_idx)) + if(budget(var_idx) .gt. 0.0) then + totprod = totprod + budget(var_idx) + else + totloss = totloss + budget(var_idx)*(-1.0) + end if + var_idx = var_idx + 1 +end do + +totalBudget = totprod - totloss +totalBudgetString = variableName + " : PROD : " + sprintf("%5.2e",totprod) + "; LOSS : " + sprintf("%5.2e",totloss) + " ; NET : " + sprintf("%5.2e",totalBudget) + +print("FINAL STRING " + totalBudgetString) + +;create panel plot +pres = True +pres@txString=totalBudgetString +gsn_panel(wks,plot,(/4,3/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/budgets/budgets.sh b/tools/diagnostics/ncl/budgets/budgets.sh new file mode 100755 index 0000000000..d1c354d543 --- /dev/null +++ b/tools/diagnostics/ncl/budgets/budgets.sh @@ -0,0 +1,50 @@ +#!/bin/sh + +#Write heading for latex output document +echo "\\documentclass{beamer}" > output.tex +echo "\\usetheme{Frankfurt}" >> output.tex +echo "\\usepackage{color}" >> output.tex +echo "\\\\begin{document}" >> output.tex +echo "\\\\title{Component budgets}" >> output.tex +echo "\\\\frame{\\\\titlepage}" >> output.tex + +#Create the plots +#varlist="BC SO4 SS DUST OM BC_SRF SO4_SRF SS_SRF DUST_SRF OM_SRF SO2_SRF BC_CLOUD SO4_CLOUD SS_CLOUD DUST_CLOUD OM_CLOUD" +varlist="SO4_N SO4_NA SO4_A1 SO4_A2 SO4_AC SO4_PR BC_N BC_AC BC_AX BC_NI BC_A BC_AI OM_NI OM_AI OM_AC DST_A2 DST_A3 SS_A1 SS_A2 SS_A3 SOA_A1 SOA_N SOA_NA" +varlist2="" + +for var in $varlist +do + varlist2="$varlist2 $var ${var}_OCW" +done + +#for MAM, the above does not work, so uncomment the below for MAM +#varlist2="bc_a1 bc_c1 so4_a1 so4_a2 so4_a3 so4_c1 so4_c2 so4_c3 dst_a1 dst_a3 ncl_a1 ncl_a2 ncl_a3 ncl_c1 ncl_c2 ncl_c3 soa_a1 soa_a2 soa_c1 soa_c2 pom_a1 pom_c1" + +for var in $varlist2 +do + echo $var + varName=`echo $var|sed 's/_/\\\\_/g'` + echo $varName + expression=\'variableName=\"$var\"\' + cmd="ncl $expression ./budgets.ncl" + echo $cmd + eval $cmd + pdf2ps $var.pdf + ps2eps -f $var.ps + epstopdf $var.eps + + #add frame with result for this component + echo "\\\\begin{frame}{$varName - BUDGET}" > tmp.txt + echo '\\begin{center}' >> tmp.txt + echo "\\\\includegraphics[width=\\\\textwidth,height=0.8\\\\textheight]{$var.pdf}" >> tmp.txt + echo "\\\\end{center}" >> tmp.txt + echo "\\\\end{frame}" >> tmp.txt + + cat tmp.txt >> output.tex + +done + +echo "\\\\end{document}" >> output.tex + +pdflatex output.tex diff --git a/tools/diagnostics/ncl/budgets/lifetimes.ncl b/tools/diagnostics/ncl/budgets/lifetimes.ncl new file mode 100644 index 0000000000..c3f1537bfd --- /dev/null +++ b/tools/diagnostics/ncl/budgets/lifetimes.ncl @@ -0,0 +1,297 @@ + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl" + +begin + +MWH2SO4 = 98.0 +MWNH4HSO4 = 114.0 +MWScale = MWNH4HSO4/MWH2SO4 + +if (.not. isvar("variableName")) then + variableName="SS_A3_OCW" +end if + +model = "Oslo" + +if (model .eq. "Oslo") then + POST_process=(/"DDF","SFWET","SFSIC","SFSBC","SFSIS","SFSBS", "_mixnuc1"/) + POST_reverse=(/False,True,True,True,True,True,True /) ;Dry dep is a loss, but plotted as positive! +else + POST_process=(/"DDF","SFWET","SFSIC","SFSBC","SFSIS","SFSBS", "_mixnuc1"/) + POST_reverse=(/False,True,True,True,True,True,True /) ;Dry dep is a loss, but plotted as positive! +end if + +alternativeBurdenName="" +if(model .eq. "Oslo") + ;Some tracers are lumped tracers + if(variableName .eq. "sulfate")then + subTracerList=(/ "SO4_A1", "SO4_A2", "SO4_AC", "SO4_N","SO4_NA", "SO4_PR"/) + scaleFactor=(/ 1.0, MWScale , 1.0, 1.0, 1.0, 1.0, 1.0/) + else if (variableName .eq. "bc")then + subTracerList=(/ "BC_N", "BC_AX", "BC_NI", "BC_AC","BC_A", "BC_AI"/) + scaleFactor=(/ 1.0, 1.0 , 1.0, 1.0, 1.0, 1.0, 1.0/) + else if (variableName .eq. "om")then + subTracerList=(/ "OM_NI", "OM_AI","OM_AC", "SOA_N", "SOA_NA", "SOA_A1" /) + scaleFactor=(/ 1.0, 1.0 , 1.0, 1.0, 1.0, 1.0 /) + else if (variableName .eq. "dust") then + subTracerList=(/ "DST_A2", "DST_A3" /) + scaleFactor=(/ 1.0, 1.0 , 1.0 /) + else if (variableName .eq. "salt")then + subTracerList=(/ "SS_A1", "SS_A2", "SS_A3"/) + scaleFactor=(/ 1.0, 1.0 , 1.0 /) + else + subTracerList=(/variableName/) + scaleFactor=(/1.0/) + end if + end if + end if + end if + end if +else + ;Some tracers are lumped tracers + if(variableName .eq. "sulfate")then + alternativeBurdenName="BURDENSO4" + subTracerList=(/ "so4_a1", "so4_a2", "so4_a3"/) + scaleFactor=(/ 1.0, 1.0 , 1.0/) + else if (variableName .eq. "bc")then + alternativeBurdenName="BURDENBC" + subTracerList=(/ "bc_a1"/) + scaleFactor=(/ 1.0/) + else if (variableName .eq. "om")then + alternativeBurdenName="BURDENPOM" + subTracerList = (/"pom_a1"/) + scaleFactor = (/ 1.0 /) + else if (variableName .eq. "dust")then + alternativeBurdenName="BURDENDUST" + subTracerList = (/"dst_a1", "dst_a3"/) + scaleFactor = (/ 1.0, 1.0 /) + else if (variableName .eq. "salt")then + alternativeBurdenName="BURDENSEASALT" + subTracerList = (/"ncl_a1", "ncl_a2", "ncl_a3"/) + scaleFactor = (/ 1.0, 1.0, 1.0 /) + else + subTracerList=(/variableName/) + scaleFactor=(/1.0/) + end if + end if + end if + end if + end if +end if + +;THE FILE NAME TO USE +myFileName="/lustre/mnt/alfg/condTimeStep/R566SoaNucl/atm/hist/1982_1983_AVG.nc" +;myFileName="/disk1/alfg/noresmrun/PTAER/PTAERO1_1YR_HR/BF1NudgePD2000.cam.h0.1979_AVG.nc" + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; No changes by the user should be necessary below... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +myFile=addfile(myFileName,"r") + +; Get the gaussian weights +wgty = myFile->gw + +dim_PRE = 0 +dim_POST = dimsizes(POST_process) +numberOfVariables = dim_PRE + dim_POST +dim_SUBTRACER = dimsizes(subTracerList) + +;Name of all the processes to print +process=new((/numberOfVariables, dim_SUBTRACER/),string) +reverse=new(numberOfVariables,logical) +budget=new(numberOfVariables, float) + +print("NV " + numberOfVariables) + +;Do the plotting +format="pdf" +wks = gsn_open_wks(format,variableName) + +;Go through the variables and check if they are in the file +var_idx = 0 +numberOfVariablesUsed = 0 +fieldOK = new((/numberOfVariables,dim_SUBTRACER/), logical) + + + tracer_idx = 0 + do while (tracer_idx .lt. dim_SUBTRACER) + + ;Do initial processing and construct variable names to take out + varName2 = subTracerList(tracer_idx) + var_idx=0 + do while(var_idx .lt. dim_PRE) + str_array = (/PRE_process(var_idx), varName2/) + lookupVariable=str_concat(str_array) + process(var_idx,tracer_idx) = lookupVariable + reverse(var_idx) = PRE_reverse(var_idx) + print("lookupVariable " + lookupVariable + " " + var_idx) + var_idx = var_idx + 1 + end do + + var_idx = 0 + do while(var_idx .lt. dim_POST) + str_array = (/ varName2, POST_process(var_idx)/) + lookupVariable=str_concat(str_array) + process(dim_PRE+var_idx,tracer_idx) = lookupVariable + reverse(dim_PRE+var_idx)=POST_reverse(var_idx) + print("lookupVariable " + lookupVariable + " " + (dim_PRE + var_idx)) + var_idx = var_idx + 1 + end do + + ;This is the column + if(alternativeBurdenName .ne. "") then + cbFieldSum = myFile->$alternativeBurdenName$ + else + cbVarName = str_concat( (/"cb_",varName2/)) + print("column variable name is " + cbVarName) + + cbField= myFile->$cbVarName$ + + if(tracer_idx .eq. 0)then + cbFieldSum = cbField + else + cbFieldSum = cbFieldSum + cbField + end if + + ;Need to save the un-touched cbField since + ;coordinates are lost when multiplying by scale factor + tmpField = cbField + cbField = tmpField* scaleFactor(tracer_idx) + + copy_VarCoords(tmpField, cbField) + copy_VarCoords(cbField, cbFieldSum) + end if + + + var_idx = 0 + do while (var_idx .lt. dim_POST + dim_PRE) + ;Check if field exists in file + print("var_idx, tracer_idx" + var_idx +" "+ tracer_idx) + lookupVariable = process(var_idx,tracer_idx) + ;print("searching for variable " + lookupVariable) + fieldOK(var_idx,tracer_idx) = isfilevarcoord(myFile, lookupVariable, "lon") + if(fieldOK(var_idx,tracer_idx))then + if(tracer_idx .eq. 0)then + numberOfVariablesUsed = numberOfVariablesUsed + 1 + end if + else + ; print("Could not find field " + lookupVariable + " in file " + myFileName) + end if + var_idx = var_idx + 1 + end do + + tracer_idx = tracer_idx + 1 + end do ; tracers + +print("Number of variables_USED " + numberOfVariablesUsed) + +plot=new(numberOfVariablesUsed,graphic) + +budget(:) = 0.0 +var_idx_used = 0 +var_idx=0 +nv_found = 0 +do while(var_idx .lt. numberOfVariables) + + if(var_idx .lt. dim_PRE) + titleName = str_concat((/ model, " : ", variableName, " : ", PRE_process(var_idx)/) ) + else + titleName = str_concat( (/ model, " : ", variableName, " : ", POST_process(var_idx-dim_PRE) /)) + end if + print("TITLENAME " + titleName) + + if(fieldOK(var_idx,0))then + + tracer_idx = 0 + + do while(tracer_idx .lt. dim_SUBTRACER) + + print(" ") + lookupVariable = process(var_idx,tracer_idx) + print("WILL TRY TO ACCESS " + lookupVariable) + + if(fieldOK(var_idx, tracer_idx))then + print ("field " + lookupVariable + " is ok") + budgetField= myFile->$lookupVariable$*scaleFactor(tracer_idx) + else + print(" field " + lookupVariable + "not ok ==> set to zero") + budgetField = budgetField * 0.0; + end if + + ;Reverse field if field is plotted the wrong way.. + if(reverse(var_idx))then + print("reversing field " + lookupVariable) + budgetField = budgetField * (-1.0) + end if + + copy_VarCoords(cbFieldSum, budgetField) + + ;Sum budget over several processes... + if(tracer_idx .eq.0)then + print("Initializing budgetFieldSum") + budgetFieldSum = budgetField + else + budgetFieldSum = budgetFieldSum + budgetField + end if + + tracer_idx = tracer_idx + 1 + end do ; sub-tracers + + ;This is the lifetime + myField2 =cbFieldSum / (budgetFieldSum + 1.e-30)/3600.0/24.0 ; days + + copy_VarCoords(budgetField, myField2) + copy_VarCoords(budgetField, budgetFieldSum) + + print("WILL PLOT " + lookupVariable + " in " + var_idx_used) + + glAve1 = wgt_areaave_Wrap(budgetFieldSum, wgty, 1.0, 1) + glAve2 = wgt_areaave_Wrap(cbFieldSum, wgty, 1.0, 1) + + print("avg burden " + glAve2 + " / avg loss " + glAve1) + + if(abs(glAve1) .gt. 1.e-100)then + budget(var_idx)=(glAve2/glAve1)/3600.0/24.0 ;days + else + budget(var_idx) = 9999999; days + end if + + ;Set intervals for plotting + maxPT = budget(var_idx)*4.0 ;max(myField2) + minPT = budget(var_idx)*0.2 ; + + print("min/max " + minPT + " " + maxPT) + + maxint = 10 + intervals = fspan(minPT, maxPT, maxint) + + res = True ; plot mods desired + + res@cnFillOn = True ; color fill + res@cnLevelSelectionMode = "ExplicitLevels" ; manual levels + res@cnLevels = sprintf("%3.1e",intervals) + res@gsnFrame = False ; Do not draw plot + res@gsnDraw = False ; Do not advance frame + + res@gsnLeftString = titleName + avgString = " LIFETIME = " + sprintf("%5.2f",budget(var_idx)) + " [ "+ "days" + " ]" + res@gsnRightString = avgString + + print("Creating plot for var_idx used " + var_idx_used) + plot(var_idx_used) = gsn_csm_contour_map_ce(wks,dim_avg_n_Wrap(myField2,0),res) ; create the plot + + var_idx_used = var_idx_used + 1 + end if ; check if field OK + + var_idx=var_idx+1 + +;end do number of variables +end do + +;create panel plot +pres = True +gsn_panel(wks,plot,(/4,3/),pres) ; create panel plot + +end diff --git a/tools/diagnostics/ncl/budgets/lifetimes.sh b/tools/diagnostics/ncl/budgets/lifetimes.sh new file mode 100755 index 0000000000..f84dc70293 --- /dev/null +++ b/tools/diagnostics/ncl/budgets/lifetimes.sh @@ -0,0 +1,49 @@ +#!/bin/sh + +#Write heading for latex output document +echo "\\documentclass{beamer}" > output.tex +echo "\\usetheme{Frankfurt}" >> output.tex +echo "\\usepackage{color}" >> output.tex +echo "\\\\begin{document}" >> output.tex +echo "\\\\title{Component lifetimes}" >> output.tex +echo "\\\\frame{\\\\titlepage}" >> output.tex + +#Create the plots (for NorESM), individual components.. +varlist="SO4_N SO4_NA SO4_A1 SO4_A2 SO4_AC SO4_PR BC_N BC_AC BC_AX BC_NI BC_A BC_AI OM_NI OM_AI OM_AC DST_A2 DST_A3 SS_A1 SS_A2 SS_A3 SOA_N SOA_NA SOA_A1" +varlist2="" + +for var in $varlist +do + varlist2="$varlist2 $var ${var}_OCW" +done + +#for total budgets or MAM the above does not work, so uncomment the below for MAM +varlist2="bc om dust sulfate dust salt" + +for var in $varlist2 +do + echo $var + varName=`echo $var|sed 's/_/\\\\_/g'` + echo $varName + expression=\'variableName=\"$var\"\' + cmd="ncl $expression ./lifetimes.ncl" + echo $cmd + eval $cmd + pdf2ps $var.pdf + ps2eps -f $var.ps + epstopdf $var.eps + + #add frame with result for this component + echo "\\\\begin{frame}{$varName - BUDGET}" > tmp.txt + echo '\\begin{center}' >> tmp.txt + echo "\\\\includegraphics[width=\\\\textwidth,height=0.8\\\\textheight]{$var.pdf}" >> tmp.txt + echo "\\\\end{center}" >> tmp.txt + echo "\\\\end{frame}" >> tmp.txt + + cat tmp.txt >> output.tex + +done + +echo "\\\\end{document}" >> output.tex + +pdflatex output.tex diff --git a/tools/diagnostics/ncl/cloudBudgets/mg_budget_plot.py b/tools/diagnostics/ncl/cloudBudgets/mg_budget_plot.py new file mode 100644 index 0000000000..7a712080e1 --- /dev/null +++ b/tools/diagnostics/ncl/cloudBudgets/mg_budget_plot.py @@ -0,0 +1,909 @@ +import os +import sys +import gc +import pylab as p +from pylab import * +import numpy as np +import netCDF4 +from scipy import stats +from mpl_toolkits.basemap import cm,Basemap,maskoceans,shiftgrid,addcyclic +from matplotlib.colors import SymLogNorm +from matplotlib.ticker import LogFormatter +from matplotlib.ticker import SymmetricalLogLocator +import argparse +import os.path + +############################################################################################## +# READ DATA +############################################################################################## +# +# This is a script for plotting the the tendency terms that contribute to the total tendencies +# of the cloud microphysics scheme by Morrison and Gettelman in NorESM2/CAM5. +# +# Please edit this part of the script to read you input files and choose the budget you want +# to plot. +# +# The input file should be 3D output from NorESM2 with history_budget=.true. +# +# Currently the script reads only 1 time step and reads all variables from the same file. +# +# You can compare two files with diff=True. If diff is not PD-PI plaese edit the title section +# below or set a custom title. You can also turn off title by setting title=False. +# +# Projections +# map will give you lat-lon plots of column tendencies sorted by global average contribution to +# the total budget. +# zm will give you zonal mean projection of the zonal average tendencies sorted by global average +# contribution to the total budget. +# global will give you histogram of global average tendencies sorted by contribution to the total +# budget (Not so pretty yet). +# +# Written by Anna Lewinschal anna@misu.su.se +############################################################################################## + +stateName={'cldliq':'liquid', 'cldice':'ice'} +diffTitle={'normal':'', 'diff':'PD-PI'} +mgVersion={'MG10':10, 'MG15':15, 'MG20':20} + +if __name__ == '__main__': + + parser = argparse.ArgumentParser() + parser.add_argument('--version',choices=['MG10','MG15','MG20'],default='MG10',help='MG-version') + parser.add_argument('--plottype',choices=['normal','diff'],default='normal') + parser.add_argument('--projection',choices=['map','zm','global'],default='global',help='desired plot type') + parser.add_argument('--state',choices=['cldliq','cldice'],default='cldliq') + parser.add_argument('--budget',choices=['mass','number'],default='mass') + parser.add_argument('--inputFile', default="/lustre/storeB/users/alfg/CESM1_5/MGRuns/MG10PDb2d4Free/atm/hist/MG10PDb2d4Free_YA_0003_0004.nc") + parser.add_argument('--diffInputFile', default="") + parser.add_argument('--outputFile',default="result.png") + parser.add_argument('--icenucleation',choices=['cam53',"classnuc","bestguess"],default="bestguess") + args = parser.parse_args() + + # Choose budget + + # Mass or number? + budget= args.budget + + # Liquid or ice? + state = args.state + + # Plot projection + proj = args.projection + + print( "YOUR CONFIG: "+budget + " " + state +" " + proj + " " + args.version + " " + args.inputFile) + # Diffplot? + diff = (args.plottype == 'diff') + + # Number of panels to show + # 8 panels works best for map + # 10 works for zm + panels = 10 + pan_row = 2 + pan_col = panels/pan_row + + # For histogram: number of bars: + nbars = 9 + + # colours + bar_colour =(0.2,0.3,0.9) # a blue colour + bar_colour_bdgt = (0.9,0.4,0.5) # a pink colour + + # Set y-axis limits + ###################### + #y-limits for ice mass + qi_ymin=-1.0e-9 + qi_ymax=1.0e-9 + + # Poster: y-limits for liquid mass + qc_ymin=-2.1e-9 + qc_ymax=0.5e-9 + + # Poster: y-limits for ice number + ni_ymin=-3.5 + ni_ymax=2.5 + + # Poster: y-limits for liquid number + nc_ymin=-150 + nc_ymax=650 + + # font sizes + ############### + # axis label + ax_fsz = 14 + # tick label + tk_fsz = 12 + # title + tt_fsz = 16 + + # figure size + fg_sz_x=9 + fg_sz_y=7 + + # Logscale for plotting? + logscale = False + logscale = True + + # Output from MG1.0 or MG1.5 + usedMGVersion=mgVersion[args.version] + + #ice nucleation scheme uses classnuc + use_classnuc=False + if(args.icenucleation == "bestguess"): + if usedMGVersion > 15: + use_classnuc=True + if(args.icenucleation == "classnuc"): + use_classnuc=True + + plottitle=stateName[args.state] + " " + budget+ " budget " + args.version + plottitle+= " " +diffTitle[args.plottype] + + + # Custom title + #plottitle = 'Your title' + + # Don't want title? + #title=False + title=True + + if not (os.path.exists(args.inputFile)): + print("inputfile : " + args.inputFile + "does not exist") + sys.exit(1) + + ############################################################################################## + # Read netcdf file + id_nc = netCDF4.Dataset(args.inputFile) + + if (os.path.exists(args.diffInputFile)): + id_nc2 = netCDF4.Dataset(args.diffInputFile) + + + ############################################################################################## + # No need to edit anything in the sections below + ############################################################################################## + ############################################################################################## + ############################################################################################## + # Define variables + n_var = list() + n_var_long = list() + + # Number budget + if budget == 'number': + if state == 'cldliq': + + n_var.append('MPDNLIQ'), n_var_long.append('CLDNLIQ tendency - Morrison microphysics') + n_var.append('NPSACWSO'), n_var_long.append('NC tendency accretion by snow') + n_var.append('NSUBCO'), n_var_long.append('NC tendency evaporation of droplet') # this is zero! + n_var.append('NPRAO'), n_var_long.append('NC tendency accretion') + n_var.append('NPRC1O'), n_var_long.append('NC tendency autoconversion') + n_var.append('NQCSEDTEN'), n_var_long.append('NC tendency sedimentation') + n_var.append('NMELTO'), n_var_long.append('NC tendency melting') + n_var.append('NHOMOO'), n_var_long.append('NC tendency homogeneous freezing') + n_var.append('NPCCNO'), n_var_long.append('NC activation') + n_var.append('NCTNNCLD'), n_var_long.append('NC removal no cloud water') + n_var.append('NCTNSZMN'), n_var_long.append('NC $\gamma$-distribution adjustment min slope') + n_var.append('NCTNSZMX'), n_var_long.append('NC $\gamma$-distribution adjustment max slope') + + if usedMGVersion == 10: + n_var.append('NCTNCONS'), n_var_long.append('correction for conservation of NC') + n_var.append('NCTNNBMN'), n_var_long.append('NC correction min number') + + elif state == 'cldice': + n_var.append('MPDNICE'), n_var_long.append('CLDNICE tendency - Morrison microphysics') + n_var.append('NQISEDTEN'), n_var_long.append('NI tendency sedimentation') + n_var.append('NIMELTO'), n_var_long.append('NI tendency melting') + n_var.append('NIHOMOO'), n_var_long.append('NI tendency homogeneous freezing') + n_var.append('NSACWIO'), n_var_long.append('NI tendency from HM') + n_var.append('NSUBIO'), n_var_long.append('NI tendency evaporation') + n_var.append('NPRCIO'), n_var_long.append('NI tendency autoconversion snow') + n_var.append('NPRAIO'), n_var_long.append('NI tendency accretion snow') + n_var.append('NNUDEPO'), n_var_long.append('NI deposition') + n_var.append('NNUCCDO'), n_var_long.append('NI nucleation') + n_var.append('NITNCONS'), n_var_long.append('correction for conservation of NI') + n_var.append('NITNNCLD'), n_var_long.append('NI removal no cloud ice') + n_var.append('NITNSZMN'), n_var_long.append('NI $\gamma$-distribution adjustment min slope') + n_var.append('NITNSZMX'), n_var_long.append('NI $\gamma$-distribution adjustment max slope') + + if usedMGVersion==20: + n_var.append('NFRZR'), n_var_long.append('Freezing of rain droplets to snow') + n_var.append('NNUCCRI'),n_var_long.append('Freezing of rain droplets to ice') + + #Immersion freezing is only included in ice budget if "classnuc_ice" is used + if (state=='cldice') and (not use_classnuc): + #don't include immersion freezing in budget + dontDoAnyThingHere = True + else: + #immersion freezing is included in all budgets + n_var.append('NNUCCCO'), n_var_long.append('NC/NI tendency immersion freezing') + # contact freezing In both cloud liquid and ice states: + n_var.append('NNUCCTO'), n_var_long.append('NC/NI tendency contact freezing') + + # Mass budget + elif budget == 'mass': + if state == 'cldliq': + + n_var.append('MPDLIQ'), n_var_long.append('CLDLIQ tendency - Morrison microphysics') + n_var.append('BERGSO'), n_var_long.append('Conv. of cloud water to snow from bergeron') + n_var.append('QCRESO'), n_var_long.append('Residual condensation term for cloud water ') + n_var.append('PRCO'), n_var_long.append('Autoconversion of cloud water') + n_var.append('PRAO'), n_var_long.append('Accretion of cloud water by rain') + n_var.append('PSACWSO'), n_var_long.append('Accretion of cloud water by snow') + n_var.append('QCSEDTEN'), n_var_long.append('CLDLIQ tend. from sedimentation') + + + elif state == 'cldice': + n_var.append('MPDICE'), n_var_long.append('CLDICE tendency - Morrison microphysics') + n_var.append('CMEIOUT'), n_var_long.append('Rate of dep-subl of ice within the cloud') + n_var.append('QIRESO'), n_var_long.append('Residual dep term for cloud ice ') + n_var.append('PRCIO'), n_var_long.append('Autoconversion of cloud ice') + n_var.append('PRAIO'), n_var_long.append('Accretion of cloud ice by snow') + n_var.append('QISEDTEN'), n_var_long.append('CLDICE tendency from sedimentation') + n_var.append('MNUDEPO'), n_var_long.append('deposition') + + if usedMGVersion==20: + n_var.append('FRZR'), n_var_long.append('Freezing of rain droplets to snow') + n_var.append('MNUCCRI'),n_var_long.append('Freezing of rain droplets to ice') + + # In both cloud liquid and ice budgets: + n_var.append('BERGO'), n_var_long.append('Conv. of cloud water to ice from bergeron') + n_var.append('MNUCCCO'), n_var_long.append('Immersion freezing of cloud water') + n_var.append('MNUCCTO'), n_var_long.append('Contact freezing of cloud water') + n_var.append('HOMOO'), n_var_long.append('Homogeneous freezing of cloud water') + n_var.append('MELTO'), n_var_long.append('Melting of cloud ice') + n_var.append('MSACWIO'), n_var_long.append('Conv. of cloud water from rime-splintering') + + + + + + # Read dimensions + lat = id_nc.variables['lat'][:] + lon = id_nc.variables['lon'][:] + lev = id_nc.variables['lev'][:] + hyai = id_nc.variables['hyai'][:] + hybi = id_nc.variables['hybi'][:] + ps = id_nc.variables['PS'][:] + if diff: + ps2 = id_nc2.variables['PS'][:] + + varnb = len(n_var) + varnb2 = varnb+1 + # Read variables + + var = empty((varnb,len(lev),len(lat),len(lon)), dtype=float32) + if diff: + var2 = empty((varnb,len(lev),len(lat),len(lon)), dtype=float32) + + for i in range(0,varnb): + var[i] = id_nc.variables[n_var[i]][:,:,:,:] # time, lev, lat, lon + if diff: + var2[i] = id_nc2.variables[n_var[i]][:,:,:,:] # time, lev, lat, lon + + + + # change sign + if budget == 'number': + if state == 'cldliq': + if n_var[i] == 'NNUCCCO' \ + or n_var[i] == 'NNUCCTO' \ + or n_var[i] == 'NPSACWSO'\ + or n_var[i] == 'NPRAO' \ + or n_var[i] == 'NPRC1O' \ + or n_var[i] == 'NCRES' \ + or n_var[i] == 'NHOMOO' \ + or n_var[i] == 'NCTNCONS'\ + or n_var[i] == 'NCTNNBMN'\ + or n_var[i] == 'NCTNSZMN'\ + or n_var[i] == 'NCTNSZMX'\ + or n_var[i] == 'NCTNNCLD': + var[i]=-var[i] + if diff: + var2[i]=-var2[i] + + elif state == 'cldice': + if n_var[i] == 'NPRCIO' \ + or n_var[i] == 'NPRAIO' \ + or n_var[i] == 'NIRES' \ + or n_var[i] == 'NITNCONS'\ + or n_var[i] == 'NITNNBMN'\ + or n_var[i] == 'NITNSZMN'\ + or n_var[i] == 'NITNSZMX'\ + or n_var[i] == 'NITNNCLD'\ + or n_var[i] == 'NIMELTO' : + var[i]=-var[i] + if diff: + var2[i]=-var2[i] + + elif budget == 'mass': + if state == 'cldliq': + if n_var[i] == 'BERGSO' \ + or n_var[i] == 'PRCO' \ + or n_var[i] == 'PRAO' \ + or n_var[i] == 'PSACWSO' \ + or n_var[i] == 'BERGO' \ + or n_var[i] == 'MNUCCCO' \ + or n_var[i] == 'MNUCCTO' \ + or n_var[i] == 'HOMOO' \ + or n_var[i] == 'MSACWIO' : + var[i]=-var[i] + if diff: + var2[i]=-var2[i] + elif state == 'cldice': + if n_var[i] == 'PRCIO' \ + or n_var[i] == 'PRAIO' \ + or n_var[i] == 'MELTO': + var[i]=-var[i] + if diff: + var2[i]=-var2[i] + # Close file + id_nc.close() + if diff: + id_nc2.close() + + ############################################################################################## + + + # vertical pressure coordinate + dp = zeros_like(var[0,:,:,:]) + if diff: + dp2 = zeros_like(var[0,:,:,:]) + + for i in range(0,len(hyai)-1): + p1 = hyai[i]*100000.+hybi[i]*ps + p2 = hyai[i+1]*100000.+hybi[i+1]*ps + dp[i,:,:] = p2 -p1 + if diff: + p12 = hyai[i]*100000.+hybi[i]*ps2 + p22 = hyai[i+1]*100000.+hybi[i+1]*ps2 + dp2[i,:,:] = p22 -p12 + + + # horizontal grid etc. + lat_d = (lat[10]-lat[9])*np.pi/180. + lon_d = (lon[10]-lon[9])*np.pi/180. + R=6371000. + lon2d,lat2d = np.meshgrid(lon,lat) + + + # Shift function + def shiftcyclic(in_var): + var_s, lons = shiftgrid(180., in_var, lon, start=False,cyclic=360.0) + var_sc, lonscout = addcyclic(var_s,lons) + return var_sc,lonscout + + + # Zonal mean + ######################################################### + if proj == 'zm': + var_zm = zeros((varnb,len(lev),len(lat)), dtype=float32) + if diff: + var_zm2 = zeros((varnb,len(lev),len(lat)), dtype=float32) + + for i in range(0,varnb): + var_zm[i,:,:] = np.average(var[i,:,:,:],2) + if diff: + var_zm2[i,:,:] = np.average(var2[i,:,:,:],2) + + budg_zm = sum(var_zm[1:varnb],0) + if diff: + budg_zm2 = sum(var_zm2[1:varnb],0) + + n_var.append(n_var[0]+'-BDGT'), n_var_long.append(n_var[0]+'-Sum of all terms') + budg_zm = np.expand_dims(budg_zm,0) + var_zm = np.append(var_zm,budg_zm,axis=0) + if diff: + n_var.append(n_var[0]+'-BDGT'), n_var_long.append(n_var[0]+'-Sum of all terms') + budg_zm2 = np.expand_dims(budg_zm2,0) + var_zm2 = np.append(var_zm2,budg_zm2,axis=0) + + var_zm = var_zm - var_zm2 + + # MG tendency-budget in last position + var_zm[varnb2-1] = var_zm[0]-var_zm[varnb2-1] + + + + # 2D map projection and global average (which is always calculated for sorting) + ############################################################## + + var_v = zeros((varnb,len(lat),len(lon)), dtype=float32) + var_vs = zeros((varnb,len(lat),len(lon)+1), dtype=float32) + var_g = zeros((varnb), dtype=float32) + atm = zeros((len(lat),len(lon))) + if diff: + var_v2 = zeros((varnb,len(lat),len(lon)), dtype=float32) + var_vs2 = zeros((varnb,len(lat),len(lon)+1), dtype=float32) + var_g2 = zeros((varnb), dtype=float32) + atm2 = zeros((len(lat),len(lon))) + + + # Vertical integration of cloud variables + for i in range(0,varnb): + for k in range(0, len(lev)): + var_v[i,:,:] = var_v[i,:,:] + var[i,k,:,:]*dp[k,:,:]/9.81 + if diff: + var_v2[i,:,:] = var_v2[i,:,:] + var2[i,k,:,:]*dp2[k,:,:]/9.81 + # global sum + var_g[i] = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),var_v[i,:,:])) + var_vs[i,:,:],lonsc = shiftcyclic(var_v[i,:,:]) + if diff: + var_g2[i] = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),var_v2[i,:,:])) + var_vs2[i,:,:],lonsc = shiftcyclic(var_v2[i,:,:]) + + # Vertical integration of the atmosphere + for k in range(0, len(lev)): + atm = atm + dp[k,:,:]/9.81 + if diff: + atm2 = atm2 + dp2[k,:,:]/9.81 + + # Mass of the atmosphere + atm_g = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),atm)) + + # MG budget (sum of all terms) + budg_vs = sum(var_vs[1:varnb],0) + + # Global sum of budget + budg_g = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),budg_vs[:,0:len(lon)])) + + + if proj == 'map': + n_var.append(n_var[0]+'-BDGT'), n_var_long.append(n_var[0]+'-Sum of all terms') + elif proj == 'global': + n_var.append('BDGT'), n_var_long.append('Sum of all terms') + + budg_vs = np.expand_dims(budg_vs,0) + + if diff: + atm_g2 = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),atm2)) + budg_vs2 = sum(var_vs2[1:varnb],0) + budg_g2 = np.sum(np.multiply(lat_d*lon_d*R*R*cos(np.pi*lat2d/180.),budg_vs2[:,0:len(lon)])) + budg_vs2 = np.expand_dims(budg_vs2,0) + + + + # Global sum of cloud variables divided by mass of atmosphere + var_g = np.append(var_g,budg_g)/atm_g + var_vs = np.append(var_vs,budg_vs,axis=0) + if diff: + var_g2 = np.append(var_g2,budg_g2)/atm_g2 + var_vs2 = np.append(var_vs2,budg_vs2,axis=0) + + var_vs = var_vs-var_vs2 + var_g = var_g-var_g2 + + + # Sort variables according to global mean + var_g_sorted = zeros(varnb2,dtype=int8) + + var_g_sorted[1:varnb] = np.argsort(-abs(var_g[1:varnb]))+1 + + + # Difference btw MG tend and bdg in last position + if proj != 'global': + + var_vs[varnb2-1] = var_vs[0]-var_vs[varnb2-1] + var_g[varnb2-1] = var_g[0]-var_g[varnb2-1] + + + + ############################################################################################## + # PLOT FUNCTIONS + ############################################################################################## + # + # X Axis Information (Longitude) + ################################## + x_min = -180 + x_max = 180 + #delta_x = 5 + majorLocator_x = MultipleLocator(60) + minorLocator_x = MultipleLocator(10) + minorLocator_x_south = MultipleLocator(1) + xlab = 'longitude' + + # + # Y Axis Information (Latitude) + ################################## + y_min = -90 + y_max = 90 + delta_y = 2 + majorLocator_y = MultipleLocator(30) + minorLocator_y = MultipleLocator(10) + ylab = 'latitude' + + # + # Z Axis Information (Pressure/height) + ################################## + z_min = max(lev) # Reverse Y-axis + z_max = min(lev) + #delta_x = 2 + #majorLocator_x = MultipleLocator(30) + #minorLocator_x = MultipleLocator(10) + zlab = 'level' + + # + # Defined DEGREE X AXIS + ################################## + def degree(x, pos): + # 'The two args are the value and tick position' + if x < 0: + return "%1.f$^{\circ}$W" % abs(x) + if x > 0: + return "%1.f$^{\circ}$E" % (x) + if x == 0: + return "%1.f$^{\circ}$" % (x) + formatter = FuncFormatter(degree) + + # + # Defined DEGREE Y AXIS + ################################## + def degreey(y, pos): + # 'The two args are the value and tick position' + if y < 0: + return "%1.f$^{\circ}$S" % abs(y) + if y > 0: + return "%1.f$^{\circ}$N" % (y) + if y == 0: + return "EQ" % (y) + formatter2 = FuncFormatter(degreey) + + # + # Define PLOTS: + ##################################################################################### + ##################################################################################### + def plot_bar(): + + + np_var = np.array(n_var) + + var_g_sorted_hist = zeros(varnb2,dtype=int8) + var_g_sorted_hist[2:varnb2] = var_g_sorted[1:varnb] + var_g_sorted_hist[1]=varnb2-1 + + + #var_g_s = var_g[:10].copy() + #print var_g_s + + var_g_h = var_g.copy() + var_g_h[:varnb2-1]=0 + var_g_h[0]=var_g[0] + + #print var_g_sorted_hist + + + var_g_s = var_g[var_g_sorted_hist] + var_g_hs = var_g_h[var_g_sorted_hist] + + + + # Poster: font side for axis label here. + if budget == 'number': + ax.set_ylabel('Number [1/kg/s]', fontsize=ax_fsz) + elif budget == 'mass': + ax.set_ylabel('Mass [kg/kg/s]', fontsize=ax_fsz) + + #xpos=arange(1,varnb2+1) + xpos=arange(1,nbars+1) + + c = ax.bar(xpos,var_g_s[:nbars],color=bar_colour) + c = ax.bar(xpos,var_g_hs[:nbars],color=bar_colour_bdgt) + + fig.subplots_adjust(hspace=None) + xticks(arange(1,nbars+1)+0.4,np_var[var_g_sorted_hist], fontsize=tk_fsz, rotation =30) + + ax.hlines(0,0.4, nbars+1+0.4, colors='k', linestyles='solid' ) + + if budget == 'mass': + if state == 'cldice': + if diff: + p_min = -1*1e-10 + else: + ax.set_ylim(qi_ymin,qi_ymax) + else: #liq + ax.set_ylim(qc_ymin,qi_ymax) + else: # number + if state == 'cldice': + if diff: + p_min = -1*1e-10 + else: + ax.set_ylim(nc_ymin,nc_ymax) + else: #liq + ax.set_ylim(nc_ymin,nc_ymax) + ax.set_title('Global average '+plottitle) + ##################################################################################### + ##################################################################################### + def plot_zm(): + + tfs = '12' # title font size + lfs = '12' # label font size + cfs = '10' + + + # linear scale + if budget == 'number': + if state == 'cldice': + if diff: + p_min = -1*1e1 + else: + p_min = -1*1e2 + else: #liquid + if diff: + p_min = -1*1e3 + else: + p_min = -1*1e3 + #p_min = -5*1e1 + if budget == 'mass': + if state == 'cldice': + if diff: + p_min = -1*1e-10 + else: + p_min = -5*1e-9 + else: #liquid + if diff: + p_min = -1*1e-10 + else: + p_min = -5*1e-9 + + p_max = -p_min + lvls1 = linspace(p_min,p_max,21) + + cmap = 'seismic' + if logscale: + cmap = 'RdBu_r' + + + # Log scale + if budget == 'number': + if state == 'cldliq': + max_log = 5 + min_log = -2 + else : # ice + max_log = 5 + min_log = -2 + elif budget == 'mass': + if state == 'cldliq': + max_log = -8 + min_log = -15 + else : # ice + max_log = -8 + min_log = -15 + + thresh = 10**min_log + num_log = (max_log-min_log+1)*1 + lvls_lp = logspace(min_log, max_log, num=num_log, endpoint=True, base=10.0) + lvls_ln = -lvls_lp + lvls_lpn = zeros((2*num_log+1)) + lvls_lpn[0:num_log]=lvls_ln[::-1] + lvls_lpn[num_log]=0 + lvls_lpn[num_log+1:2*num_log+1]=lvls_lp + + + i = 0 + for m in range(0,pan_row): + for n in range(0,pan_col): + + if i == 0: + j = var_g_sorted[i] # variable index + elif i ==1: + j = varnb2-1 + else: + j = var_g_sorted[i-1] # variable index + + ax[m,n].set_ylabel(zlab, fontsize=lfs) + + #c1 = ax[m,n].contourf(lat,lev,var_zm[j],levels=lvls1) + + # Plotting + if logscale: + c1 = ax[m,n].contourf(lat,lev,var_zm[j,:,:],levels=lvls_lpn,norm=SymLogNorm(thresh),extend='both') + else: + c1 = ax[m,n].contourf(lat,lev,var_zm[j],levels=lvls1,extend='both') + + # Set title + if budget == 'number': + unit_str = ' #kg$^{-1}$s$^{-1}$' + elif budget == 'mass': + unit_str = ' kgkg$^{-1}$s$^{-1}$' + ax[m,n].set_title(n_var[j]+unit_str, fontsize=tfs) + + # Axis ticks + ax[m,n].set_ylim(z_min,z_max) + ax[m,n].xaxis.set_major_formatter(formatter2) + ax[m,n].xaxis.set_major_locator(majorLocator_y) + ax[m,n].xaxis.set_minor_locator(minorLocator_y) + ax[m,n].set_xlim(y_min,y_max) + + # Colourbar + if logscale: + #l_f = LogFormatter(10, labelOnlyBase=False) + l_f = LogFormatterMathtext(base=10, labelOnlyBase=True) + cb1 = colorbar(c1,ax=ax[m,n],format=l_f) + #cb1 = colorbar(c1,ax=ax[m,n]) + else: + cb1 = colorbar(c1,ax=ax[m,n]) + c1.set_cmap(cmap) + + i=i+1 + + + ######################################################################################## + ######################################################################################## + def plot_map(): + + if pan_row > pan_col: + tfs = '11' # title font size + lfs = '10' # label font size + cfs = '8' + else: + tfs = '12' # title font size + lfs = '12' # label font size + cfs = '10' + + # linear scale + if budget == 'number': + if state == 'cldice': + if diff: + p_min = -1*1e4 + else: + p_min = -1*1e5 + else: #liquid + if diff: + p_min = -5*1e6 + else: + p_min = -1*1e7 + #p_min = -5*1e1 + if budget == 'mass': + if state == 'cldice': + if diff: + p_min = -1*1e-6 + else: + p_min = -1*1e-5 + else: #liquid + if diff: + p_min = -1*1e-6 + else: + p_min = -5*1e-5 + #p_min = -5*1e1 + p_max = -p_min + lvls = linspace(p_min,p_max,21) + lvls2 = linspace(-5*1e-10,5*1e-10,21) + lvls3 = linspace(-5*1e-11,5*1e-11,21) + lvls1 = linspace(-2*1e-8,2*1e-8,21) + + # Log scale + if budget == 'number': + if state == 'cldliq': + max_log = 7 + min_log = 0 + else : # ice + max_log = 7 + min_log = 0 + elif budget == 'mass': + if state == 'cldliq': + max_log = -4 + min_log = -11 + else : # ice + max_log = -4 + min_log = -11 + + thresh = 10**min_log + num_log = (max_log-min_log+1)*1 + lvls_lp = logspace(min_log, max_log, num=num_log, endpoint=True, base=10.0) + lvls_ln = -lvls_lp + lvls_lpn = zeros((2*num_log+1)) + lvls_lpn[0:num_log]=lvls_ln[::-1] + lvls_lpn[num_log]=0 + lvls_lpn[num_log+1:2*num_log+1]=lvls_lp + + + cmap = 'seismic' + if logscale: + cmap = 'RdBu_r' + + i=0 + for m in range(0,pan_row): + for n in range(0,pan_col): + + if i == 0: + j = var_g_sorted[i] # variable index + elif i ==1: + j = varnb2-1 + else: + j = var_g_sorted[i-1] # variable index + + + # ax[m,n].set_xlabel(xlab, fontsize=lfs) + # ax[m,n].set_ylabel(ylab, fontsize=lfs) + + m1 = Basemap(projection='cyl',llcrnrlat=-90,urcrnrlat=90,\ + llcrnrlon=-180,urcrnrlon=180,resolution='c',ax=ax[m,n]) + + if logscale: + c1 = ax[m,n].contourf(lonsc,lat,var_vs[j,:,:],levels=lvls_lpn,norm=SymLogNorm(thresh),extend='both') + else: + c1 = ax[m,n].contourf(lonsc,lat,var_vs[j,:,:],levels=lvls,extend='both') + + m1.drawcoastlines() + + # Set title + if budget == 'number': + unit_str = ' #m$^{-2}$s$^{-1}$ Average: ' + unit_str2 = ' #kg$^{-1}$s$^{-1}$' + elif budget == 'mass': + unit_str = ' kgm$^{-2}$s$^{-1}$ Average: ' + unit_str2 = ' kgkg$^{-1}$s$^{-1}$' + ax[m,n].set_title(n_var[j] +unit_str+ str("%.2e" % var_g[j])+unit_str2, fontsize=tfs) + + ax[m,n].xaxis.set_major_formatter(formatter) + ax[m,n].xaxis.set_major_locator(majorLocator_x) + ax[m,n].xaxis.set_minor_locator(minorLocator_x) + ax[m,n].yaxis.set_major_formatter(formatter2) + ax[m,n].yaxis.set_major_locator(majorLocator_y) + ax[m,n].yaxis.set_minor_locator(minorLocator_y) + ax[m,n].set_xlim(x_min,x_max) + ax[m,n].set_ylim(y_min,y_max) + + ax[m,n].tick_params(axis='both', which='major', labelsize=10) + + #cb1 = colorbar(c1,ax=ax[m,n],orientation='horizontal',label=n_var_long[j], format='%.4e') + if logscale: + #l_f = LogFormatter(base=10, labelOnlyBase=True) + #l_f = LogFormatterExponent(base=10, labelOnlyBase=True) + l_f = LogFormatterMathtext(base=10, labelOnlyBase=True) + else: + #cb1 = colorbar(c1,ax=ax[m,n],orientation='horizontal',label=n_var_long[j], format='%.1e') + # cb1.set_label(n_var_long[j],labelpad=-50) + cb1.formatter.set_powerlimits((0, 0)) + c1.set_cmap(cmap) + + i=i+1 + + cbar_ax = fig.add_axes([0.1, 0.025, 0.8, 0.02]) + fig.colorbar(c1, cax=cbar_ax,orientation='horizontal', format=l_f,) + + ########################################################################################## + ########################################################################################## + # Plotting + + # Create panels + if proj == 'map' or proj == 'zm': + fig, ax = subplots(pan_row,pan_col) + if pan_row > pan_col: + fig.set_size_inches(9.2,14, forward=True) + else: + fig.set_size_inches(23,10, forward=True) + else: + fig, ax = subplots(1) + #fig, ax = subplots(1) + #fig = plt.figure() + #ax =fig.add_subplot(1,1,1) + title=False + + # Poster: Set figure size here for histogram + fig.set_size_inches(fg_sz_x,fg_sz_y, forward=True) + + # Plot + if proj == 'zm': + plot_zm() + elif proj == 'map': + plot_map() + elif proj == 'global': + plot_bar() + + if proj=='global': + fig.tight_layout(rect=[0,0.05,1,1]) + + if proj == 'zm': + subplots_adjust(top=0.92) + + if title: + fig.suptitle(plottitle, fontsize=tt_fsz) + + #Only show figure if no outputfile is given + if(len(args.outputFile)>0): + fig.savefig(args.outputFile) + else: + show() + + + sys.exit(0) + + diff --git a/tools/diagnostics/ncl/cloudBudgets/run_budgets.sh b/tools/diagnostics/ncl/cloudBudgets/run_budgets.sh new file mode 100755 index 0000000000..cf05b0160b --- /dev/null +++ b/tools/diagnostics/ncl/cloudBudgets/run_budgets.sh @@ -0,0 +1,31 @@ +#!/bin/bash +#Runs with CAM-Oslo but missing output from MG2_0 +#MG10InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/MG10PDb2d4Free/atm/hist/MG10PDb2d4Free_YA_0003_0004.nc" +#MG15InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/MG15PDb2d4Free/atm/hist/MG15PDb2d4Free_YA_0003_0004.nc" +#MG20InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/MG2PDb2d4Free2/atm/hist/MG2PDb2d4Free2_YA_0003_0004.nc" + +#Runs with CAM (alpha06_cntrlexp07) but with Oslo branch (bug with uninitialized ndep) +MG10InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/FC5MG1001595/atm/hist/FC5MG1001595_YA_0003_0004_depfix.nc" +MG15InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/FC5MG1501595/atm/hist/FC5MG150159_YA_0003_0004.nc" +MG20InputFile="/lustre/storeB/users/alfg/CESM1_5/MGRuns/FC55CL01595/atm/hist/FC55CL01595_YA_0003_0004.nc" + +projection="global" +#You have to know which ice nucleation scheme you used! +mg10icenucleation="cam53" +mg15icenucleation="cam53" +mg20icenucleation="classnuc" + +python mg_budget_plot.py --icenucleation=$mg10icenucleation --inputFile=$MG10InputFile --projection=$projection --version="MG10" --plottype="normal" --state="cldliq" --budget="number" --outputFile="CLDLIQ_NTOT_MG10.png" +python mg_budget_plot.py --icenucleation=$mg10icenucleation --inputFile=$MG10InputFile --projection=$projection --version="MG10" --plottype="normal" --state="cldliq" --budget="mass" --outputFile="CLDLIQ_MTOT_MG10.png" +python mg_budget_plot.py --icenucleation=$mg10icenucleation --inputFile=$MG10InputFile --projection=$projection --version="MG10" --plottype="normal" --state="cldice" --budget="mass" --outputFile="CLDICE_MTOT_MG10.png" +python mg_budget_plot.py --icenucleation=$mg10icenucleation --inputFile=$MG10InputFile --projection=$projection --version="MG10" --plottype="normal" --state="cldice" --budget="number" --outputFile="CLDICE_NTOT_MG10.png" + +python mg_budget_plot.py --icenucleation=$mg15icenucleation --inputFile=$MG15InputFile --projection=$projection --version="MG15" --plottype="normal" --state="cldliq" --budget="number" --outputFile="CLDLIQ_NTOT_MG15.png" +python mg_budget_plot.py --icenucleation=$mg15icenucleation --inputFile=$MG15InputFile --projection=$projection --version="MG15" --plottype="normal" --state="cldliq" --budget="mass" --outputFile="CLDLIQ_MTOT_MG15.png" +python mg_budget_plot.py --icenucleation=$mg15icenucleation --inputFile=$MG15InputFile --projection=$projection --version="MG15" --plottype="normal" --state="cldice" --budget="mass" --outputFile="CLDICE_MTOT_MG15.png" +python mg_budget_plot.py --icenucleation=$mg15icenucleation --inputFile=$MG15InputFile --projection=$projection --version="MG15" --plottype="normal" --state="cldice" --budget="number" --outputFile="CLDICE_NTOT_MG15.png" + +python mg_budget_plot.py --icenucleation=$mg20icenucleation --inputFile=$MG20InputFile --projection=$projection --version="MG20" --plottype="normal" --state="cldliq" --budget="number" --outputFile="CLDLIQ_NTOT_MG20.png" +python mg_budget_plot.py --icenucleation=$mg20icenucleation --inputFile=$MG20InputFile --projection=$projection --version="MG20" --plottype="normal" --state="cldliq" --budget="mass" --outputFile="CLDLIQ_MTOT_MG20.png" +python mg_budget_plot.py --icenucleation=$mg20icenucleation --inputFile=$MG20InputFile --projection=$projection --version="MG20" --plottype="normal" --state="cldice" --budget="mass" --outputFile="CLDICE_MTOT_MG20.png" +python mg_budget_plot.py --icenucleation=$mg20icenucleation --inputFile=$MG20InputFile --projection=$projection --version="MG20" --plottype="normal" --state="cldice" --budget="number" --outputFile="CLDICE_NTOT_MG20.png" diff --git a/tools/emis/2D/eclipse_default/createEmis.sh b/tools/emis/2D/eclipse_default/createEmis.sh new file mode 100755 index 0000000000..0a4d8246d9 --- /dev/null +++ b/tools/emis/2D/eclipse_default/createEmis.sh @@ -0,0 +1,96 @@ +#!/bin/sh + +#Create the input directory here with +#mkdir linkToInDirectory and then +#sshfs -r alfgr@hexagon.bccs.uib.no:/work/olivie/emissions/ECLIPSE-V5/CLE/1990-2050/version2014-05-26 ./linkToInDirectory/ +inDir="linkToInDirectory" +outDir="/disk1/alfg/noresm2emis" + +rm $outDir/*.nc + +#################################################################### +#SO2 +infile="ECLIPSE-V5_emissions_SO2_surface_CLE_1990-2050_1.9x2.5.nc" +infileFullPath="$inDir/$infile" + +outfile_SO2=$outDir/`basename $infile .nc`_SO2G.nc +outfile_SO4=$outDir/`basename $infile .nc`_SO4PR.nc + +#Multiply to get primary SO4 +cdo mulc,0.025 $infileFullPath $outfile_SO4 +cdo mulc,0.975 $infileFullPath $outfile_SO2 + +#Set back the date (since it was also multiplied by factors) +ncks -O -a -x -v date $outfile_SO4 $outfile_SO4 #take it away +ncks -A -v date $infileFullPath $outfile_SO4 #put in original one + +ncks -O -a -x -v date $outfile_SO2 $outfile_SO2 #take it away +ncks -A -v date $infileFullPath $outfile_SO2 #put in a new one + +#default is cycle-year = 0, so create files for this! +ncap2 -O -s "date=date-19850000" $outfile_SO2 $outfile_SO2 #make sure year zero exist +ncap2 -O -s "date=date-19850000" $outfile_SO4 $outfile_SO4 #make sure year zero exist +######################################################## +#OC +infile1="ECLIPSE-V5_emissions_OC1_surface_CLE_1990-2050_1.9x2.5.nc" +infile2="ECLIPSE-V5_emissions_OC2_surface_CLE_1990-2050_1.9x2.5.nc" + +infileFullPath1="$inDir/$infile1" +infileFullPath2="$inDir/$infile2" + +outfile=$outDir/`basename $infile1 .nc`_OCTOT.nc + +#add the files +cdo add $infileFullPath1 $infileFullPath2 $outfile + +#convert oc ==> om (make sure consistent with molecular weight) +#NOT DONE YET + +#Set back the date (since it was also added) +ncks -O -a -x -v date $outfile $outfile #take it away +ncks -A -v date $infileFullPath1 $outfile #put in original one + +#default is cycle-year = 0, so create files for this! +ncap2 -O -s "date=date-19850000" $outfile $outfile #make sure year zero exist + +###################################################### +#BC + +infile1="ECLIPSE-V5_emissions_CB1_surface_CLE_1990-2050_1.9x2.5.nc" +infile2="ECLIPSE-V5_emissions_CB2_surface_CLE_1990-2050_1.9x2.5.nc" + +infileFullPath1="$inDir/$infile1" +infileFullPath2="$inDir/$infile2" + +outfile_tmp=$outDir/`basename $infile1 .nc`_BCTOT.nc + +outfile_ff=$outDir/`basename $infile1 .nc`_BCFF.nc +outfile_bb=$outDir/`basename $infile1 .nc`_BCBB.nc + +outfile_ff_x=$outDir/`basename $infile1 .nc`_BCFFX.nc +outfile_ff_n=$outDir/`basename $infile1 .nc`_BCFFN.nc + +#add the files +cdo add $infileFullPath1 $infileFullPath2 $outfile_tmp + +#pick out the biomass related fields +ncks -v deforestation,forest,peat,savanna,woodland,awb $outfile_tmp $outfile_bb +ncks -v dom,ene,ind,tra,wst,ship $outfile_tmp $outfile_ff + +#10 % of ff goes to ax-mode, 90 % of ff goes to "n" mode +cdo mulc,0.9 $outfile_ff $outfile_ff_n +cdo mulc,0.1 $outfile_ff $outfile_ff_x + +#insert the dates in the ff-files +ncks -A -v date $infileFullPath1 $outfile_ff_n #put in original one +ncks -A -v date $infileFullPath1 $outfile_ff_x #put in original one +ncks -A -v date $infileFullPath1 $outfile_bb #put in original one + + +#default is cycle-year = 0, so create files for this! +ncap2 -O -s "date=date-19850000" $outfile_ff_n $outfile_ff_n #make sure year zero exist +ncap2 -O -s "date=date-19850000" $outfile_ff_x $outfile_ff_x #make sure year zero exist +ncap2 -O -s "date=date-19850000" $outfile_bb $outfile_bb #make sure year zero exist + +rm -f $outfile_tmp +#################################################### diff --git a/tools/emis/3D/BC_ipccdefault/BC_3D.xml b/tools/emis/3D/BC_ipccdefault/BC_3D.xml new file mode 100644 index 0000000000..19d7974431 --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/BC_3D.xml @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/3D/BC_ipccdefault/BC_3D_bb.xml b/tools/emis/3D/BC_ipccdefault/BC_3D_bb.xml new file mode 100644 index 0000000000..f9cf2abc89 --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/BC_3D_bb.xml @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/3D/BC_ipccdefault/BC_3D_ff.xml b/tools/emis/3D/BC_ipccdefault/BC_3D_ff.xml new file mode 100644 index 0000000000..be3b93d207 --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/BC_3D_ff.xml @@ -0,0 +1,31 @@ + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/3D/BC_ipccdefault/copyInputFiles.sh b/tools/emis/3D/BC_ipccdefault/copyInputFiles.sh new file mode 100755 index 0000000000..7b30881d0a --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/copyInputFiles.sh @@ -0,0 +1,70 @@ +#!/bin/sh + +#PURPOSE: CONVERT INPUT FILES TO UNITS "molec/cm^2" OR "molec/cm^3" AND +#THEN RUN THE MERGER-PROGRAM WHICH CREATES ONE OUTPUT FILE PER COMPONENT + +#NOTE: CHECK CONSISTENCY WITH SO2_ipcc.xml + +tmpDir=/disk1/alfg/noresm2emis/tmp +#conversion factor kg/m2 ==> mol/m2 ==> molec/m2 ==> molec/cm2 +conversionFactor2D="*1.0/12e-3*6.02e23*1.e-4" +#same as above but 1.e-6 factor for m3 ==> cm3 +conversionFactor3D="*1.0/12e-3*6.02e23*1.e-6" + +echo $tmpDir +rm $tmpDir/*.nc + +echo "Getting air craft" +cdo cat /disk1/alfg/linkToNorstoreEmissions/cmipemis/IPCC*emis*BC*aircraft*0.5x0.5*.nc $tmpDir/BC_3D_air_in.nc +echo "Selecting only some years" +cdo selyear,1980,1990,2000 $tmpDir/BC_3D_air_in.nc $tmpDir/tmp.nc +echo "converting to molec/cm3" +expr="emiss_air=emiss_air"$conversionFactor3D +cmd="cdo expr,$expr $tmpDir/tmp.nc $tmpDir/BC_3D_air_moleccm3.nc" +echo using command $cmd +$cmd +rm $tmpDir/tmp.nc + +################################################ +echo "Getting antrhopopgenic" +cdo cat /disk1/alfg/linkToNorstoreEmissions/cmipemis/IPCC_*BC*anthr*.nc $tmpDir/BC_2D_anthr.nc +echo "Converting to molec/cm3" +expr="emiss_dom=emiss_dom"$conversionFactor2D +expr=$expr";emiss_ene=emiss_ene"$conversionFactor2D +expr=$expr";emiss_ind=emiss_ind"$conversionFactor2D +expr=$expr";emiss_tra=emiss_tra"$conversionFactor2D +expr=$expr";emiss_wst=emiss_wst"$conversionFactor2D +expr=$expr";emiss_awb=emiss_awb"$conversionFactor2D +cmd="cdo expr,$expr $tmpDir/BC_2D_anthr.nc $tmpDir/BC_2D_anthr_moleccm2.nc" +echo using command $cmd +$cmd +rm $tmpDir/BC_2D_anthr.nc + +########################################## +echo "Getting ships" +cdo cat /disk1/alfg/linkToNorstoreEmissions/cmipemis/IPCC*BC*ships*.nc $tmpDir/BC_2D_ships.nc +echo "converting ships" +expr="emiss_shp=emiss_shp"$conversionFactor2D +cmd="cdo expr,$expr $tmpDir/BC_2D_ships.nc $tmpDir/BC_2D_ships_moleccm2.nc" +$cmd +echo "Fixing ship dates" +cdo shifttime,-14days $tmpDir/BC_2D_ships_moleccm2.nc $tmpDir/BC_2D_ships_moleccm2_date.nc +rm $tmpDir/BC_2D_ships.nc +rm $tmpDir/BC_2D_ships_moleccm2.nc + +############################################ + +echo "Getting biomass burning" +cdo cat /disk1/alfg/linkToNorstoreEmissions/cmipemis/IPCC_GriddedBiomassBurningEmissions_BC*decadalmonthlymean*.nc $tmpDir/BC_2D_Biomass.nc +expr="grassfire=grassfire"$conversionFactor2D +expr=$expr";forestfire=forestfire"$conversionFactor2D +echo "converting biomass" +cmd="cdo expr,$expr $tmpDir/BC_2D_Biomass.nc $tmpDir/BC_2D_Biomass_moleccm2.nc" +$cmd +rm $tmpDir/BC_2D_Biomass.nc + +#################################################### + +#level fraction files +echo "Getting level fractions" +cp /disk1/alfg/linkToNorstoreEmissions/cmipemis/levelFractionFiles/GFED*level*.nc $tmpDir diff --git a/tools/emis/3D/BC_ipccdefault/mergeFiles.sh b/tools/emis/3D/BC_ipccdefault/mergeFiles.sh new file mode 100755 index 0000000000..7e51cfaed4 --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/mergeFiles.sh @@ -0,0 +1,12 @@ +#!/bin/sh + + +#3) Run the converter / merger script +#================================================================ +export PYTHONPATH=$PYTHONPATH:/home/alfg/workspace/camOsloInputGenerator + +#Merge the 3D BC ff emissions +python /home/alfg/workspace/camOsloInputGenerator/main.py -x BC_3D_ff.xml -r /home/alfg/workspace/camOsloInputGenerator/camRegularGrid144x72 + +#Merge the 3D BC bb emissions +python /home/alfg/workspace/camOsloInputGenerator/main.py -x BC_3D_bb.xml -r /home/alfg/workspace/camOsloInputGenerator/camRegularGrid144x72 diff --git a/tools/emis/3D/BC_ipccdefault/postprocess.sh b/tools/emis/3D/BC_ipccdefault/postprocess.sh new file mode 100755 index 0000000000..2cf740ce10 --- /dev/null +++ b/tools/emis/3D/BC_ipccdefault/postprocess.sh @@ -0,0 +1,32 @@ +#!/bin/sh + +#Create the input directory here with +#mkdir linkToInDirectory and then +#sshfs -r alfgr@hexagon.bccs.uib.no:/work/olivie/emissions/ECLIPSE-V5/CLE/1990-2050/version2014-05-26 ./linkToInDirectory/ +inDir="/disk1/alfg/camOsloEmis" +outDir="/disk1/alfg/noresm2emis" + +#rm $outDir/*.nc +###################################################### +#BC + +infile_ff="BC_ff_3D_default.nc" +infile_bb="BC_bb_3D_default.nc" + +outfile_bb=$outDir/`basename $infile_bb .nc`_BCBB.nc +outfile_ff_x=$outDir/`basename $infile_ff .nc`_BCFFX.nc +outfile_ff_n=$outDir/`basename $infile_ff .nc`_BCFFN.nc + +echo $outfile_ff_x $outfile_ff_n $outfile_bb + +#10 % of ff goes to ax-mode, 90 % of ff goes to "n" mode +cp $inDir/$infile_bb $outfile_bb +ncap2 -O -s "emiss_air=0.9f*emiss_air;emiss_shp=0.9f*emiss_shp" $inDir/$infile_ff $outfile_ff_n +ncap2 -O -s "emiss_air=0.1f*emiss_air;emiss_shp=0.1f*emiss_shp" $inDir/$infile_ff $outfile_ff_x + +#default is cycle-year = 0, so create files for this! +ncap2 -O -s "date=date-19900000" $outfile_ff_n $outfile_ff_n #make sure year zero exist +ncap2 -O -s "date=date-19900000" $outfile_ff_x $outfile_ff_x #make sure year zero exist +ncap2 -O -s "date=date-19900000" $outfile_bb $outfile_bb #make sure year zero exist + +#################################################### diff --git a/tools/emis/3D/SO2_ipccdefault/SO2_3D.xml b/tools/emis/3D/SO2_ipccdefault/SO2_3D.xml new file mode 100644 index 0000000000..17c8191073 --- /dev/null +++ b/tools/emis/3D/SO2_ipccdefault/SO2_3D.xml @@ -0,0 +1,33 @@ + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/3D/SO2_ipccdefault/fixme2.sh b/tools/emis/3D/SO2_ipccdefault/fixme2.sh new file mode 100755 index 0000000000..b0e39629f1 --- /dev/null +++ b/tools/emis/3D/SO2_ipccdefault/fixme2.sh @@ -0,0 +1,37 @@ +#!/bin/sh + +#PURPOSE: CONVERT INPUT FILES TO UNITS "molec/cm^2" OR "molec/cm^3" AND +#THEN RUN THE MERGER-PROGRAM WHICH CREATES ONE OUTPUT FILE PER COMPONENT + +#NOTE: CHECK CONSISTENCY WITH SO2_ipcc.xml + +tmpDir=/disk1/alfg/noresm2emis/tmp + +echo $tmpDir +rm $tmpDir/*.nc + +#1) First create volcano 3D-file which has "height" as vertical coordinates using "cdo ml2hlx" +#============================================================================== +#Some variables in this file have different horizontal coordinates and this stops cdo ml2hlx from working +ncks -v SO2,lev,PS,hyai,hybi,hyam,hybm ECLIPSE-V5_volc_SO2_0.975_1990-2050_vertical_xxxx.nc $tmpDir/tmp1.nc +#cdo ml2hlx needs surface pressure to be called "aps" +ncrename -v PS,aps $tmpDir/tmp1.nc $tmpDir/tmp2.nc +#transfrom from hybrid to height vertical coordinates Note need consistenecy with input levels in xml-file +cdo ml2hlx,100,500,1000,5000,10000,20000 $tmpDir/tmp2.nc $tmpDir/ECLIPSE_VOLC_1985_2050_vertical_HEIGHT.nc +#Remove tmp-files +rm $tmpDir/tmp?.nc +#The volcano emissions are already in molec/cm3 so OK no unit conversion needed :-) + +#2) #Then, copy ship emissions to that same directory +#================================================================= +#These emissions are in kg/m2 so need to transform to "molec/cm2" +cp /disk1/alfg/linkToNorstoreEmissions/cmipemis/*SO2*ship*_2000_*.nc $tmpDir/tmp1.nc +cdo expr,"emiss_shp=emiss_shp*6.02e23/64.0e-3/1.0e4" $tmpDir/tmp1.nc $tmpDir/tmp2.nc #converted units +ncatted -a units,emiss_shp,o,c,molec/cm2/s $tmpDir/tmp2.nc $tmpDir/SO2_ship_2000.nc +rm $tmpDir/tmp?.nc + +#3) Run the converter / merger script +#================================================================ +export PYTHONPATH=$PYTHONPATH:/home/alfg/workspace/camOsloInputGenerator +python /home/alfg/workspace/camOsloInputGenerator/main.py -x SO2_3D.xml -r /home/alfg/workspace/camOsloInputGenerator/camRegularGrid144x72 + diff --git a/tools/emis/regridder/GFEDFiles/fixfile.sh b/tools/emis/regridder/GFEDFiles/fixfile.sh new file mode 100755 index 0000000000..d5b927cfed --- /dev/null +++ b/tools/emis/regridder/GFEDFiles/fixfile.sh @@ -0,0 +1,82 @@ +#!/bin/sh + +tmpfile1=tmp1.nc +tmpfile2=tmp2.nc + +input=${1:-input.nc} +output=${2:-outFractions.nc} + +echo $input + +#Remove all wrongly named attributes +ncatted -a ",^,d,," $input $tmpfile1 + +#Remove also all global attributes +ncatted -a ",global,d,," $tmpfile1 $tmpfile2 + +#Save the file without attributes +cp $tmpfile2 $output +rm $tmpfile1 +rm $tmpfile2 + +#Create a time -variable, first +ncwa -a lat,lon,lev $output $tmpfile1 + +#Rename field ==> time in tmpfile1 +ncrename -O -v field,time $tmpfile1 + +#put (append) the time variable in output file +ncks -A -v time $tmpfile1 $output + +#Create a record dimension "record" +rm $tmpfile1 +ncecat $output $tmpfile1 + +#Change record dimension to be time +rm $tmpfile2 +ncpdq -a time,record $tmpfile1 $tmpfile2 + +#Remove the extra record dimension +rm $tmpfile1 +ncwa -a record $tmpfile2 $tmpfile1 + +#Set time-axis +rm $tmpfile2 +cdo settaxis,2000-01-15,12:00:00,1mon $tmpfile1 $tmpfile2 + +#Set z-levels +rm $tmpfile1 +rm $output +cdo setzaxis,zaxisdef $tmpfile2 $output + +#Do the sum +rm $tmpfile2 +cdo vertsum $output $tmpfile2 + +#Rename the field +ncrename -O -v field,fieldsum $tmpfile2 +cdo expr,"fieldsum=fieldsum+1.e-10" $tmpfile2 $tmpfile1 +rm $tmpfile2 +mv $tmpfile1 $tmpfile2 + +#merge sum back +ncks -v fieldsum $tmpfile2 $tmpfile1 +rm $tmpfile2 +cdo merge $tmpfile1 $output $tmpfile2 + +#Fix the missing values +#rm $tmpfile1 +#cdo setmissval,0.0 $tmpfile2 $tmpfile1 + +#create fractions +mv $tmpfile2 $tmpfile1 +#rm $tmpfile2 +cdo expr,"fraction=field/fieldsum" $tmpfile1 $tmpfile2 + +#Set missing value to zero +#cdo setmisstoc,0.0 $tmpfile2 $tmpfile1 + +#Copy to output file +rm $output +rm $tmpfile1 +mv $tmpfile2 $output diff --git a/tools/emis/regridder/GFEDFiles/zaxisdef b/tools/emis/regridder/GFEDFiles/zaxisdef new file mode 100644 index 0000000000..006fdea475 --- /dev/null +++ b/tools/emis/regridder/GFEDFiles/zaxisdef @@ -0,0 +1,3 @@ + zaxistype = height + size = 6 + levels = 50 300 750 1500 2500 4500 diff --git a/tools/emis/regridder/TODO b/tools/emis/regridder/TODO new file mode 100644 index 0000000000..737d0749ee --- /dev/null +++ b/tools/emis/regridder/TODO @@ -0,0 +1,31 @@ +ISSUES REMAINING: + +NEEDED BEFORE PRODUCT IS FINISHED +******************************************** + +*) Include config-files for aerocom emissions + +*) Create historical, RCP60 and RCP85 for all fields BC/OC/SO2 (finish ipccConfig.xml) + +*) Allow reading of old ascii files. SOA.1x1 , check readpom.f under aerocomemis. +The files aerocom.soxbb.fv19.asciiflat go into the cam program. Do this on netcdf format. + +*) Allow input-file for hight-scaling of emissions. Do this outside of program. All input-files must be + on right grid when input to this program. Explain in manual how to do this. + +*) Correct OH in stratosphere. This is only special files which contain OH-concentration + + +NICE TO DO / IMPROVEMENTS +******************************************** + +*) Same point as above, but for transforming yearly data to monthly data. Possibly this should also go + outside program in stand-alone script. + +*) Allow scale-factor per sector to increase or increase sector emissions + +*) Speed up initial scanning of possible output files (this command is for example REALLY slow: python main.py -x ipccConfig.xml -s RCP85) + +*) Code clean up + +*) Create xml schema validator to validate configuration files (allowed sectors, allowed conversions etc) diff --git a/tools/emis/regridder/camOsloFileProcessor.py b/tools/emis/regridder/camOsloFileProcessor.py new file mode 100644 index 0000000000..ffaec45b36 --- /dev/null +++ b/tools/emis/regridder/camOsloFileProcessor.py @@ -0,0 +1,462 @@ +''' +Created on Aug 30, 2013 + +@author: alfg +''' + +from cdo import * +cdo = Cdo() +from lxml import etree as ET +import os +import progressbar +import uuid + +class levelFractionFile(object): + def __init__(self, absPath): + self.absPath = absPath + + def getFullPath(self): + return self.absPath + + def findClosestTimeStep(self,aDate): + """ + Returns time step in file + """ + dateStrings = cdo.showdate(input=self.absPath)[0].split() + searchMonth = aDate.month + retVal = 1 + minVal = 99999999999999999 + i = 1 + for aDate in dateStrings: + ymd = aDate.split("-") + aMonth = int(ymd[1]) + if(abs(aMonth-searchMonth) < minVal): + retVal = i + minVal = abs(aMonth-searchMonth) + i=i+1 + return retVal + +class camOutputFile(object): + + def __init__(self, inputPath,outputPath,xmlElement): + self.inputPath=inputPath + self.outputPath=outputPath + self.inputFiles = [] #list of inputfiles + self.xmlElement= xmlElement + self.fullPath="" + self.levels=0 + self.scenario="" + self.component="" + self.source="" + self.bottomLevel=0.0 + self.levelValues=[] + self.minYear=0 + self.maxYear=9999999 + self.interfaceLevels=[] + + #Error checking + if(not os.path.isdir(self.inputPath)): + raise Exception("input directory " + self.inputPath + " does not exist") + if(not os.path.isdir(self.outputPath)): + raise Exception("output directory " + self.outputPath + " does not exist") + + def getLevelValues(self): + return self.levelValues + + def getBottomLevel(self): + return self.bottomLevel + + def getOutputPath(self): + return self.outputPath + + def getNumberOfLayers(self): + return self.levels + + def __setLevels(self,levels): + self.levels = levels + + def getInputFileList(self): + return self.inputFiles + + def getFullPath(self): + return self.fullPath + + def getLevelHeight(self,i): + return self.interfaceLevels[i+1] - self.interfaceLevels[i] + + def __setFullPath(self,outputFileName): + fullPath = os.path.normpath(os.path.join(self.outputPath,outputFileName)) + self.fullPath=fullPath + + def getMinYear(self): + return self.minYear + + def getMaxYear(self): + return self.maxYear + + def getInterfaceLevels(self): + return self.interfaceLevels + + def configure(self): + """Purpose: Based on the + "file field in the config-file.. Create a set of input- + files with the same properties.. Child is an e-tree xml-node""" + relativePathName = self.xmlElement.attrib["name"] + + self.__setFullPath(relativePathName) + + if self.xmlElement.attrib.has_key("bottomLevel"): + self.bottomLevel = float(self.xmlElement.attrib["bottomLevel"]) + + if self.xmlElement.attrib.has_key("levelValues"): + levelValues = (self.xmlElement.attrib["levelValues"]) + levelValuesList=levelValues.split(",") + levelValuesList2=[] + #Make sure the level values are numbers.. + for i in levelValuesList: + numberValue = float(i) + levelValuesList2.append(numberValue) + self.levelValues = levelValuesList2 + + #set number of levels + self.__setLevels(len(self.levelValues)) + + #find the levels of the interfaces given the midpoints + self.interfaceLevels=[] + self.interfaceLevels.append(0.0) + idx=0 + if(len(self.levelValues) > 0 ): + for aLevel in self.levelValues: + #add another entry to the interface levels + self.interfaceLevels.append(self.interfaceLevels[idx] + 2.0*(self.levelValues[idx] -self.interfaceLevels[idx])) + idx += 1 + #Check for error in midpoint layer config + if(idx <= len(self.levelValues)-1): + if(self.interfaceLevels[idx] > self.levelValues[idx]): + raise Exception("Error of output levels in level " + str(idx) + " upper interface "+str(self.interfaceLevels[idx]) + + " midpoint above: " + str(self.levelValues[idx]) + self.fullPath) + + tmpMinYear = 999999999999999999999 + tmpMaxYear = 0 + if self.xmlElement.attrib.has_key("year"): + yearTag = str(self.xmlElement.attrib["year"]) + years=yearTag.split(",") + for aYear in years: + fYear = float(aYear) + if(fYear < tmpMinYear): + tmpMinYear = fYear + self.minYear = fYear + if(fYear > tmpMaxYear): + self.maxYear = fYear + tmpMaxYear = fYear + + #Search through list of input files + for inputFileElement in self.xmlElement.getiterator("inputfile"): + #Create an input-file instance + aCamInputFile = camInputFile() + + aCamInputFile.configure(inputFileElement, self.inputPath , aYear, self) + + #Successfully configured ==> add our list of needed input files + self.inputFiles.append(aCamInputFile) + +class camInputFile(object): + ''' + Class describing an input file, resolution etc + ''' + def __init__(self): + self.year="" + self.fullPath="" #name of the file + self.fields=[] #list of cam-fields + self.hasVerticalProfile=False + self.sector=dict() + self.fieldLevel=dict() + self.inputLevels=[] + self.inputInterfaceLevels=[] + self.layerHeight=[] + self.conversion = None + self.levelFractionFile=None + self.levelFractionFileReGrid=None + + def hasLevelFractionFile(self): + return (self.levelFractionFile != None) + + def getLevelFractionFileName(self): + if self.levelFractionFile != None: + return self.levelFractionFile.getFullPath() + + def getConversionFactor(self): + if(self.conversion != None): + return self.conversion.getConversionFactor() + else: + return 1.0 + + def getInterfaceLevels(self): + return self.inputInterfaceLevels + + def hasConversion(self,aString): + if(self.conversion != None): + return self.conversion.hasConversion(aString) + else: + return False + + def setField(self,fieldName,fieldSector,outputLevel): + #fxm: Guard against same sector several times in file + #levels is list of levels.., normally a list of size 1 with levels[0]=0 + self.sector[fieldSector]=fieldName + self.fieldLevel[fieldName]=outputLevel + + def configure(self,inputFileElement,inputPath,aYear,parentOutputFile): + #Get file name + fileWithCodes=inputFileElement.get("name") + + #Replace the codes to create the real name + aFileName=fileWithCodes.replace("$year$",aYear) + + #Check if the file exists + inputFullPath = os.path.join(os.path.normpath(inputPath),aFileName) + if(os.path.isfile(inputFullPath)): + #Create the output file with the configuration options + self.fullPath = inputFullPath + else: + raise Exception ("Could not find file " + inputFullPath + "===> error in xml-config file") + + #Check names of fields in file + fieldNamesInFile = cdo.showname(input=self.getFullPath())[0].split(" ") + fieldLevelsInFile = cdo.showlevel(input=self.getFullPath()) + for expr in fieldLevelsInFile: + list2 = expr.split(" ") + for expr2 in list2: + if (float(expr2) > 0.0): + self.hasVerticalProfile = True + + #Find the level values of the input file (m) + self.inputLevels=[] + if inputFileElement.attrib.has_key("levelValues"): + levelValues = (inputFileElement.attrib["levelValues"]) + levelValuesList=levelValues.split(",") + levelValuesList2=[] + #Make sure the level values are numbers.. + for i in levelValuesList: + numberValue = float(i) + levelValuesList2.append(numberValue) + self.inputLevels = levelValuesList2 + + #find the levels of the interfaces given the midpoints + self.inputInterfaceLevels=[] + self.inputInterfaceLevels.append(0.0) + idx=0 + if(len(self.inputLevels) > 0 ): + for aLevel in self.inputLevels: + #add another entry to the interface levels + self.inputInterfaceLevels.append(self.inputInterfaceLevels[idx] + 2.0*(self.inputLevels[idx] -self.inputInterfaceLevels[idx])) + idx += 1 + #Check for error in midpoint layer config + if(idx <= len(self.inputLevels)-1): + if(self.inputInterfaceLevels[idx] > self.inputLevels[idx]): + raise Exception("Error of input levels in level " + str(idx) + " upper interface "+str(self.inputInterfaceLevels[idx]) + + " midpoint above: " + str(self.inputLevels[idx]) + self.fullPath) + #Calculate the layer height(m) + self.layerHeight.append(self.inputInterfaceLevels[idx]-self.inputInterfaceLevels[idx-1]) + + #Go through the fields the user asked for.. + #Either, we have 1 layer in input file which can go to any level.. Either we have a 3d input file + for field in inputFileElement.getiterator("field"): + fieldName=field.get("name") + fieldSector=field.get("sector") + aLevel = 1 #default is output layer 1 + if field.attrib.has_key("level"): + aLevel=int(field.get("level")) + + #Verify the configured fields against the names actually in the file + found = False + #Check all field names in file and see if we find this one.. + for aName in fieldNamesInFile: + if (aName == fieldName): + found = True + if(not found): + raise(Exception("Requested field "+ fieldName + " not found in file " + self.fullPath)) + else: #==> ALL OK + self.setField(fieldName,fieldSector,aLevel) + + for lf in inputFileElement.getiterator("levelFractionFile"): + aFileName=lf.get("name") + fullname = os.path.join(os.path.normpath(inputPath),aFileName) + self.levelFractionFile = fullname + + if (self.levelFractionFile != None): + ########################################################################### + #NEED TO REGRID THE LEVEL FRACTION FILE TO SAME GRID AS INPUT FILE + #DO THIS ON INIT (WHEN READING THE INPUT FILE + ############################################################################ + griddes = cdo.griddes(input=self.getFullPath()) + basepath = parentOutputFile.getOutputPath() + gridfilename = os.path.normpath(os.path.join(basepath,"griddes01")) + + #create a grid file from this list output (grid description of fraction file) + startIndex = 0 + endIndex = 0 + icnt = 0 + gridOK=False + for item in griddes: + if(startIndex == 0 or endIndex == 0): + if(item.find("#") != -1 ): + if(not gridOK): + startIndex = icnt + else: + endIndex = icnt + if item.find("gridtype") != -1 and item.find("generic") == -1 : + gridOK = True + icnt = icnt + 1 + if(endIndex ==0): + endIndex = len(griddes)-1 + + aString="" + icnt=startIndex + while icnt < endIndex : + aString = aString + griddes[icnt] + aString = aString + os.linesep + icnt = icnt + 1 + f = open(gridfilename,'w') + f.write(aString) + f.close() + #Now we have the grid description!! + #Interpolate level fractions to same grid as input file + tmpFileName1= os.path.normpath(os.path.join(basepath,str(uuid.uuid4())+".nc")) + tmpFileName2= os.path.normpath(os.path.join(basepath,str(uuid.uuid4())+".nc")) + tmpFileName3= os.path.normpath(os.path.join(basepath,str(uuid.uuid4())+".nc")) + + cdo.remapbil(gridfilename,input=self.levelFractionFile,output=tmpFileName1) # fraction file is now for one time step to input file format + os.remove(gridfilename) + + #Make sure vertical sum is one + cdo.vertsum(input=tmpFileName1, output=tmpFileName2) + subprocess.check_call(["ncrename","-v","fraction,sumFraction",tmpFileName2]) + #avoid division by zero + expr = "sumFraction=sumFraction+1.e-30" + cdo.expr(expr,input=tmpFileName2,output=tmpFileName3) + os.remove(tmpFileName2) + + subprocess.check_call(["ncks","-A","-v","sumFraction",tmpFileName3,tmpFileName1]) + os.remove(tmpFileName3) + + expr="fraction=fraction/sumFraction" + cdo.expr(expr,input=tmpFileName1,output=tmpFileName2) + + self.levelFractionFileReGrid = tmpFileName2 + os.remove(tmpFileName1) + + def getLevelFractionFileReGrid(self): + return self.levelFractionFileReGrid + + def cleanFiles(self): + if (self.levelFractionFileReGrid != None): + os.remove(self.levelFractionFileReGrid) + + def getLevelHeight(self,i): + return self.layerHeight[i] + + def getNumberOfLevels(self): + return len(self.inputLevels) + + def getLevelValues(self): + return self.inputLevels + + def getHasVerticalProfile(self): + return self.hasVerticalProfile + + def validateFieldNames(self, fieldNames): + """Check if the field names obtained from xml config file + are the same as the fields in the netCDF file""" + foundAll = True + + for aSector in self.sector.keys(): #These are the fields the xml-files says we should have.. + aField = self.sector[aSector] + foundOne = False + for ncField in fieldNames: #Look through the fields we do have.. + if(ncField == aField): + foundOne = True + if(not foundOne): + print "could not find field specified in xml config file" + aField + " in " + self.fullPath + foundAll = False + return foundAll + + #fxm: This should take an optional argument.. outputfile + def getConfiguredFields(self): + ret=[] + for aSector in self.sector.keys(): + ret.append(self.sector[aSector]) + return ret + + def getConfiguredFieldsInLayer(self,layer): + ret=[] + fields = self.getConfiguredFields() + for aField in fields: + if(self.fieldLevel[aField] == layer): + ret.append(aField) + return ret + + def getFullPath(self): + return self.fullPath + + def setPaths(self, fullpath, outputfile): + self.fullPath = fullpath + self.outputfilename = outputfile + + +class FileProvider(object): + ''' + Class which provides information about files in the system + ''' + + def __init__(self,xmlpath): + ''' + Constructor + ''' + self.inputDataPath="" + self.outputDataPath="" + self.xmlconfigfile=xmlpath + self.outputFile=None + + if(not os.path.isfile(xmlpath)): + raise Exception(xmlpath + "Can not find " + xmlpath) + + def createFileStructure(self): + self.__cleanAll() + + self.__createFileList() + + def __cleanAll(self): + self.outputFileList = [] + + def getOutputFile(self): + return self.outputFile + + def __createFileList(self): + """Purpose: Get a list of camFiles based on an xml-file""" + + #Parse xml file + tree = ET.parse(self.xmlconfigfile) + + #Get xml root element.. + root = tree.getroot() + + #Get input data path + for anElement in root.getiterator("inputDataPath"): + self.inputDataPath = str(anElement.get("name")) + + #Get output data path + for anElement in root.getiterator("outputDataPath"): + self.outputDataPath=str(anElement.get("name")) + + print "configuring output file" + for child in root.getiterator("outputfile"): + self.outputFile = camOutputFile(self.inputDataPath,self.outputDataPath,child) + + self.outputFile.configure() + + #Check if already exists + if(os.path.isfile(self.outputFile.getFullPath())): + raise Exception ("File to create : " + self.outputFile.getFullPath() + " already exists ! ==> exiting now") + if(not os.path.isdir(os.path.dirname(self.outputFile.getFullPath()))): + raise Exception("Creation directory does not exist") \ No newline at end of file diff --git a/tools/emis/regridder/camRegularGrid144x72 b/tools/emis/regridder/camRegularGrid144x72 new file mode 100644 index 0000000000..e42ba55523 --- /dev/null +++ b/tools/emis/regridder/camRegularGrid144x72 @@ -0,0 +1,7 @@ +gridtype = lonlat + xsize = 144 + ysize = 96 + xfirst = 0 + xinc = 2.5 + yfirst = -90 + yinc = 1.89473684211 diff --git a/tools/emis/regridder/convertToLevelPercentage.sh b/tools/emis/regridder/convertToLevelPercentage.sh new file mode 100755 index 0000000000..7718add548 --- /dev/null +++ b/tools/emis/regridder/convertToLevelPercentage.sh @@ -0,0 +1,71 @@ +#!/bin/sh + +tmpfile1=tmp1.nc +tmpfile2=tmp2.nc +output=outFractions.nc + +#Remove all wrongly named attributes +ncatted -a ",^,d,," GFED_2000_BC.nc $tmpfile1 + +#Remove also all global attributes +ncatted -a ",global,d,," $tmpfile1 $tmpfile2 + +#Save the file without attributes +cp $tmpfile2 $output +rm $tmpfile1 +rm $tmpfile2 + +#Create a time -variable, first +ncwa -a lat,lon,lev $output $tmpfile1 + +#Rename field ==> time in tmpfile1 +ncrename -O -v field,time $tmpfile1 + +#put (append) the time variable in output file +ncks -A -v time $tmpfile1 $output + +#Create a record dimension "record" +rm $tmpfile1 +ncecat $output $tmpfile1 + +#Change record dimension to be time +rm $tmpfile2 +ncpdq -a time,record $tmpfile1 $tmpfile2 + +#Remove the extra record dimension +rm $tmpfile1 +ncwa -a record $tmpfile2 $tmpfile1 + +#Set time-axis +rm $tmpfile2 +cdo settaxis,2000-01-15,12:00:00,1mon $tmpfile1 $tmpfile2 + +#Set z-levels +rm $tmpfile1 +rm $output +cdo setzaxis,zaxisdef $tmpfile2 $output + +#Do the sum +rm $tmpfile2 +cdo vertsum $output $tmpfile2 + +#Rename the field (avoid division by zero) +ncrename -O -v field,fieldsum $tmpfile2 +cdo expr,"fieldsum=fieldsum+1.e-10" $tmpfile2 $tmpfile1 +rm $tmpfile2 +mv $tmpfile1 $tmpfile2 + +#merge sum back +ncks -v fieldsum $tmpfile2 $tmpfile1 +rm $tmpfile2 +cdo merge $tmpfile1 $output $tmpfile2 + +#create fractions +mv $tmpfile2 $tmpfile1 +#rm $tmpfile2 +cdo expr,"fraction=field/fieldsum" $tmpfile1 $tmpfile2 + +#Copy to output file +rm $output +rm $tmpfile1 +mv $tmpfile2 $output diff --git a/tools/emis/regridder/doc/camOsloInputGenerator.tex b/tools/emis/regridder/doc/camOsloInputGenerator.tex new file mode 100644 index 0000000000..d6f7a82f97 --- /dev/null +++ b/tools/emis/regridder/doc/camOsloInputGenerator.tex @@ -0,0 +1,207 @@ +\documentclass[12pt]{article} +\usepackage{listings} +\usepackage{url} + +\begin{document} +\lstset{language=Python} + +\tableofcontents +\newpage + +\section{Installation} + +You need the following installed +\begin{itemize} +\item python from ubuntu installer +\item python-lxml from ubuntu installer +\item nco from ubuntu installer +\item cdo from ubuntu installer +\item python-pip from ubuntu installer +\item python-progressbar from ubuntu installer +\item cdo-python (see below) +\end{itemize} +Install cdo-python using the follwing commands which are valid if you are using python2.7 +\begin{verbatim} +mkdir /home/user/pythonPackages +pip install --install-option="--prefix=/home/user/pythonPackages/" cdo +export PYTHONPATH + =$PYTHONPATH:/home/user/pythonPackages/lib/python2.7/site-packages +\end{verbatim} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%$ DOLLAR SIGN NEEDED TO GET VIM COLORS WORKING +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\section{Functionality} + +The program is used to interpolate fields at some resolution to another resolution. +It also adds different fields together. + +The main purpose can be explained as shown in Figure \ref{fgr:synopsis} + +\begin{figure}[htb] +\begin{lstlisting} +for outputFile in outputFilesToCreate: + for inputFiles in inputFiles: + regridInputFile() + for field in Fields: + createListOfFieldsWithSameDates() + + for date in foundDates: + sumFieldWithSameDate() + writeSumToOutputFile() +\end{lstlisting} +\caption{Synopsis of program. This only gives a very simplified impression of what the program does \label{fgr:synopsis}} +\end{figure} + + + +\section{Required input} + +The program will read input data from a catalogue with emissions data. + +Currently that directory is on the norstore machine (ssh user@login.norstore.uio.no) + +You can mount that directory to your machine using the following commands: +\begin{verbatim} +mkdir linkToEmissionData +sshfs user@login.norstore.uio.no:/projects/NS2345K/noresm/emissiondata + linkToEmissionData +\end{verbatim} +When you don't need the directory anymore, remove the link using the command +\begin{verbatim} +fusermount -u linkToEmissionData +\end{verbatim} + +Note that when linking the directory this way, you will get write-access to the directory at the remote machine. +If you do not need to write to the remote machine, use \begin{verbatim}sshfs -r \end{verbatim} which mounts the +directory "read-only". + +If you don't have access to the emission data, ask your administrator. + +\section{Usages} + +The program will collect input files from some emission provider (default IPCC) and merge them to +input emission files at the right resolution. + +\subsection{Allowed conversions} + +The output fields can be converted by some allowed conversions: +\begin{enumerate} +\item \bf{factor}: The output field will be multiplied by this factor +\item \bf{multiplyByLayerHeight}: If this type is given, the field will be multiplied by layer height. This is useful if a +field is given as tendency ($m^{-3}$) and we need to convert to flux ($m^{-2}$). This can be the case for aircraft emissions. +Note that the unit of the z-axix is used as "layer height", so if z-axis is in pressure, the value will be multiplied by a $\Delta P$. +\item \bf{convertToLayerMidpoints}: Values are calculated at output grid mid points. The user input "levelValues" are at top of layers. If +this conversion is given, the values are interpolated to values at mid-points. +\item \bf{divideByArea}. If this conversion is given, the values will be divided by cell area given. This is useful is input data is given +as $kg/cell$. The \it{dividebyArea}-conversion converts this to $kg/m2$. +\end{enumerate} + +\subsection{Config files syntax} + +The config files are written in xml syntax. +The hierarchy is: An output files is created from a set of input file. +An input file has a set of fields. + +It is allowed to specify year as \begin{verbatim}$year$\end{verbatim} in the input file +file-name. + +\subsubsection{Output files} + +The following attributes are required +\begin{enumerate} +\item name : name of output file +\item field : field to create in output file +\item component: component in question +\item provider: Emission set provider +\item scenario : Emission set scenario +\end{enumerate} + +The following attributes are optional +\begin{enumerate} +\item levels: Number of levels in output file +\item levelValues: Comma separated list of +\end{enumerate} + +\subsubsection{Input files} + +The following attributes are required: +\begin{enumerate} +\item name: File name +\end{enumerate} + +\subsubsection{Fields} + +The following attributes are required +\begin{enumerate} +\item name: Field name in netcdf file +\item sector: Emission sector (any sector) +\end{enumerate} + +The following attributes are optional +\begin{enumerate} +\item level: Place this emission sector in a level other than the first level +\end{enumerate} + +\section{Resolution and grids} + +\subsection{Output resolution} +Output resolution is given by cdo grid syntax. This is explained in the cdo manual \url{https://code.zmaw.de/embedded/cdo/1.6.1/cdo.html} +in the chapter about horizontal grids. An example grid definition file is given together with the code base. It's file name is camRegularGrid144x72. + +A user can define a new grid file using keywords such as "gridtype", "gridsize", "xfirst", "xinc". See the cdo manual for details. There +are even examples of unstructured grids in the cdo manual. Look for "unstructured" in the manual. + +The program assumes that the input files know their own grid, so they are interpolated from their own, known grid to the grid specification file +given with the "-r" argument. + +The interpolation inside the program using the "cdo remapbil" command which does a bilinear interpolation. + +It is possible to give input files at diffent horizontal resolution. Each file is interpolated individually before it is merged with other input files + +\subsection{Vertical levels} + +If the output files has vertical levels, the value atribute "levels" must be given to a value different from the default value "1". +There are two ways to get an output file with levels: +\begin{enumerate} +\item The input file is 3d and already contains levels. +\item A specific model level is assigned to the input value. +\end{enumerate} + +\section{Time interpolation} + +The program will NOT interpolate in time. It will add all fields which go into same date and same outputfield/outputfile. +Therefore it is important that the command. The program internally uses the command +\begin{verbatim} +cdo showdate inputfile +\end{verbatim} +to find the dates in an input file. It then searches for same date in other input files and adds the emissions. + +This is {\bf the most important task for any user: Make sure the dates are correct}. If the program finds two different +dates, it will create different time-steps in the output file instead of summing the input-fields. + +For example: If a file has given sulphur emissions from industry on the dates 1996-01-01 and 1996-02-01, and a second file +has given sulphur emission from energy use on 1996-01-15 and 1996-02-15, the output file will contain 4 time steps where +time step 1 and 3 will be industry emissions and time step 2 and 4 will be energy emissions. + +This is {\bf particularly important if a user wants to add new files to the emission inputs} + +The command "cdo settaxis" is helpful to transform the dates. For example: +\begin{verbatim} +cdo settaxis,1987-01-16,12:00:00,1mon ifile ofile +\end{verbatim} +will set the first time step to 16th of January, 1987 and increament of 1 month. + +\section{Examples} + +\begin{verbatim} +python main.py --help +python main.py -x exampleConfig.xml +python main.py --sourcetype=ff +python main.py --provider=IPCC +python main.py -c SO2 -t bb -x ipccConfig.xml -y 1850,1880 +\end{verbatim} + + +\end{document} diff --git a/tools/emis/regridder/eclipseConfig.xml b/tools/emis/regridder/eclipseConfig.xml new file mode 100644 index 0000000000..a6bb65723c --- /dev/null +++ b/tools/emis/regridder/eclipseConfig.xml @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/exampleConfig.xml b/tools/emis/regridder/exampleConfig.xml new file mode 100644 index 0000000000..0f78f5d611 --- /dev/null +++ b/tools/emis/regridder/exampleConfig.xml @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/interpolator.py b/tools/emis/regridder/interpolator.py new file mode 100644 index 0000000000..360f437797 --- /dev/null +++ b/tools/emis/regridder/interpolator.py @@ -0,0 +1,535 @@ +''' +Created on Sep 2, 2013 + +@author: alfg +''' + +import sys +import os +from cdo import * +cdo = Cdo() +from camOsloFileProcessor import camInputFile, camOutputFile, FileProvider, levelFractionFile +import uuid +import glob +import datetime +import shutil +import progressbar +import time + +areaEarth = 5.1e14 + +################################################################## + +class outputCreator(object): + ''' + classdocs + ''' + + def __init__(self, fileProvider): + ''' + Constructor + ''' + self.FileProvider = fileProvider + self.dateMap = dict() + + def __getOutputFile(self): + return self.FileProvider.getOutputFile() + + + def __createTmpFileNames(self,anOutputFile,n): + + retVal = [] + + aUuid = str(uuid.uuid4()) + + nFiles = 0 + while nFiles < n: + retVal.append(os.path.normpath(os.path.join(anOutputFile.getOutputPath(),aUuid+"_"+str(nFiles)+".nc"))) + nFiles = nFiles +1 + return retVal + + def __create3DFromLevelFractions(self,timestepFile, input2DFile, anOutputFile, aDate): + """ + Creates 3D output from 1d input and level fractions + """ + ################################################## + #multiplying by layer fraction messes up the dates + timestepFileDate=cdo.showdate(input=timestepFile)[0] + + #This is a file with a variable "fraction" which is vertical fraction to be + #applied to the 1D input file + lfname=self.__createTmpFileNames(anOutputFile,1) + levelFractionFileName = input2DFile.getLevelFractionFileReGrid() + aLevelFractionFile=levelFractionFile(levelFractionFileName) + closestTimeStep = aLevelFractionFile.findClosestTimeStep(aDate) + cdo.seltimestep(closestTimeStep,input=levelFractionFileName,output=lfname[0]) + + interfaceLevels = input2DFile.getInterfaceLevels() + + #Get all the levels from the 2D input file + theLevels = input2DFile.getLevelValues() + + uuidLevel = str(uuid.uuid4()) + aPattern=os.path.normpath(anOutputFile.getOutputPath()+"/"+uuidLevel) + aPattern2 = aPattern+"*.nc" + + cdo.splitlevel(input=lfname[0],output=aPattern) + + #These are the fields we want to multiply with this fraction + fields = input2DFile.getConfiguredFields() + + #Get back all the level fraction files + levelFiles = glob.glob(aPattern2) + sortedLevelFiles = [""]*len(levelFiles) + foundLevel=[False]*len(levelFiles) + + for lf in levelFiles: + aLevel = cdo.showlevel(input=lf) + cnt = 0 + for lev in theLevels: + if(str(aLevel[0]) == str(int(lev)) ): + sortedLevelFiles[cnt] = lf + foundLevel[cnt]=True + cnt += 1 + + if(False in set(foundLevel)): + raise Exception("Inconsistent levels in fractionFile and xml file") + + levelFileList=[] + cnt=0 + for levelFile in sortedLevelFiles: + workFiles = self.__createTmpFileNames(anOutputFile,2) + + #Remove level-dimension in the fraction-file + subprocess.check_call(["ncwa","-O","-a","height",levelFile,workFiles[0]]) + + #set correct date in the workfile + cdo.setdate(timestepFileDate,input=workFiles[0],output=workFiles[1]) + + #put "fraction" in the inputfile (which is the time step we want to treat) + subprocess.check_call(["ncks","-A","--fix_rec_dmn","-v","fraction",workFiles[1],timestepFile]) + + height = str(float(interfaceLevels[cnt+1]) - float(interfaceLevels[cnt])) + cnt += 1 + + #Go through fields and multiply by fraction and level height + expr="'" + for aField in fields: + expr += aField+"="+aField+"*fraction"+"/"+height+"*1.e-2;" + + #remove last ";" + expr=expr[:-1] + expr+="'" + + cdo.expr(expr,input=timestepFile,output=workFiles[1]) + + levelFileList.append(workFiles[1]) + + self.__cleanButLeave(workFiles,1) + + self.__cleanButLeave(sortedLevelFiles) + self.__cleanButLeave(lfname) + + #forward to the subroutine which creates a 3D-file from a list of 1d-files + a3DFile = self.__create3DFromFixedFiles(levelFileList,anOutputFile) + try: + os.remove(timestepFile) + except: + pass + return a3DFile + + + ############################################################################## + def __create3DFrom1D(self,timestepFile, input2DFile,anOutputFile): + """ + Convert a 1D file to a 3D file with correct number of levels + """ + #When specific levels are specified, it is the output levels we are talking about + inputLevels = len(anOutputFile.getLevelValues()) + tmpLayerFiles = [] + level=1 + while (level <= inputLevels): + + #In this case levels are about output file levels + layerHeight = anOutputFile.getLevelHeight(level-1) + + workFiles = self.__createTmpFileNames(anOutputFile,3) + + #get the fields to be placed in this layer + fieldsInLayer = input2DFile.getConfiguredFieldsInLayer(level) + allFields = input2DFile.getConfiguredFields() + fieldsNotInLayer= set(allFields) - set(fieldsInLayer) + + anExpression="'" + for field in fieldsInLayer: + anExpression+=field+"="+field+"*1.e-2/"+str(layerHeight) #==> molec/cm2/s ==> molec/cm2/sec + for field in fieldsNotInLayer: + anExpression+=field+"="+field+"*0.0;" + anExpression=anExpression[:-1] + anExpression+="'" + #execute expression + cdo.expr(anExpression,input=timestepFile, output=workFiles[1]) + + #Remove record dimension using ncks ==> create file without record dimension.. + subprocess.check_call(["ncks","--fix_rec_dmn", workFiles[1], workFiles[2]]) + + #Remember the file for this layer + tmpLayerFiles.append(workFiles[2]) + + #Leave all but this file + self.__cleanButLeave(workFiles,2) + + #increase levels created + level+=1 + + #Done loop of levels to create + return self.__create3DFromFixedFiles(tmpLayerFiles,anOutputFile) + + ################################################################################ + def __create3DFromFixedFiles(self,tmpLayerFiles,anOutputFile): + + workFiles = self.__createTmpFileNames(anOutputFile,2) + #Create new dimension "record" which is actually layers + myCall = [] + myCall.append("ncecat") + for fixedTmpFile in tmpLayerFiles: + myCall.append(fixedTmpFile) + myCall.append(workFiles[0]) + subprocess.check_call(myCall) + + #Rename record ==level + subprocess.check_call(["ncrename","-d","record,level",workFiles[0]]) + + #change dimensions + subprocess.check_output(["ncpdq","-a","time,level",workFiles[0],workFiles[1]]) + + self.__cleanButLeave(workFiles,1) + self.__cleanButLeave(tmpLayerFiles) + return workFiles[1] + + ############################################################################# + def __cleanButLeave(self,fileList,leave=-99): + index = 0 + for aFile in fileList: + if(index != leave and os.path.isfile(aFile)): + os.remove(aFile) + index = index + 1 + + ############################################################################## + def __mergeOutputFiles(self,anOutputFile): + + #Now we have gone through all input files and have a bunch of temporary input files valid for different dates + #Need to merge all files with same date! + #We add up all the files which have the same date. + #The code below is needed because "cdo add" only takes two arguments.. + + #These are the files with will go to final cdo.mergetime, the files in outfilelist have different dates + outfiles = self.__createTmpFileNames(anOutputFile,1) + + dateFiles=[] + #Go through the files with same dates + for aKey in self.dateMap: + fileString="" + workFiles = self.__createTmpFileNames(anOutputFile,2) + aFileList = [] + aFileList.extend(self.dateMap.get(aKey)) #All the files we need to add up (the ones with same date) + fileString += " ".join(aFileList) + fileString += " " + #Create only one file per date (with all the entries in it) + #print "merging for date" + aKey + " " + fileString + #xyz = cdo.showdate(input=fileString) + #print "date in input :" + xyz[0] + cdo.merge(input=fileString,output=workFiles[0]) + dateFiles.append(workFiles[0]) + self.__cleanButLeave(aFileList) + + fileString=" ".join(dateFiles) + cdo.mergetime(input=fileString, output=outfiles[0]) + #print "merged timesteps " + fileString + + self.__cleanButLeave(dateFiles) + + print "Created "+ outfiles[0]+ " with dates " + cdo.showdate(input=outfiles[0])[0] + + return outfiles[0] + + ######################################################################################################### + def __checkTotals(self,anOutputFile): + #Done one output file, check totals, print to screen + nOutTimeStep = 1 + workFiles = self.__createTmpFileNames(anOutputFile,2) + for aKey in self.dateMap: + cdo.seltimestep(nOutTimeStep, input=anOutputFile.getFullPath(), output=workFiles[0] ) + cdo.vertsum(input=workFiles[0], output=workFiles[1]) + os.remove(workFiles[0]) + cdo.fldmean(input=workFiles[1], output=workFiles[0]) + os.remove(workFiles[1]) + output = cdo.infon(input=workFiles[0]) + fieldInfo = output[len(output)-1] + fieldInfoList = fieldInfo.split(" ") + fieldMean = fieldInfoList[len(fieldInfoList)-1] + fieldMeanNbr = float(fieldMean) + timesAearth = fieldMeanNbr*areaEarth*3600.0*24.0*365.0/1.e9 + print("field " + " "+ str(aKey) + " MEAN: "+ fieldMean + " TIMES AEARTH*AYEAR(Tg): " + str(timesAearth)) + #clean up + for aFile in workFiles: + if(os.path.isfile(aFile)): + os.remove(aFile) + + ########################################################################################## + + def doWork(self,resolutionFile): + + if(not os.path.isfile(resolutionFile)): + raise Exception("Can not find resolution file : "+ str(resolutionFile)) + + + time_startAll = time.time() + nOutputFiles = 0 + anOutputFile = self.__getOutputFile() + + #Datemap is only valid for one output file + self.dateMap = dict() + + time_start = time.time() + + nOutputFiles = nOutputFiles + 1 + + #IF WE NEED A 3D-FILE, PUT IT TO OUTPUT-RESOLUTION NOW + outputZaxisDef="" + if(anOutputFile.getNumberOfLayers() > 0): + stringList = [str(i) for i in anOutputFile.getLevelValues()] + outputZaxisDef = ",".join(stringList) + + print"*********************************************************" + print"*********************************************************" + print "==> creating output file " + anOutputFile.getFullPath() + " " + print"*******************************************************" + aUuid = str(uuid.uuid4()) #temporary id for this output file + maxInputFiles = len(anOutputFile.getInputFileList()) + inputFileCounter = 0 + for anInputFile in anOutputFile.getInputFileList(): #Go through all input files contributing to this file + inputFileCounter = inputFileCounter + 1 + inputFullPath = anInputFile.getFullPath() #Get the input file + + #Write output-values in m in z-axis definition + f = open('inputZAxisDef', 'w') + levels = anInputFile.getLevelValues() + #if the input file does not have levels, then we use the output z-axis + if(len(levels) == 0): + levels = anOutputFile.getLevelValues() + f.write("zaxistype = height \n") + f.write("size = "+ str(len(levels)) + " \n" ) + stringList = [str(i) for i in levels] + expr = " ".join(stringList) + f.write("levels =" + expr + "\n") + f.close() + + #Create one file per date!! + print " ==>preparing output based on " + os.path.basename(inputFullPath) + " " + str(int(float(inputFileCounter)/float(maxInputFiles)*100.0))+"%" + dateStrings = cdo.showdate(input=inputFullPath)[0].split() + ntimestep = 1 + maxtimesteps = len(dateStrings) + datebar = progressbar.ProgressBar(maxval=maxtimesteps,widgets=[progressbar.Bar('x', '[', ']'), ' ', progressbar.Percentage()]) + for aDateString in dateStrings: + + #Create some tmp-filenames which will be created for this input file and date + datebar.update(ntimestep) + + ymd = aDateString.split("-") + aDate = datetime.date(int(ymd[0]),int(ymd[1]),int(ymd[2])) + + #print("year is " + str(aDate.year)+ " max/min: " + str(anOutputFile.getMaxYear()) +"/"+ str(anOutputFile.getMinYear())) + if(aDate.year > anOutputFile.getMaxYear() or aDate.year < anOutputFile.getMinYear()): + ntimestep += 1 + #print("skipping input for year " +str(aDate.year) +"in " + anInputFile.getFullPath()) + continue + + workFiles = self.__createTmpFileNames(anOutputFile,4) + + #print " ==>found date in " +anInputFile.getFullPath() + aDate.isoformat() + " " + str(int(float(ntimestep)/float(maxtimesteps)*100.0)) + "%" + + #Select the time corresponding to this time step in the file workFiles[0] + cdo.seltimestep(ntimestep, input=anInputFile.getFullPath(), output=workFiles[0]) + + #print "created file for timestep " + str(ntimestep) + workFiles[0] + #print "created file has date " + cdo.showdate(input=workFiles[0])[0] + + #print("processing timestep "+str(ntimestep) + " in " + anInputFile.getFullPath() ) + + timeStepFile="" + + #FOUR OPTIONS + #1) OUTPUT FILES HAS LEVELS AND INPUT FILE DOES NOT... + #==> CREATE FROM LEVEL FRACTIONS + if(anOutputFile.getNumberOfLayers() > 0 and (not anInputFile.getHasVerticalProfile()) and + anInputFile.hasLevelFractionFile()): + + timeStepFile = self.__create3DFromLevelFractions(workFiles[0], anInputFile , anOutputFile, aDate) + + #2) OUTPUT FILE HAS LEVELS AND INPUT FILE DOES NOT HAVE LEVELS ==> 3D file in workfiles[0] + #==>PLACE SOME STUFF IN CONFIGURED LEVELS + elif(anOutputFile.getNumberOfLayers() > 0 and (not anInputFile.getHasVerticalProfile())): + timeStepFile = self.__create3DFrom1D(workFiles[0], anInputFile, anOutputFile ) + + #3) BOTH FILES HAVE LAYERS ==> JUST INTERPOLATE + elif(anOutputFile.getNumberOfLayers() > 0 and (anInputFile.getHasVerticalProfile() )): + timeStepFile = workFiles[0] + + elif(anOutputFile.getNumberOfLayers() == 0 and anInputFile.getNumberOfLevels() == 0 ): + #4) OUTPUT FILE DOES NOT HAVE LEVELS, AND INPUT FILE DOES NOT HAVE LEVELS + timeStepFile = workFiles[0] + else: + raise("undefined case") + + if(anOutputFile.getNumberOfLayers() > 0 ): + cdo.setzaxis("inputZAxisDef",input=timeStepFile,output=workFiles[1]) + cdo.intlevelx(outputZaxisDef,input=workFiles[1],output=workFiles[2]) #interpolate to output levels + else: + shutil.move(workFiles[0],workFiles[2]) + + try: + os.remove(timeStepFile) + except: + pass + + #set correct unit attribute (required by mozart) + if (anOutputFile.getNumberOfLayers() > 0): + fileUnits="molecules/cm3/s" + else: + fileUnits="molecules/cm2/s" + for aField in anInputFile.getConfiguredFields(): + att_dsc=str("units,"+str(aField)+",o,c,"+fileUnits) + subprocess.check_call(["ncatted","-a",att_dsc,workFiles[2]]) + + ############################################################################### + + #Do the regridding (surface grid) + cdo.remapbil(resolutionFile,input=workFiles[2],output=workFiles[3]) + + #Remove these tmp-files ==> no longer needed + self.__cleanButLeave(workFiles,3) + + #Modify the list of files per date + aList = [] + if (self.dateMap.has_key(aDate.isoformat())): + #==> we already have input files for this date + aList = self.dateMap.get(aDate.isoformat()) + #Put the new list back in map + aList.append(workFiles[3]) + self.dateMap[aDate.isoformat()] = aList + + #prepare for next time step + ntimestep = ntimestep + 1 + + #Done loop on dates in one input file + anInputFile.cleanFiles() + #Done loop on all inputfiles + + #Add up all input file from "self.datemap" searched into one output-file + wrongCoordinateFile = self.__mergeOutputFiles(anOutputFile) + + ################################################################ + #create output z-axis definition (in km needed for MAM) + #Write output-values in km in z-axis definition + f = open('outputZAxisDef', 'w') + levels = anOutputFile.getLevelValues() #level values in km + l2=[] + for aLevel in levels: + l2.append(float(aLevel)*1.e-3) #==> km + f.write("zaxistype = height \n") + f.write("size = "+ str(anOutputFile.getNumberOfLayers()) + " \n" ) + stringList = [str(i) for i in l2] + expr = " ".join(stringList) + f.write("levels =" + expr + "\n") + f.close() + + workFiles2 = self.__createTmpFileNames(anOutputFile,2) + cdo.setzaxis("outputZAxisDef",input=wrongCoordinateFile,output=workFiles2[0]) + + #create the interface levels + f = open("foo.cdl", 'w') + f.write("netcdf foo{ \n") + f.write("dimensions:") + f.write("altitude_int = " + str(anOutputFile.getNumberOfLayers()+1) + ";\n") + f.write("variables: \n") + f.write("float altitude_int(altitude_int) ;\n") + f.write("data: \n") + interfaceLevels = anOutputFile.getInterfaceLevels() + il2=[] + for aLevel in interfaceLevels: + il2.append(str(float(aLevel)*1.e-3)) + expr = ",".join(il2) + f.write("altitude_int="+expr+"; \n") + f.write("} \n") + f.close() + + #Add the axis definition used by mozart + subprocess.check_call(["ncgen","foo.cdl"]) #create foo.nc + subprocess.check_call(["ncks","-A","foo.nc",workFiles2[0]]) #append to wrong coordinate file + subprocess.check_call(["ncrename","-d","height,altitude",workFiles2[0]]) #rename dimension height to altitude + subprocess.check_call(["ncrename","-v","height,altitude",workFiles2[0]]) #rename variable height to altitude + subprocess.check_call(["ncatted","-O","-a","units,altitude,o,c,km",workFiles2[0]]) + subprocess.check_call(["ncatted","-O","-a","units,altitude_int,o,c,km",workFiles2[0]]) + #shutil.move(workFiles2[0],anOutputFile.getFullPath()) + os.remove(wrongCoordinateFile) + os.remove("foo.cdl") + os.remove("foo.nc") + + #create the "date" variables needed by mozart levels + f = open("dates.cdl", 'w') + f.write("netcdf dates{ \n") + f.write("dimensions:") + f.write("time = " + str(len(self.dateMap)) + ";\n") + f.write("variables: \n") + f.write("int date(time) ;\n") + f.write("data: \n") + il2=[] + for aKey in self.dateMap: + dateVal = aKey.replace("-","") + il2.append(int(dateVal)) + il2.sort() + il4=[] + for aKey2 in il2: + il4.append(str(aKey2)) + expr = ",".join(il4) + f.write("date="+expr+"; \n") + f.write("} \n") + f.close() + + #Add the date used by mozart + subprocess.check_call(["ncgen","dates.cdl"]) #create dates.nc + subprocess.check_call(["ncks","-A","dates.nc",workFiles2[0]]) #append to wrong coordinate file + + + shutil.move(workFiles2[0],anOutputFile.getFullPath()) + os.remove("dates.cdl") + os.remove("dates.nc") + + #Check how much time was spent for this file.. + time_now = time.time() + print "Time spent for " + anOutputFile.getFullPath() + " " + str(int((time_now -time_start)/60.0)) + " minutes" + print "Total time spent : " + str(float((time_now -time_startAll)/60.0)) + " minutes" + time_start = time_now + + #Remove all tmp-files needed to create this output file + pattern=os.path.normpath(anOutputFile.getOutputPath()+"/*"+aUuid+"*") + filelist = glob.glob(pattern) + for tmpFile in filelist: + os.remove(tmpFile) + print " " + + #Remove all input files which were ever created for this output file + for aKey in self.dateMap: + aFileList = self.dateMap[aKey] + self.__cleanButLeave(aFileList) + + #Check totals + #self.__checkTotals(anOutputFile) + + #end of function + return + + + + \ No newline at end of file diff --git a/tools/emis/regridder/ipccConfig.xml b/tools/emis/regridder/ipccConfig.xml new file mode 100644 index 0000000000..459312a6a8 --- /dev/null +++ b/tools/emis/regridder/ipccConfig.xml @@ -0,0 +1,342 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/levelFractions.xml b/tools/emis/regridder/levelFractions.xml new file mode 100644 index 0000000000..f9cf2abc89 --- /dev/null +++ b/tools/emis/regridder/levelFractions.xml @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/main.py b/tools/emis/regridder/main.py new file mode 100644 index 0000000000..2974465d10 --- /dev/null +++ b/tools/emis/regridder/main.py @@ -0,0 +1,63 @@ +''' +Created on Aug 30, 2013 + +@author: alfg +''' + +from cdo import * +cdo = Cdo() +import sys +from camOsloFileProcessor import FileProvider +from interpolator import outputCreator +import argparse + +#MAIN PROGRAM +if __name__ == '__main__': + + parser = argparse.ArgumentParser() + #parser.add_argument("-s","--scenario",type=str,help="Scenario for which to create emissions (default historical)",default="historical") + parser.add_argument("-x","--xmlConfigFile",type=str,help="config xml-file (default exampleConfig.xml)",default="exampleConfig.xml") + #parser.add_argument("-c","--component",type=str,help="component to include (default BC)", default="BC") + #parser.add_argument("-y","--years",type=str,help="comma separated min and max years (default: 0,3000)",default="0,3000") + #parser.add_argument("-p","--provider",type=str,help="provider of emission data, for example \"IPCC\" or \"ECLIPSE\" (default IPCC)", default="IPCC") + parser.add_argument("-r","--resolution",type=str,help="file describing model resolution (default camRegularGrid144x72)",default="camRegularGrid144x72") + #parser.add_argument("-t","--sourcetype" ,type=str,choices=["ff","bb","air","all"],help="emission source to create (Default all)",default="all") + args = parser.parse_args() + + ############################################################ + #SET UP THE FILES WE WANT TO READ + ############################################################ + try: + provider = FileProvider(args.xmlConfigFile) + except Exception as e: + print e + sys.exit(1) + + try: + provider.createFileStructure() + aFile = provider.getOutputFile() + if(aFile == None): + print "No files to create for options : " + print "scenario " + args.scenario + print "xmlConfigFile " + args.xmlConfigFile + print "component " + args.component + print "provider "+args.provider + print "resolution "+args.resolution + print "sourcetype " + args.sourcetype + print "years" + args.years + + except Exception as e: + print e + print "a problem occurred when scanning the config file" + sys.exit(1) + + #Make an output-creator and ask it to create the output based on the file list + try: + worker = outputCreator(provider) + worker.doWork(args.resolution) + except Exception as e: + print e + sys.exit(1) + + #Successful exit + sys.exit(0) \ No newline at end of file diff --git a/tools/emis/regridder/oxidants.xml b/tools/emis/regridder/oxidants.xml new file mode 100644 index 0000000000..c70c2b26ca --- /dev/null +++ b/tools/emis/regridder/oxidants.xml @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/smallex.xml b/tools/emis/regridder/smallex.xml new file mode 100644 index 0000000000..eb1ecebc00 --- /dev/null +++ b/tools/emis/regridder/smallex.xml @@ -0,0 +1,37 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/smallex2.xml b/tools/emis/regridder/smallex2.xml new file mode 100644 index 0000000000..d519fbf1c2 --- /dev/null +++ b/tools/emis/regridder/smallex2.xml @@ -0,0 +1,38 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tools/emis/regridder/smallex_mix.xml b/tools/emis/regridder/smallex_mix.xml new file mode 100644 index 0000000000..a24ac32573 --- /dev/null +++ b/tools/emis/regridder/smallex_mix.xml @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + +